subroutine aaaaaa ( ver ) !*****************************************************************************80 ! !! AAAAAA is the SLATEC Common Mathematical Library disclaimer and version. ! !***LIBRARY SLATEC !***CATEGORY Z !***TYPE ALL (AAAAAA-A) !***KEYWORDS DISCLAIMER, DOCUMENTATION, VERSION !***AUTHOR SLATEC Common Mathematical Library Committee !***DESCRIPTION ! ! The SLATEC Common Mathematical Library is issued by the following ! ! Air Force Weapons Laboratory, Albuquerque ! Lawrence Livermore National Laboratory, Livermore ! Los Alamos National Laboratory, Los Alamos ! National Institute of Standards and Technology, Washington ! National Energy Research Supercomputer Center, Livermore ! Oak Ridge National Laboratory, Oak Ridge ! Sandia National Laboratories, Albuquerque ! Sandia National Laboratories, Livermore ! ! All questions concerning the distribution of the library should be ! directed to the NATIONAL ENERGY SOFTWARE CENTER, 9700 Cass Ave., ! Argonne, Illinois 60439, and not to the authors of the subprograms. ! ! * * * * * Notice * * * * * ! ! This material was prepared as an account of work sponsored by the ! United States Government. Neither the United States, nor the ! Department of Energy, nor the Department of Defense, nor any of ! their employees, nor any of their contractors, subcontractors, or ! their employees, makes any warranty, expressed or implied, or ! assumes any legal liability or responsibility for the accuracy, ! completeness, or usefulness of any information, apparatus, product, ! or process disclosed, or represents that its use would not infringe ! upon privately owned rights. ! ! *Usage: ! ! CHARACTER * 16 VER ! ! call AAAAAA (VER) ! ! *Arguments: ! ! VER:OUT will contain the version number of the SLATEC CML. ! ! *Description: ! ! This routine contains the SLATEC Common Mathematical Library ! disclaimer and can be used to return the library version number. ! !***REFERENCES Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro ! and Lee Walton, Guide to the SLATEC Common Mathema- ! tical Library, April 10, 1990. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800424 DATE WRITTEN ! 890414 REVISION DATE from Version 3.2 ! 890713 Routine modified to return version number. (WRB) ! 900330 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 921215 Updated for Version 4.0. (WRB) ! 930701 Updated for Version 4.1. (WRB) !***END PROLOGUE AAAAAA CHARACTER * (*) VER !***FIRST EXECUTABLE STATEMENT AAAAAA VER = ' 4.1' return end function acosh ( x ) !*****************************************************************************80 ! !! ACOSH computes the arc hyperbolic cosine. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE SINGLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C) !***KEYWORDS ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB, ! INVERSE HYPERBOLIC COSINE !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! ACOSH(X) computes the arc hyperbolic cosine of X. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE ACOSH real, parameter :: aln2 = 0.69314718055994530942E+00 real x real, save :: xmax = 0.0E+00 !***FIRST EXECUTABLE STATEMENT ACOSH if ( xmax == 0.0E+00 ) then xmax = 1.0E+00 / sqrt ( r1mach(3) ) end if if ( x < 1.0E+00 ) then call XERMSG ( 'SLATEC', 'ACOSH', 'X LESS THAN 1', 1, 2 ) end if if ( x < xmax ) then acosh = log ( x + sqrt ( x * x - 1.0E+00 ) ) end if if ( x >= xmax ) then acosh = aln2 + log ( x ) end if return end function aie ( x ) !*****************************************************************************80 ! !! AIE calculates the Airy function for a negative argument... ! and an exponentially scaled Airy function for a non-negative argument. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10D !***TYPE SINGLE PRECISION (AIE-S, DAIE-D) !***KEYWORDS EXPONENTIALLY SCALED AIRY FUNCTION, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! AIE(X) computes the exponentially scaled Airy function for ! non-negative X. It evaluates AI(X) for X <= 0.0 and ! EXP(ZETA)*AI(X) for X >= 0.0 where ZETA = (2.0/3.0)*(X**1.5). ! ! Series for AIF on the interval -1.00000D+00 to 1.00000D+00 ! with weighted error 1.09E-19 ! log weighted error 18.96 ! significant figures required 17.76 ! decimal places required 19.44 ! ! Series for AIG on the interval -1.00000D+00 to 1.00000D+00 ! with weighted error 1.51E-17 ! log weighted error 16.82 ! significant figures required 15.19 ! decimal places required 17.27 ! ! Series for AIP on the interval 0. to 1.00000D+00 ! with weighted error 5.10E-17 ! log weighted error 16.29 ! significant figures required 14.41 ! decimal places required 17.06 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, R9AIMP !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE AIE DIMENSION AIFCS(9), AIGCS(8), AIPCS(34) LOGICAL FIRST SAVE AIFCS, AIGCS, AIPCS, NAIF, NAIG, & NAIP, X3SML, X32SML, XBIG, FIRST DATA AIFCS( 1) / -0.03797135849666999750E0 / DATA AIFCS( 2) / 0.05919188853726363857E0 / DATA AIFCS( 3) / 0.00098629280577279975E0 / DATA AIFCS( 4) / 0.00000684884381907656E0 / DATA AIFCS( 5) / 0.00000002594202596219E0 / DATA AIFCS( 6) / 0.00000000006176612774E0 / DATA AIFCS( 7) / 0.00000000000010092454E0 / DATA AIFCS( 8) / 0.00000000000000012014E0 / DATA AIFCS( 9) / 0.00000000000000000010E0 / DATA AIGCS( 1) / 0.01815236558116127E0 / DATA AIGCS( 2) / 0.02157256316601076E0 / DATA AIGCS( 3) / 0.00025678356987483E0 / DATA AIGCS( 4) / 0.00000142652141197E0 / DATA AIGCS( 5) / 0.00000000457211492E0 / DATA AIGCS( 6) / 0.00000000000952517E0 / DATA AIGCS( 7) / 0.00000000000001392E0 / DATA AIGCS( 8) / 0.00000000000000001E0 / DATA AIPCS( 1) / -0.0187519297793868E0 / DATA AIPCS( 2) / -0.0091443848250055E0 / DATA AIPCS( 3) / 0.0009010457337825E0 / DATA AIPCS( 4) / -0.0001394184127221E0 / DATA AIPCS( 5) / 0.0000273815815785E0 / DATA AIPCS( 6) / -0.0000062750421119E0 / DATA AIPCS( 7) / 0.0000016064844184E0 / DATA AIPCS( 8) / -0.0000004476392158E0 / DATA AIPCS( 9) / 0.0000001334635874E0 / DATA AIPCS(10) / -0.0000000420735334E0 / DATA AIPCS(11) / 0.0000000139021990E0 / DATA AIPCS(12) / -0.0000000047831848E0 / DATA AIPCS(13) / 0.0000000017047897E0 / DATA AIPCS(14) / -0.0000000006268389E0 / DATA AIPCS(15) / 0.0000000002369824E0 / DATA AIPCS(16) / -0.0000000000918641E0 / DATA AIPCS(17) / 0.0000000000364278E0 / DATA AIPCS(18) / -0.0000000000147475E0 / DATA AIPCS(19) / 0.0000000000060851E0 / DATA AIPCS(20) / -0.0000000000025552E0 / DATA AIPCS(21) / 0.0000000000010906E0 / DATA AIPCS(22) / -0.0000000000004725E0 / DATA AIPCS(23) / 0.0000000000002076E0 / DATA AIPCS(24) / -0.0000000000000924E0 / DATA AIPCS(25) / 0.0000000000000417E0 / DATA AIPCS(26) / -0.0000000000000190E0 / DATA AIPCS(27) / 0.0000000000000087E0 / DATA AIPCS(28) / -0.0000000000000040E0 / DATA AIPCS(29) / 0.0000000000000019E0 / DATA AIPCS(30) / -0.0000000000000009E0 / DATA AIPCS(31) / 0.0000000000000004E0 / DATA AIPCS(32) / -0.0000000000000002E0 / DATA AIPCS(33) / 0.0000000000000001E0 / DATA AIPCS(34) / -0.0000000000000000E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT AIE if ( first ) then eta = 0.1 * r1mach(3) naif = inits ( aifcs, 9, eta ) naig = inits ( aigcs, 8, eta ) naip = inits ( aipcs, 34, eta ) x3sml = eta**0.3333 x32sml = 1.3104 * x3sml**2 xbig = r1mach(2)**0.6666 first = .false. end if if ( x < -1.0 ) then call r9aimp ( x, xm, theta ) aie = xm * cos ( theta ) else if ( x <= 1.0 ) then if ( abs ( x ) <= x3sml ) then z = 0.0 else z = x**3 end if aie = 0.375 + ( csevl ( z, aifcs, naif ) & - x * ( 0.25 + csevl ( z, aigcs, naig ) ) ) if ( x32sml < x ) then aie = aie * exp ( 2.0 * x * sqrt ( x ) / 3.0 ) end if else sqrtx = sqrt ( x ) if ( x < xbig ) then z = 2.0 / ( x * sqrtx ) - 1.0 else z = -1.0 end if aie = ( 0.28125 + csevl ( z, aipcs, naip ) ) / sqrt ( sqrtx ) end if return end function ai ( x ) !*****************************************************************************80 ! !! AI evaluates the Airy function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10D !***TYPE SINGLE PRECISION (AI-S, DAI-D) !***KEYWORDS AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! AI(X) computes the Airy function Ai(X) ! Series for AIF on the interval -1.00000D+00 to 1.00000D+00 ! with weighted error 1.09E-19 ! log weighted error 18.96 ! significant figures required 17.76 ! decimal places required 19.44 ! ! Series for AIG on the interval -1.00000D+00 to 1.00000D+00 ! with weighted error 1.51E-17 ! log weighted error 16.82 ! significant figures required 15.19 ! decimal places required 17.27 ! !***REFERENCES (NONE) !***ROUTINES CALLED AIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE AI ! implicit none real ai real aie real, save, dimension ( 9 ) :: aifcs = (/ & -0.03797135849666999750E0, & 0.05919188853726363857E0, & 0.00098629280577279975E0, & 0.00000684884381907656E0, & 0.00000002594202596219E0, & 0.00000000006176612774E0, & 0.00000000000010092454E0, & 0.00000000000000012014E0, & 0.00000000000000000010E0 /) real, save, dimension ( 8 ) :: aigcs = (/ & 0.01815236558116127E0, & 0.02157256316601076E0, & 0.00025678356987483E0, & 0.00000142652141197E0, & 0.00000000457211492E0, & 0.00000000000952517E0, & 0.00000000000001392E0, & 0.00000000000000001E0 /) real csevl logical, save :: first = .true. integer inits integer, save :: naif integer, save :: naig real r1mach real theta real x real, save :: x3sml real xm real, save :: xmax real xmaxt real z !***FIRST EXECUTABLE STATEMENT AI if ( first ) then naif = inits ( aifcs, 9, 0.1 * r1mach(3) ) naig = inits ( aigcs, 8, 0.1 * r1mach(3) ) x3sml = r1mach(3)**0.3334 xmaxt = ( -1.5 * log ( r1mach(1) ) )**0.6667 xmax = xmaxt - xmaxt * log ( xmaxt ) & / ( 4.0 * sqrt ( xmaxt ) + 1.0 ) - 0.01 first = .false. end if if ( x < -1.0 ) then call r9aimp ( x, xm, theta ) ai = xm * cos ( theta ) else if ( x <= 1.0 ) then if ( abs ( x ) <= x3sml ) then z = 0.0 else z = x**3 end if ai = 0.375 + ( csevl ( z, aifcs, naif ) & - x * ( 0.25 + csevl ( z, aigcs, naig ) ) ) else if ( x <= xmax ) then ai = aie ( x ) * exp ( -2.0 * x * sqrt ( x ) / 3.0 ) else ai = 0.0 call xermsg ( 'SLATEC', 'AI', 'X so big AI underflows', 1, 1 ) end if return end function ALBETA (A, B) ! !! ALBETA computes the natural logarithm of the complete Beta function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7B !***TYPE SINGLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C) !***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! ALBETA computes the natural log of the complete beta function. ! ! Input Parameters: ! A real and positive ! B real and positive ! !***REFERENCES (NONE) !***ROUTINES CALLED ALNGAM, ALNREL, GAMMA, R9LGMC, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE ALBETA EXTERNAL GAMMA SAVE SQ2PIL DATA SQ2PIL / 0.91893853320467274E0 / !***FIRST EXECUTABLE STATEMENT ALBETA P = MIN (A, B) Q = MAX (A, B) ! if (P <= 0.0) call XERMSG ('SLATEC', 'ALBETA', & 'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2) if (P >= 10.0) go to 30 if (Q >= 10.0) go to 20 ! ! P AND Q ARE SMALL. ! ALBETA = LOG(GAMMA(P) * (GAMMA(Q)/GAMMA(P+Q)) ) return ! ! P IS SMALL, BUT Q IS BIG. ! 20 CORR = R9LGMC(Q) - R9LGMC(P+Q) ALBETA = ALNGAM(P) + CORR + P - P*LOG(P+Q) + & (Q-0.5)*ALNREL(-P/(P+Q)) return ! ! P AND Q ARE BIG. ! 30 CORR = R9LGMC(P) + R9LGMC(Q) - R9LGMC(P+Q) ALBETA = -0.5*LOG(Q) + SQ2PIL + CORR + (P-0.5)*LOG(P/(P+Q)) & + Q*ALNREL(-P/(P+Q)) return ! end subroutine ALGAMS (X, ALGAM, SGNGAM) ! !! ALGAMS computes the logarithm of the absolute value of the Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE SINGLE PRECISION (ALGAMS-S, DLGAMS-D) !***KEYWORDS ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION, ! FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluates the logarithm of the absolute value of the gamma ! function. ! X - input argument ! ALGAM - result ! SGNGAM - is set to the sign of GAMMA(X) and will ! be returned at +1.0 or -1.0. ! !***REFERENCES (NONE) !***ROUTINES CALLED ALNGAM !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ALGAMS !***FIRST EXECUTABLE STATEMENT ALGAMS ALGAM = ALNGAM(X) SGNGAM = 1.0 if (X > 0.0) RETURN ! INT = MOD (-AINT(X), 2.0) + 0.1 if (INT == 0) SGNGAM = -1.0 ! return end function ALI (X) ! !! ALI computes the logarithmic integral. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C5 !***TYPE SINGLE PRECISION (ALI-S, DLI-D) !***KEYWORDS FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! ALI(X) computes the logarithmic integral; i.e., the ! integral from 0.0 to X of (1.0/ln(t))dt. ! !***REFERENCES (NONE) !***ROUTINES CALLED EI, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE ALI !***FIRST EXECUTABLE STATEMENT ALI if (X <= 0.0) call XERMSG ('SLATEC', 'ALI', & 'LOG INTEGRAL UNDEFINED FOR X LE 0', 1, 2) if (X == 1.0) call XERMSG ('SLATEC', 'ALI', & 'LOG INTEGRAL UNDEFINED FOR X = 1', 2, 2) ! ALI = EI (LOG(X) ) ! return end function ALNGAM (X) ! !! ALNGAM computes the logarithm of the absolute value of the Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE SINGLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C) !***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! ALNGAM(X) computes the logarithm of the absolute value of the ! gamma function at X. ! !***REFERENCES (NONE) !***ROUTINES CALLED GAMMA, R1MACH, R9LGMC, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE ALNGAM LOGICAL FIRST EXTERNAL GAMMA SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST DATA SQ2PIL / 0.91893853320467274E0/ DATA SQPI2L / 0.22579135264472743E0/ DATA PI / 3.14159265358979324E0/ DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT ALNGAM if (FIRST) THEN XMAX = R1MACH(2)/LOG(R1MACH(2)) DXREL = SQRT (R1MACH(4)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 10.0) go to 20 ! ! LOG (ABS (GAMMA(X))) FOR ABS(X) <= 10.0 ! ALNGAM = LOG (ABS (GAMMA(X))) return ! ! LOG (ABS (GAMMA(X))) FOR ABS(X) > 10.0 ! 20 if (Y > XMAX) call XERMSG ('SLATEC', 'ALNGAM', & 'ABS(X) SO BIG ALNGAM OVERFLOWS', 2, 2) ! if (X > 0.) ALNGAM = SQ2PIL + (X-0.5)*LOG(X) - X + R9LGMC(Y) if (X > 0.) RETURN ! SINPIY = ABS (SIN(PI*Y)) if (SINPIY == 0.) call XERMSG ('SLATEC', 'ALNGAM', & 'X IS A NEGATIVE INTEGER', 3, 2) ! if (ABS((X-AINT(X-0.5))/X) < DXREL) call XERMSG ('SLATEC', & 'ALNGAM', 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR ' // & 'NEGATIVE INTEGER', 1, 1) ! ALNGAM = SQPI2L + (X-0.5)*LOG(Y) - X - LOG(SINPIY) - R9LGMC(Y) return ! end function ALNREL (X) ! !! ALNREL evaluates ln(1+X) accurate in the sense of relative error. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4B !***TYPE SINGLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C) !***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! ALNREL(X) evaluates ln(1+X) accurately in the sense of relative ! error when X is very small. This routine must be used to ! maintain relative error accuracy whenever X is small and ! accurately known. ! ! Series for ALNR on the interval -3.75000D-01 to 3.75000D-01 ! with weighted error 1.93E-17 ! log weighted error 16.72 ! significant figures required 16.44 ! decimal places required 17.40 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE ALNREL DIMENSION ALNRCS(23) LOGICAL FIRST SAVE ALNRCS, NLNREL, XMIN, FIRST DATA ALNRCS( 1) / 1.0378693562743770E0 / DATA ALNRCS( 2) / -.13364301504908918E0 / DATA ALNRCS( 3) / .019408249135520563E0 / DATA ALNRCS( 4) / -.003010755112753577E0 / DATA ALNRCS( 5) / .000486946147971548E0 / DATA ALNRCS( 6) / -.000081054881893175E0 / DATA ALNRCS( 7) / .000013778847799559E0 / DATA ALNRCS( 8) / -.000002380221089435E0 / DATA ALNRCS( 9) / .000000416404162138E0 / DATA ALNRCS(10) / -.000000073595828378E0 / DATA ALNRCS(11) / .000000013117611876E0 / DATA ALNRCS(12) / -.000000002354670931E0 / DATA ALNRCS(13) / .000000000425227732E0 / DATA ALNRCS(14) / -.000000000077190894E0 / DATA ALNRCS(15) / .000000000014075746E0 / DATA ALNRCS(16) / -.000000000002576907E0 / DATA ALNRCS(17) / .000000000000473424E0 / DATA ALNRCS(18) / -.000000000000087249E0 / DATA ALNRCS(19) / .000000000000016124E0 / DATA ALNRCS(20) / -.000000000000002987E0 / DATA ALNRCS(21) / .000000000000000554E0 / DATA ALNRCS(22) / -.000000000000000103E0 / DATA ALNRCS(23) / .000000000000000019E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT ALNREL if (FIRST) THEN NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3)) XMIN = -1.0 + SQRT(R1MACH(4)) end if FIRST = .FALSE. ! if (X <= (-1.0)) call XERMSG ('SLATEC', 'ALNREL', 'X IS LE -1', & 2, 2) if (X < XMIN) call XERMSG ('SLATEC', 'ALNREL', & 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1) ! if (ABS(X) <= 0.375) ALNREL = X*(1. - & X*CSEVL (X/.375, ALNRCS, NLNREL)) if (ABS(X) > 0.375) ALNREL = LOG (1.0+X) ! return end function ASINH (X) ! !! ASINH computes the arc hyperbolic sine. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE SINGLE PRECISION (ASINH-S, DASINH-D, CASINH-C) !***KEYWORDS ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB, ! INVERSE HYPERBOLIC SINE !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! ASINH(X) computes the arc hyperbolic sine of X. ! ! Series for ASNH on the interval 0. to 1.00000D+00 ! with weighted error 2.19E-17 ! log weighted error 16.66 ! significant figures required 15.60 ! decimal places required 17.31 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ASINH DIMENSION ASNHCS(20) LOGICAL FIRST SAVE ALN2, ASNHCS, NTERMS, XMAX, SQEPS, FIRST DATA ALN2 /0.69314718055994530942E0/ DATA ASNHCS( 1) / -.12820039911738186E0 / DATA ASNHCS( 2) / -.058811761189951768E0 / DATA ASNHCS( 3) / .004727465432212481E0 / DATA ASNHCS( 4) / -.000493836316265361E0 / DATA ASNHCS( 5) / .000058506207058557E0 / DATA ASNHCS( 6) / -.000007466998328931E0 / DATA ASNHCS( 7) / .000001001169358355E0 / DATA ASNHCS( 8) / -.000000139035438587E0 / DATA ASNHCS( 9) / .000000019823169483E0 / DATA ASNHCS(10) / -.000000002884746841E0 / DATA ASNHCS(11) / .000000000426729654E0 / DATA ASNHCS(12) / -.000000000063976084E0 / DATA ASNHCS(13) / .000000000009699168E0 / DATA ASNHCS(14) / -.000000000001484427E0 / DATA ASNHCS(15) / .000000000000229037E0 / DATA ASNHCS(16) / -.000000000000035588E0 / DATA ASNHCS(17) / .000000000000005563E0 / DATA ASNHCS(18) / -.000000000000000874E0 / DATA ASNHCS(19) / .000000000000000138E0 / DATA ASNHCS(20) / -.000000000000000021E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT ASINH if (FIRST) THEN NTERMS = INITS (ASNHCS, 20, 0.1*R1MACH(3)) SQEPS = SQRT (R1MACH(3)) XMAX = 1.0/SQEPS end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 1.0) go to 20 ! ASINH = X if (Y > SQEPS) ASINH = X*(1.0 + CSEVL (2.*X*X-1., ASNHCS,NTERMS)) return ! 20 if (Y < XMAX) ASINH = LOG (Y + SQRT(Y**2+1.)) if (Y >= XMAX) ASINH = ALN2 + LOG(Y) ASINH = SIGN (ASINH, X) ! return end subroutine ASYIK (X, FNU, KODE, FLGIK, RA, ARG, IN, Y) ! !! ASYIK is subsidiary to BESI and BESK. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (ASYIK-S, DASYIK-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! ASYIK computes Bessel functions I and K ! for arguments X > 0.0 and orders FNU >= 35 ! on FLGIK = 1 and FLGIK = -1 respectively. ! ! INPUT ! ! X - argument, X > 0.0E0 ! FNU - order of first Bessel function ! KODE - a parameter to indicate the scaling option ! KODE=1 returns Y(I)= I/SUB(FNU+I-1)/(X), I=1,IN ! or Y(I)= K/SUB(FNU+I-1)/(X), I=1,IN ! on FLGIK = 1.0E0 or FLGIK = -1.0E0 ! KODE=2 returns Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN ! or Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN ! on FLGIK = 1.0E0 or FLGIK = -1.0E0 ! FLGIK - selection parameter for I or K function ! FLGIK = 1.0E0 gives the I function ! FLGIK = -1.0E0 gives the K function ! RA - SQRT(1.+Z*Z), Z=X/FNU ! ARG - argument of the leading exponential ! IN - number of functions desired, IN=1 or 2 ! ! OUTPUT ! ! Y - a vector whose first in components contain the sequence ! ! Abstract ! ASYIK implements the uniform asymptotic expansion of ! the I and K Bessel functions for FNU >= 35 and real ! X > 0.0E0. The forms are identical except for a change ! in sign of some of the terms. This change in sign is ! accomplished by means of the flag FLGIK = 1 or -1. ! !***SEE ALSO BESI, BESK !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE ASYIK ! 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 REAL R1MACH DIMENSION Y(*), C(65), CON(2) SAVE CON, C DATA CON(1), CON(2) / & 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), & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), & C(19), C(20), C(21), C(22), C(23), C(24)/ & -2.08333333333333E-01, 1.25000000000000E-01, & 3.34201388888889E-01, -4.01041666666667E-01, & 7.03125000000000E-02, -1.02581259645062E+00, & 1.84646267361111E+00, -8.91210937500000E-01, & 7.32421875000000E-02, 4.66958442342625E+00, & -1.12070026162230E+01, 8.78912353515625E+00, & -2.36408691406250E+00, 1.12152099609375E-01, & -2.82120725582002E+01, 8.46362176746007E+01, & -9.18182415432400E+01, 4.25349987453885E+01, & -7.36879435947963E+00, 2.27108001708984E-01, & 2.12570130039217E+02, -7.65252468141182E+02, & 1.05999045252800E+03, -6.99579627376133E+02/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ & 2.18190511744212E+02, -2.64914304869516E+01, & 5.72501420974731E-01, -1.91945766231841E+03, & 8.06172218173731E+03, -1.35865500064341E+04, & 1.16553933368645E+04, -5.30564697861340E+03, & 1.20090291321635E+03, -1.08090919788395E+02, & 1.72772750258446E+00, 2.02042913309661E+04, & -9.69805983886375E+04, 1.92547001232532E+05, & -2.03400177280416E+05, 1.22200464983017E+05, & -4.11926549688976E+04, 7.10951430248936E+03, & -4.93915304773088E+02, 6.07404200127348E+00, & -2.42919187900551E+05, 1.31176361466298E+06, & -2.99801591853811E+06, 3.76327129765640E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), & C(65)/ & -2.81356322658653E+06, 1.26836527332162E+06, & -3.31645172484564E+05, 4.52187689813627E+04, & -2.49983048181121E+03, 2.43805296995561E+01, & 3.28446985307204E+06, -1.97068191184322E+07, & 5.09526024926646E+07, -7.41051482115327E+07, & 6.63445122747290E+07, -3.75671766607634E+07, & 1.32887671664218E+07, -2.78561812808645E+06, & 3.08186404612662E+05, -1.38860897537170E+04, & 1.10017140269247E+02/ !***FIRST EXECUTABLE STATEMENT ASYIK TOL = R1MACH(3) TOL = MAX(TOL,1.0E-15) FN = FNU Z = (3.0E0-FLGIK)/2.0E0 KK = INT(Z) DO 50 JN=1,IN if (JN == 1) go to 10 FN = FN - FLGIK Z = X/FN RA = SQRT(1.0E0+Z*Z) GLN = LOG((1.0E0+RA)/Z) ETX = 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 (MAX(ABS(AK),ABS(AP)) < TOL) go to 40 30 CONTINUE 40 CONTINUE T = ABS(T) Y(JN) = S2*COEF*SQRT(T)*CON(KK) 50 CONTINUE return end subroutine ASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW) ! !! ASYJY is subsidiary to BESJ and BESY. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (ASYJY-S, DASYJY-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! ASYJY computes Bessel functions J and Y ! for arguments X > 0.0 and orders FNU >= 35.0 ! on FLGJY = 1 and FLGJY = -1 respectively ! ! INPUT ! ! FUNJY - external function JAIRY or YAIRY ! X - argument, X > 0.0E0 ! FNU - order of the first Bessel function ! FLGJY - selection flag ! FLGJY = 1.0E0 gives the J function ! FLGJY = -1.0E0 gives the Y function ! IN - number of functions desired, IN = 1 or 2 ! ! OUTPUT ! ! Y - a vector whose first in components contain the sequence ! IFLW - a flag indicating underflow or overflow ! return variables for BESJ only ! WK(1) = 1 - (X/FNU)**2 = W**2 ! WK(2) = SQRT(ABS(WK(1))) ! WK(3) = ABS(WK(2) - ATAN(WK(2))) or ! ABS(LN((1 + WK(2))/(X/FNU)) - WK(2)) ! = ABS((2/3)*ZETA**(3/2)) ! WK(4) = FNU*WK(3) ! WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3) ! WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3) ! WK(7) = FNU**(1/3) ! ! Abstract ! ASYJY implements the uniform asymptotic expansion of ! the J and Y Bessel functions for FNU >= 35 and real ! X > 0.0E0. The forms are identical except for a change ! in sign of some of the terms. This change in sign is ! accomplished by means of the flag FLGJY = 1 or -1. On ! FLGJY = 1 the AIRY functions AI(X) and DAI(X) are ! supplied by the external function JAIRY, and on ! FLGJY = -1 the AIRY functions BI(X) and DBI(X) are ! supplied by the external function YAIRY. ! !***SEE ALSO BESJ, BESY !***ROUTINES CALLED I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE ASYJY INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1, & KSTEMP, L, LR, LRP1, ISETA, ISETB INTEGER I1MACH REAL ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ, & BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2, & 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 REAL R1MACH 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)) SAVE TOLS, CON1, CON2, CON548, AR, BR, C, ALFA1, ALFA2, & BETA1, BETA2, BETA3, GAMA DATA TOLS /-6.90775527898214E+00/ DATA CON1,CON2,CON548/ & 6.66666666666667E-01, 3.33333333333333E-01, 1.04166666666667E-01/ DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), & AR(8) / 8.35503472222222E-02, 1.28226574556327E-01, & 2.91849026464140E-01, 8.81627267443758E-01, 3.32140828186277E+00, & 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), & BR(9), BR(10) /-1.45833333333333E-01,-9.87413194444444E-02, & -1.43312053915895E-01,-3.17227202678414E-01,-9.42429147957120E-01, & -3.51120304082635E+00,-1.57272636203680E+01,-8.22814390971859E+01, & -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), & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), & C(19), C(20), C(21), C(22), C(23), C(24)/ & -2.08333333333333E-01, 1.25000000000000E-01, & 3.34201388888889E-01, -4.01041666666667E-01, & 7.03125000000000E-02, -1.02581259645062E+00, & 1.84646267361111E+00, -8.91210937500000E-01, & 7.32421875000000E-02, 4.66958442342625E+00, & -1.12070026162230E+01, 8.78912353515625E+00, & -2.36408691406250E+00, 1.12152099609375E-01, & -2.82120725582002E+01, 8.46362176746007E+01, & -9.18182415432400E+01, 4.25349987453885E+01, & -7.36879435947963E+00, 2.27108001708984E-01, & 2.12570130039217E+02, -7.65252468141182E+02, & 1.05999045252800E+03, -6.99579627376133E+02/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ & 2.18190511744212E+02, -2.64914304869516E+01, & 5.72501420974731E-01, -1.91945766231841E+03, & 8.06172218173731E+03, -1.35865500064341E+04, & 1.16553933368645E+04, -5.30564697861340E+03, & 1.20090291321635E+03, -1.08090919788395E+02, & 1.72772750258446E+00, 2.02042913309661E+04, & -9.69805983886375E+04, 1.92547001232532E+05, & -2.03400177280416E+05, 1.22200464983017E+05, & -4.11926549688976E+04, 7.10951430248936E+03, & -4.93915304773088E+02, 6.07404200127348E+00, & -2.42919187900551E+05, 1.31176361466298E+06, & -2.99801591853811E+06, 3.76327129765640E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), & C(65)/ & -2.81356322658653E+06, 1.26836527332162E+06, & -3.31645172484564E+05, 4.52187689813627E+04, & -2.49983048181121E+03, 2.43805296995561E+01, & 3.28446985307204E+06, -1.97068191184322E+07, & 5.09526024926646E+07, -7.41051482115327E+07, & 6.63445122747290E+07, -3.75671766607634E+07, & 1.32887671664218E+07, -2.78561812808645E+06, & 3.08186404612662E+05, -1.38860897537170E+04, & 1.10017140269247E+02/ DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1), & ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1), & ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1), & ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1), & ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1), & ALFA1(26,1) /-4.44444444444444E-03,-9.22077922077922E-04, & -8.84892884892885E-05, 1.65927687832450E-04, 2.46691372741793E-04, & 2.65995589346255E-04, 2.61824297061501E-04, 2.48730437344656E-04, & 2.32721040083232E-04, 2.16362485712365E-04, 2.00738858762752E-04, & 1.86267636637545E-04, 1.73060775917876E-04, 1.61091705929016E-04, & 1.50274774160908E-04, 1.40503497391270E-04, 1.31668816545923E-04, & 1.23667445598253E-04, 1.16405271474738E-04, 1.09798298372713E-04, & 1.03772410422993E-04, 9.82626078369363E-05, 9.32120517249503E-05, & 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), & ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2), & ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2), & ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2), & ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2), & ALFA1(26,2) / 6.93735541354589E-04, 2.32241745182922E-04, & -1.41986273556691E-05,-1.16444931672049E-04,-1.50803558053049E-04, & -1.55121924918096E-04,-1.46809756646466E-04,-1.33815503867491E-04, & -1.19744975684254E-04,-1.06184319207974E-04,-9.37699549891194E-05, & -8.26923045588193E-05,-7.29374348155221E-05,-6.44042357721016E-05, & -5.69611566009369E-05,-5.04731044303562E-05,-4.48134868008883E-05, & -3.98688727717599E-05,-3.55400532972042E-05,-3.17414256609022E-05, & -2.83996793904175E-05,-2.54522720634871E-05,-2.28459297164725E-05, & -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), & ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1), & ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1), & ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1), & ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1), & ALFA2(26,1) /-3.54211971457744E-04,-1.56161263945159E-04, & 3.04465503594936E-05, 1.30198655773243E-04, 1.67471106699712E-04, & 1.70222587683593E-04, 1.56501427608595E-04, 1.36339170977445E-04, & 1.14886692029825E-04, 9.45869093034688E-05, 7.64498419250898E-05, & 6.07570334965197E-05, 4.74394299290509E-05, 3.62757512005344E-05, & 2.69939714979225E-05, 1.93210938247939E-05, 1.30056674793963E-05, & 7.82620866744497E-06, 3.59257485819352E-06, 1.44040049814252E-07, & -2.65396769697939E-06,-4.91346867098486E-06,-6.72739296091248E-06, & -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), & ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2), & ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2), & ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2), & ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2), & ALFA2(26,2) / 3.78194199201773E-04, 2.02471952761816E-04, & -6.37938506318862E-05,-2.38598230603006E-04,-3.10916256027362E-04, & -3.13680115247576E-04,-2.78950273791323E-04,-2.28564082619141E-04, & -1.75245280340847E-04,-1.25544063060690E-04,-8.22982872820208E-05, & -4.62860730588116E-05,-1.72334302366962E-05, 5.60690482304602E-06, & 2.31395443148287E-05, 3.62642745856794E-05, 4.58006124490189E-05, & 5.24595294959114E-05, 5.68396208545815E-05, 5.94349820393104E-05, & 6.06478527578422E-05, 6.08023907788436E-05, 6.01577894539460E-05, & 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), & BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1), & BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1), & BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1), & BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1), & BETA1(26,1) / 1.79988721413553E-02, 5.59964911064388E-03, & 2.88501402231133E-03, 1.80096606761054E-03, 1.24753110589199E-03, & 9.22878876572938E-04, 7.14430421727287E-04, 5.71787281789705E-04, & 4.69431007606482E-04, 3.93232835462917E-04, 3.34818889318298E-04, & 2.88952148495752E-04, 2.52211615549573E-04, 2.22280580798883E-04, & 1.97541838033063E-04, 1.76836855019718E-04, 1.59316899661821E-04, & 1.44347930197334E-04, 1.31448068119965E-04, 1.20245444949303E-04, & 1.10449144504599E-04, 1.01828770740567E-04, 9.41998224204238E-05, & 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), & BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2), & BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2), & BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2), & BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2), & BETA1(26,2) /-1.49282953213429E-03,-8.78204709546389E-04, & -5.02916549572035E-04,-2.94822138512746E-04,-1.75463996970783E-04, & -1.04008550460816E-04,-5.96141953046458E-05,-3.12038929076098E-05, & -1.26089735980230E-05,-2.42892608575730E-07, 8.05996165414274E-06, & 1.36507009262147E-05, 1.73964125472926E-05, 1.98672978842134E-05, & 2.14463263790823E-05, 2.23954659232457E-05, 2.28967783814713E-05, & 2.30785389811178E-05, 2.30321976080909E-05, 2.28236073720349E-05, & 2.25005881105292E-05, 2.20981015361991E-05, 2.16418427448104E-05, & 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), & BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1), & BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1), & BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1), & BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1), & BETA2(26,1) / 5.52213076721293E-04, 4.47932581552385E-04, & 2.79520653992021E-04, 1.52468156198447E-04, 6.93271105657044E-05, & 1.76258683069991E-05,-1.35744996343269E-05,-3.17972413350427E-05, & -4.18861861696693E-05,-4.69004889379141E-05,-4.87665447413787E-05, & -4.87010031186735E-05,-4.74755620890087E-05,-4.55813058138628E-05, & -4.33309644511266E-05,-4.09230193157750E-05,-3.84822638603221E-05, & -3.60857167535411E-05,-3.37793306123367E-05,-3.15888560772110E-05, & -2.95269561750807E-05,-2.75978914828336E-05,-2.58006174666884E-05, & -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), & BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2), & BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2), & BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2), & BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2), & BETA2(26,2) /-4.74617796559960E-04,-4.77864567147321E-04, & -3.20390228067038E-04,-1.61105016119962E-04,-4.25778101285435E-05, & 3.44571294294968E-05, 7.97092684075675E-05, 1.03138236708272E-04, & 1.12466775262204E-04, 1.13103642108481E-04, 1.08651634848774E-04, & 1.01437951597662E-04, 9.29298396593364E-05, 8.40293133016090E-05, & 7.52727991349134E-05, 6.69632521975731E-05, 5.92564547323195E-05, & 5.22169308826976E-05, 4.58539485165361E-05, 4.01445513891487E-05, & 3.50481730031328E-05, 3.05157995034347E-05, 2.64956119950516E-05, & 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), & BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1), & BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1), & BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1), & BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1), & BETA3(26,1) / 7.36465810572578E-04, 8.72790805146194E-04, & 6.22614862573135E-04, 2.85998154194304E-04, 3.84737672879366E-06, & -1.87906003636972E-04,-2.97603646594555E-04,-3.45998126832656E-04, & -3.53382470916038E-04,-3.35715635775049E-04,-3.04321124789040E-04, & -2.66722723047613E-04,-2.27654214122820E-04,-1.89922611854562E-04, & -1.55058918599094E-04,-1.23778240761874E-04,-9.62926147717644E-05, & -7.25178327714425E-05,-5.22070028895634E-05,-3.50347750511901E-05, & -2.06489761035552E-05,-8.70106096849767E-06, 1.13698686675100E-06, & 9.16426474122779E-06, 1.56477785428873E-05, 2.08223629482467E-05/ DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), & GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), & GAMA(11), GAMA(12), GAMA(13), GAMA(14), GAMA(15), & GAMA(16), GAMA(17), GAMA(18), GAMA(19), GAMA(20), & GAMA(21), GAMA(22), GAMA(23), GAMA(24), GAMA(25), & GAMA(26) / 6.29960524947437E-01, 2.51984209978975E-01, & 1.54790300415656E-01, 1.10713062416159E-01, 8.57309395527395E-02, & 6.97161316958684E-02, 5.86085671893714E-02, 5.04698873536311E-02, & 4.42600580689155E-02, 3.93720661543510E-02, 3.54283195924455E-02, & 3.21818857502098E-02, 2.94646240791158E-02, 2.71581677112934E-02, & 2.51768272973862E-02, 2.34570755306079E-02, 2.19508390134907E-02, & 2.06210828235646E-02, 1.94388240897881E-02, 1.83810633800683E-02, & 1.74293213231963E-02, 1.65685837786612E-02, 1.57865285987918E-02, & 1.50729501494096E-02, 1.44193250839955E-02, 1.38184805735342E-02/ !***FIRST EXECUTABLE STATEMENT ASYJY TA = R1MACH(3) TOL = MAX(TA,1.0E-15) TB = R1MACH(5) JU = I1MACH(12) if ( FLGJY == 1.0E0) go to 6 JR = I1MACH(11) ELIM = -2.303E0*TB*(JU+JR) go to 7 6 CONTINUE ELIM = -2.303E0*(TB*JU+3.0E0) 7 CONTINUE 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 > 0.27750E0) go to 80 ! ! ASYMPTOTIC EXPANSION ! CASES NEAR X=FN, ABS(1.-(X/FN)**2) <= 0.2775 ! COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES ! ! ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES ! ! KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA) ! SA = 0.0E0 if (ABW2 == 0.0E0) go to 10 SA = TOLS/LOG(ABW2) 10 SB = SA DO 20 I=1,5 AKM = MAX(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 <= 0.0E0) go to 35 if ( WK(4) > ELIM) go to 75 WK(6) = -WK(6) 35 CONTINUE PHI = SQRT(SQRT(SA+SA+SA+SA)) ! ! B(ZETA) FOR S=0 ! 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 ! ! A(ZETA) AND B(ZETA) FOR S=1,2,3,4 ! 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) <= TOL .AND. ABS(TB) <= RELB) go to 70 60 CONTINUE 70 CONTINUE BSUM = BSUM/(FN*WK(7)) go to 160 ! 75 CONTINUE IFLW = 1 return ! 80 CONTINUE UPOL(1) = 1.0E0 TAU = 1.0E0/WK(2) T2 = 1.0E0/WK(1) if (WK(1) >= 0.0E0) go to 90 ! ! CASES FOR (X/FN) > SQRT(1.2775) ! 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 ! ! CASES FOR (X/FN) < SQRT(0.7225) ! WK(3) = ABS(LOG((1.0E0+WK(2))/XX)-WK(2)) WK(4) = WK(3)*FN RCZ = CON1/WK(4) if ( WK(4) > 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 RDEN=1.0E0/FN RFN2=RDEN*RDEN RDEN=1.0E0 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 ISETA=0 ISETB=0 DO 140 LR=2,8,2 ! ! COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA) ! 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 RDEN=RDEN*RFN2 TB = -TB if (WK(1) > 0.0E0) TB = ABS(TB) if (RDEN < TOL) go to 131 ASUM = ASUM + SUMA*TB BSUM = BSUM + SUMB*TB go to 140 131 if ( ISETA == 1) go to 132 if ( ABS(SUMA) < TOL) ISETA=1 ASUM=ASUM+SUMA*TB 132 if ( ISETB == 1) go to 133 if ( ABS(SUMB) < RELB) ISETB=1 BSUM=BSUM+SUMB*TB 133 if ( ISETA == 1 .AND. ISETB == 1) go to 150 140 CONTINUE 150 TB = WK(5) if (WK(1) > 0.0E0) TB = -TB BSUM = BSUM/TB ! 160 CONTINUE call FUNJY(WK(6), WK(5), WK(4), FI, DFI) TA=1.0E0/TOL TB=R1MACH(1)*TA*1.0E+3 if ( ABS(FI) > TB) go to 165 FI=FI*TA DFI=DFI*TA PHI=PHI*TOL 165 CONTINUE Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7) FN = FN - FLGJY 170 CONTINUE return end function ATANH (X) ! !! ATANH computes the arc hyperbolic tangent. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE SINGLE PRECISION (ATANH-S, DATANH-D, CATANH-C) !***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, ! FNLIB, INVERSE HYPERBOLIC TANGENT !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! ATANH(X) computes the arc hyperbolic tangent of X. ! ! Series for ATNH on the interval 0. to 2.50000D-01 ! with weighted error 6.70E-18 ! log weighted error 17.17 ! significant figures required 16.01 ! decimal places required 17.76 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE ATANH DIMENSION ATNHCS(15) LOGICAL FIRST SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST DATA ATNHCS( 1) / .094395102393195492E0 / DATA ATNHCS( 2) / .049198437055786159E0 / DATA ATNHCS( 3) / .002102593522455432E0 / DATA ATNHCS( 4) / .000107355444977611E0 / DATA ATNHCS( 5) / .000005978267249293E0 / DATA ATNHCS( 6) / .000000350506203088E0 / DATA ATNHCS( 7) / .000000021263743437E0 / DATA ATNHCS( 8) / .000000001321694535E0 / DATA ATNHCS( 9) / .000000000083658755E0 / DATA ATNHCS(10) / .000000000005370503E0 / DATA ATNHCS(11) / .000000000000348665E0 / DATA ATNHCS(12) / .000000000000022845E0 / DATA ATNHCS(13) / .000000000000001508E0 / DATA ATNHCS(14) / .000000000000000100E0 / DATA ATNHCS(15) / .000000000000000006E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT ATANH if (FIRST) THEN NTERMS = INITS (ATNHCS, 15, 0.1*R1MACH(3)) DXREL = SQRT (R1MACH(4)) SQEPS = SQRT (3.0*R1MACH(3)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y >= 1.0) call XERMSG ('SLATEC', 'ATANH', 'ABS(X) GE 1', 2, & 2) ! if (1.0-Y < DXREL) call XERMSG ('SLATEC', 'ATANH', & 'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1) ! ATANH = X if (Y > SQEPS .AND. Y <= 0.5) ATANH = X*(1.0 + CSEVL (8.*X*X-1., & ATNHCS, NTERMS)) if (Y > 0.5) ATANH = 0.5*LOG((1.0+X)/(1.0-X)) ! return end subroutine AVINT (X, Y, N, XLO, XUP, ANS, IERR) ! !! AVINT integrates a function tabulated at arbitrarily spaced abscissas... ! using overlapping parabolas. ! !***LIBRARY SLATEC !***CATEGORY H2A1B2 !***TYPE SINGLE PRECISION (AVINT-S, DAVINT-D) !***KEYWORDS INTEGRATION, QUADRATURE, TABULATED DATA !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! AVINT integrates a function tabulated at arbitrarily spaced ! abscissas. The limits of integration need not coincide ! with the tabulated abscissas. ! ! A method of overlapping parabolas fitted to the data is used ! provided that there are at least 3 abscissas between the ! limits of integration. AVINT also handles two special cases. ! If the limits of integration are equal, AVINT returns a result ! of zero regardless of the number of tabulated values. ! If there are only two function values, AVINT uses the ! trapezoid rule. ! ! Description of Parameters ! The user must dimension all arrays appearing in the call list ! X(N), Y(N). ! ! Input-- ! X - real array of abscissas, which must be in increasing ! order. ! Y - real array of functional values. i.e., Y(I)=FUNC(X(I)). ! N - the integer number of function values supplied. ! N >= 2 unless XLO = XUP. ! XLO - real lower limit of integration. ! XUP - real upper limit of integration. ! Must have XLO <= XUP. ! ! Output-- ! ANS - computed approximate value of integral ! IERR - a status code ! --normal code ! =1 means the requested integration was performed. ! --abnormal codes ! =2 means XUP was less than XLO. ! =3 means the number of X(I) between XLO and XUP ! (inclusive) was less than 3 and neither of the two ! special cases described in the Abstract occurred. ! No integration was performed. ! =4 means the restriction X(I+1) > X(I) was violated. ! =5 means the number N of function values was < 2. ! ANS is set to zero if IERR=2,3,4,or 5. ! ! AVINT is documented completely in SC-M-69-335 ! Original program from "Numerical Integration" by Davis & ! Rabinowitz. ! Adaptation and modifications for Sandia Mathematical Program ! Library by Rondall E. Jones. ! !***REFERENCES R. E. Jones, Approximate integrator of functions ! tabulated at arbitrarily spaced abscissas, ! Report SC-M-69-335, Sandia Laboratories, 1969. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 690901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE AVINT ! DOUBLE PRECISION R3,RP5,SUM,SYL,SYL2,SYL3,SYU,SYU2,SYU3,X1,X2,X3 & ,X12,X13,X23,TERM1,TERM2,TERM3,A,B,C,CA,CB,CC DIMENSION X(*),Y(*) !***FIRST EXECUTABLE STATEMENT AVINT IERR=1 ANS =0.0 if (XLO-XUP) 3,100,200 3 if (N < 2) go to 215 DO 5 I=2,N if (X(I) <= X(I-1)) go to 210 if (X(I) > XUP) go to 6 5 CONTINUE 6 CONTINUE if (N >= 3) go to 9 ! ! SPECIAL N=2 CASE SLOPE = (Y(2)-Y(1))/(X(2)-X(1)) FL = Y(1) + SLOPE*(XLO-X(1)) FR = Y(2) + SLOPE*(XUP-X(2)) ANS = 0.5*(FL+FR)*(XUP-XLO) return 9 CONTINUE if (X(N-2) < XLO) go to 205 if (X(3) > XUP) go to 205 I = 1 10 if (X(I) >= XLO) go to 15 I = I+1 go to 10 15 INLFT = I I = N 20 if (X(I) <= XUP) go to 25 I = I-1 go to 20 25 INRT = I if ((INRT-INLFT) < 2) go to 205 ISTART = INLFT if (INLFT == 1) ISTART = 2 ISTOP = INRT if (INRT == N) ISTOP = N-1 ! R3 = 3.0D0 RP5= 0.5D0 SUM = 0.0 SYL = XLO SYL2= SYL*SYL SYL3= SYL2*SYL ! DO 50 I=ISTART,ISTOP X1 = X(I-1) X2 = X(I) X3 = X(I+1) X12 = X1-X2 X13 = X1-X3 X23 = X2-X3 TERM1 = DBLE(Y(I-1))/(X12*X13) TERM2 =-DBLE(Y(I)) /(X12*X23) TERM3 = DBLE(Y(I+1))/(X13*X23) A = TERM1+TERM2+TERM3 B = -(X2+X3)*TERM1 - (X1+X3)*TERM2 - (X1+X2)*TERM3 C = X2*X3*TERM1 + X1*X3*TERM2 + X1*X2*TERM3 if (I-ISTART) 30,30,35 30 CA = A CB = B CC = C go to 40 35 CA = 0.5*(A+CA) CB = 0.5*(B+CB) CC = 0.5*(C+CC) 40 SYU = X2 SYU2= SYU*SYU SYU3= SYU2*SYU SUM = SUM + CA*(SYU3-SYL3)/R3 + CB*RP5*(SYU2-SYL2) + CC*(SYU-SYL) CA = A CB = B CC = C SYL = SYU SYL2= SYU2 SYL3= SYU3 50 CONTINUE SYU = XUP ANS = SUM + CA*(SYU**3-SYL3)/R3 + CB*RP5*(SYU**2-SYL2) & + CC*(SYU-SYL) 100 RETURN 200 IERR=2 call XERMSG ('SLATEC', 'AVINT', & 'THE UPPER LIMIT OF INTEGRATION WAS NOT GREATER THAN THE ' // & 'LOWER LIMIT.', 4, 1) return 205 IERR=3 call XERMSG ('SLATEC', 'AVINT', & 'THERE WERE LESS THAN THREE FUNCTION VALUES BETWEEN THE ' // & 'LIMITS OF INTEGRATION.', 4, 1) return 210 IERR=4 call XERMSG ('SLATEC', 'AVINT', & 'THE ABSCISSAS WERE NOT STRICTLY INCREASING. MUST HAVE ' // & 'X(I-1) < X(I) FOR ALL I.', 4, 1) return 215 IERR=5 call XERMSG ('SLATEC', 'AVINT', & 'LESS THAN TWO FUNCTION VALUES WERE SUPPLIED.', 4, 1) return end subroutine BAKVEC (NM, N, T, E, M, Z, IERR) ! !! BAKVEC forms the eigenvectors of a certain real non-symmetric tridiagonal ! matrix from a symmetric tridiagonal matrix output from FIGI. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (BAKVEC-S) !***KEYWORDS EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine forms the eigenvectors of a NONSYMMETRIC ! TRIDIAGONAL matrix by back transforming those of the ! corresponding symmetric matrix determined by FIGI. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, T and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix T. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! T contains the nonsymmetric matrix. Its subdiagonal is ! stored in the last N-1 positions of the first column, ! its diagonal in the N positions of the second column, ! and its superdiagonal in the first N-1 positions of ! the third column. T(1,1) and T(N,3) are arbitrary. ! T is a two-dimensional REAL array, dimensioned T(NM,3). ! ! E contains the subdiagonal elements of the symmetric ! matrix in its last N-1 positions. E(1) is arbitrary. ! E is a one-dimensional REAL array, dimensioned E(N). ! ! M is the number of eigenvectors to be back transformed. ! M is an INTEGER variable. ! ! Z contains the eigenvectors to be back transformed ! in its first M columns. Z is a two-dimensional REAL ! array, dimensioned Z(NM,M). ! ! On OUTPUT ! ! T is unaltered. ! ! E is destroyed. ! ! Z contains the transformed eigenvectors in its first M columns. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 2*N+I if E(I) is zero with T(I,1) or T(I-1,3) non-zero. ! In this case, the symmetric matrix is not similar ! to the original matrix, and the eigenvectors ! cannot be found by this program. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BAKVEC ! INTEGER I,J,M,N,NM,IERR REAL T(NM,3),E(*),Z(NM,*) ! !***FIRST EXECUTABLE STATEMENT BAKVEC IERR = 0 if (M == 0) go to 1001 E(1) = 1.0E0 if (N == 1) go to 1001 ! DO 100 I = 2, N if (E(I) /= 0.0E0) go to 80 if (T(I,1) /= 0.0E0 .OR. T(I-1,3) /= 0.0E0) go to 1000 E(I) = 1.0E0 go to 100 80 E(I) = E(I-1) * E(I) / T(I-1,3) 100 CONTINUE ! DO 120 J = 1, M ! DO 120 I = 2, N Z(I,J) = Z(I,J) * E(I) 120 CONTINUE ! go to 1001 ! .......... SET ERROR -- EIGENVECTORS CANNOT BE ! FOUND BY THIS PROGRAM .......... 1000 IERR = 2 * N + I 1001 RETURN end subroutine BALANC (NM, N, A, LOW, IGH, SCALE) ! !! BALANC balances a real general matrix and isolates eigenvalues when possible. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1A !***TYPE SINGLE PRECISION (BALANC-S, CBAL-C) !***KEYWORDS EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure BALANCE, ! NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch. ! HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971). ! ! This subroutine balances a REAL matrix and isolates ! eigenvalues whenever possible. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, A, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! A contains the input matrix to be balanced. A is a ! two-dimensional REAL array, dimensioned A(NM,N). ! ! On OUTPUT ! ! A contains the balanced matrix. ! ! LOW and IGH are two INTEGER variables such that A(I,J) ! is equal to zero if ! (1) I is greater than J and ! (2) J=1,...,LOW-1 or I=IGH+1,...,N. ! ! SCALE contains information determining the permutations and ! scaling factors used. SCALE is a one-dimensional REAL array, ! dimensioned SCALE(N). ! ! Suppose that the principal submatrix in rows LOW through IGH ! has been balanced, that P(J) denotes the index interchanged ! with J during the permutation step, and that the elements ! of the diagonal matrix used are denoted by D(I,J). Then ! SCALE(J) = P(J), for J = 1,...,LOW-1 ! = D(J,J), J = LOW,...,IGH ! = P(J) J = IGH+1,...,N. ! The order in which the interchanges are made is N to IGH+1, ! then 1 TO LOW-1. ! ! Note that 1 is returned for IGH if IGH is zero formally. ! ! The ALGOL procedure EXC contained in BALANCE appears in ! BALANC in line. (Note that the ALGOL roles of identifiers ! K,L have been reversed.) ! ! Questions and comments should be directed to B. S. Garbow, ! Applied Mathematics Division, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BALANC ! INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC REAL A(NM,*),SCALE(*) REAL C,F,G,R,S,B2,RADIX LOGICAL NOCONV ! !***FIRST EXECUTABLE STATEMENT BALANC RADIX = 16 ! B2 = RADIX * RADIX K = 1 L = N go to 100 ! .......... IN-LINE PROCEDURE FOR ROW AND ! COLUMN EXCHANGE .......... 20 SCALE(M) = J if (J == M) go to 50 ! DO 30 I = 1, L F = A(I,J) A(I,J) = A(I,M) A(I,M) = F 30 CONTINUE ! DO 40 I = K, N F = A(J,I) A(J,I) = A(M,I) A(M,I) = F 40 CONTINUE ! 50 go to (80,130), IEXC ! .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE ! AND PUSH THEM DOWN .......... 80 if (L == 1) go to 280 L = L - 1 ! .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... 100 DO 120 JJ = 1, L J = L + 1 - JJ ! DO 110 I = 1, L if (I == J) go to 110 if (A(J,I) /= 0.0E0) go to 120 110 CONTINUE ! M = L IEXC = 1 go to 20 120 CONTINUE ! go to 140 ! .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE ! AND PUSH THEM LEFT .......... 130 K = K + 1 ! 140 DO 170 J = K, L ! DO 150 I = K, L if (I == J) go to 150 if (A(I,J) /= 0.0E0) go to 170 150 CONTINUE ! M = K IEXC = 2 go to 20 170 CONTINUE ! .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... DO 180 I = K, L 180 SCALE(I) = 1.0E0 ! .......... ITERATIVE LOOP FOR NORM REDUCTION .......... 190 NOCONV = .FALSE. ! DO 270 I = K, L C = 0.0E0 R = 0.0E0 ! DO 200 J = K, L if (J == I) go to 200 C = C + ABS(A(J,I)) R = R + ABS(A(I,J)) 200 CONTINUE ! .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... if (C == 0.0E0 .OR. R == 0.0E0) go to 270 G = R / RADIX F = 1.0E0 S = C + R 210 if (C >= G) go to 220 F = F * RADIX C = C * B2 go to 210 220 G = R * RADIX 230 if (C < G) go to 240 F = F / RADIX C = C / B2 go to 230 ! .......... NOW BALANCE .......... 240 if ((C + R) / F >= 0.95E0 * S) go to 270 G = 1.0E0 / F SCALE(I) = SCALE(I) * F NOCONV = .TRUE. ! DO 250 J = K, N 250 A(I,J) = A(I,J) * G ! DO 260 J = 1, L 260 A(J,I) = A(J,I) * F ! 270 CONTINUE ! if (NOCONV) go to 190 ! 280 LOW = K IGH = L return end subroutine BALBAK (NM, N, LOW, IGH, SCALE, M, Z) ! !! BALBAK forms the eigenvectors of a real general matrix from the ... ! eigenvectors of matrix output from BALANC. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (BALBAK-S, CBABK2-C) !***KEYWORDS EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure BALBAK, ! NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch. ! HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971). ! ! This subroutine forms the eigenvectors of a REAL GENERAL ! matrix by back transforming those of the corresponding ! balanced matrix determined by BALANC. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, Z, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the number of components of the vectors in matrix Z. ! N is an INTEGER variable. N must be less than or equal ! to NM. ! ! LOW and IGH are INTEGER variables determined by BALANC. ! ! SCALE contains information determining the permutations and ! scaling factors used by BALANC. SCALE is a one-dimensional ! REAL array, dimensioned SCALE(N). ! ! M is the number of columns of Z to be back transformed. ! M is an INTEGER variable. ! ! Z contains the real and imaginary parts of the eigen- ! vectors to be back transformed in its first M columns. ! Z is a two-dimensional REAL array, dimensioned Z(NM,M). ! ! On OUTPUT ! ! Z contains the real and imaginary parts of the ! transformed eigenvectors in its first M columns. ! ! Questions and comments should be directed to B. S. Garbow, ! Applied Mathematics Division, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BALBAK ! INTEGER I,J,K,M,N,II,NM,IGH,LOW REAL SCALE(*),Z(NM,*) REAL S ! !***FIRST EXECUTABLE STATEMENT BALBAK if (M == 0) go to 200 if (IGH == LOW) go to 120 ! DO 110 I = LOW, IGH S = SCALE(I) ! .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED ! if THE FOREGOING STATEMENT IS REPLACED BY ! S=1.0E0/SCALE(I). .......... DO 100 J = 1, M 100 Z(I,J) = Z(I,J) * S ! 110 CONTINUE ! ......... FOR I=LOW-1 STEP -1 UNTIL 1, ! IGH+1 STEP 1 UNTIL N DO -- .......... 120 DO 140 II = 1, N I = II if (I >= LOW .AND. I <= IGH) go to 140 if (I < LOW) I = LOW - II K = SCALE(I) if (K == I) go to 140 ! DO 130 J = 1, M S = Z(I,J) Z(I,J) = Z(K,J) Z(K,J) = S 130 CONTINUE ! 140 CONTINUE ! 200 RETURN end subroutine BANDR (NM, N, MB, A, D, E, E2, MATZ, Z) ! !! BANDR reduces a real symmetric band matrix to symmetric tridiagonal ... ! matrix and, optionally, accumulates orthogonal similarity transformations. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B1 !***TYPE SINGLE PRECISION (BANDR-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure BANDRD, ! NUM. MATH. 12, 231-241(1968) by Schwarz. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971). ! ! This subroutine reduces a REAL SYMMETRIC BAND matrix ! to a symmetric tridiagonal matrix using and optionally ! accumulating orthogonal similarity transformations. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! MB is the (half) band width of the matrix, defined as the ! number of adjacent diagonals, including the principal ! diagonal, required to specify the non-zero portion of the ! lower triangle of the matrix. MB is less than or equal ! to N. MB is an INTEGER variable. ! ! A contains the lower triangle of the real symmetric band ! matrix. Its lowest subdiagonal is stored in the last ! N+1-MB positions of the first column, its next subdiagonal ! in the last N+2-MB positions of the second column, further ! subdiagonals similarly, and finally its principal diagonal ! in the N positions of the last column. Contents of storage ! locations not part of the matrix are arbitrary. A is a ! two-dimensional REAL array, dimensioned A(NM,MB). ! ! MATZ should be set to .TRUE. if the transformation matrix is ! to be accumulated, and to .FALSE. otherwise. MATZ is a ! LOGICAL variable. ! ! On OUTPUT ! ! A has been destroyed, except for its last two columns which ! contain a copy of the tridiagonal matrix. ! ! D contains the diagonal elements of the tridiagonal matrix. ! D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the tridiagonal ! matrix in its last N-1 positions. E(1) is set to zero. ! E is a one-dimensional REAL array, dimensioned E(N). ! ! E2 contains the squares of the corresponding elements of E. ! E2 may coincide with E if the squares are not needed. ! E2 is a one-dimensional REAL array, dimensioned E2(N). ! ! Z contains the orthogonal transformation matrix produced in ! the reduction if MATZ has been set to .TRUE. Otherwise, Z ! is not referenced. Z is a two-dimensional REAL array, ! dimensioned Z(NM,N). ! ! Questions and comments should be directed to B. S. Garbow, ! Applied Mathematics Division, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BANDR ! INTEGER J,K,L,N,R,I1,I2,J1,J2,KR,MB,MR,M1,NM,N2,R1,UGL,MAXL,MAXR REAL A(NM,*),D(*),E(*),E2(*),Z(NM,*) REAL G,U,B1,B2,C2,F1,F2,S2,DMIN,DMINRT LOGICAL MATZ ! !***FIRST EXECUTABLE STATEMENT BANDR DMIN = 2.0E0**(-64) DMINRT = 2.0E0**(-32) ! .......... INITIALIZE DIAGONAL SCALING MATRIX .......... DO 30 J = 1, N 30 D(J) = 1.0E0 ! if (.NOT. MATZ) go to 60 ! DO 50 J = 1, N ! DO 40 K = 1, N 40 Z(J,K) = 0.0E0 ! Z(J,J) = 1.0E0 50 CONTINUE ! 60 M1 = MB - 1 if (M1 - 1) 900, 800, 70 70 N2 = N - 2 ! DO 700 K = 1, N2 MAXR = MIN(M1,N-K) ! .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- .......... DO 600 R1 = 2, MAXR R = MAXR + 2 - R1 KR = K + R MR = MB - R G = A(KR,MR) A(KR-1,1) = A(KR-1,MR+1) UGL = K ! DO 500 J = KR, N, M1 J1 = J - 1 J2 = J1 - 1 if (G == 0.0E0) go to 600 B1 = A(J1,1) / G B2 = B1 * D(J1) / D(J) S2 = 1.0E0 / (1.0E0 + B1 * B2) if (S2 >= 0.5E0 ) go to 450 B1 = G / A(J1,1) B2 = B1 * D(J) / D(J1) C2 = 1.0E0 - S2 D(J1) = C2 * D(J1) D(J) = C2 * D(J) F1 = 2.0E0 * A(J,M1) F2 = B1 * A(J1,MB) A(J,M1) = -B2 * (B1 * A(J,M1) - A(J,MB)) - F2 + A(J,M1) A(J1,MB) = B2 * (B2 * A(J,MB) + F1) + A(J1,MB) A(J,MB) = B1 * (F2 - F1) + A(J,MB) ! DO 200 L = UGL, J2 I2 = MB - J + L U = A(J1,I2+1) + B2 * A(J,I2) A(J,I2) = -B1 * A(J1,I2+1) + A(J,I2) A(J1,I2+1) = U 200 CONTINUE ! UGL = J A(J1,1) = A(J1,1) + B2 * G if (J == N) go to 350 MAXL = MIN(M1,N-J1) ! DO 300 L = 2, MAXL I1 = J1 + L I2 = MB - L U = A(I1,I2) + B2 * A(I1,I2+1) A(I1,I2+1) = -B1 * A(I1,I2) + A(I1,I2+1) A(I1,I2) = U 300 CONTINUE ! I1 = J + M1 if (I1 > N) go to 350 G = B2 * A(I1,1) 350 if (.NOT. MATZ) go to 500 ! DO 400 L = 1, N U = Z(L,J1) + B2 * Z(L,J) Z(L,J) = -B1 * Z(L,J1) + Z(L,J) Z(L,J1) = U 400 CONTINUE ! go to 500 ! 450 U = D(J1) D(J1) = S2 * D(J) D(J) = S2 * U F1 = 2.0E0 * A(J,M1) F2 = B1 * A(J,MB) U = B1 * (F2 - F1) + A(J1,MB) A(J,M1) = B2 * (B1 * A(J,M1) - A(J1,MB)) + F2 - A(J,M1) A(J1,MB) = B2 * (B2 * A(J1,MB) + F1) + A(J,MB) A(J,MB) = U ! DO 460 L = UGL, J2 I2 = MB - J + L U = B2 * A(J1,I2+1) + A(J,I2) A(J,I2) = -A(J1,I2+1) + B1 * A(J,I2) A(J1,I2+1) = U 460 CONTINUE ! UGL = J A(J1,1) = B2 * A(J1,1) + G if (J == N) go to 480 MAXL = MIN(M1,N-J1) ! DO 470 L = 2, MAXL I1 = J1 + L I2 = MB - L U = B2 * A(I1,I2) + A(I1,I2+1) A(I1,I2+1) = -A(I1,I2) + B1 * A(I1,I2+1) A(I1,I2) = U 470 CONTINUE ! I1 = J + M1 if (I1 > N) go to 480 G = A(I1,1) A(I1,1) = B1 * A(I1,1) 480 if (.NOT. MATZ) go to 500 ! DO 490 L = 1, N U = B2 * Z(L,J1) + Z(L,J) Z(L,J) = -Z(L,J1) + B1 * Z(L,J) Z(L,J1) = U 490 CONTINUE ! 500 CONTINUE ! 600 CONTINUE ! if (MOD(K,64) /= 0) go to 700 ! .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW .......... DO 650 J = K, N if (D(J) >= DMIN) go to 650 MAXL = MAX(1,MB+1-J) ! DO 610 L = MAXL, M1 610 A(J,L) = DMINRT * A(J,L) ! if (J == N) go to 630 MAXL = MIN(M1,N-J) ! DO 620 L = 1, MAXL I1 = J + L I2 = MB - L A(I1,I2) = DMINRT * A(I1,I2) 620 CONTINUE ! 630 if (.NOT. MATZ) go to 645 ! DO 640 L = 1, N 640 Z(L,J) = DMINRT * Z(L,J) ! 645 A(J,MB) = DMIN * A(J,MB) D(J) = D(J) / DMIN 650 CONTINUE ! 700 CONTINUE ! .......... FORM SQUARE ROOT OF SCALING MATRIX .......... 800 DO 810 J = 2, N 810 E(J) = SQRT(D(J)) ! if (.NOT. MATZ) go to 840 ! DO 830 J = 1, N ! DO 820 K = 2, N 820 Z(J,K) = E(K) * Z(J,K) ! 830 CONTINUE ! 840 U = 1.0E0 ! DO 850 J = 2, N A(J,M1) = U * E(J) * A(J,M1) U = E(J) E2(J) = A(J,M1) ** 2 A(J,MB) = D(J) * A(J,MB) D(J) = A(J,MB) E(J) = A(J,M1) 850 CONTINUE ! D(1) = A(1,MB) E(1) = 0.0E0 E2(1) = 0.0E0 go to 1001 ! 900 DO 950 J = 1, N D(J) = A(J,MB) E(J) = 0.0E0 E2(J) = 0.0E0 950 CONTINUE ! 1001 RETURN end subroutine BANDV (NM, N, MBW, A, E21, M, W, Z, IERR, NV, RV, RV6) ! !! BANDV forms the eigenvectors of a real symmetric band matrix ... ! associated with a set of ordered approximate eigenvalues ! by inverse iteration. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C3 !***TYPE SINGLE PRECISION (BANDV-S) !***KEYWORDS EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine finds those eigenvectors of a REAL SYMMETRIC ! BAND matrix corresponding to specified eigenvalues, using inverse ! iteration. The subroutine may also be used to solve systems ! of linear equations with a symmetric or non-symmetric band ! coefficient matrix. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! MBW is the number of columns of the array A used to store the ! band matrix. If the matrix is symmetric, MBW is its (half) ! band width, denoted MB and defined as the number of adjacent ! diagonals, including the principal diagonal, required to ! specify the non-zero portion of the lower triangle of the ! matrix. If the subroutine is being used to solve systems ! of linear equations and the coefficient matrix is not ! symmetric, it must however have the same number of adjacent ! diagonals above the main diagonal as below, and in this ! case, MBW=2*MB-1. MBW is an INTEGER variable. MB must not ! be greater than N. ! ! A contains the lower triangle of the symmetric band input ! matrix stored as an N by MB array. Its lowest subdiagonal ! is stored in the last N+1-MB positions of the first column, ! its next subdiagonal in the last N+2-MB positions of the ! second column, further subdiagonals similarly, and finally ! its principal diagonal in the N positions of column MB. ! If the subroutine is being used to solve systems of linear ! equations and the coefficient matrix is not symmetric, A is ! N by 2*MB-1 instead with lower triangle as above and with ! its first superdiagonal stored in the first N-1 positions of ! column MB+1, its second superdiagonal in the first N-2 ! positions of column MB+2, further superdiagonals similarly, ! and finally its highest superdiagonal in the first N+1-MB ! positions of the last column. Contents of storage locations ! not part of the matrix are arbitrary. A is a two-dimensional ! REAL array, dimensioned A(NM,MBW). ! ! E21 specifies the ordering of the eigenvalues and contains ! 0.0E0 if the eigenvalues are in ascending order, or ! 2.0E0 if the eigenvalues are in descending order. ! If the subroutine is being used to solve systems of linear ! equations, E21 should be set to 1.0E0 if the coefficient ! matrix is symmetric and to -1.0E0 if not. E21 is a REAL ! variable. ! ! M is the number of specified eigenvalues or the number of ! systems of linear equations. M is an INTEGER variable. ! ! W contains the M eigenvalues in ascending or descending order. ! If the subroutine is being used to solve systems of linear ! equations (A-W(J)*I)*X(J)=B(J), where I is the identity ! matrix, W(J) should be set accordingly, for J=1,2,...,M. ! W is a one-dimensional REAL array, dimensioned W(M). ! ! Z contains the constant matrix columns (B(J),J=1,2,...,M), if ! the subroutine is used to solve systems of linear equations. ! Z is a two-dimensional REAL array, dimensioned Z(NM,M). ! ! NV must be set to the dimension of the array parameter RV ! as declared in the calling program dimension statement. ! NV is an INTEGER variable. ! ! On OUTPUT ! ! A and W are unaltered. ! ! Z contains the associated set of orthogonal eigenvectors. ! Any vector which fails to converge is set to zero. If the ! subroutine is used to solve systems of linear equations, ! Z contains the solution matrix columns (X(J),J=1,2,...,M). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! -J if the eigenvector corresponding to the J-th ! eigenvalue fails to converge, or if the J-th ! system of linear equations is nearly singular. ! ! RV and RV6 are temporary storage arrays. If the subroutine ! is being used to solve systems of linear equations, the ! determinant (up to sign) of A-W(M)*I is available, upon ! return, as the product of the first N elements of RV. ! RV and RV6 are one-dimensional REAL arrays. Note that RV ! is dimensioned RV(NV), where NV must be at least N*(2*MB-1). ! RV6 is dimensioned RV6(N). ! ! Questions and comments should be directed to B. S. Garbow, ! Applied Mathematics Division, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BANDV ! INTEGER I,J,K,M,N,R,II,IJ,JJ,KJ,MB,M1,NM,NV,IJ1,ITS,KJ1,MBW,M21 INTEGER IERR,MAXJ,MAXK,GROUP REAL A(NM,*),W(*),Z(NM,*),RV(*),RV6(*) REAL U,V,UK,XU,X0,X1,E21,EPS2,EPS3,EPS4,NORM,ORDER,S ! !***FIRST EXECUTABLE STATEMENT BANDV IERR = 0 if (M == 0) go to 1001 MB = MBW if (E21 < 0.0E0) MB = (MBW + 1) / 2 M1 = MB - 1 M21 = M1 + MB ORDER = 1.0E0 - ABS(E21) ! .......... FIND VECTORS BY INVERSE ITERATION .......... DO 920 R = 1, M ITS = 1 X1 = W(R) if (R /= 1) go to 100 ! .......... COMPUTE NORM OF MATRIX .......... NORM = 0.0E0 ! DO 60 J = 1, MB JJ = MB + 1 - J KJ = JJ + M1 IJ = 1 S = 0.0E0 ! DO 40 I = JJ, N S = S + ABS(A(I,J)) if (E21 >= 0.0E0) go to 40 S = S + ABS(A(IJ,KJ)) IJ = IJ + 1 40 CONTINUE ! NORM = MAX(NORM,S) 60 CONTINUE ! if (E21 < 0.0E0) NORM = 0.5E0 * NORM ! .......... EPS2 IS THE CRITERION FOR GROUPING, ! EPS3 REPLACES ZERO PIVOTS AND EQUAL ! ROOTS ARE MODIFIED BY EPS3, ! EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... if (NORM == 0.0E0) NORM = 1.0E0 EPS2 = 1.0E-3 * NORM * ABS(ORDER) EPS3 = NORM 70 EPS3 = 0.5E0*EPS3 if (NORM + EPS3 > NORM) go to 70 UK = SQRT(REAL(N)) EPS3 = UK * EPS3 EPS4 = UK * EPS3 80 GROUP = 0 go to 120 ! .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... 100 if (ABS(X1-X0) >= EPS2) go to 80 GROUP = GROUP + 1 if (ORDER * (X1 - X0) <= 0.0E0) X1 = X0 + ORDER * EPS3 ! .......... EXPAND MATRIX, SUBTRACT EIGENVALUE, ! AND INITIALIZE VECTOR .......... 120 DO 200 I = 1, N IJ = I + MIN(0,I-M1) * N KJ = IJ + MB * N IJ1 = KJ + M1 * N if (M1 == 0) go to 180 ! DO 150 J = 1, M1 if (IJ > M1) go to 125 if (IJ > 0) go to 130 RV(IJ1) = 0.0E0 IJ1 = IJ1 + N go to 130 125 RV(IJ) = A(I,J) 130 IJ = IJ + N II = I + J if (II > N) go to 150 JJ = MB - J if (E21 >= 0.0E0) go to 140 II = I JJ = MB + J 140 RV(KJ) = A(II,JJ) KJ = KJ + N 150 CONTINUE ! 180 RV(IJ) = A(I,MB) - X1 RV6(I) = EPS4 if (ORDER == 0.0E0) RV6(I) = Z(I,R) 200 CONTINUE ! if (M1 == 0) go to 600 ! .......... ELIMINATION WITH INTERCHANGES .......... DO 580 I = 1, N II = I + 1 MAXK = MIN(I+M1-1,N) MAXJ = MIN(N-I,M21-2) * N ! DO 360 K = I, MAXK KJ1 = K J = KJ1 + N JJ = J + MAXJ ! DO 340 KJ = J, JJ, N RV(KJ1) = RV(KJ) KJ1 = KJ 340 CONTINUE ! RV(KJ1) = 0.0E0 360 CONTINUE ! if (I == N) go to 580 U = 0.0E0 MAXK = MIN(I+M1,N) MAXJ = MIN(N-II,M21-2) * N ! DO 450 J = I, MAXK if (ABS(RV(J)) < ABS(U)) go to 450 U = RV(J) K = J 450 CONTINUE ! J = I + N JJ = J + MAXJ if (K == I) go to 520 KJ = K ! DO 500 IJ = I, JJ, N V = RV(IJ) RV(IJ) = RV(KJ) RV(KJ) = V KJ = KJ + N 500 CONTINUE ! if (ORDER /= 0.0E0) go to 520 V = RV6(I) RV6(I) = RV6(K) RV6(K) = V 520 if (U == 0.0E0) go to 580 ! DO 560 K = II, MAXK V = RV(K) / U KJ = K ! DO 540 IJ = J, JJ, N KJ = KJ + N RV(KJ) = RV(KJ) - V * RV(IJ) 540 CONTINUE ! if (ORDER == 0.0E0) RV6(K) = RV6(K) - V * RV6(I) 560 CONTINUE ! 580 CONTINUE ! .......... BACK SUBSTITUTION ! FOR I=N STEP -1 UNTIL 1 DO -- .......... 600 DO 630 II = 1, N I = N + 1 - II MAXJ = MIN(II,M21) if (MAXJ == 1) go to 620 IJ1 = I J = IJ1 + N JJ = J + (MAXJ - 2) * N ! DO 610 IJ = J, JJ, N IJ1 = IJ1 + 1 RV6(I) = RV6(I) - RV(IJ) * RV6(IJ1) 610 CONTINUE ! 620 V = RV(I) if (ABS(V) >= EPS3) go to 625 ! .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM .......... if (ORDER == 0.0E0) IERR = -R V = SIGN(EPS3,V) 625 RV6(I) = RV6(I) / V 630 CONTINUE ! XU = 1.0E0 if (ORDER == 0.0E0) go to 870 ! .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS ! MEMBERS OF GROUP .......... if (GROUP == 0) go to 700 ! DO 680 JJ = 1, GROUP J = R - GROUP - 1 + JJ XU = 0.0E0 ! DO 640 I = 1, N 640 XU = XU + RV6(I) * Z(I,J) ! DO 660 I = 1, N 660 RV6(I) = RV6(I) - XU * Z(I,J) ! 680 CONTINUE ! 700 NORM = 0.0E0 ! DO 720 I = 1, N 720 NORM = NORM + ABS(RV6(I)) ! if (NORM >= 0.1E0) go to 840 ! .......... IN-LINE PROCEDURE FOR CHOOSING ! A NEW STARTING VECTOR .......... if (ITS >= N) go to 830 ITS = ITS + 1 XU = EPS4 / (UK + 1.0E0) RV6(1) = EPS4 ! DO 760 I = 2, N 760 RV6(I) = XU ! RV6(ITS) = RV6(ITS) - EPS4 * UK go to 600 ! .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... 830 IERR = -R XU = 0.0E0 go to 870 ! .......... NORMALIZE SO THAT SUM OF SQUARES IS ! 1 AND EXPAND TO FULL ORDER .......... 840 U = 0.0E0 ! DO 860 I = 1, N 860 U = U + RV6(I)**2 ! XU = 1.0E0 / SQRT(U) ! 870 DO 900 I = 1, N 900 Z(I,R) = RV6(I) * XU ! X0 = X1 920 CONTINUE ! 1001 RETURN end function BCRH (XLL, XRR, IZ, C, A, BH, F, SGN) ! !! BCRH is subsidiary to CBLKTR ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BCRH-S, BSRH-S) !***AUTHOR (UNKNOWN) !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CCBLK !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE BCRH DIMENSION A(*) ,C(*) ,BH(*) COMMON /CCBLK/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT BCRH XL = XLL XR = XRR DX = .5*ABS(XR-XL) 101 X = .5*(XL+XR) if (SGN*F(X,IZ,C,A,BH)) 103,105,102 102 XR = X go to 104 103 XL = X 104 DX = .5*DX if (DX-CNV) 105,105,101 105 BCRH = .5*(XL+XR) return end subroutine BDIFF (L, V) ! !! BDIFF is subsidiary to BSKIN ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BDIFF-S, DBDIFF-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! BDIFF computes the sum of B(L,K)*V(K)*(-1)**K where B(L,K) ! are the binomial coefficients. Truncated sums are computed by ! setting last part of the V vector to zero. On return, the binomial ! sum is in V(L). ! !***SEE ALSO BSKIN !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE BDIFF INTEGER I, J, K, L REAL V DIMENSION V(*) !***FIRST EXECUTABLE STATEMENT BDIFF if (L == 1) RETURN DO 20 J=2,L K = L DO 10 I=J,L V(K) = V(K-1) - V(K) K = K - 1 10 CONTINUE 20 CONTINUE return end function BESI0E (X) ! !! BESI0E computes the exponentially scaled modified (hyperbolic) ... ! Bessel function of the first kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE SINGLE PRECISION (BESI0E-S, DBSI0E-D) !***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, ! HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, ! ORDER ZERO, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESI0E(X) calculates the exponentially scaled modified (hyperbolic) ! Bessel function of the first kind of order zero for real argument X; ! i.e., EXP(-ABS(X))*I0(X). ! ! ! Series for BI0 on the interval 0. to 9.00000D+00 ! with weighted error 2.46E-18 ! log weighted error 17.61 ! significant figures required 17.90 ! decimal places required 18.15 ! ! ! Series for AI0 on the interval 1.25000D-01 to 3.33333D-01 ! with weighted error 7.87E-17 ! log weighted error 16.10 ! significant figures required 14.69 ! decimal places required 16.76 ! ! ! Series for AI02 on the interval 0. to 1.25000D-01 ! with weighted error 3.79E-17 ! log weighted error 16.42 ! significant figures required 14.86 ! decimal places required 17.09 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890313 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE BESI0E DIMENSION BI0CS(12), AI0CS(21), AI02CS(22) LOGICAL FIRST SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02, XSML, FIRST DATA BI0CS( 1) / -.07660547252839144951E0 / DATA BI0CS( 2) / 1.927337953993808270E0 / DATA BI0CS( 3) / .2282644586920301339E0 / DATA BI0CS( 4) / .01304891466707290428E0 / DATA BI0CS( 5) / .00043442709008164874E0 / DATA BI0CS( 6) / .00000942265768600193E0 / DATA BI0CS( 7) / .00000014340062895106E0 / DATA BI0CS( 8) / .00000000161384906966E0 / DATA BI0CS( 9) / .00000000001396650044E0 / DATA BI0CS(10) / .00000000000009579451E0 / DATA BI0CS(11) / .00000000000000053339E0 / DATA BI0CS(12) / .00000000000000000245E0 / DATA AI0CS( 1) / .07575994494023796E0 / DATA AI0CS( 2) / .00759138081082334E0 / DATA AI0CS( 3) / .00041531313389237E0 / DATA AI0CS( 4) / .00001070076463439E0 / DATA AI0CS( 5) / -.00000790117997921E0 / DATA AI0CS( 6) / -.00000078261435014E0 / DATA AI0CS( 7) / .00000027838499429E0 / DATA AI0CS( 8) / .00000000825247260E0 / DATA AI0CS( 9) / -.00000001204463945E0 / DATA AI0CS(10) / .00000000155964859E0 / DATA AI0CS(11) / .00000000022925563E0 / DATA AI0CS(12) / -.00000000011916228E0 / DATA AI0CS(13) / .00000000001757854E0 / DATA AI0CS(14) / .00000000000112822E0 / DATA AI0CS(15) / -.00000000000114684E0 / DATA AI0CS(16) / .00000000000027155E0 / DATA AI0CS(17) / -.00000000000002415E0 / DATA AI0CS(18) / -.00000000000000608E0 / DATA AI0CS(19) / .00000000000000314E0 / DATA AI0CS(20) / -.00000000000000071E0 / DATA AI0CS(21) / .00000000000000007E0 / DATA AI02CS( 1) / .05449041101410882E0 / DATA AI02CS( 2) / .00336911647825569E0 / DATA AI02CS( 3) / .00006889758346918E0 / DATA AI02CS( 4) / .00000289137052082E0 / DATA AI02CS( 5) / .00000020489185893E0 / DATA AI02CS( 6) / .00000002266668991E0 / DATA AI02CS( 7) / .00000000339623203E0 / DATA AI02CS( 8) / .00000000049406022E0 / DATA AI02CS( 9) / .00000000001188914E0 / DATA AI02CS(10) / -.00000000003149915E0 / DATA AI02CS(11) / -.00000000001321580E0 / DATA AI02CS(12) / -.00000000000179419E0 / DATA AI02CS(13) / .00000000000071801E0 / DATA AI02CS(14) / .00000000000038529E0 / DATA AI02CS(15) / .00000000000001539E0 / DATA AI02CS(16) / -.00000000000004151E0 / DATA AI02CS(17) / -.00000000000000954E0 / DATA AI02CS(18) / .00000000000000382E0 / DATA AI02CS(19) / .00000000000000176E0 / DATA AI02CS(20) / -.00000000000000034E0 / DATA AI02CS(21) / -.00000000000000027E0 / DATA AI02CS(22) / .00000000000000003E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESI0E if (FIRST) THEN NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3)) NTAI0 = INITS (AI0CS, 21, 0.1*R1MACH(3)) NTAI02 = INITS (AI02CS, 22, 0.1*R1MACH(3)) XSML = SQRT (4.5*R1MACH(3)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 3.0) go to 20 ! BESI0E = 1.0 - X if (Y > XSML) BESI0E = EXP(-Y) * ( 2.75 + & CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0) ) return ! 20 if (Y <= 8.) BESI0E = (.375 + CSEVL ((48./Y-11.)/5., AI0CS, NTAI0) & ) / SQRT(Y) if (Y > 8.) BESI0E = (.375 + CSEVL (16./Y-1., AI02CS, NTAI02)) & / SQRT(Y) ! return end function BESI0 (X) ! !! BESI0 computes the hyperbolic Bessel function of the first kind ... ! of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE SINGLE PRECISION (BESI0-S, DBESI0-D) !***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESI0(X) computes the modified (hyperbolic) Bessel function ! of the first kind of order zero and real argument X. ! ! Series for BI0 on the interval 0. to 9.00000D+00 ! with weighted error 2.46E-18 ! log weighted error 17.61 ! significant figures required 17.90 ! decimal places required 18.15 ! !***REFERENCES (NONE) !***ROUTINES CALLED BESI0E, CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESI0 DIMENSION BI0CS(12) LOGICAL FIRST SAVE BI0CS, NTI0, XSML, XMAX, FIRST DATA BI0CS( 1) / -.07660547252839144951E0 / DATA BI0CS( 2) / 1.927337953993808270E0 / DATA BI0CS( 3) / .2282644586920301339E0 / DATA BI0CS( 4) / .01304891466707290428E0 / DATA BI0CS( 5) / .00043442709008164874E0 / DATA BI0CS( 6) / .00000942265768600193E0 / DATA BI0CS( 7) / .00000014340062895106E0 / DATA BI0CS( 8) / .00000000161384906966E0 / DATA BI0CS( 9) / .00000000001396650044E0 / DATA BI0CS(10) / .00000000000009579451E0 / DATA BI0CS(11) / .00000000000000053339E0 / DATA BI0CS(12) / .00000000000000000245E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESI0 if (FIRST) THEN NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3)) XSML = SQRT (4.5*R1MACH(3)) XMAX = LOG (R1MACH(2)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 3.0) go to 20 ! BESI0 = 1.0 if (Y > XSML) BESI0 = 2.75 + CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0) return ! 20 if (Y > XMAX) call XERMSG ('SLATEC', 'BESI0', & 'ABS(X) SO BIG I0 OVERFLOWS', 1, 2) ! BESI0 = EXP(Y) * BESI0E(X) ! return end function BESI1E (X) ! !! BESI1E computes the exponentially scaled modified (hyperbolic) ... ! Bessel function of the first kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE SINGLE PRECISION (BESI1E-S, DBSI1E-D) !***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, ! HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, ! ORDER ONE, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESI1E(X) calculates the exponentially scaled modified (hyperbolic) ! Bessel function of the first kind of order one for real argument X; ! i.e., EXP(-ABS(X))*I1(X). ! ! Series for BI1 on the interval 0. to 9.00000D+00 ! with weighted error 2.40E-17 ! log weighted error 16.62 ! significant figures required 16.23 ! decimal places required 17.14 ! ! Series for AI1 on the interval 1.25000D-01 to 3.33333D-01 ! with weighted error 6.98E-17 ! log weighted error 16.16 ! significant figures required 14.53 ! decimal places required 16.82 ! ! Series for AI12 on the interval 0. to 1.25000D-01 ! with weighted error 3.55E-17 ! log weighted error 16.45 ! significant figures required 14.69 ! decimal places required 17.12 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890210 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE BESI1E DIMENSION BI1CS(11), AI1CS(21), AI12CS(22) LOGICAL FIRST SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML, FIRST DATA BI1CS( 1) / -.001971713261099859E0 / DATA BI1CS( 2) / .40734887667546481E0 / DATA BI1CS( 3) / .034838994299959456E0 / DATA BI1CS( 4) / .001545394556300123E0 / DATA BI1CS( 5) / .000041888521098377E0 / DATA BI1CS( 6) / .000000764902676483E0 / DATA BI1CS( 7) / .000000010042493924E0 / DATA BI1CS( 8) / .000000000099322077E0 / DATA BI1CS( 9) / .000000000000766380E0 / DATA BI1CS(10) / .000000000000004741E0 / DATA BI1CS(11) / .000000000000000024E0 / DATA AI1CS( 1) / -.02846744181881479E0 / DATA AI1CS( 2) / -.01922953231443221E0 / DATA AI1CS( 3) / -.00061151858579437E0 / DATA AI1CS( 4) / -.00002069971253350E0 / DATA AI1CS( 5) / .00000858561914581E0 / DATA AI1CS( 6) / .00000104949824671E0 / DATA AI1CS( 7) / -.00000029183389184E0 / DATA AI1CS( 8) / -.00000001559378146E0 / DATA AI1CS( 9) / .00000001318012367E0 / DATA AI1CS(10) / -.00000000144842341E0 / DATA AI1CS(11) / -.00000000029085122E0 / DATA AI1CS(12) / .00000000012663889E0 / DATA AI1CS(13) / -.00000000001664947E0 / DATA AI1CS(14) / -.00000000000166665E0 / DATA AI1CS(15) / .00000000000124260E0 / DATA AI1CS(16) / -.00000000000027315E0 / DATA AI1CS(17) / .00000000000002023E0 / DATA AI1CS(18) / .00000000000000730E0 / DATA AI1CS(19) / -.00000000000000333E0 / DATA AI1CS(20) / .00000000000000071E0 / DATA AI1CS(21) / -.00000000000000006E0 / DATA AI12CS( 1) / .02857623501828014E0 / DATA AI12CS( 2) / -.00976109749136147E0 / DATA AI12CS( 3) / -.00011058893876263E0 / DATA AI12CS( 4) / -.00000388256480887E0 / DATA AI12CS( 5) / -.00000025122362377E0 / DATA AI12CS( 6) / -.00000002631468847E0 / DATA AI12CS( 7) / -.00000000383538039E0 / DATA AI12CS( 8) / -.00000000055897433E0 / DATA AI12CS( 9) / -.00000000001897495E0 / DATA AI12CS(10) / .00000000003252602E0 / DATA AI12CS(11) / .00000000001412580E0 / DATA AI12CS(12) / .00000000000203564E0 / DATA AI12CS(13) / -.00000000000071985E0 / DATA AI12CS(14) / -.00000000000040836E0 / DATA AI12CS(15) / -.00000000000002101E0 / DATA AI12CS(16) / .00000000000004273E0 / DATA AI12CS(17) / .00000000000001041E0 / DATA AI12CS(18) / -.00000000000000382E0 / DATA AI12CS(19) / -.00000000000000186E0 / DATA AI12CS(20) / .00000000000000033E0 / DATA AI12CS(21) / .00000000000000028E0 / DATA AI12CS(22) / -.00000000000000003E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESI1E if (FIRST) THEN NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3)) NTAI1 = INITS (AI1CS, 21, 0.1*R1MACH(3)) NTAI12 = INITS (AI12CS, 22, 0.1*R1MACH(3)) ! XMIN = 2.0*R1MACH(1) XSML = SQRT (4.5*R1MACH(3)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 3.0) go to 20 ! BESI1E = 0.0 if (Y == 0.0) return ! if (Y <= XMIN) call XERMSG ('SLATEC', 'BESI1E', & 'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1) if (Y > XMIN) BESI1E = 0.5*X if (Y > XSML) BESI1E = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS,NTI1)) BESI1E = EXP(-Y) * BESI1E return ! 20 if (Y <= 8.) BESI1E = (.375 + CSEVL ((48./Y-11.)/5., AI1CS, NTAI1) & ) / SQRT(Y) if (Y > 8.) BESI1E = (.375 + CSEVL (16./Y-1.0, AI12CS, NTAI12)) & / SQRT(Y) BESI1E = SIGN (BESI1E, X) ! return end function BESI1 (X) ! !! BESI1 computes the modified (hyperbolic) Bessel function of the ... ! first kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE SINGLE PRECISION (BESI1-S, DBESI1-D) !***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESI1(X) calculates the modified (hyperbolic) Bessel function ! of the first kind of order one for real argument X. ! ! Series for BI1 on the interval 0. to 9.00000D+00 ! with weighted error 2.40E-17 ! log weighted error 16.62 ! significant figures required 16.23 ! decimal places required 17.14 ! !***REFERENCES (NONE) !***ROUTINES CALLED BESI1E, CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESI1 DIMENSION BI1CS(11) LOGICAL FIRST SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST DATA BI1CS( 1) / -.001971713261099859E0 / DATA BI1CS( 2) / .40734887667546481E0 / DATA BI1CS( 3) / .034838994299959456E0 / DATA BI1CS( 4) / .001545394556300123E0 / DATA BI1CS( 5) / .000041888521098377E0 / DATA BI1CS( 6) / .000000764902676483E0 / DATA BI1CS( 7) / .000000010042493924E0 / DATA BI1CS( 8) / .000000000099322077E0 / DATA BI1CS( 9) / .000000000000766380E0 / DATA BI1CS(10) / .000000000000004741E0 / DATA BI1CS(11) / .000000000000000024E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESI1 if (FIRST) THEN NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3)) XMIN = 2.0*R1MACH(1) XSML = SQRT (4.5*R1MACH(3)) XMAX = LOG (R1MACH(2)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 3.0) go to 20 ! BESI1 = 0.0 if (Y == 0.0) return ! if (Y <= XMIN) call XERMSG ('SLATEC', 'BESI1', & 'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1) if (Y > XMIN) BESI1 = 0.5*X if (Y > XSML) BESI1 = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS, NTI1)) return ! 20 if (Y > XMAX) call XERMSG ('SLATEC', 'BESI1', & 'ABS(X) SO BIG I1 OVERFLOWS', 2, 2) ! BESI1 = EXP(Y) * BESI1E(X) ! return end subroutine BESI (X, ALPHA, KODE, N, Y, NZ) ! !! BESI computes an N member sequence of I Bessel functions ! I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions ! EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ! ALPHA and X. ! !***LIBRARY SLATEC !***CATEGORY C10B3 !***TYPE SINGLE PRECISION (BESI-S, DBESI-D) !***KEYWORDS I BESSEL FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Amos, D. E., (SNLA) ! Daniel, S. L., (SNLA) !***DESCRIPTION ! ! Abstract ! BESI computes an N member sequence of I Bessel functions ! I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions ! EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA ! and X. A combination of the power series, the asymptotic ! expansion for X to infinity, and the uniform asymptotic ! expansion for NU to infinity are applied over subdivisions of ! the (NU,X) plane. For values not covered by one of these ! formulae, the order is incremented by an integer so that one ! of these formulae apply. Backward recursion is used to reduce ! orders by integer values. The asymptotic expansion for X to ! infinity is used only when the entire sequence (specifically ! the last member) lies within the region covered by the ! expansion. Leading terms of these expansions are used to test ! for over or underflow where appropriate. If a sequence is ! requested and the last member would underflow, the result is ! set to zero and the next lower order tried, etc., until a ! member comes on scale or all are set to zero. An overflow ! cannot occur with scaling. ! ! Description of Arguments ! ! Input ! X - X >= 0.0E0 ! ALPHA - order of first member of the sequence, ! ALPHA >= 0.0E0 ! KODE - a parameter to indicate the scaling option ! KODE=1 returns ! Y(K)= I/sub(ALPHA+K-1)/(X), ! K=1,...,N ! KODE=2 returns ! Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X), ! K=1,...,N ! N - number of members in the sequence, N >= 1 ! ! Output ! Y - a vector whose first N components contain ! values for I/sub(ALPHA+K-1)/(X) or scaled ! values for EXP(-X)*I/sub(ALPHA+K-1)/(X), ! K=1,...,N depending on KODE ! NZ - number of components of Y set to zero due to ! underflow, ! NZ=0 , normal return, computation completed ! NZ /= 0, last NZ components of Y set to zero, ! Y(K)=0.0E0, K=N-NZ+1,...,N. ! ! Error Conditions ! Improper input arguments - a fatal error ! Overflow with KODE=1 - a fatal error ! Underflow - a non-fatal error (NZ /= 0) ! !***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 ! subroutines IBESS and JBESS for Bessel functions ! I(NU,X) and J(NU,X), X >= 0, NU >= 0, ACM ! Transactions on Mathematical Software 3, (1977), ! pp. 76-92. ! F. W. J. Olver, Tables of Bessel Functions of Moderate ! or Large Orders, NPL Mathematical Tables 6, Her ! Majesty's Stationery Office, London, 1962. !***ROUTINES CALLED ALNGAM, ASYIK, I1MACH, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BESI ! INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT, & N, NN, NS, NZ INTEGER I1MACH 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 R1MACH, ALNGAM DIMENSION Y(*), TEMP(3) SAVE RTTPI, INLIM DATA RTTPI / 3.98942280401433E-01/ DATA INLIM / 80 / !***FIRST EXECUTABLE STATEMENT BESI NZ = 0 KT = 1 ! I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE ! I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE RA = R1MACH(3) TOL = MAX(RA,1.0E-15) I1 = -I1MACH(12) GLN = R1MACH(5) ELIM = 2.303E0*(I1*GLN-3.0E0) ! TOLLN = -LN(TOL) I1 = I1MACH(11)+1 TOLLN = 2.303E0*GLN*I1 TOLLN = MIN(TOLLN,34.5388E0) if (N-1) 590, 10, 20 10 KT = 2 20 NN = N if (KODE < 1 .OR. KODE > 2) go to 570 if (X) 600, 30, 80 30 if (ALPHA) 580, 40, 50 40 Y(1) = 1.0E0 if (N == 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 < 0.0E0) go to 580 ! IALP = INT(ALPHA) FNI = IALP + N - 1 FNF = ALPHA - IALP DFN = FNI + FNF FNU = DFN IN = 0 XO2 = X*0.5E0 SXO2 = XO2*XO2 ETX = KODE - 1 SX = ETX*X ! ! DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X ! TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE ! APPLIED. ! if (SXO2 <= (FNU+1.0E0)) go to 90 if (X <= 12.0E0) go to 110 FN = 0.55E0*FNU*FNU FN = MAX(17.0E0,FN) if (X >= FN) go to 430 ANS = MAX(36.0E0-FNU,0.0E0) NS = INT(ANS) FNI = FNI + NS DFN = FNI + FNF FN = DFN IS = KT KM = N - 1 + NS if (KM > 0) IS = 3 go to 120 90 FN = FNU FNP1 = FN + 1.0E0 XO2L = LOG(XO2) IS = KT if (X <= 0.5E0) go to 230 NS = 0 100 FNI = FNI + NS DFN = FNI + FNF FN = DFN FNP1 = FN + 1.0E0 IS = KT if (N-1+NS > 0) IS = 3 go to 230 110 XO2L = LOG(XO2) NS = INT(SXO2-FNU) go to 100 120 CONTINUE ! ! OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION ! if (KODE == 2) go to 130 if (ALPHA < 1.0E0) go to 150 Z = X/ALPHA RA = SQRT(1.0E0+Z*Z) GLN = LOG((1.0E0+RA)/Z) T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = ALPHA*(T-GLN) if (ARG > ELIM) go to 610 if (KM == 0) go to 140 130 CONTINUE ! ! UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION ! Z = X/FN RA = SQRT(1.0E0+Z*Z) GLN = LOG((1.0E0+RA)/Z) T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN) 140 if (ARG < (-ELIM)) go to 280 go to 190 150 if (X > ELIM) go to 610 go to 130 ! ! UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY ! 160 if (KM /= 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 == 2) go to 350 Z = X/FN RA = SQRT(1.0E0+Z*Z) GLN = LOG((1.0E0+RA)/Z) T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN) 190 CONTINUE I1 = ABS(3-IS) I1 = MAX(I1,1) FLGIK = 1.0E0 call ASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS)) go to (180, 350, 510), IS ! ! SERIES FOR (X/2)**2 <= NU+1 ! 230 CONTINUE GLN = ALNGAM(FNP1) ARG = FN*XO2L - GLN - SX if (ARG < (-ELIM)) go to 300 EARG = EXP(ARG) 240 CONTINUE S = 1.0E0 if (X < 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) < 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 ! ! SET UNDERFLOW VALUE AND UPDATE PARAMETERS ! 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 <= FNP1) go to 330 go to 130 330 ARG = ARG - XO2L + LOG(FNP1) if (ARG < (-ELIM)) go to 300 go to 230 340 NZ = N - NN return ! ! BACKWARD RECURSION SECTION ! 350 CONTINUE NZ = N - NN 360 CONTINUE if ( KT == 2) go to 420 S1 = TEMP(1) S2 = TEMP(2) TRX = 2.0E0/X DTM = FNI TM = (DTM+FNF)*TRX if (IN == 0) go to 390 ! 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 == 1) RETURN Y(NN-1) = S2 if (NN == 2) RETURN go to 400 390 CONTINUE ! BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA Y(NN) = S1 Y(NN-1) = S2 if (NN == 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 ! ! ASYMPTOTIC EXPANSION FOR X TO INFINITY ! 430 CONTINUE EARG = RTTPI/SQRT(X) if (KODE == 2) go to 440 if (X > 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 == 0.0E0 .AND. ABS(FNF) < 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) <= ATOL) go to 480 AK = AK + 8.0E0 470 CONTINUE 480 TEMP(IS) = S*EARG if ( IS == 2) go to 360 IS = 2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN go to 450 ! ! BACKWARD RECURSION WITH NORMALIZATION BY ! ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. ! 500 CONTINUE ! COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION AKM = MAX(3.0E0-FN,0.0E0) KM = INT(AKM) TFN = FN + 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 ! 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 > INLIM) go to 160 520 CONTINUE TRX = 2.0E0/X DTM = FNI + IN TM = (DTM+FNF)*TRX TA = 0.0E0 TB = TOL KK = 1 530 CONTINUE ! ! BACKWARD RECUR UNINDEXED ! DO 540 I=1,IN S = TB TB = TM*TB + TA TA = S DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 540 CONTINUE ! NORMALIZATION if (KK /= 1) go to 550 TA = (TA/TB)*TEMP(3) TB = TEMP(3) KK = 2 IN = NS if (NS /= 0) go to 530 550 Y(NN) = TB NZ = N - NN if (NN == 1) RETURN TB = TM*TB + TA K = NN - 1 Y(K) = TB if (NN == 2) RETURN DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX KM = K - 1 ! ! BACKWARD RECUR INDEXED ! 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 ! ! ! 570 CONTINUE call XERMSG ('SLATEC', 'BESI', & 'SCALING OPTION, KODE, NOT 1 OR 2.', 2, 1) return 580 CONTINUE call XERMSG ('SLATEC', 'BESI', 'ORDER, ALPHA, LESS THAN ZERO.', & 2, 1) return 590 CONTINUE call XERMSG ('SLATEC', 'BESI', 'N LESS THAN ONE.', 2, 1) return 600 CONTINUE call XERMSG ('SLATEC', 'BESI', 'X LESS THAN ZERO.', 2, 1) return 610 CONTINUE call XERMSG ('SLATEC', 'BESI', & 'OVERFLOW, X TOO LARGE FOR KODE = 1.', 6, 1) return end function BESJ0 (X) ! !! BESJ0 computes the Bessel function of the first kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10A1 !***TYPE SINGLE PRECISION (BESJ0-S, DBESJ0-D) !***KEYWORDS BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ZERO, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESJ0(X) calculates the Bessel function of the first kind of ! order zero for real argument X. ! ! Series for BJ0 on the interval 0. to 1.60000D+01 ! with weighted error 7.47E-18 ! log weighted error 17.13 ! significant figures required 16.98 ! decimal places required 17.68 ! ! Series for BM0 on the interval 0. to 6.25000D-02 ! with weighted error 4.98E-17 ! log weighted error 16.30 ! significant figures required 14.97 ! decimal places required 16.96 ! ! Series for BTH0 on the interval 0. to 6.25000D-02 ! with weighted error 3.67E-17 ! log weighted error 16.44 ! significant figures required 15.53 ! decimal places required 17.13 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890210 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESJ0 DIMENSION BJ0CS(13), BM0CS(21), BTH0CS(24) LOGICAL FIRST SAVE BJ0CS, BM0CS, BTH0CS, PI4, NTJ0, NTM0, NTTH0, XSML, XMAX, & FIRST DATA BJ0CS( 1) / .100254161968939137E0 / DATA BJ0CS( 2) / -.665223007764405132E0 / DATA BJ0CS( 3) / .248983703498281314E0 / DATA BJ0CS( 4) / -.0332527231700357697E0 / DATA BJ0CS( 5) / .0023114179304694015E0 / DATA BJ0CS( 6) / -.0000991127741995080E0 / DATA BJ0CS( 7) / .0000028916708643998E0 / DATA BJ0CS( 8) / -.0000000612108586630E0 / DATA BJ0CS( 9) / .0000000009838650793E0 / DATA BJ0CS(10) / -.0000000000124235515E0 / DATA BJ0CS(11) / .0000000000001265433E0 / DATA BJ0CS(12) / -.0000000000000010619E0 / DATA BJ0CS(13) / .0000000000000000074E0 / DATA BM0CS( 1) / .09284961637381644E0 / DATA BM0CS( 2) / -.00142987707403484E0 / DATA BM0CS( 3) / .00002830579271257E0 / DATA BM0CS( 4) / -.00000143300611424E0 / DATA BM0CS( 5) / .00000012028628046E0 / DATA BM0CS( 6) / -.00000001397113013E0 / DATA BM0CS( 7) / .00000000204076188E0 / DATA BM0CS( 8) / -.00000000035399669E0 / DATA BM0CS( 9) / .00000000007024759E0 / DATA BM0CS(10) / -.00000000001554107E0 / DATA BM0CS(11) / .00000000000376226E0 / DATA BM0CS(12) / -.00000000000098282E0 / DATA BM0CS(13) / .00000000000027408E0 / DATA BM0CS(14) / -.00000000000008091E0 / DATA BM0CS(15) / .00000000000002511E0 / DATA BM0CS(16) / -.00000000000000814E0 / DATA BM0CS(17) / .00000000000000275E0 / DATA BM0CS(18) / -.00000000000000096E0 / DATA BM0CS(19) / .00000000000000034E0 / DATA BM0CS(20) / -.00000000000000012E0 / DATA BM0CS(21) / .00000000000000004E0 / DATA BTH0CS( 1) / -.24639163774300119E0 / DATA BTH0CS( 2) / .001737098307508963E0 / DATA BTH0CS( 3) / -.000062183633402968E0 / DATA BTH0CS( 4) / .000004368050165742E0 / DATA BTH0CS( 5) / -.000000456093019869E0 / DATA BTH0CS( 6) / .000000062197400101E0 / DATA BTH0CS( 7) / -.000000010300442889E0 / DATA BTH0CS( 8) / .000000001979526776E0 / DATA BTH0CS( 9) / -.000000000428198396E0 / DATA BTH0CS(10) / .000000000102035840E0 / DATA BTH0CS(11) / -.000000000026363898E0 / DATA BTH0CS(12) / .000000000007297935E0 / DATA BTH0CS(13) / -.000000000002144188E0 / DATA BTH0CS(14) / .000000000000663693E0 / DATA BTH0CS(15) / -.000000000000215126E0 / DATA BTH0CS(16) / .000000000000072659E0 / DATA BTH0CS(17) / -.000000000000025465E0 / DATA BTH0CS(18) / .000000000000009229E0 / DATA BTH0CS(19) / -.000000000000003448E0 / DATA BTH0CS(20) / .000000000000001325E0 / DATA BTH0CS(21) / -.000000000000000522E0 / DATA BTH0CS(22) / .000000000000000210E0 / DATA BTH0CS(23) / -.000000000000000087E0 / DATA BTH0CS(24) / .000000000000000036E0 / DATA PI4 / 0.78539816339744831E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESJ0 if (FIRST) THEN NTJ0 = INITS (BJ0CS, 13, 0.1*R1MACH(3)) NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3)) NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3)) ! XSML = SQRT (8.0*R1MACH(3)) XMAX = 1.0/R1MACH(4) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 4.0) go to 20 ! BESJ0 = 1.0 if (Y > XSML) BESJ0 = CSEVL (.125*Y*Y-1., BJ0CS, NTJ0) return ! 20 if (Y > XMAX) call XERMSG ('SLATEC', 'BESJ0', & 'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 1, 2) ! Z = 32.0/Y**2 - 1.0 AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(Y) THETA = Y - PI4 + CSEVL (Z, BTH0CS, NTTH0) / Y BESJ0 = AMPL * COS (THETA) ! return end function BESJ1 (X) ! !! BESJ1 computes the Bessel function of the first kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10A1 !***TYPE SINGLE PRECISION (BESJ1-S, DBESJ1-D) !***KEYWORDS BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESJ1(X) calculates the Bessel function of the first kind of ! order one for real argument X. ! ! Series for BJ1 on the interval 0. to 1.60000D+01 ! with weighted error 4.48E-17 ! log weighted error 16.35 ! significant figures required 15.77 ! decimal places required 16.89 ! ! Series for BM1 on the interval 0. to 6.25000D-02 ! with weighted error 5.61E-17 ! log weighted error 16.25 ! significant figures required 14.97 ! decimal places required 16.91 ! ! Series for BTH1 on the interval 0. to 6.25000D-02 ! with weighted error 4.10E-17 ! log weighted error 16.39 ! significant figures required 15.96 ! decimal places required 17.08 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 780601 DATE WRITTEN ! 890210 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESJ1 DIMENSION BJ1CS(12), BM1CS(21), BTH1CS(24) LOGICAL FIRST SAVE BJ1CS, BM1CS, BTH1CS, PI4, NTJ1, NTM1, NTTH1, & XSML, XMIN, XMAX, FIRST DATA BJ1CS( 1) / -.11726141513332787E0 / DATA BJ1CS( 2) / -.25361521830790640E0 / DATA BJ1CS( 3) / .050127080984469569E0 / DATA BJ1CS( 4) / -.004631514809625081E0 / DATA BJ1CS( 5) / .000247996229415914E0 / DATA BJ1CS( 6) / -.000008678948686278E0 / DATA BJ1CS( 7) / .000000214293917143E0 / DATA BJ1CS( 8) / -.000000003936093079E0 / DATA BJ1CS( 9) / .000000000055911823E0 / DATA BJ1CS(10) / -.000000000000632761E0 / DATA BJ1CS(11) / .000000000000005840E0 / DATA BJ1CS(12) / -.000000000000000044E0 / DATA BM1CS( 1) / .1047362510931285E0 / DATA BM1CS( 2) / .00442443893702345E0 / DATA BM1CS( 3) / -.00005661639504035E0 / DATA BM1CS( 4) / .00000231349417339E0 / DATA BM1CS( 5) / -.00000017377182007E0 / DATA BM1CS( 6) / .00000001893209930E0 / DATA BM1CS( 7) / -.00000000265416023E0 / DATA BM1CS( 8) / .00000000044740209E0 / DATA BM1CS( 9) / -.00000000008691795E0 / DATA BM1CS(10) / .00000000001891492E0 / DATA BM1CS(11) / -.00000000000451884E0 / DATA BM1CS(12) / .00000000000116765E0 / DATA BM1CS(13) / -.00000000000032265E0 / DATA BM1CS(14) / .00000000000009450E0 / DATA BM1CS(15) / -.00000000000002913E0 / DATA BM1CS(16) / .00000000000000939E0 / DATA BM1CS(17) / -.00000000000000315E0 / DATA BM1CS(18) / .00000000000000109E0 / DATA BM1CS(19) / -.00000000000000039E0 / DATA BM1CS(20) / .00000000000000014E0 / DATA BM1CS(21) / -.00000000000000005E0 / DATA BTH1CS( 1) / .74060141026313850E0 / DATA BTH1CS( 2) / -.004571755659637690E0 / DATA BTH1CS( 3) / .000119818510964326E0 / DATA BTH1CS( 4) / -.000006964561891648E0 / DATA BTH1CS( 5) / .000000655495621447E0 / DATA BTH1CS( 6) / -.000000084066228945E0 / DATA BTH1CS( 7) / .000000013376886564E0 / DATA BTH1CS( 8) / -.000000002499565654E0 / DATA BTH1CS( 9) / .000000000529495100E0 / DATA BTH1CS(10) / -.000000000124135944E0 / DATA BTH1CS(11) / .000000000031656485E0 / DATA BTH1CS(12) / -.000000000008668640E0 / DATA BTH1CS(13) / .000000000002523758E0 / DATA BTH1CS(14) / -.000000000000775085E0 / DATA BTH1CS(15) / .000000000000249527E0 / DATA BTH1CS(16) / -.000000000000083773E0 / DATA BTH1CS(17) / .000000000000029205E0 / DATA BTH1CS(18) / -.000000000000010534E0 / DATA BTH1CS(19) / .000000000000003919E0 / DATA BTH1CS(20) / -.000000000000001500E0 / DATA BTH1CS(21) / .000000000000000589E0 / DATA BTH1CS(22) / -.000000000000000237E0 / DATA BTH1CS(23) / .000000000000000097E0 / DATA BTH1CS(24) / -.000000000000000040E0 / DATA PI4 / 0.78539816339744831E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESJ1 if (FIRST) THEN NTJ1 = INITS (BJ1CS, 12, 0.1*R1MACH(3)) NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3)) NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3)) ! XSML = SQRT (8.0*R1MACH(3)) XMIN = 2.0*R1MACH(1) XMAX = 1.0/R1MACH(4) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 4.0) go to 20 ! BESJ1 = 0. if (Y == 0.0) RETURN if (Y <= XMIN) call XERMSG ('SLATEC', 'BESJ1', & 'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1) if (Y > XMIN) BESJ1 = 0.5*X if (Y > XSML) BESJ1 = X * (.25 + CSEVL(.125*Y*Y-1., BJ1CS, NTJ1)) return ! 20 if (Y > XMAX) call XERMSG ('SLATEC', 'BESJ1', & 'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 2, 2) Z = 32.0/Y**2 - 1.0 AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(Y) THETA = Y - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / Y BESJ1 = SIGN (AMPL, X) * COS (THETA) ! return end subroutine BESJ (X, ALPHA, N, Y, NZ) ! !! BESJ computes an N member sequence of J Bessel functions ... ! J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. ! !***LIBRARY SLATEC !***CATEGORY C10A3 !***TYPE SINGLE PRECISION (BESJ-S, DBESJ-D) !***KEYWORDS J BESSEL FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Amos, D. E., (SNLA) ! Daniel, S. L., (SNLA) ! Weston, M. K., (SNLA) !***DESCRIPTION ! ! Abstract ! BESJ computes an N member sequence of J Bessel functions ! J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. ! A combination of the power series, the asymptotic expansion ! for X to infinity and the uniform asymptotic expansion for ! NU to infinity are applied over subdivisions of the (NU,X) ! plane. For values of (NU,X) not covered by one of these ! formulae, the order is incremented or decremented by integer ! values into a region where one of the formulae apply. Backward ! recursion is applied to reduce orders by integer values except ! where the entire sequence lies in the oscillatory region. In ! this case forward recursion is stable and values from the ! asymptotic expansion for X to infinity start the recursion ! when it is efficient to do so. Leading terms of the series ! and uniform expansion are tested for underflow. If a sequence ! is requested and the last member would underflow, the result ! is set to zero and the next lower order tried, etc., until a ! member comes on scale or all members are set to zero. ! Overflow cannot occur. ! ! Description of Arguments ! ! Input ! X - X >= 0.0E0 ! ALPHA - order of first member of the sequence, ! ALPHA >= 0.0E0 ! N - number of members in the sequence, N >= 1 ! ! Output ! Y - a vector whose first N components contain ! values for J/sub(ALPHA+K-1)/(X), K=1,...,N ! NZ - number of components of Y set to zero due to ! underflow, ! NZ=0 , normal return, computation completed ! NZ /= 0, last NZ components of Y set to zero, ! Y(K)=0.0E0, K=N-NZ+1,...,N. ! ! Error Conditions ! Improper input arguments - a fatal error ! Underflow - a non-fatal error (NZ /= 0) ! !***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 ! subroutines IBESS and JBESS for Bessel functions ! I(NU,X) and J(NU,X), X >= 0, NU >= 0, ACM ! Transactions on Mathematical Software 3, (1977), ! pp. 76-92. ! F. W. J. Olver, Tables of Bessel Functions of Moderate ! or Large Orders, NPL Mathematical Tables 6, Her ! Majesty's Stationery Office, London, 1962. !***ROUTINES CALLED ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BESJ EXTERNAL JAIRY INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN, & NS,NZ INTEGER I1MACH REAL AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM,EARG, & ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU,FNULIM, & GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN, & S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL, & TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,RTOL,SLIM SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM REAL R1MACH, ALNGAM DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7) DATA RTWO,PDF,RTTP,PIDT / 1.34839972492648E+00, & 7.85398163397448E-01, 7.97884560802865E-01, 1.57079632679490E+00/ DATA PP(1), PP(2), PP(3), PP(4) / 8.72909153935547E+00, & 2.65693932265030E-01, 1.24578576865586E-01, 7.70133747430388E-04/ DATA INLIM / 150 / DATA FNULIM(1), FNULIM(2) / 100.0E0, 60.0E0 / !***FIRST EXECUTABLE STATEMENT BESJ NZ = 0 KT = 1 NS=0 ! I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE ! I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE TA = R1MACH(3) TOL = MAX(TA,1.0E-15) I1 = I1MACH(11) + 1 I2 = I1MACH(12) TB = R1MACH(5) ELIM1 = -2.303E0*(I2*TB+3.0E0) RTOL=1.0E0/TOL SLIM=R1MACH(1)*1.0E+3*RTOL ! TOLLN = -LN(TOL) TOLLN = 2.303E0*TB*I1 TOLLN = MIN(TOLLN,34.5388E0) 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 == 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 < 0.0E0) go to 710 ! IALP = INT(ALPHA) FNI = IALP + N - 1 FNF = ALPHA - IALP DFN = FNI + FNF FNU = DFN XO2 = X*0.5E0 SXO2 = XO2*XO2 ! ! DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X ! TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE ! APPLIED. ! if (SXO2 <= (FNU+1.0E0)) go to 90 TA = MAX(20.0E0,FNU) if (X > TA) go to 120 if (X > 12.0E0) go to 110 XO2L = LOG(XO2) NS = INT(SXO2-FNU) + 1 go to 100 90 FN = FNU FNP1 = FN + 1.0E0 XO2L = LOG(XO2) IS = KT if (X <= 0.50E0) go to 330 NS = 0 100 FNI = FNI + NS DFN = FNI + FNF FN = DFN FNP1 = FN + 1.0E0 IS = KT if (N-1+NS > 0) IS = 3 go to 330 110 ANS = MAX(36.0E0-FNU,0.0E0) NS = INT(ANS) FNI = FNI + NS DFN = FNI + FNF FN = DFN IS = KT if (N-1+NS > 0) IS = 3 go to 130 120 CONTINUE RTX = SQRT(X) TAU = RTWO*RTX TA = TAU + FNULIM(KT) if (FNU <= TA) go to 480 FN = FNU IS = KT ! ! UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY ! 130 CONTINUE I1 = ABS(3-IS) I1 = MAX(I1,1) FLGJY = 1.0E0 call ASYJY(JAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW) if ( IFLW /= 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 == 2) go to 450 go to 130 ! ! SERIES FOR (X/2)**2 <= NU+1 ! 330 CONTINUE GLN = ALNGAM(FNP1) ARG = FN*XO2L - GLN if (ARG < (-ELIM1)) go to 400 EARG = EXP(ARG) 340 CONTINUE S = 1.0E0 if (X < 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) < 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 ! ! SET UNDERFLOW VALUE AND UPDATE PARAMETERS ! UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE ! LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED. ! 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 <= FNP1) go to 430 go to 130 430 ARG = ARG - XO2L + LOG(FNP1) if (ARG < (-ELIM1)) go to 400 go to 330 440 NZ = N - NN return ! ! BACKWARD RECURSION SECTION ! 450 CONTINUE if ( NS /= 0) go to 451 NZ = N - NN if (KT == 2) go to 470 ! BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA Y(NN) = TEMP(1) Y(NN-1) = TEMP(2) if (NN == 2) RETURN 451 CONTINUE TRX = 2.0E0/X DTM = FNI TM = (DTM+FNF)*TRX AK=1.0E0 TA=TEMP(1) TB=TEMP(2) if ( ABS(TA) > SLIM) go to 455 TA=TA*RTOL TB=TB*RTOL AK=TOL 455 CONTINUE KK=2 IN=NS-1 if ( IN == 0) go to 690 if ( NS /= 0) go to 670 K=NN-2 DO 460 I=3,NN S=TB TB=TM*TB-TA TA=S Y(K)=TB*AK K=K-1 DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 460 CONTINUE return 470 Y(1) = TEMP(2) return ! ! ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN ! OSCILLATORY REGION X > MAX(20, NU), PROVIDED THE LAST MEMBER ! OF THE SEQUENCE IS ALSO IN THE REGION. ! 480 CONTINUE IN = INT(ALPHA-TAU+2.0E0) if (IN <= 0) go to 490 IDALP = IALP - IN - 1 KT = 1 go to 500 490 CONTINUE IDALP = IALP IN = 0 500 IS = KT FIDAL = 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 == 0.0E0 .AND. ABS(FNF) < 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) <= RELB) go to 540 AK = AK + 8.0E0 530 CONTINUE 540 TEMP(IS) = COEF*(S1*SB-S2*SA) if ( IS == 2) go to 560 FIDAL = FIDAL + 1.0E0 DALPHA = FIDAL + FNF IS = 2 TB = SA SA = -SB SB = TB go to 510 ! ! FORWARD RECURSION SECTION ! 560 if (KT == 2) go to 470 S1 = TEMP(1) S2 = TEMP(2) TX = 2.0E0/X TM = DALPHA*TX if (IN == 0) go to 580 ! ! FORWARD RECUR TO INDEX ALPHA ! DO 570 I=1,IN S = S2 S2 = TM*S2 - S1 TM = TM + TX S1 = S 570 CONTINUE if (NN == 1) go to 600 S = S2 S2 = TM*S2 - S1 TM = TM + TX S1 = S 580 CONTINUE ! ! FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 ! Y(1) = S1 Y(2) = S2 if (NN == 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 ! ! BACKWARD RECURSION WITH NORMALIZATION BY ! ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. ! 610 CONTINUE ! COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION AKM = MAX(3.0E0-FN,0.0E0) KM = INT(AKM) TFN = FN + 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 ! COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION GLN = WK(3) + WK(2) if (WK(6) > 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) < 0.10E0) go to 630 TB = GLN/WK(5) go to 650 630 TB=(1.259921049E0+(0.1679894730E0+0.0887944358E0*WK(1))*WK(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) < 0.10E0) go to 630 TB = GLN/WK(5) 650 IN = INT(TA/TB+1.5E0) if (IN > INLIM) go to 310 660 CONTINUE DTM = FNI + IN TRX = 2.0E0/X TM = (DTM+FNF)*TRX TA = 0.0E0 TB = TOL KK = 1 AK=1.0E0 670 CONTINUE ! ! BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO ! UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL) ! DO 680 I=1,IN S = TB TB = TM*TB - TA TA = S DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 680 CONTINUE ! NORMALIZATION if (KK /= 1) go to 690 S=TEMP(3) SA=TA/TB TA=S TB=S if ( ABS(S) > SLIM) go to 685 TA=TA*RTOL TB=TB*RTOL AK=TOL 685 CONTINUE TA=TA*SA KK = 2 IN = NS if (NS /= 0) go to 670 690 Y(NN) = TB*AK NZ = N - NN if (NN == 1) RETURN K = NN - 1 S=TB TB = TM*TB - TA TA=S Y(K)=TB*AK if (NN == 2) RETURN DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX K=NN-2 ! ! BACKWARD RECUR INDEXED ! DO 700 I=3,NN S=TB TB = TM*TB - TA TA=S Y(K)=TB*AK DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX K = K - 1 700 CONTINUE return ! ! ! 710 CONTINUE call XERMSG ('SLATEC', 'BESJ', 'ORDER, ALPHA, LESS THAN ZERO.', & 2, 1) return 720 CONTINUE call XERMSG ('SLATEC', 'BESJ', 'N LESS THAN ONE.', 2, 1) return 730 CONTINUE call XERMSG ('SLATEC', 'BESJ', 'X LESS THAN ZERO.', 2, 1) return end function BESK0E (X) ! !! BESK0E computes the exponentially scaled modified (hyperbolic) ! Bessel function of the third kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE SINGLE PRECISION (BESK0E-S, DBSK0E-D) !***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, ! THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESK0E(X) computes the exponentially scaled modified (hyperbolic) ! Bessel function of third kind of order zero for real argument ! X > 0.0, i.e., EXP(X)*K0(X). ! ! Series for BK0 on the interval 0. to 4.00000D+00 ! with weighted error 3.57E-19 ! log weighted error 18.45 ! significant figures required 17.99 ! decimal places required 18.97 ! ! Series for AK0 on the interval 1.25000D-01 to 5.00000D-01 ! with weighted error 5.34E-17 ! log weighted error 16.27 ! significant figures required 14.92 ! decimal places required 16.89 ! ! Series for AK02 on the interval 0. to 1.25000D-01 ! with weighted error 2.34E-17 ! log weighted error 16.63 ! significant figures required 14.67 ! decimal places required 17.20 ! !***REFERENCES (NONE) !***ROUTINES CALLED BESI0, CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESK0E DIMENSION BK0CS(11), AK0CS(17), AK02CS(14) LOGICAL FIRST SAVE BK0CS, AK0CS, AK02CS, NTK0, NTAK0, NTAK02, XSML, FIRST DATA BK0CS( 1) / -.03532739323390276872E0 / DATA BK0CS( 2) / .3442898999246284869E0 / DATA BK0CS( 3) / .03597993651536150163E0 / DATA BK0CS( 4) / .00126461541144692592E0 / DATA BK0CS( 5) / .00002286212103119451E0 / DATA BK0CS( 6) / .00000025347910790261E0 / DATA BK0CS( 7) / .00000000190451637722E0 / DATA BK0CS( 8) / .00000000001034969525E0 / DATA BK0CS( 9) / .00000000000004259816E0 / DATA BK0CS(10) / .00000000000000013744E0 / DATA BK0CS(11) / .00000000000000000035E0 / DATA AK0CS( 1) / -.07643947903327941E0 / DATA AK0CS( 2) / -.02235652605699819E0 / DATA AK0CS( 3) / .00077341811546938E0 / DATA AK0CS( 4) / -.00004281006688886E0 / DATA AK0CS( 5) / .00000308170017386E0 / DATA AK0CS( 6) / -.00000026393672220E0 / DATA AK0CS( 7) / .00000002563713036E0 / DATA AK0CS( 8) / -.00000000274270554E0 / DATA AK0CS( 9) / .00000000031694296E0 / DATA AK0CS(10) / -.00000000003902353E0 / DATA AK0CS(11) / .00000000000506804E0 / DATA AK0CS(12) / -.00000000000068895E0 / DATA AK0CS(13) / .00000000000009744E0 / DATA AK0CS(14) / -.00000000000001427E0 / DATA AK0CS(15) / .00000000000000215E0 / DATA AK0CS(16) / -.00000000000000033E0 / DATA AK0CS(17) / .00000000000000005E0 / DATA AK02CS( 1) / -.01201869826307592E0 / DATA AK02CS( 2) / -.00917485269102569E0 / DATA AK02CS( 3) / .00014445509317750E0 / DATA AK02CS( 4) / -.00000401361417543E0 / DATA AK02CS( 5) / .00000015678318108E0 / DATA AK02CS( 6) / -.00000000777011043E0 / DATA AK02CS( 7) / .00000000046111825E0 / DATA AK02CS( 8) / -.00000000003158592E0 / DATA AK02CS( 9) / .00000000000243501E0 / DATA AK02CS(10) / -.00000000000020743E0 / DATA AK02CS(11) / .00000000000001925E0 / DATA AK02CS(12) / -.00000000000000192E0 / DATA AK02CS(13) / .00000000000000020E0 / DATA AK02CS(14) / -.00000000000000002E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESK0E if (FIRST) THEN NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3)) NTAK0 = INITS (AK0CS, 17, 0.1*R1MACH(3)) NTAK02 = INITS (AK02CS, 14, 0.1*R1MACH(3)) XSML = SQRT (4.0*R1MACH(3)) end if FIRST = .FALSE. ! if (X <= 0.) call XERMSG ('SLATEC', 'BESK0E', & 'X IS ZERO OR NEGATIVE', 2, 2) if (X > 2.) go to 20 ! Y = 0. if (X > XSML) Y = X*X BESK0E = EXP(X) * (-LOG(0.5*X)*BESI0(X) & - .25 + CSEVL (.5*Y-1., BK0CS, NTK0) ) return ! 20 if (X <= 8.) BESK0E = (1.25 + CSEVL ((16./X-5.)/3., AK0CS, NTAK0)) & / SQRT(X) if (X > 8.) BESK0E = (1.25 + CSEVL (16./X-1., AK02CS, NTAK02)) & / SQRT(X) ! return end function BESK0 (X) ! !! BESK0 computes the modified (hyperbolic) Bessel function of the ! third kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE SINGLE PRECISION (BESK0-S, DBESK0-D) !***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, ! THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESK0(X) calculates the modified (hyperbolic) Bessel function ! of the third kind of order zero for real argument X > 0.0. ! ! Series for BK0 on the interval 0. to 4.00000D+00 ! with weighted error 3.57E-19 ! log weighted error 18.45 ! significant figures required 17.99 ! decimal places required 18.97 ! !***REFERENCES (NONE) !***ROUTINES CALLED BESI0, BESK0E, CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESK0 DIMENSION BK0CS(11) LOGICAL FIRST SAVE BK0CS, NTK0, XSML, XMAX, FIRST DATA BK0CS( 1) / -.03532739323390276872E0 / DATA BK0CS( 2) / .3442898999246284869E0 / DATA BK0CS( 3) / .03597993651536150163E0 / DATA BK0CS( 4) / .00126461541144692592E0 / DATA BK0CS( 5) / .00002286212103119451E0 / DATA BK0CS( 6) / .00000025347910790261E0 / DATA BK0CS( 7) / .00000000190451637722E0 / DATA BK0CS( 8) / .00000000001034969525E0 / DATA BK0CS( 9) / .00000000000004259816E0 / DATA BK0CS(10) / .00000000000000013744E0 / DATA BK0CS(11) / .00000000000000000035E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESK0 if (FIRST) THEN NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3)) XSML = SQRT (4.0*R1MACH(3)) XMAXT = -LOG(R1MACH(1)) XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5) - 0.01 end if FIRST = .FALSE. ! if (X <= 0.) call XERMSG ('SLATEC', 'BESK0', & 'X IS ZERO OR NEGATIVE', 2, 2) if (X > 2.) go to 20 ! Y = 0. if (X > XSML) Y = X*X BESK0 = -LOG(0.5*X)*BESI0(X) - .25 + CSEVL (.5*Y-1., BK0CS, NTK0) return ! 20 BESK0 = 0. if (X > XMAX) call XERMSG ('SLATEC', 'BESK0', & 'X SO BIG K0 UNDERFLOWS', 1, 1) if (X > XMAX) RETURN ! BESK0 = EXP(-X) * BESK0E(X) ! return end function BESK1E (X) ! !! BESK1E computes the exponentially scaled modified (hyperbolic) ! Bessel function of the third kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE SINGLE PRECISION (BESK1E-S, DBSK1E-D) !***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, ! THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESK1E(X) computes the exponentially scaled modified (hyperbolic) ! Bessel function of third kind of order one for real argument ! X > 0.0, i.e., EXP(X)*K1(X). ! ! Series for BK1 on the interval 0. to 4.00000D+00 ! with weighted error 7.02E-18 ! log weighted error 17.15 ! significant figures required 16.73 ! decimal places required 17.67 ! ! Series for AK1 on the interval 1.25000D-01 to 5.00000D-01 ! with weighted error 6.06E-17 ! log weighted error 16.22 ! significant figures required 15.41 ! decimal places required 16.83 ! ! Series for AK12 on the interval 0. to 1.25000D-01 ! with weighted error 2.58E-17 ! log weighted error 16.59 ! significant figures required 15.22 ! decimal places required 17.16 ! !***REFERENCES (NONE) !***ROUTINES CALLED BESI1, CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESK1E DIMENSION BK1CS(11), AK1CS(17), AK12CS(14) LOGICAL FIRST SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML, & FIRST DATA BK1CS( 1) / .0253002273389477705E0 / DATA BK1CS( 2) / -.353155960776544876E0 / DATA BK1CS( 3) / -.122611180822657148E0 / DATA BK1CS( 4) / -.0069757238596398643E0 / DATA BK1CS( 5) / -.0001730288957513052E0 / DATA BK1CS( 6) / -.0000024334061415659E0 / DATA BK1CS( 7) / -.0000000221338763073E0 / DATA BK1CS( 8) / -.0000000001411488392E0 / DATA BK1CS( 9) / -.0000000000006666901E0 / DATA BK1CS(10) / -.0000000000000024274E0 / DATA BK1CS(11) / -.0000000000000000070E0 / DATA AK1CS( 1) / .2744313406973883E0 / DATA AK1CS( 2) / .07571989953199368E0 / DATA AK1CS( 3) / -.00144105155647540E0 / DATA AK1CS( 4) / .00006650116955125E0 / DATA AK1CS( 5) / -.00000436998470952E0 / DATA AK1CS( 6) / .00000035402774997E0 / DATA AK1CS( 7) / -.00000003311163779E0 / DATA AK1CS( 8) / .00000000344597758E0 / DATA AK1CS( 9) / -.00000000038989323E0 / DATA AK1CS(10) / .00000000004720819E0 / DATA AK1CS(11) / -.00000000000604783E0 / DATA AK1CS(12) / .00000000000081284E0 / DATA AK1CS(13) / -.00000000000011386E0 / DATA AK1CS(14) / .00000000000001654E0 / DATA AK1CS(15) / -.00000000000000248E0 / DATA AK1CS(16) / .00000000000000038E0 / DATA AK1CS(17) / -.00000000000000006E0 / DATA AK12CS( 1) / .06379308343739001E0 / DATA AK12CS( 2) / .02832887813049721E0 / DATA AK12CS( 3) / -.00024753706739052E0 / DATA AK12CS( 4) / .00000577197245160E0 / DATA AK12CS( 5) / -.00000020689392195E0 / DATA AK12CS( 6) / .00000000973998344E0 / DATA AK12CS( 7) / -.00000000055853361E0 / DATA AK12CS( 8) / .00000000003732996E0 / DATA AK12CS( 9) / -.00000000000282505E0 / DATA AK12CS(10) / .00000000000023720E0 / DATA AK12CS(11) / -.00000000000002176E0 / DATA AK12CS(12) / .00000000000000215E0 / DATA AK12CS(13) / -.00000000000000022E0 / DATA AK12CS(14) / .00000000000000002E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESK1E if (FIRST) THEN NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3)) NTAK1 = INITS (AK1CS, 17, 0.1*R1MACH(3)) NTAK12 = INITS (AK12CS, 14, 0.1*R1MACH(3)) ! XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01) XSML = SQRT (4.0*R1MACH(3)) end if FIRST = .FALSE. ! if (X <= 0.) call XERMSG ('SLATEC', 'BESK1E', & 'X IS ZERO OR NEGATIVE', 2, 2) if (X > 2.0) go to 20 ! if (X < XMIN) call XERMSG ('SLATEC', 'BESK1E', & 'X SO SMALL K1 OVERFLOWS', 3, 2) Y = 0. if (X > XSML) Y = X*X BESK1E = EXP(X) * (LOG(0.5*X)*BESI1(X) + & (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X ) return ! 20 if (X <= 8.) BESK1E = (1.25 + CSEVL ((16./X-5.)/3., AK1CS, NTAK1)) & / SQRT(X) if (X > 8.) BESK1E = (1.25 + CSEVL (16./X-1., AK12CS, NTAK12)) & / SQRT(X) ! return end function BESK1 (X) ! !! BESK1 computes the modified (hyperbolic) Bessel function of the ! third kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE SINGLE PRECISION (BESK1-S, DBESK1-D) !***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, ! THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESK1(X) computes the modified (hyperbolic) Bessel function of third ! kind of order one for real argument X, where X > 0. ! ! Series for BK1 on the interval 0. to 4.00000D+00 ! with weighted error 7.02E-18 ! log weighted error 17.15 ! significant figures required 16.73 ! decimal places required 17.67 ! !***REFERENCES (NONE) !***ROUTINES CALLED BESI1, BESK1E, CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESK1 DIMENSION BK1CS(11) LOGICAL FIRST SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST DATA BK1CS( 1) / .0253002273389477705E0 / DATA BK1CS( 2) / -.353155960776544876E0 / DATA BK1CS( 3) / -.122611180822657148E0 / DATA BK1CS( 4) / -.0069757238596398643E0 / DATA BK1CS( 5) / -.0001730288957513052E0 / DATA BK1CS( 6) / -.0000024334061415659E0 / DATA BK1CS( 7) / -.0000000221338763073E0 / DATA BK1CS( 8) / -.0000000001411488392E0 / DATA BK1CS( 9) / -.0000000000006666901E0 / DATA BK1CS(10) / -.0000000000000024274E0 / DATA BK1CS(11) / -.0000000000000000070E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESK1 if (FIRST) THEN NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3)) XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01) XSML = SQRT (4.0*R1MACH(3)) XMAXT = -LOG(R1MACH(1)) XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5) end if FIRST = .FALSE. ! if (X <= 0.) call XERMSG ('SLATEC', 'BESK1', & 'X IS ZERO OR NEGATIVE', 2, 2) if (X > 2.0) go to 20 ! if (X < XMIN) call XERMSG ('SLATEC', 'BESK1', & 'X SO SMALL K1 OVERFLOWS', 3, 2) Y = 0. if (X > XSML) Y = X*X BESK1 = LOG(0.5*X)*BESI1(X) + & (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X return ! 20 BESK1 = 0. if (X > XMAX) call XERMSG ('SLATEC', 'BESK1', & 'X SO BIG K1 UNDERFLOWS', 1, 1) if (X > XMAX) RETURN ! BESK1 = EXP(-X) * BESK1E(X) ! return end subroutine BESKES (XNU, X, NIN, BKE) ! !! BESKES computes a sequence of exponentially scaled modified Bessel ! functions of the third kind of fractional order. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B3 !***TYPE SINGLE PRECISION (BESKES-S, DBSKES-D) !***KEYWORDS EXPONENTIALLY SCALED, FNLIB, FRACTIONAL ORDER, ! MODIFIED BESSEL FUNCTION, SEQUENCE OF BESSEL FUNCTIONS, ! SPECIAL FUNCTIONS, THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESKES computes a sequence of exponentially scaled ! (i.e., multipled by EXP(X)) modified Bessel ! functions of the third kind of order XNU + I at X, where X > 0, ! XNU lies in (-1,1), and I = 0, 1, ... , NIN - 1, if NIN is positive ! and I = 0, -1, ... , NIN + 1, if NIN is negative. On return, the ! vector BKE(.) contains the results at X for order starting at XNU. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, R9KNUS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESKES DIMENSION BKE(*) SAVE ALNBIG DATA ALNBIG / 0. / !***FIRST EXECUTABLE STATEMENT BESKES if (ALNBIG == 0.) ALNBIG = LOG (R1MACH(2)) ! V = ABS(XNU) N = ABS(NIN) ! if (V >= 1.) call XERMSG ('SLATEC', 'BESKES', & 'ABS(XNU) MUST BE LT 1', 2, 2) if (X <= 0.) call XERMSG ('SLATEC', 'BESKES', 'X IS LE 0', 3, & 2) if (N == 0) call XERMSG ('SLATEC', 'BESKES', & 'N THE NUMBER IN THE SEQUENCE IS 0', 4, 2) ! call R9KNUS (V, X, BKE(1), BKNU1, ISWTCH) if (N == 1) RETURN ! VINCR = SIGN (1.0, REAL(NIN)) DIRECT = VINCR if (XNU /= 0.) DIRECT = VINCR*SIGN(1.0,XNU) if (ISWTCH == 1 .AND. DIRECT > 0.) call XERMSG ('SLATEC', & 'BESKES', 'X SO SMALL BESSEL K-SUB-XNU+1 OVERFLOWS', 5, 2) BKE(2) = BKNU1 ! if (DIRECT < 0.) call R9KNUS (ABS(XNU+VINCR), X, BKE(2), BKNU1, & ISWTCH) if (N == 2) RETURN ! VEND = ABS(XNU+NIN) - 1.0 if ((VEND-0.5)*LOG(VEND)+0.27-VEND*(LOG(X)-.694) > ALNBIG) & call XERMSG ( 'SLATEC', 'BESKES', & 'X SO SMALL OR ABS(NU) SO BIG THAT BESSEL K-SUB-NU OVERFLOWS', & 5, 2) ! V = XNU DO 10 I=3,N V = V + VINCR BKE(I) = 2.0*V*BKE(I-1)/X + BKE(I-2) 10 CONTINUE ! return end subroutine BESK (X, FNU, KODE, N, Y, NZ) ! !! BESK implements forward recursion on the three term recursion ... ! relation for a sequence of non-negative order Bessel ! functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions ! EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive ! X and non-negative orders FNU. ! !***LIBRARY SLATEC !***CATEGORY C10B3 !***TYPE SINGLE PRECISION (BESK-S, DBESK-D) !***KEYWORDS K BESSEL FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! BESK implements forward recursion on the three term ! recursion relation for a sequence of non-negative order Bessel ! functions K/sub(FNU+I-1)/(X), or scaled Bessel functions ! EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N for real X > 0.0E0 and ! non-negative orders FNU. If FNU < NULIM, orders FNU and ! FNU+1 are obtained from BESKNU to start the recursion. If ! FNU >= NULIM, the uniform asymptotic expansion is used for ! orders FNU and FNU+1 to start the recursion. NULIM is 35 or ! 70 depending on whether N=1 or N >= 2. Under and overflow ! tests are made on the leading term of the asymptotic expansion ! before any extensive computation is done. ! ! Description of Arguments ! ! Input ! X - X > 0.0E0 ! FNU - order of the initial K function, FNU >= 0.0E0 ! KODE - a parameter to indicate the scaling option ! KODE=1 returns Y(I)= K/sub(FNU+I-1)/(X), ! I=1,...,N ! KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), ! I=1,...,N ! N - number of members in the sequence, N >= 1 ! ! Output ! y - a vector whose first n components contain values ! for the sequence ! Y(I)= K/sub(FNU+I-1)/(X), I=1,...,N or ! Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N ! depending on KODE ! NZ - number of components of Y set to zero due to ! underflow with KODE=1, ! NZ=0 , normal return, computation completed ! NZ /= 0, first NZ components of Y set to zero ! due to underflow, Y(I)=0.0E0, I=1,...,NZ ! ! Error Conditions ! Improper input arguments - a fatal error ! Overflow - a fatal error ! Underflow with KODE=1 - a non-fatal error (NZ /= 0) ! !***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate ! or Large Orders, NPL Mathematical Tables 6, Her ! Majesty's Stationery Office, London, 1962. ! N. M. Temme, On the numerical evaluation of the modified ! Bessel function of the third kind, Journal of ! Computational Physics 19, (1975), pp. 324-337. !***ROUTINES CALLED ASYIK, BESK0, BESK0E, BESK1, BESK1E, BESKNU, ! I1MACH, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790201 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BESK ! INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ INTEGER I1MACH REAL CN, DNU, ELIM, ETX, FLGIK,FN, FNN, FNU,GLN,GNU,RTZ,S,S1,S2, & T, TM, TRX, W, X, XLIM, Y, ZN REAL BESK0, BESK1, BESK1E, BESK0E, R1MACH DIMENSION W(2), NULIM(2), Y(*) SAVE NULIM DATA NULIM(1),NULIM(2) / 35 , 70 / !***FIRST EXECUTABLE STATEMENT BESK NN = -I1MACH(12) ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0) XLIM = R1MACH(1)*1.0E+3 if (KODE < 1 .OR. KODE > 2) go to 280 if (FNU < 0.0E0) go to 290 if (X <= 0.0E0) go to 300 if (X < XLIM) go to 320 if (N < 1) go to 310 ETX = KODE - 1 ! ! ND IS A DUMMY VARIABLE FOR N ! GNU IS A DUMMY VARIABLE FOR FNU ! NZ = NUMBER OF UNDERFLOWS ON KODE=1 ! ND = N NZ = 0 NUD = INT(FNU) DNU = FNU - NUD GNU = FNU NN = MIN(2,ND) FN = FNU + N - 1 FNN = FN if (FN < 2.0E0) go to 150 ! ! OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) ! FOR THE LAST ORDER, FNU+N-1 >= NULIM ! ZN = X/FN if (ZN == 0.0E0) go to 320 RTZ = SQRT(1.0E0+ZN*ZN) GLN = LOG((1.0E0+RTZ)/ZN) T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ) CN = -FN*(T-GLN) if (CN > ELIM) go to 320 if (NUD < NULIM(NN)) go to 30 if (NN == 1) go to 20 10 CONTINUE ! ! UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) ! FOR THE FIRST ORDER, FNU >= NULIM ! FN = GNU ZN = X/FN RTZ = SQRT(1.0E0+ZN*ZN) GLN = LOG((1.0E0+RTZ)/ZN) T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ) CN = -FN*(T-GLN) 20 CONTINUE if (CN < -ELIM) go to 230 ! ! ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1 >= NULIM ! FLGIK = -1.0E0 call ASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y) if (NN == 1) go to 240 TRX = 2.0E0/X TM = (GNU+GNU+2.0E0)/X go to 130 ! 30 CONTINUE if (KODE == 2) go to 40 ! ! UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X) ! FOR ORDER DNU ! if (X > ELIM) go to 230 40 CONTINUE if (DNU /= 0.0E0) go to 80 if (KODE == 2) go to 50 S1 = BESK0(X) go to 60 50 S1 = BESK0E(X) 60 CONTINUE if (NUD == 0 .AND. ND == 1) go to 120 if (KODE == 2) go to 70 S2 = BESK1(X) go to 90 70 S2 = BESK1E(X) go to 90 80 CONTINUE NB = 2 if (NUD == 0 .AND. ND == 1) NB = 1 call BESKNU(X, DNU, KODE, NB, W, NZ) S1 = W(1) if (NB == 1) go to 120 S2 = W(2) 90 CONTINUE TRX = 2.0E0/X TM = (DNU+DNU+2.0E0)/X ! FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) if (ND == 1) NUD = NUD - 1 if (NUD > 0) go to 100 if (ND > 1) go to 120 S1 = S2 go to 120 100 CONTINUE DO 110 I=1,NUD S = S2 S2 = TM*S2 + S1 S1 = S TM = TM + TRX 110 CONTINUE if (ND == 1) S1 = S2 120 CONTINUE Y(1) = S1 if (ND == 1) go to 240 Y(2) = S2 130 CONTINUE if (ND == 2) go to 240 ! FORWARD RECUR FROM FNU+2 TO FNU+N-1 DO 140 I=3,ND Y(I) = TM*Y(I-1) + Y(I-2) TM = TM + TRX 140 CONTINUE go to 240 ! 150 CONTINUE ! UNDERFLOW TEST FOR KODE=1 if (KODE == 2) go to 160 if (X > ELIM) go to 230 160 CONTINUE ! OVERFLOW TEST if (FN <= 1.0E0) go to 170 if (-FN*(LOG(X)-0.693E0) > ELIM) go to 320 170 CONTINUE if (DNU == 0.0E0) go to 180 call BESKNU(X, FNU, KODE, ND, Y, MZ) go to 240 180 CONTINUE J = NUD if (J == 1) go to 210 J = J + 1 if (KODE == 2) go to 190 Y(J) = BESK0(X) go to 200 190 Y(J) = BESK0E(X) 200 if (ND == 1) go to 240 J = J + 1 210 if (KODE == 2) go to 220 Y(J) = BESK1(X) go to 240 220 Y(J) = BESK1E(X) go to 240 ! ! UPDATE PARAMETERS ON UNDERFLOW ! 230 CONTINUE NUD = NUD + 1 ND = ND - 1 if (ND == 0) go to 240 NN = MIN(2,ND) GNU = GNU + 1.0E0 if (FNN < 2.0E0) go to 230 if (NUD < NULIM(NN)) go to 230 go to 10 240 CONTINUE NZ = N - ND if (NZ == 0) RETURN if (ND == 0) go to 260 DO 250 I=1,ND J = N - I + 1 K = ND - I + 1 Y(J) = Y(K) 250 CONTINUE 260 CONTINUE DO 270 I=1,NZ Y(I) = 0.0E0 270 CONTINUE return ! ! ! 280 CONTINUE call XERMSG ('SLATEC', 'BESK', 'SCALING OPTION, KODE, NOT 1 OR 2' & , 2, 1) return 290 CONTINUE call XERMSG ('SLATEC', 'BESK', 'ORDER, FNU, LESS THAN ZERO', 2, & 1) return 300 CONTINUE call XERMSG ('SLATEC', 'BESK', 'X LESS THAN OR EQUAL TO ZERO', 2, & 1) return 310 CONTINUE call XERMSG ('SLATEC', 'BESK', 'N LESS THAN ONE', 2, 1) return 320 CONTINUE call XERMSG ('SLATEC', 'BESK', & 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) return end subroutine BESKNU (X, FNU, KODE, N, Y, NZ) ! !! BESKNU is subsidiary to BESK. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BESKNU-S, DBSKNU-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! BESKNU computes N member sequences of K Bessel functions ! K/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and ! positive X. Equations of the references are implemented on ! small orders DNU for K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X). ! Forward recursion with the three term recursion relation ! generates higher orders FNU+I-1, I=1,...,N. The parameter ! KODE permits K/SUB(FNU+I-1)/(X) values or scaled values ! EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned. ! ! To start the recursion FNU is normalized to the interval ! -0.5 <= DNU < 0.5. A special form of the power series is ! implemented on 0 < X <= X1 while the Miller algorithm for the ! K Bessel function in terms of the confluent hypergeometric ! function U(FNU+0.5,2*FNU+1,X) is implemented on X1 < X <= X2. ! For X > X2, the asymptotic expansion for large X is used. ! When FNU is a half odd integer, a special formula for ! DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. ! ! BESKNU assumes that a significant digit SINH(X) function is ! available. ! ! Description of Arguments ! ! Input ! X - X > 0.0E0 ! FNU - Order of initial K function, FNU >= 0.0E0 ! N - Number of members of the sequence, N >= 1 ! KODE - A parameter to indicate the scaling option ! KODE= 1 returns ! Y(I)= K/SUB(FNU+I-1)/(X) ! I=1,...,N ! = 2 returns ! Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X) ! I=1,...,N ! ! Output ! Y - A vector whose first N components contain values ! for the sequence ! Y(I)= K/SUB(FNU+I-1)/(X), I=1,...,N or ! Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N ! depending on KODE ! NZ - Number of components set to zero due to ! underflow, ! NZ= 0 , Normal return ! NZ /= 0 , First NZ components of Y set to zero ! due to underflow, Y(I)=0.0E0,I=1,...,NZ ! ! Error Conditions ! Improper input arguments - a fatal error ! Overflow - a fatal error ! Underflow with KODE=1 - a non-fatal error (NZ /= 0) ! !***SEE ALSO BESK !***REFERENCES N. M. Temme, On the numerical evaluation of the modified ! Bessel function of the third kind, Journal of ! Computational Physics 19, (1975), pp. 324-337. !***ROUTINES CALLED GAMMA, I1MACH, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790201 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) ! 900727 Added EXTERNAL statement. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BESKNU ! INTEGER I, IFLAG, INU, J, K, KK, KODE, KODED, N, NN, NZ INTEGER I1MACH REAL A, AK, A1, A2, B, BK, CC, CK, COEF, CX, DK, DNU, DNU2, ELIM, & ETEST, EX, F, FC, FHS, FK, FKS, FLRX, FMU, FNU, G1, G2, P, PI, & PT, P1, P2, Q, RTHPI, RX, S, SMU, SQK, ST, S1, S2, TM, TOL, T1, & T2, X, X1, X2, Y REAL GAMMA, R1MACH DIMENSION A(160), B(160), Y(*), CC(8) EXTERNAL GAMMA SAVE X1, X2, PI, RTHPI, CC DATA X1, X2 / 2.0E0, 17.0E0 / DATA PI,RTHPI / 3.14159265358979E+00, 1.25331413731550E+00/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) & / 5.77215664901533E-01,-4.20026350340952E-02, & -4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04, & -2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/ !***FIRST EXECUTABLE STATEMENT BESKNU KK = -I1MACH(12) ELIM = 2.303E0*(KK*R1MACH(5)-3.0E0) AK = R1MACH(3) TOL = MAX(AK,1.0E-15) if (X <= 0.0E0) go to 350 if (FNU < 0.0E0) go to 360 if (KODE < 1 .OR. KODE > 2) go to 370 if (N < 1) go to 380 NZ = 0 IFLAG = 0 KODED = KODE RX = 2.0E0/X INU = INT(FNU+0.5E0) DNU = FNU - INU if (ABS(DNU) == 0.5E0) go to 120 DNU2 = 0.0E0 if (ABS(DNU) < TOL) go to 10 DNU2 = DNU*DNU 10 CONTINUE if (X > X1) go to 120 ! ! SERIES FOR X <= X1 ! A1 = 1.0E0 - DNU A2 = 1.0E0 + DNU T1 = 1.0E0/GAMMA(A1) T2 = 1.0E0/GAMMA(A2) if (ABS(DNU) > 0.1E0) go to 40 ! SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) S = CC(1) AK = 1.0E0 DO 20 K=2,8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM if (ABS(TM) < TOL) go to 30 20 CONTINUE 30 G1 = -S go to 50 40 CONTINUE G1 = (T1-T2)/(DNU+DNU) 50 CONTINUE G2 = (T1+T2)*0.5E0 SMU = 1.0E0 FC = 1.0E0 FLRX = LOG(RX) FMU = DNU*FLRX if (DNU == 0.0E0) go to 60 FC = DNU*PI FC = FC/SIN(FC) if (FMU /= 0.0E0) SMU = SINH(FMU)/FMU 60 CONTINUE F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) FC = EXP(FMU) P = 0.5E0*FC/T2 Q = 0.5E0/(FC*T1) AK = 1.0E0 CK = 1.0E0 BK = 1.0E0 S1 = F S2 = P if (INU > 0 .OR. N > 1) go to 90 if (X < TOL) go to 80 CX = X*X*0.25E0 70 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) CK = CK*CX/AK T1 = CK*F S1 = S1 + T1 BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 S = ABS(T1)/(1.0E0+ABS(S1)) if (S > TOL) go to 70 80 CONTINUE Y(1) = S1 if (KODED == 1) RETURN Y(1) = S1*EXP(X) return 90 CONTINUE if (X < TOL) go to 110 CX = X*X*0.25E0 100 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) CK = CK*CX/AK T1 = CK*F S1 = S1 + T1 T2 = CK*(P-AK*F) S2 = S2 + T2 BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2)) if (S > TOL) go to 100 110 CONTINUE S2 = S2*RX if (KODED == 1) go to 170 F = EXP(X) S1 = S1*F S2 = S2*F go to 170 120 CONTINUE COEF = RTHPI/SQRT(X) if (KODED == 2) go to 130 if (X > ELIM) go to 330 COEF = COEF*EXP(-X) 130 CONTINUE if (ABS(DNU) == 0.5E0) go to 340 if (X > X2) go to 280 ! ! MILLER ALGORITHM FOR X1 < X <= X2 ! ETEST = COS(PI*DNU)/(PI*X*TOL) FKS = 1.0E0 FHS = 0.25E0 FK = 0.0E0 CK = X + X + 2.0E0 P1 = 0.0E0 P2 = 1.0E0 K = 0 140 CONTINUE K = K + 1 FK = FK + 1.0E0 AK = (FHS-DNU2)/(FKS+FK) BK = CK/(FK+1.0E0) PT = P2 P2 = BK*P2 - AK*P1 P1 = PT A(K) = AK B(K) = BK CK = CK + 2.0E0 FKS = FKS + FK + FK + 1.0E0 FHS = FHS + FK + FK if (ETEST > FK*P1) go to 140 KK = K S = 1.0E0 P1 = 0.0E0 P2 = 1.0E0 DO 150 I=1,K PT = P2 P2 = (B(KK)*P2-P1)/A(KK) P1 = PT S = S + P2 KK = KK - 1 150 CONTINUE S1 = COEF*(P2/S) if (INU > 0 .OR. N > 1) go to 160 go to 200 160 CONTINUE S2 = S1*(X+DNU+0.5E0-P1/P2)/X ! ! FORWARD RECURSION ON THE THREE TERM RECURSION RELATION ! 170 CONTINUE CK = (DNU+DNU+2.0E0)/X if (N == 1) INU = INU - 1 if (INU > 0) go to 180 if (N > 1) go to 200 S1 = S2 go to 200 180 CONTINUE DO 190 I=1,INU ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RX 190 CONTINUE if (N == 1) S1 = S2 200 CONTINUE if (IFLAG == 1) go to 220 Y(1) = S1 if (N == 1) RETURN Y(2) = S2 if (N == 2) RETURN DO 210 I=3,N Y(I) = CK*Y(I-1) + Y(I-2) CK = CK + RX 210 CONTINUE return ! IFLAG=1 CASES 220 CONTINUE S = -X + LOG(S1) Y(1) = 0.0E0 NZ = 1 if (S < -ELIM) go to 230 Y(1) = EXP(S) NZ = 0 230 CONTINUE if (N == 1) RETURN S = -X + LOG(S2) Y(2) = 0.0E0 NZ = NZ + 1 if (S < -ELIM) go to 240 NZ = NZ - 1 Y(2) = EXP(S) 240 CONTINUE if (N == 2) RETURN KK = 2 if (NZ < 2) go to 260 DO 250 I=3,N KK = I ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RX S = -X + LOG(S2) NZ = NZ + 1 Y(I) = 0.0E0 if (S < -ELIM) go to 250 Y(I) = EXP(S) NZ = NZ - 1 go to 260 250 CONTINUE return 260 CONTINUE if (KK == N) RETURN S2 = S2*CK + S1 CK = CK + RX KK = KK + 1 Y(KK) = EXP(-X+LOG(S2)) if (KK == N) RETURN KK = KK + 1 DO 270 I=KK,N Y(I) = CK*Y(I-1) + Y(I-2) CK = CK + RX 270 CONTINUE return ! ! ASYMPTOTIC EXPANSION FOR LARGE X, X > X2 ! ! IFLAG=0 MEANS NO UNDERFLOW OCCURRED ! IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH ! KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD ! RECURSION 280 CONTINUE NN = 2 if (INU == 0 .AND. N == 1) NN = 1 DNU2 = DNU + DNU FMU = 0.0E0 if (ABS(DNU2) < TOL) go to 290 FMU = DNU2*DNU2 290 CONTINUE EX = X*8.0E0 S2 = 0.0E0 DO 320 K=1,NN S1 = S2 S = 1.0E0 AK = 0.0E0 CK = 1.0E0 SQK = 1.0E0 DK = EX DO 300 J=1,30 CK = CK*(FMU-SQK)/DK S = S + CK DK = DK + EX AK = AK + 8.0E0 SQK = SQK + AK if (ABS(CK) < TOL) go to 310 300 CONTINUE 310 S2 = S*COEF FMU = FMU + 8.0E0*DNU + 4.0E0 320 CONTINUE if (NN > 1) go to 170 S1 = S2 go to 200 330 CONTINUE KODED = 2 IFLAG = 1 go to 120 ! ! FNU=HALF ODD INTEGER CASE ! 340 CONTINUE S1 = COEF S2 = COEF go to 170 ! ! 350 call XERMSG ('SLATEC', 'BESKNU', 'X NOT GREATER THAN ZERO', 2, 1) return 360 call XERMSG ('SLATEC', 'BESKNU', 'FNU NOT ZERO OR POSITIVE', 2, & 1) return 370 call XERMSG ('SLATEC', 'BESKNU', 'KODE NOT 1 OR 2', 2, 1) return 380 call XERMSG ('SLATEC', 'BESKNU', 'N NOT GREATER THAN 0', 2, 1) return end subroutine BESKS (XNU, X, NIN, BK) ! !! BESKS computes a sequence of modified Bessel functions of the ! third kind of fractional order. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B3 !***TYPE SINGLE PRECISION (BESKS-S, DBESKS-D) !***KEYWORDS FNLIB, FRACTIONAL ORDER, MODIFIED BESSEL FUNCTION, ! SEQUENCE OF BESSEL FUNCTIONS, SPECIAL FUNCTIONS, ! THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESKS computes a sequence of modified Bessel functions of the third ! kind of order XNU + I at X, where X > 0, XNU lies in (-1,1), ! and I = 0, 1, ... , NIN - 1, if NIN is positive and I = 0, 1, ... , ! NIN + 1, if NIN is negative. On return, the vector BK(.) Contains ! the results at X for order starting at XNU. ! !***REFERENCES (NONE) !***ROUTINES CALLED BESKES, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESKS DIMENSION BK(*) SAVE XMAX DATA XMAX / 0.0 / !***FIRST EXECUTABLE STATEMENT BESKS if (XMAX == 0.0) XMAX = -LOG (R1MACH(1)) ! if (X > XMAX) call XERMSG ('SLATEC', 'BESKS', & 'X SO BIG BESSEL K UNDERFLOWS', 1, 2) ! call BESKES (XNU, X, NIN, BK) ! EXPXI = EXP (-X) N = ABS (NIN) DO 20 I=1,N BK(I) = EXPXI * BK(I) 20 CONTINUE ! return end function BESY0 (X) ! !! BESY0 computes the Bessel function of the second kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10A1 !***TYPE SINGLE PRECISION (BESY0-S, DBESY0-D) !***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ZERO, SECOND KIND, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESY0(X) calculates the Bessel function of the second kind ! of order zero for real argument X. ! ! Series for BY0 on the interval 0. to 1.60000D+01 ! with weighted error 1.20E-17 ! log weighted error 16.92 ! significant figures required 16.15 ! decimal places required 17.48 ! ! Series for BM0 on the interval 0. to 6.25000D-02 ! with weighted error 4.98E-17 ! log weighted error 16.30 ! significant figures required 14.97 ! decimal places required 16.96 ! ! Series for BTH0 on the interval 0. to 6.25000D-02 ! with weighted error 3.67E-17 ! log weighted error 16.44 ! significant figures required 15.53 ! decimal places required 17.13 ! !***REFERENCES (NONE) !***ROUTINES CALLED BESJ0, CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESY0 DIMENSION BY0CS(13), BM0CS(21), BTH0CS(24) LOGICAL FIRST SAVE BY0CS, BM0CS, BTH0CS, TWODPI, PI4, & NTY0, NTM0, NTTH0, XSML, XMAX, FIRST DATA BY0CS( 1) / -.011277839392865573E0 / DATA BY0CS( 2) / -.12834523756042035E0 / DATA BY0CS( 3) / -.10437884799794249E0 / DATA BY0CS( 4) / .023662749183969695E0 / DATA BY0CS( 5) / -.002090391647700486E0 / DATA BY0CS( 6) / .000103975453939057E0 / DATA BY0CS( 7) / -.000003369747162423E0 / DATA BY0CS( 8) / .000000077293842676E0 / DATA BY0CS( 9) / -.000000001324976772E0 / DATA BY0CS(10) / .000000000017648232E0 / DATA BY0CS(11) / -.000000000000188105E0 / DATA BY0CS(12) / .000000000000001641E0 / DATA BY0CS(13) / -.000000000000000011E0 / DATA BM0CS( 1) / .09284961637381644E0 / DATA BM0CS( 2) / -.00142987707403484E0 / DATA BM0CS( 3) / .00002830579271257E0 / DATA BM0CS( 4) / -.00000143300611424E0 / DATA BM0CS( 5) / .00000012028628046E0 / DATA BM0CS( 6) / -.00000001397113013E0 / DATA BM0CS( 7) / .00000000204076188E0 / DATA BM0CS( 8) / -.00000000035399669E0 / DATA BM0CS( 9) / .00000000007024759E0 / DATA BM0CS(10) / -.00000000001554107E0 / DATA BM0CS(11) / .00000000000376226E0 / DATA BM0CS(12) / -.00000000000098282E0 / DATA BM0CS(13) / .00000000000027408E0 / DATA BM0CS(14) / -.00000000000008091E0 / DATA BM0CS(15) / .00000000000002511E0 / DATA BM0CS(16) / -.00000000000000814E0 / DATA BM0CS(17) / .00000000000000275E0 / DATA BM0CS(18) / -.00000000000000096E0 / DATA BM0CS(19) / .00000000000000034E0 / DATA BM0CS(20) / -.00000000000000012E0 / DATA BM0CS(21) / .00000000000000004E0 / DATA BTH0CS( 1) / -.24639163774300119E0 / DATA BTH0CS( 2) / .001737098307508963E0 / DATA BTH0CS( 3) / -.000062183633402968E0 / DATA BTH0CS( 4) / .000004368050165742E0 / DATA BTH0CS( 5) / -.000000456093019869E0 / DATA BTH0CS( 6) / .000000062197400101E0 / DATA BTH0CS( 7) / -.000000010300442889E0 / DATA BTH0CS( 8) / .000000001979526776E0 / DATA BTH0CS( 9) / -.000000000428198396E0 / DATA BTH0CS(10) / .000000000102035840E0 / DATA BTH0CS(11) / -.000000000026363898E0 / DATA BTH0CS(12) / .000000000007297935E0 / DATA BTH0CS(13) / -.000000000002144188E0 / DATA BTH0CS(14) / .000000000000663693E0 / DATA BTH0CS(15) / -.000000000000215126E0 / DATA BTH0CS(16) / .000000000000072659E0 / DATA BTH0CS(17) / -.000000000000025465E0 / DATA BTH0CS(18) / .000000000000009229E0 / DATA BTH0CS(19) / -.000000000000003448E0 / DATA BTH0CS(20) / .000000000000001325E0 / DATA BTH0CS(21) / -.000000000000000522E0 / DATA BTH0CS(22) / .000000000000000210E0 / DATA BTH0CS(23) / -.000000000000000087E0 / DATA BTH0CS(24) / .000000000000000036E0 / DATA TWODPI / 0.63661977236758134E0 / DATA PI4 / 0.78539816339744831E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESY0 if (FIRST) THEN NTY0 = INITS (BY0CS, 13, 0.1*R1MACH(3)) NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3)) NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3)) XSML = SQRT (4.0*R1MACH(3)) XMAX = 1.0/R1MACH(4) end if FIRST = .FALSE. if (X <= 0.) call XERMSG ('SLATEC', 'BESY0', & 'X IS ZERO OR NEGATIVE', 1, 2) if (X > 4.0) go to 20 Y = 0. if (X > XSML) Y = X*X BESY0 = TWODPI*LOG(0.5*X)*BESJ0(X) + .375 + CSEVL (.125*Y-1., & BY0CS, NTY0) return ! 20 if (X > XMAX) call XERMSG ('SLATEC', 'BESY0', & 'NO PRECISION BECAUSE X IS BIG', 2, 2) ! Z = 32.0/X**2 - 1.0 AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(X) THETA = X - PI4 + CSEVL (Z, BTH0CS, NTTH0) / X BESY0 = AMPL * SIN (THETA) ! return end function BESY1 (X) ! !! BESY1 computes the Bessel function of the second kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10A1 !***TYPE SINGLE PRECISION (BESY1-S, DBESY1-D) !***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BESY1(X) calculates the Bessel function of the second kind of ! order one for real argument X. ! ! Series for BY1 on the interval 0. to 1.60000D+01 ! with weighted error 1.87E-18 ! log weighted error 17.73 ! significant figures required 17.83 ! decimal places required 18.30 ! ! Series for BM1 on the interval 0. to 6.25000D-02 ! with weighted error 5.61E-17 ! log weighted error 16.25 ! significant figures required 14.97 ! decimal places required 16.91 ! ! Series for BTH1 on the interval 0. to 6.25000D-02 ! with weighted error 4.10E-17 ! log weighted error 16.39 ! significant figures required 15.96 ! decimal places required 17.08 ! !***REFERENCES (NONE) !***ROUTINES CALLED BESJ1, CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BESY1 DIMENSION BY1CS(14), BM1CS(21), BTH1CS(24) LOGICAL FIRST SAVE BY1CS, BM1CS, BTH1CS, TWODPI, PI4, & NTY1, NTM1, NTTH1, XMIN, XSML, XMAX, FIRST DATA BY1CS( 1) / .03208047100611908629E0 / DATA BY1CS( 2) / 1.262707897433500450E0 / DATA BY1CS( 3) / .00649996189992317500E0 / DATA BY1CS( 4) / -.08936164528860504117E0 / DATA BY1CS( 5) / .01325088122175709545E0 / DATA BY1CS( 6) / -.00089790591196483523E0 / DATA BY1CS( 7) / .00003647361487958306E0 / DATA BY1CS( 8) / -.00000100137438166600E0 / DATA BY1CS( 9) / .00000001994539657390E0 / DATA BY1CS(10) / -.00000000030230656018E0 / DATA BY1CS(11) / .00000000000360987815E0 / DATA BY1CS(12) / -.00000000000003487488E0 / DATA BY1CS(13) / .00000000000000027838E0 / DATA BY1CS(14) / -.00000000000000000186E0 / DATA BM1CS( 1) / .1047362510931285E0 / DATA BM1CS( 2) / .00442443893702345E0 / DATA BM1CS( 3) / -.00005661639504035E0 / DATA BM1CS( 4) / .00000231349417339E0 / DATA BM1CS( 5) / -.00000017377182007E0 / DATA BM1CS( 6) / .00000001893209930E0 / DATA BM1CS( 7) / -.00000000265416023E0 / DATA BM1CS( 8) / .00000000044740209E0 / DATA BM1CS( 9) / -.00000000008691795E0 / DATA BM1CS(10) / .00000000001891492E0 / DATA BM1CS(11) / -.00000000000451884E0 / DATA BM1CS(12) / .00000000000116765E0 / DATA BM1CS(13) / -.00000000000032265E0 / DATA BM1CS(14) / .00000000000009450E0 / DATA BM1CS(15) / -.00000000000002913E0 / DATA BM1CS(16) / .00000000000000939E0 / DATA BM1CS(17) / -.00000000000000315E0 / DATA BM1CS(18) / .00000000000000109E0 / DATA BM1CS(19) / -.00000000000000039E0 / DATA BM1CS(20) / .00000000000000014E0 / DATA BM1CS(21) / -.00000000000000005E0 / DATA BTH1CS( 1) / .74060141026313850E0 / DATA BTH1CS( 2) / -.004571755659637690E0 / DATA BTH1CS( 3) / .000119818510964326E0 / DATA BTH1CS( 4) / -.000006964561891648E0 / DATA BTH1CS( 5) / .000000655495621447E0 / DATA BTH1CS( 6) / -.000000084066228945E0 / DATA BTH1CS( 7) / .000000013376886564E0 / DATA BTH1CS( 8) / -.000000002499565654E0 / DATA BTH1CS( 9) / .000000000529495100E0 / DATA BTH1CS(10) / -.000000000124135944E0 / DATA BTH1CS(11) / .000000000031656485E0 / DATA BTH1CS(12) / -.000000000008668640E0 / DATA BTH1CS(13) / .000000000002523758E0 / DATA BTH1CS(14) / -.000000000000775085E0 / DATA BTH1CS(15) / .000000000000249527E0 / DATA BTH1CS(16) / -.000000000000083773E0 / DATA BTH1CS(17) / .000000000000029205E0 / DATA BTH1CS(18) / -.000000000000010534E0 / DATA BTH1CS(19) / .000000000000003919E0 / DATA BTH1CS(20) / -.000000000000001500E0 / DATA BTH1CS(21) / .000000000000000589E0 / DATA BTH1CS(22) / -.000000000000000237E0 / DATA BTH1CS(23) / .000000000000000097E0 / DATA BTH1CS(24) / -.000000000000000040E0 / DATA TWODPI / 0.63661977236758134E0 / DATA PI4 / 0.78539816339744831E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BESY1 if (FIRST) THEN NTY1 = INITS (BY1CS, 14, 0.1*R1MACH(3)) NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3)) NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3)) ! XMIN = 1.571*EXP ( MAX(LOG(R1MACH(1)), -LOG(R1MACH(2)))+.01) XSML = SQRT (4.0*R1MACH(3)) XMAX = 1.0/R1MACH(4) end if FIRST = .FALSE. ! if (X <= 0.) call XERMSG ('SLATEC', 'BESY1', & 'X IS ZERO OR NEGATIVE', 1, 2) if (X > 4.0) go to 20 ! if (X < XMIN) call XERMSG ('SLATEC', 'BESY1', & 'X SO SMALL Y1 OVERFLOWS', 3, 2) Y = 0. if (X > XSML) Y = X*X BESY1 = TWODPI*LOG(0.5*X)*BESJ1(X) + & (0.5 + CSEVL (.125*Y-1., BY1CS, NTY1))/X return ! 20 if (X > XMAX) call XERMSG ('SLATEC', 'BESY1', & 'NO PRECISION BECAUSE X IS BIG', 2, 2) ! Z = 32.0/X**2 - 1.0 AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(X) THETA = X - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / X BESY1 = AMPL * SIN (THETA) ! return end subroutine BESY (X, FNU, N, Y) ! !! BESY implements forward recursion on the three term recursion ... ! relation for a sequence of non-negative order Bessel ! functions Y/SUB(FNU+I-1)/(X), I=1,...,N for real, positive ! X and non-negative orders FNU. ! !***LIBRARY SLATEC !***CATEGORY C10A3 !***TYPE SINGLE PRECISION (BESY-S, DBESY-D) !***KEYWORDS SPECIAL FUNCTIONS, Y BESSEL FUNCTION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! BESY implements forward recursion on the three term ! recursion relation for a sequence of non-negative order Bessel ! functions Y/sub(FNU+I-1)/(X), I=1,N for real X > 0.0E0 and ! non-negative orders FNU. If FNU < NULIM, orders FNU and ! FNU+1 are obtained from BESYNU which computes by a power ! series for X <= 2, the K Bessel function of an imaginary ! argument for 2 < X <= 20 and the asymptotic expansion for ! X > 20. ! ! If FNU >= NULIM, the uniform asymptotic expansion is coded ! in ASYJY for orders FNU and FNU+1 to start the recursion. ! NULIM is 70 or 100 depending on whether N=1 or N >= 2. An ! overflow test is made on the leading term of the asymptotic ! expansion before any extensive computation is done. ! ! Description of Arguments ! ! Input ! X - X > 0.0E0 ! FNU - order of the initial Y function, FNU >= 0.0E0 ! N - number of members in the sequence, N >= 1 ! ! Output ! Y - a vector whose first N components contain values ! for the sequence Y(I)=Y/sub(FNU+I-1)/(X), I=1,N. ! ! Error Conditions ! Improper input arguments - a fatal error ! Overflow - a fatal error ! !***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate ! or Large Orders, NPL Mathematical Tables 6, Her ! Majesty's Stationery Office, London, 1962. ! N. M. Temme, On the numerical evaluation of the modified ! Bessel function of the third kind, Journal of ! Computational Physics 19, (1975), pp. 324-337. ! N. M. Temme, On the numerical evaluation of the ordinary ! Bessel function of the second kind, Journal of ! Computational Physics 21, (1976), pp. 343-350. !***ROUTINES CALLED ASYJY, BESY0, BESY1, BESYNU, I1MACH, R1MACH, ! XERMSG, YAIRY !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BESY ! EXTERNAL YAIRY INTEGER I, IFLW, J, N, NB, ND, NN, NUD, NULIM INTEGER I1MACH REAL AZN,CN,DNU,ELIM,FLGJY,FN,FNU,RAN,S,S1,S2,TM,TRX, & W,WK,W2N,X,XLIM,XXN,Y REAL BESY0, BESY1, R1MACH DIMENSION W(2), NULIM(2), Y(*), WK(7) SAVE NULIM DATA NULIM(1),NULIM(2) / 70 , 100 / !***FIRST EXECUTABLE STATEMENT BESY NN = -I1MACH(12) ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0) XLIM = R1MACH(1)*1.0E+3 if (FNU < 0.0E0) go to 140 if (X <= 0.0E0) go to 150 if (X < XLIM) go to 170 if (N < 1) go to 160 ! ! ND IS A DUMMY VARIABLE FOR N ! ND = N NUD = INT(FNU) DNU = FNU - NUD NN = MIN(2,ND) FN = FNU + N - 1 if (FN < 2.0E0) go to 100 ! ! OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) ! FOR THE LAST ORDER, FNU+N-1 >= NULIM ! XXN = X/FN W2N = 1.0E0-XXN*XXN if ( W2N <= 0.0E0) go to 10 RAN = SQRT(W2N) AZN = LOG((1.0E0+RAN)/XXN) - RAN CN = FN*AZN if ( CN > ELIM) go to 170 10 CONTINUE if (NUD < NULIM(NN)) go to 20 ! ! ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1 >= NULIM ! FLGJY = -1.0E0 call ASYJY(YAIRY,X,FNU,FLGJY,NN,Y,WK,IFLW) if ( IFLW /= 0) go to 170 if (NN == 1) RETURN TRX = 2.0E0/X TM = (FNU+FNU+2.0E0)/X go to 80 ! 20 CONTINUE if (DNU /= 0.0E0) go to 30 S1 = BESY0(X) if (NUD == 0 .AND. ND == 1) go to 70 S2 = BESY1(X) go to 40 30 CONTINUE NB = 2 if (NUD == 0 .AND. ND == 1) NB = 1 call BESYNU(X, DNU, NB, W) S1 = W(1) if (NB == 1) go to 70 S2 = W(2) 40 CONTINUE TRX = 2.0E0/X TM = (DNU+DNU+2.0E0)/X ! FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) if (ND == 1) NUD = NUD - 1 if (NUD > 0) go to 50 if (ND > 1) go to 70 S1 = S2 go to 70 50 CONTINUE DO 60 I=1,NUD S = S2 S2 = TM*S2 - S1 S1 = S TM = TM + TRX 60 CONTINUE if (ND == 1) S1 = S2 70 CONTINUE Y(1) = S1 if (ND == 1) RETURN Y(2) = S2 80 CONTINUE if (ND == 2) RETURN ! FORWARD RECUR FROM FNU+2 TO FNU+N-1 DO 90 I=3,ND Y(I) = TM*Y(I-1) - Y(I-2) TM = TM + TRX 90 CONTINUE return ! 100 CONTINUE ! OVERFLOW TEST if (FN <= 1.0E0) go to 110 if (-FN*(LOG(X)-0.693E0) > ELIM) go to 170 110 CONTINUE if (DNU == 0.0E0) go to 120 call BESYNU(X, FNU, ND, Y) return 120 CONTINUE J = NUD if (J == 1) go to 130 J = J + 1 Y(J) = BESY0(X) if (ND == 1) RETURN J = J + 1 130 CONTINUE Y(J) = BESY1(X) if (ND == 1) RETURN TRX = 2.0E0/X TM = TRX go to 80 ! ! ! 140 CONTINUE call XERMSG ('SLATEC', 'BESY', 'ORDER, FNU, LESS THAN ZERO', 2, & 1) return 150 CONTINUE call XERMSG ('SLATEC', 'BESY', 'X LESS THAN OR EQUAL TO ZERO', 2, & 1) return 160 CONTINUE call XERMSG ('SLATEC', 'BESY', 'N LESS THAN ONE', 2, 1) return 170 CONTINUE call XERMSG ('SLATEC', 'BESY', & 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) return end subroutine BESYNU (X, FNU, N, Y) ! !! BESYNU is subsidiary to BESY. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BESYNU-S, DBSYNU-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! BESYNU computes N member sequences of Y Bessel functions ! Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and ! positive X. Equations of the references are implemented on ! small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X). ! Forward recursion with the three term recursion relation ! generates higher orders FNU+I-1, I=1,...,N. ! ! To start the recursion FNU is normalized to the interval ! -0.5 <= DNU < 0.5. A special form of the power series is ! implemented on 0 < X <= X1 while the Miller algorithm for the ! K Bessel function in terms of the confluent hypergeometric ! function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1 < X <= X ! Here I is the complex number SQRT(-1.). ! For X > X2, the asymptotic expansion for large X is used. ! When FNU is a half odd integer, a special formula for ! DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. ! ! BESYNU assumes that a significant digit SINH(X) function is ! available. ! ! Description of Arguments ! ! Input ! X - X > 0.0E0 ! FNU - Order of initial Y function, FNU >= 0.0E0 ! N - Number of members of the sequence, N >= 1 ! ! Output ! Y - A vector whose first N components contain values ! for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N. ! ! Error Conditions ! Improper input arguments - a fatal error ! Overflow - a fatal error ! !***SEE ALSO BESY !***REFERENCES N. M. Temme, On the numerical evaluation of the ordinary ! Bessel function of the second kind, Journal of ! Computational Physics 21, (1976), pp. 343-350. ! N. M. Temme, On the numerical evaluation of the modified ! Bessel function of the third kind, Journal of ! Computational Physics 19, (1975), pp. 324-337. !***ROUTINES CALLED GAMMA, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) ! 900727 Added EXTERNAL statement. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BESYNU ! INTEGER I, INU, J, K, KK, N, NN REAL A, AK, ARG, A1, A2, BK, CB, CBK, CC, CCK, CK, COEF, CPT, & CP1, CP2, CS, CS1, CS2, CX, DNU, DNU2, ETEST, ETX, F, FC, FHS, & FK, FKS, FLRX, FMU, FN, FNU, FX, G, G1, G2, HPI, P, PI, PT, Q, & RB, RBK, RCK, RELB, RPT, RP1, RP2, RS, RS1, RS2, RTHPI, RX, S, & SA, SB, SMU, SS, ST, S1, S2, TB, TM, TOL, T1, T2, X, X1, X2, Y DIMENSION A(120), RB(120), CB(120), Y(*), CC(8) REAL GAMMA, R1MACH EXTERNAL GAMMA SAVE X1, X2, PI, RTHPI, HPI, CC DATA X1, X2 / 3.0E0, 20.0E0 / DATA PI,RTHPI / 3.14159265358979E+00, 7.97884560802865E-01/ DATA HPI / 1.57079632679490E+00/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) & / 5.77215664901533E-01,-4.20026350340952E-02, & -4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04, & -2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/ !***FIRST EXECUTABLE STATEMENT BESYNU AK = R1MACH(3) TOL = MAX(AK,1.0E-15) if (X <= 0.0E0) go to 270 if (FNU < 0.0E0) go to 280 if (N < 1) go to 290 RX = 2.0E0/X INU = INT(FNU+0.5E0) DNU = FNU - INU if (ABS(DNU) == 0.5E0) go to 260 DNU2 = 0.0E0 if (ABS(DNU) < TOL) go to 10 DNU2 = DNU*DNU 10 CONTINUE if (X > X1) go to 120 ! ! SERIES FOR X <= X1 ! A1 = 1.0E0 - DNU A2 = 1.0E0 + DNU T1 = 1.0E0/GAMMA(A1) T2 = 1.0E0/GAMMA(A2) if (ABS(DNU) > 0.1E0) go to 40 ! SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) S = CC(1) AK = 1.0E0 DO 20 K=2,8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM if (ABS(TM) < TOL) go to 30 20 CONTINUE 30 G1 = -(S+S) go to 50 40 CONTINUE G1 = (T1-T2)/DNU 50 CONTINUE G2 = T1 + T2 SMU = 1.0E0 FC = 1.0E0/PI FLRX = LOG(RX) FMU = DNU*FLRX TM = 0.0E0 if (DNU == 0.0E0) go to 60 TM = SIN(DNU*HPI)/DNU TM = (DNU+DNU)*TM*TM FC = DNU/SIN(DNU*PI) if (FMU /= 0.0E0) SMU = SINH(FMU)/FMU 60 CONTINUE F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) FX = EXP(FMU) P = FC*T1*FX Q = FC*T2/FX G = F + TM*Q AK = 1.0E0 CK = 1.0E0 BK = 1.0E0 S1 = G S2 = P if (INU > 0 .OR. N > 1) go to 90 if (X < TOL) go to 80 CX = X*X*0.25E0 70 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) G = F + TM*Q CK = -CK*CX/AK T1 = CK*G S1 = S1 + T1 BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 S = ABS(T1)/(1.0E0+ABS(S1)) if (S > TOL) go to 70 80 CONTINUE Y(1) = -S1 return 90 CONTINUE if (X < TOL) go to 110 CX = X*X*0.25E0 100 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) G = F + TM*Q CK = -CK*CX/AK T1 = CK*G S1 = S1 + T1 T2 = CK*(P-AK*G) S2 = S2 + T2 BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2)) if (S > TOL) go to 100 110 CONTINUE S2 = -S2*RX S1 = -S1 go to 160 120 CONTINUE COEF = RTHPI/SQRT(X) if (X > X2) go to 210 ! ! MILLER ALGORITHM FOR X1 < X <= X2 ! ETEST = COS(PI*DNU)/(PI*X*TOL) FKS = 1.0E0 FHS = 0.25E0 FK = 0.0E0 RCK = 2.0E0 CCK = X + X RP1 = 0.0E0 CP1 = 0.0E0 RP2 = 1.0E0 CP2 = 0.0E0 K = 0 130 CONTINUE K = K + 1 FK = FK + 1.0E0 AK = (FHS-DNU2)/(FKS+FK) PT = FK + 1.0E0 RBK = RCK/PT CBK = CCK/PT RPT = RP2 CPT = CP2 RP2 = RBK*RPT - CBK*CPT - AK*RP1 CP2 = CBK*RPT + RBK*CPT - AK*CP1 RP1 = RPT CP1 = CPT RB(K) = RBK CB(K) = CBK A(K) = AK RCK = RCK + 2.0E0 FKS = FKS + FK + FK + 1.0E0 FHS = FHS + FK + FK PT = MAX(ABS(RP1),ABS(CP1)) FC = (RP1/PT)**2 + (CP1/PT)**2 PT = PT*SQRT(FC)*FK if (ETEST > PT) go to 130 KK = K RS = 1.0E0 CS = 0.0E0 RP1 = 0.0E0 CP1 = 0.0E0 RP2 = 1.0E0 CP2 = 0.0E0 DO 140 I=1,K RPT = RP2 CPT = CP2 RP2 = (RB(KK)*RPT-CB(KK)*CPT-RP1)/A(KK) CP2 = (CB(KK)*RPT+RB(KK)*CPT-CP1)/A(KK) RP1 = RPT CP1 = CPT RS = RS + RP2 CS = CS + CP2 KK = KK - 1 140 CONTINUE PT = MAX(ABS(RS),ABS(CS)) FC = (RS/PT)**2 + (CS/PT)**2 PT = PT*SQRT(FC) RS1 = (RP2*(RS/PT)+CP2*(CS/PT))/PT CS1 = (CP2*(RS/PT)-RP2*(CS/PT))/PT FC = HPI*(DNU-0.5E0) - X P = COS(FC) Q = SIN(FC) S1 = (CS1*Q-RS1*P)*COEF if (INU > 0 .OR. N > 1) go to 150 Y(1) = S1 return 150 CONTINUE PT = MAX(ABS(RP2),ABS(CP2)) FC = (RP2/PT)**2 + (CP2/PT)**2 PT = PT*SQRT(FC) RPT = DNU + 0.5E0 - (RP1*(RP2/PT)+CP1*(CP2/PT))/PT CPT = X - (CP1*(RP2/PT)-RP1*(CP2/PT))/PT CS2 = CS1*CPT - RS1*RPT RS2 = RPT*CS1 + RS1*CPT S2 = (RS2*Q+CS2*P)*COEF/X ! ! FORWARD RECURSION ON THE THREE TERM RECURSION RELATION ! 160 CONTINUE CK = (DNU+DNU+2.0E0)/X if (N == 1) INU = INU - 1 if (INU > 0) go to 170 if (N > 1) go to 190 S1 = S2 go to 190 170 CONTINUE DO 180 I=1,INU ST = S2 S2 = CK*S2 - S1 S1 = ST CK = CK + RX 180 CONTINUE if (N == 1) S1 = S2 190 CONTINUE Y(1) = S1 if (N == 1) RETURN Y(2) = S2 if (N == 2) RETURN DO 200 I=3,N Y(I) = CK*Y(I-1) - Y(I-2) CK = CK + RX 200 CONTINUE return ! ! ASYMPTOTIC EXPANSION FOR LARGE X, X > X2 ! 210 CONTINUE NN = 2 if (INU == 0 .AND. N == 1) NN = 1 DNU2 = DNU + DNU FMU = 0.0E0 if (ABS(DNU2) < TOL) go to 220 FMU = DNU2*DNU2 220 CONTINUE ARG = X - HPI*(DNU+0.5E0) SA = SIN(ARG) SB = COS(ARG) ETX = 8.0E0*X DO 250 K=1,NN S1 = S2 T2 = (FMU-1.0E0)/ETX SS = T2 RELB = TOL*ABS(T2) T1 = ETX S = 1.0E0 FN = 1.0E0 AK = 0.0E0 DO 230 J=1,13 T1 = T1 + ETX AK = AK + 8.0E0 FN = FN + AK T2 = -T2*(FMU-FN)/T1 S = S + T2 T1 = T1 + ETX AK = AK + 8.0E0 FN = FN + AK T2 = T2*(FMU-FN)/T1 SS = SS + T2 if (ABS(T2) <= RELB) go to 240 230 CONTINUE 240 S2 = COEF*(S*SA+SS*SB) FMU = FMU + 8.0E0*DNU + 4.0E0 TB = SA SA = -SB SB = TB 250 CONTINUE if (NN > 1) go to 160 S1 = S2 go to 190 ! ! FNU=HALF ODD INTEGER CASE ! 260 CONTINUE COEF = RTHPI/SQRT(X) S1 = COEF*SIN(X) S2 = -COEF*COS(X) go to 160 ! ! 270 call XERMSG ('SLATEC', 'BESYNU', 'X NOT GREATER THAN ZERO', 2, 1) return 280 call XERMSG ('SLATEC', 'BESYNU', 'FNU NOT ZERO OR POSITIVE', 2, & 1) return 290 call XERMSG ('SLATEC', 'BESYNU', 'N NOT GREATER THAN 0', 2, 1) return end function BETA (A, B) ! !! BETA computes the complete Beta function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7B !***TYPE SINGLE PRECISION (BETA-S, DBETA-D, CBETA-C) !***KEYWORDS COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BETA computes the complete beta function. ! ! Input Parameters: ! A real and positive ! B real and positive ! !***REFERENCES (NONE) !***ROUTINES CALLED ALBETA, GAMLIM, GAMMA, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE BETA EXTERNAL GAMMA SAVE XMAX, ALNSML DATA XMAX, ALNSML /0., 0./ !***FIRST EXECUTABLE STATEMENT BETA if (ALNSML /= 0.0) go to 10 call GAMLIM (XMIN, XMAX) ALNSML = LOG(R1MACH(1)) 10 if (A <= 0. .OR. B <= 0.) call XERMSG ('SLATEC', 'BETA', & 'BOTH ARGUMENTS MUST BE GT 0', 2, 2) if (A+B < XMAX) BETA = GAMMA(A) * GAMMA(B) / GAMMA(A+B) if (A+B < XMAX) RETURN BETA = ALBETA (A, B) if (BETA < ALNSML) call XERMSG ('SLATEC', 'BETA', & 'A AND/OR B SO BIG BETA UNDERFLOWS', 1, 2) BETA = EXP (BETA) return end FUNCTION BETAI (X, PIN, QIN) ! !! BETAI calculates the incomplete Beta function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7F !***TYPE SINGLE PRECISION (BETAI-S, DBETAI-D) !***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BETAI calculates the REAL incomplete beta function. ! ! The incomplete beta function ratio is the probability that a ! random variable from a beta distribution having parameters PIN and ! QIN will be less than or equal to X. ! ! -- Input Arguments -- All arguments are REAL. ! X upper limit of integration. X must be in (0,1) inclusive. ! PIN first beta distribution parameter. PIN must be > 0.0. ! QIN second beta distribution parameter. QIN must be > 0.0. ! !***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm ! 179, Communications of the ACM 17, 3 (March 1974), ! pp. 156. !***ROUTINES CALLED ALBETA, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920528 DESCRIPTION and REFERENCES sections revised. (WRB) !***END PROLOGUE BETAI REAL BETAI LOGICAL FIRST SAVE EPS, ALNEPS, SML, ALNSML, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BETAI if (FIRST) THEN EPS = R1MACH(3) ALNEPS = LOG(EPS) SML = R1MACH(1) ALNSML = LOG(SML) end if FIRST = .FALSE. ! if (X < 0. .OR. X > 1.0) call XERMSG ('SLATEC', 'BETAI', & 'X IS NOT IN THE RANGE (0,1)', 1, 2) if (PIN <= 0. .OR. QIN <= 0.) call XERMSG ('SLATEC', 'BETAI', & 'P AND/OR Q IS LE ZERO', 2, 2) ! Y = X P = PIN Q = QIN if (Q <= P .AND. X < 0.8) go to 20 if (X < 0.2) go to 20 Y = 1.0 - Y P = QIN Q = PIN ! 20 if ((P+Q)*Y/(P+1.) < EPS) go to 80 ! ! EVALUATE THE INFINITE SUM FIRST. ! TERM WILL EQUAL Y**P/BETA(PS,P) * (1.-PS)I * Y**I / FAC(I) ! PS = Q - AINT(Q) if (PS == 0.) PS = 1.0 XB = P*LOG(Y) - ALBETA(PS, P) - LOG(P) BETAI = 0.0 if (XB < ALNSML) go to 40 ! BETAI = EXP (XB) TERM = BETAI*P if (PS == 1.0) go to 40 ! N = MAX (ALNEPS/LOG(Y), 4.0E0) DO 30 I=1,N TERM = TERM*(I-PS)*Y/I BETAI = BETAI + TERM/(P+I) 30 CONTINUE ! ! NOW EVALUATE THE FINITE SUM, MAYBE. ! 40 if (Q <= 1.0) go to 70 ! XB = P*LOG(Y) + Q*LOG(1.0-Y) - ALBETA(P,Q) - LOG(Q) IB = MAX (XB/ALNSML, 0.0E0) TERM = EXP (XB - IB*ALNSML) C = 1.0/(1.0-Y) P1 = Q*C/(P+Q-1.) ! FINSUM = 0.0 N = Q if (Q == REAL(N)) N = N - 1 DO 50 I=1,N if (P1 <= 1.0 .AND. TERM/EPS <= FINSUM) go to 60 TERM = (Q-I+1)*C*TERM/(P+Q-I) ! if (TERM > 1.0) IB = IB - 1 if (TERM > 1.0) TERM = TERM*SML ! if (IB == 0) FINSUM = FINSUM + TERM 50 CONTINUE ! 60 BETAI = BETAI + FINSUM 70 if (Y /= X .OR. P /= PIN) BETAI = 1.0 - BETAI BETAI = MAX (MIN (BETAI, 1.0), 0.0) return ! 80 BETAI = 0.0 XB = P*LOG(MAX(Y,SML)) - LOG(P) - ALBETA(P,Q) if (XB > ALNSML .AND. Y /= 0.) BETAI = EXP (XB) if (Y /= X .OR. P /= PIN) BETAI = 1.0 - BETAI return end subroutine BFQAD (F, T, BCOEF, N, K, ID, X1, X2, TOL, QUAD, IERR, WORK) ! !! BFQAD computes the integral of a product of a function and a ... ! derivative of a B-spline. ! !***LIBRARY SLATEC !***CATEGORY H2A2A1, E3, K6 !***TYPE SINGLE PRECISION (BFQAD-S, DBFQAD-D) !***KEYWORDS INTEGRAL OF B-SPLINE, QUADRATURE !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! BFQAD computes the integral on (X1,X2) of a product of a ! function F and the ID-th derivative of a K-th order B-spline, ! using the B-representation (T,BCOEF,N,K). (X1,X2) must be ! a subinterval of T(K) <= X .le. T(N+1). An integration ! routine BSGQ8 (a modification ! of GAUS8), integrates the product on sub- ! intervals of (X1,X2) formed by included (distinct) knots. ! ! Description of Arguments ! Input ! F - external function of one argument for the ! integrand BF(X)=F(X)*BVALU(T,BCOEF,N,K,ID,X,INBV, ! WORK) ! T - knot array of length N+K ! BCOEF - coefficient array of length N ! N - length of coefficient array ! K - order of B-spline, K >= 1 ! ID - order of the spline derivative, 0 <= ID <= K-1 ! ID=0 gives the spline function ! X1,X2 - end points of quadrature interval in ! T(K) <= X <= T(N+1) ! TOL - desired accuracy for the quadrature, suggest ! 10.*STOL < TOL <= 0.1 where STOL is the single ! precision unit roundoff for the machine = R1MACH(4) ! ! Output ! QUAD - integral of BF(X) on (X1,X2) ! IERR - a status code ! IERR=1 normal return ! 2 some quadrature on (X1,X2) does not meet ! the requested tolerance. ! WORK - work vector of length 3*K ! ! Error Conditions ! X1 or X2 not in T(K) <= X <= T(N+1) is a fatal error. ! TOL not greater than the single precision unit roundoff or ! less than 0.1 is a fatal error. ! Some quadrature fails to meet the requested tolerance. ! !***REFERENCES D. E. Amos, Quadrature subroutines for splines and ! B-splines, Report SAND79-1825, Sandia Laboratories, ! December 1979. !***ROUTINES CALLED BSGQ8, INTRV, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BFQAD ! ! INTEGER ID, IERR, IFLG, ILO, IL1, IL2, K, LEFT, MFLAG, N, NPK, NP1 REAL A,AA,ANS,B,BB,BCOEF,Q,QUAD,T,TA,TB,TOL,WORK,WTOL, X1, & X2 REAL R1MACH, F DIMENSION T(*), BCOEF(*), WORK(*) EXTERNAL F !***FIRST EXECUTABLE STATEMENT BFQAD IERR = 1 QUAD = 0.0E0 if ( K < 1) go to 100 if ( N < K) go to 105 if ( ID < 0 .OR. ID >= K) go to 110 WTOL = R1MACH(4) if (TOL < WTOL .OR. TOL > 0.1E0) go to 30 AA = MIN(X1,X2) BB = MAX(X1,X2) if (AA < T(K)) go to 20 NP1 = N + 1 if (BB > T(NP1)) go to 20 if (AA == BB) RETURN NPK = N + K ! ILO = 1 call INTRV(T, NPK, AA, ILO, IL1, MFLAG) call INTRV(T, NPK, BB, ILO, IL2, MFLAG) if (IL2 >= NP1) IL2 = N INBV = 1 Q = 0.0E0 DO 10 LEFT=IL1,IL2 TA = T(LEFT) TB = T(LEFT+1) if (TA == TB) go to 10 A = MAX(AA,TA) B = MIN(BB,TB) call BSGQ8(F,T,BCOEF,N,K,ID,A,B,INBV,TOL,ANS,IFLG,WORK) if (IFLG > 1) IERR = 2 Q = Q + ANS 10 CONTINUE if (X1 > X2) Q = -Q QUAD = Q return ! ! 20 CONTINUE call XERMSG ('SLATEC', 'BFQAD', & 'X1 OR X2 OR BOTH DO NOT SATISFY T(K) <= X <= T(N+1)', 2, 1) return 30 CONTINUE call XERMSG ('SLATEC', 'BFQAD', & 'TOL IS LESS THAN THE SINGLE PRECISION TOLERANCE OR ' // & 'GREATER THAN 0.1', 2, 1) return 100 CONTINUE call XERMSG ('SLATEC', 'BFQAD', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'BFQAD', 'N DOES NOT SATISFY N >= K', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'BFQAD', & 'ID DOES NOT SATISFY 0 <= ID < K', 2, 1) return end function BIE (X) !*****************************************************************************80 ! !! BIE calculates the Bairy function for a negative argument and an ! exponentially scaled Bairy function for a non-negative argument. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10D !***TYPE SINGLE PRECISION (BIE-S, DBIE-D) !***KEYWORDS BAIRY FUNCTION, EXPONENTIALLY SCALED, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate BI(X) for X <= 0 and BI(X)*EXP(ZETA) where ! ZETA = 2/3 * X**(3/2) for X >= 0.0 ! ! Series for BIF on the interval -1.00000D+00 to 1.00000D+00 ! with weighted error 1.88E-19 ! log weighted error 18.72 ! significant figures required 17.74 ! decimal places required 19.20 ! ! Series for BIG on the interval -1.00000D+00 to 1.00000D+00 ! with weighted error 2.61E-17 ! log weighted error 16.58 ! significant figures required 15.17 ! decimal places required 17.03 ! ! Series for BIF2 on the interval 1.00000D+00 to 8.00000D+00 ! with weighted error 1.11E-17 ! log weighted error 16.95 ! approx significant figures required 16.5 ! decimal places required 17.45 ! ! Series for BIG2 on the interval 1.00000D+00 to 8.00000D+00 ! with weighted error 1.19E-18 ! log weighted error 17.92 ! approx significant figures required 17.2 ! decimal places required 18.42 ! ! Series for BIP on the interval 1.25000D-01 to 3.53553D-01 ! with weighted error 1.91E-17 ! log weighted error 16.72 ! significant figures required 15.35 ! decimal places required 17.41 ! ! Series for BIP2 on the interval 0. to 1.25000D-01 ! with weighted error 1.05E-18 ! log weighted error 17.98 ! significant figures required 16.74 ! decimal places required 18.71 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, R9AIMP !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE BIE LOGICAL FIRST DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10), BIPCS(24), & BIP2CS(29) SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, BIPCS, BIP2CS, ATR, BTR, & NBIF, NBIG, NBIF2, NBIG2, NBIP, NBIP2, X3SML, X32SML, XBIG, FIRST DATA BIFCS( 1) / -.01673021647198664948E0 / DATA BIFCS( 2) / .1025233583424944561E0 / DATA BIFCS( 3) / .00170830925073815165E0 / DATA BIFCS( 4) / .00001186254546774468E0 / DATA BIFCS( 5) / .00000004493290701779E0 / DATA BIFCS( 6) / .00000000010698207143E0 / DATA BIFCS( 7) / .00000000000017480643E0 / DATA BIFCS( 8) / .00000000000000020810E0 / DATA BIFCS( 9) / .00000000000000000018E0 / DATA BIGCS( 1) / .02246622324857452E0 / DATA BIGCS( 2) / .03736477545301955E0 / DATA BIGCS( 3) / .00044476218957212E0 / DATA BIGCS( 4) / .00000247080756363E0 / DATA BIGCS( 5) / .00000000791913533E0 / DATA BIGCS( 6) / .00000000001649807E0 / DATA BIGCS( 7) / .00000000000002411E0 / DATA BIGCS( 8) / .00000000000000002E0 / DATA BIF2CS( 1) / 0.09984572693816041E0 / DATA BIF2CS( 2) / .478624977863005538E0 / DATA BIF2CS( 3) / .0251552119604330118E0 / DATA BIF2CS( 4) / .0005820693885232645E0 / DATA BIF2CS( 5) / .0000074997659644377E0 / DATA BIF2CS( 6) / .0000000613460287034E0 / DATA BIF2CS( 7) / .0000000003462753885E0 / DATA BIF2CS( 8) / .0000000000014288910E0 / DATA BIF2CS( 9) / .0000000000000044962E0 / DATA BIF2CS(10) / .0000000000000000111E0 / DATA BIG2CS( 1) / .033305662145514340E0 / DATA BIG2CS( 2) / .161309215123197068E0 / DATA BIG2CS( 3) / .0063190073096134286E0 / DATA BIG2CS( 4) / .0001187904568162517E0 / DATA BIG2CS( 5) / .0000013045345886200E0 / DATA BIG2CS( 6) / .0000000093741259955E0 / DATA BIG2CS( 7) / .0000000000474580188E0 / DATA BIG2CS( 8) / .0000000000001783107E0 / DATA BIG2CS( 9) / .0000000000000005167E0 / DATA BIG2CS(10) / .0000000000000000011E0 / DATA BIPCS( 1) / -.08322047477943447E0 / DATA BIPCS( 2) / .01146118927371174E0 / DATA BIPCS( 3) / .00042896440718911E0 / DATA BIPCS( 4) / -.00014906639379950E0 / DATA BIPCS( 5) / -.00001307659726787E0 / DATA BIPCS( 6) / .00000632759839610E0 / DATA BIPCS( 7) / -.00000042226696982E0 / DATA BIPCS( 8) / -.00000019147186298E0 / DATA BIPCS( 9) / .00000006453106284E0 / DATA BIPCS(10) / -.00000000784485467E0 / DATA BIPCS(11) / -.00000000096077216E0 / DATA BIPCS(12) / .00000000070004713E0 / DATA BIPCS(13) / -.00000000017731789E0 / DATA BIPCS(14) / .00000000002272089E0 / DATA BIPCS(15) / .00000000000165404E0 / DATA BIPCS(16) / -.00000000000185171E0 / DATA BIPCS(17) / .00000000000059576E0 / DATA BIPCS(18) / -.00000000000012194E0 / DATA BIPCS(19) / .00000000000001334E0 / DATA BIPCS(20) / .00000000000000172E0 / DATA BIPCS(21) / -.00000000000000145E0 / DATA BIPCS(22) / .00000000000000049E0 / DATA BIPCS(23) / -.00000000000000011E0 / DATA BIPCS(24) / .00000000000000001E0 / DATA BIP2CS( 1) / -.113596737585988679E0 / DATA BIP2CS( 2) / .0041381473947881595E0 / DATA BIP2CS( 3) / .0001353470622119332E0 / DATA BIP2CS( 4) / .0000104273166530153E0 / DATA BIP2CS( 5) / .0000013474954767849E0 / DATA BIP2CS( 6) / .0000001696537405438E0 / DATA BIP2CS( 7) / -.0000000100965008656E0 / DATA BIP2CS( 8) / -.0000000167291194937E0 / DATA BIP2CS( 9) / -.0000000045815364485E0 / DATA BIP2CS(10) / .0000000003736681366E0 / DATA BIP2CS(11) / .0000000005766930320E0 / DATA BIP2CS(12) / .0000000000621812650E0 / DATA BIP2CS(13) / -.0000000000632941202E0 / DATA BIP2CS(14) / -.0000000000149150479E0 / DATA BIP2CS(15) / .0000000000078896213E0 / DATA BIP2CS(16) / .0000000000024960513E0 / DATA BIP2CS(17) / -.0000000000012130075E0 / DATA BIP2CS(18) / -.0000000000003740493E0 / DATA BIP2CS(19) / .0000000000002237727E0 / DATA BIP2CS(20) / .0000000000000474902E0 / DATA BIP2CS(21) / -.0000000000000452616E0 / DATA BIP2CS(22) / -.0000000000000030172E0 / DATA BIP2CS(23) / .0000000000000091058E0 / DATA BIP2CS(24) / -.0000000000000009814E0 / DATA BIP2CS(25) / -.0000000000000016429E0 / DATA BIP2CS(26) / .0000000000000005533E0 / DATA BIP2CS(27) / .0000000000000002175E0 / DATA BIP2CS(28) / -.0000000000000001737E0 / DATA BIP2CS(29) / -.0000000000000000010E0 / DATA ATR / 8.7506905708484345E0 / DATA BTR / -2.093836321356054E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BIE if (FIRST) THEN ETA = 0.1*R1MACH(3) NBIF = INITS (BIFCS, 9, ETA) NBIG = INITS (BIGCS, 8, ETA) NBIF2 = INITS (BIF2CS, 10, ETA) NBIG2 = INITS (BIG2CS, 10, ETA) NBIP = INITS (BIPCS , 24, ETA) NBIP2 = INITS (BIP2CS, 29, ETA) X3SML = ETA**0.3333 X32SML = 1.3104*X3SML**2 XBIG = R1MACH(2)**0.6666 FIRST = .FALSE. end if if (X >= (-1.0)) go to 20 call R9AIMP (X, XM, THETA) BIE = XM * SIN(THETA) return ! 20 if (X > 1.0) go to 30 Z = 0.0 if (ABS(X) > X3SML) Z = X**3 BIE = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 + & CSEVL (Z, BIGCS, NBIG)) if (X > X32SML) BIE = BIE * EXP(-2.0*X*SQRT(X)/3.0) return ! 30 if (X > 2.0) go to 40 Z = (2.0*X**3 - 9.0) / 7.0 BIE = EXP(-2.0*X*SQRT(X)/3.0) * (1.125 + CSEVL (Z, BIF2CS, NBIF2) & + X*(0.625 + CSEVL (Z, BIG2CS, NBIG2)) ) return ! 40 if (X > 4.0) go to 50 SQRTX = SQRT(X) Z = ATR/(X*SQRTX) + BTR BIE = (0.625 + CSEVL (Z, BIPCS, NBIP)) / SQRT(SQRTX) return ! 50 SQRTX = SQRT(X) Z = -1.0 if (X < XBIG) Z = 16.0/(X*SQRTX) - 1.0 BIE = (0.625 + CSEVL (Z, BIP2CS, NBIP2))/SQRT(SQRTX) return ! end function BI ( X ) !*****************************************************************************80 ! !! BI evaluates the Bairy function (the Airy function of the second kind). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10D !***TYPE SINGLE PRECISION (BI-S, DBI-D) !***KEYWORDS BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BI(X) calculates the Airy function of the second kind for real ! argument X. ! ! Series for BIF on the interval -1.00000D+00 to 1.00000D+00 ! with weighted error 1.88E-19 ! log weighted error 18.72 ! significant figures required 17.74 ! decimal places required 19.20 ! ! Series for BIG on the interval -1.00000D+00 to 1.00000D+00 ! with weighted error 2.61E-17 ! log weighted error 16.58 ! significant figures required 15.17 ! decimal places required 17.03 ! ! Series for BIF2 on the interval 1.00000D+00 to 8.00000D+00 ! with weighted error 1.11E-17 ! log weighted error 16.95 ! approx significant figures required 16.5 ! decimal places required 17.45 ! ! Series for BIG2 on the interval 1.00000D+00 to 8.00000D+00 ! with weighted error 1.19E-18 ! log weighted error 17.92 ! approx significant figures required 17.2 ! decimal places required 18.42 ! !***REFERENCES (NONE) !***ROUTINES CALLED BIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BI DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10) LOGICAL FIRST SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, NBIF, NBIG, NBIF2, & NBIG2, X3SML, XMAX, FIRST DATA BIFCS( 1) / -.01673021647198664948E0 / DATA BIFCS( 2) / .1025233583424944561E0 / DATA BIFCS( 3) / .00170830925073815165E0 / DATA BIFCS( 4) / .00001186254546774468E0 / DATA BIFCS( 5) / .00000004493290701779E0 / DATA BIFCS( 6) / .00000000010698207143E0 / DATA BIFCS( 7) / .00000000000017480643E0 / DATA BIFCS( 8) / .00000000000000020810E0 / DATA BIFCS( 9) / .00000000000000000018E0 / DATA BIGCS( 1) / .02246622324857452E0 / DATA BIGCS( 2) / .03736477545301955E0 / DATA BIGCS( 3) / .00044476218957212E0 / DATA BIGCS( 4) / .00000247080756363E0 / DATA BIGCS( 5) / .00000000791913533E0 / DATA BIGCS( 6) / .00000000001649807E0 / DATA BIGCS( 7) / .00000000000002411E0 / DATA BIGCS( 8) / .00000000000000002E0 / DATA BIF2CS( 1) / 0.09984572693816041E0 / DATA BIF2CS( 2) / .478624977863005538E0 / DATA BIF2CS( 3) / .0251552119604330118E0 / DATA BIF2CS( 4) / .0005820693885232645E0 / DATA BIF2CS( 5) / .0000074997659644377E0 / DATA BIF2CS( 6) / .0000000613460287034E0 / DATA BIF2CS( 7) / .0000000003462753885E0 / DATA BIF2CS( 8) / .0000000000014288910E0 / DATA BIF2CS( 9) / .0000000000000044962E0 / DATA BIF2CS(10) / .0000000000000000111E0 / DATA BIG2CS( 1) / .033305662145514340E0 / DATA BIG2CS( 2) / .161309215123197068E0 / DATA BIG2CS( 3) / .0063190073096134286E0 / DATA BIG2CS( 4) / .0001187904568162517E0 / DATA BIG2CS( 5) / .0000013045345886200E0 / DATA BIG2CS( 6) / .0000000093741259955E0 / DATA BIG2CS( 7) / .0000000000474580188E0 / DATA BIG2CS( 8) / .0000000000001783107E0 / DATA BIG2CS( 9) / .0000000000000005167E0 / DATA BIG2CS(10) / .0000000000000000011E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BI if (FIRST) THEN ETA = 0.1*R1MACH(3) NBIF = INITS (BIFCS , 9, ETA) NBIG = INITS (BIGCS , 8, ETA) NBIF2 = INITS (BIF2CS, 10, ETA) NBIG2 = INITS (BIG2CS, 10, ETA) X3SML = ETA**0.3333 XMAX = (1.5*LOG(R1MACH(2)))**0.6666 FIRST = .FALSE. end if if (X >= (-1.0)) go to 20 call R9AIMP (X, XM, THETA) BI = XM * SIN(THETA) return ! 20 if (X > 1.0) go to 30 Z = 0.0 if (ABS(X) > X3SML) Z = X**3 BI = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 + & CSEVL (Z, BIGCS, NBIG)) return ! 30 if (X > 2.0) go to 40 Z = (2.0*X**3 - 9.0) / 7.0 BI = 1.125 + CSEVL (Z, BIF2CS, NBIF2) + X*(0.625 + & CSEVL (Z, BIG2CS, NBIG2)) return ! 40 if (X > XMAX) call XERMSG ('SLATEC', 'BI', & 'X SO BIG THAT BI OVERFLOWS', 1, 2) ! BI = BIE(X) * EXP(2.0*X*SQRT(X)/3.0) return ! end function BINOM (N, M) ! !! BINOM computes the binomial coefficients. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C1 !***TYPE SINGLE PRECISION (BINOM-S, DBINOM-D) !***KEYWORDS BINOMIAL COEFFICIENTS, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! BINOM(N,M) calculates the binomial coefficient (N!)/((M!)*(N-M)!). ! !***REFERENCES (NONE) !***ROUTINES CALLED ALNREL, R1MACH, R9LGMC, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE BINOM LOGICAL FIRST SAVE SQ2PIL, BILNMX, FINTMX, FIRST DATA SQ2PIL / 0.91893853320467274E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BINOM if (FIRST) THEN BILNMX = LOG (R1MACH(2)) FINTMX = 0.9/R1MACH(3) end if FIRST = .FALSE. ! if (N < 0 .OR. M < 0) call XERMSG ('SLATEC', 'BINOM', & 'N OR M LT ZERO', 1, 2) if (N < M) call XERMSG ('SLATEC', 'BINOM', 'N LT M', 2, 2) ! K = MIN (M, N-M) if (K > 20) go to 30 if (K*LOG(AMAX0(N,1)) > BILNMX) go to 30 ! BINOM = 1. if (K == 0) RETURN ! DO 20 I=1,K BINOM = BINOM * REAL(N-I+1)/I 20 CONTINUE ! if (BINOM < FINTMX) BINOM = AINT (BINOM+0.5) return ! ! if K < 9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM 30 if (K < 9) call XERMSG ('SLATEC', 'BINOM', & 'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2) ! XN = N + 1 XK = K + 1 XNK = N - K + 1 ! CORR = R9LGMC(XN) - R9LGMC(XK) - R9LGMC(XNK) BINOM = XK*LOG(XNK/XK) - XN*ALNREL(-(XK-1.)/XN) & - 0.5*LOG(XN*XNK/XK) + 1.0 - SQ2PIL + CORR ! if (BINOM > BILNMX) call XERMSG ('SLATEC', 'BINOM', & 'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2) ! BINOM = EXP (BINOM) if (BINOM < FINTMX) BINOM = AINT (BINOM+0.5) ! return end subroutine BINT4 (X, Y, NDATA, IBCL, IBCR, FBCL, FBCR, KNTOPT, T, & BCOEF, N, K, W) ! !! BINT4 computes the B-representation of a cubic spline ... ! which interpolates given data. ! !***LIBRARY SLATEC !***CATEGORY E1A !***TYPE SINGLE PRECISION (BINT4-S, DBINT4-D) !***KEYWORDS B-SPLINE, CUBIC SPLINES, DATA FITTING, INTERPOLATION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! BINT4 computes the B representation (T,BCOEF,N,K) of a ! cubic spline (K=4) which interpolates data (X(I)),Y(I))), ! I=1,NDATA. Parameters IBCL, IBCR, FBCL, FBCR allow the ! specification of the spline first or second derivative at ! both X(1) and X(NDATA). When this data is not specified ! by the problem, it is common practice to use a natural ! spline by setting second derivatives at X(1) and X(NDATA) ! to zero (IBCL=IBCR=2,FBCL=FBCR=0.0). The spline is defined on ! T(4) <= X <= T(N+1) with (ordered) interior knots at X(I)) ! values where N=NDATA+2. The knots T(1), T(2), T(3) lie to ! the left of T(4)=X(1) and the knots T(N+2), T(N+3), T(N+4) ! lie to the right of T(N+1)=X(NDATA) in increasing order. If ! no extrapolation outside (X(1),X(NDATA)) is anticipated, the ! knots T(1)=T(2)=T(3)=T(4)=X(1) and T(N+2)=T(N+3)=T(N+4)= ! T(N+1)=X(NDATA) can be specified by KNTOPT=1. KNTOPT=2 ! selects a knot placement for T(1), T(2), T(3) to make the ! first 7 knots symmetric about T(4)=X(1) and similarly for ! T(N+2), T(N+3), T(N+4) about T(N+1)=X(NDATA). KNTOPT=3 ! allows the user to make his own selection, in increasing ! order, for T(1), T(2), T(3) to the left of X(1) and T(N+2), ! T(N+3), T(N+4) to the right of X(NDATA) in the work array ! W(1) through W(6). In any case, the interpolation on ! T(4) <= X <= T(N+1) by using function BVALU is unique ! for given boundary conditions. ! ! Description of Arguments ! Input ! X - X vector of abscissae of length NDATA, distinct ! and in increasing order ! Y - Y vector of ordinates of length NDATA ! NDATA - number of data points, NDATA >= 2 ! IBCL - selection parameter for left boundary condition ! IBCL = 1 constrain the first derivative at ! X(1) to FBCL ! = 2 constrain the second derivative at ! X(1) to FBCL ! IBCR - selection parameter for right boundary condition ! IBCR = 1 constrain first derivative at ! X(NDATA) to FBCR ! IBCR = 2 constrain second derivative at ! X(NDATA) to FBCR ! FBCL - left boundary values governed by IBCL ! FBCR - right boundary values governed by IBCR ! KNTOPT - knot selection parameter ! KNTOPT = 1 sets knot multiplicity at T(4) and ! T(N+1) to 4 ! = 2 sets a symmetric placement of knots ! about T(4) and T(N+1) ! = 3 sets TNP)=WNP) and T(N+1+I)=w(3+I),I=1,3 ! where WNP),I=1,6 is supplied by the user ! W - work array of dimension at least 5*(NDATA+2) ! if KNTOPT=3, then W(1),W(2),W(3) are knot values to ! the left of X(1) and W(4),W(5),W(6) are knot ! values to the right of X(NDATA) in increasing ! order to be supplied by the user ! ! Output ! T - knot array of length N+4 ! BCOEF - B-spline coefficient array of length N ! N - number of coefficients, N=NDATA+2 ! K - order of spline, K=4 ! ! Error Conditions ! Improper input is a fatal error ! Singular system of equations is a fatal error ! !***REFERENCES D. E. Amos, Computation with splines and B-splines, ! Report SAND78-1968, Sandia Laboratories, March 1979. ! Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. ! Carl de Boor, A Practical Guide to Splines, Applied ! Mathematics Series 27, Springer-Verlag, New York, ! 1978. !***ROUTINES CALLED BNFAC, BNSLV, BSPVD, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BINT4 ! INTEGER I, IBCL, IBCR, IFLAG, ILB, ILEFT, IT, IUB, IW, IWP, J, & JW, K, KNTOPT, N, NDATA, NDM, NP, NWROW REAL BCOEF,FBCL,FBCR,T, TOL,TXN,TX1,VNIKX,W,WDTOL,WORK,X, XL, & Y REAL R1MACH DIMENSION X(*), Y(*), T(*), BCOEF(*), W(5,*), VNIKX(4,4), WORK(15) !***FIRST EXECUTABLE STATEMENT BINT4 WDTOL = R1MACH(4) TOL = SQRT(WDTOL) if (NDATA < 2) go to 200 NDM = NDATA - 1 DO 10 I=1,NDM if (X(I) >= X(I+1)) go to 210 10 CONTINUE if (IBCL < 1 .OR. IBCL > 2) go to 220 if (IBCR < 1 .OR. IBCR > 2) go to 230 if (KNTOPT < 1 .OR. KNTOPT > 3) go to 240 K = 4 N = NDATA + 2 NP = N + 1 DO 20 I=1,NDATA T(I+3) = X(I) 20 CONTINUE go to (30, 50, 90), KNTOPT ! SET UP KNOT ARRAY WITH MULTIPLICITY 4 AT X(1) AND X(NDATA) 30 CONTINUE DO 40 I=1,3 T(4-I) = X(1) T(NP+I) = X(NDATA) 40 CONTINUE go to 110 ! SET UP KNOT ARRAY WITH SYMMETRIC PLACEMENT ABOUT END POINTS 50 CONTINUE if (NDATA > 3) go to 70 XL = (X(NDATA)-X(1))/3.0E0 DO 60 I=1,3 T(4-I) = T(5-I) - XL T(NP+I) = T(NP+I-1) + XL 60 CONTINUE go to 110 70 CONTINUE TX1 = X(1) + X(1) TXN = X(NDATA) + X(NDATA) DO 80 I=1,3 T(4-I) = TX1 - X(I+1) T(NP+I) = TXN - X(NDATA-I) 80 CONTINUE go to 110 ! SET UP KNOT ARRAY LESS THAN X(1) AND GREATER THAN X(NDATA) TO BE ! SUPPLIED BY USER IN WORK LOCATIONS W(1) THROUGH W(6) WHEN KNTOPT=3 90 CONTINUE DO 100 I=1,3 T(4-I) = W(4-I,1) JW = MAX(1,I-1) IW = MOD(I+2,5)+1 T(NP+I) = W(IW,JW) if (T(4-I) > T(5-I)) go to 250 if (T(NP+I) < T(NP+I-1)) go to 250 100 CONTINUE 110 CONTINUE ! DO 130 I=1,5 DO 120 J=1,N W(I,J) = 0.0E0 120 CONTINUE 130 CONTINUE ! SET UP LEFT INTERPOLATION POINT AND LEFT BOUNDARY CONDITION FOR ! RIGHT LIMITS IT = IBCL + 1 call BSPVD(T, K, IT, X(1), K, 4, VNIKX, WORK) IW = 0 if (ABS(VNIKX(3,1)) < TOL) IW = 1 DO 140 J=1,3 W(J+1,4-J) = VNIKX(4-J,IT) W(J,4-J) = VNIKX(4-J,1) 140 CONTINUE BCOEF(1) = Y(1) BCOEF(2) = FBCL ! SET UP INTERPOLATION EQUATIONS FOR POINTS I=2 TO I=NDATA-1 ILEFT = 4 if (NDM < 2) go to 170 DO 160 I=2,NDM ILEFT = ILEFT + 1 call BSPVD(T, K, 1, X(I), ILEFT, 4, VNIKX, WORK) DO 150 J=1,3 W(J+1,3+I-J) = VNIKX(4-J,1) 150 CONTINUE BCOEF(I+1) = Y(I) 160 CONTINUE ! SET UP RIGHT INTERPOLATION POINT AND RIGHT BOUNDARY CONDITION FOR ! LEFT LIMITS(ILEFT IS ASSOCIATED WITH T(N)=X(NDATA-1)) 170 CONTINUE IT = IBCR + 1 call BSPVD(T, K, IT, X(NDATA), ILEFT, 4, VNIKX, WORK) JW = 0 if (ABS(VNIKX(2,1)) < TOL) JW = 1 DO 180 J=1,3 W(J+1,3+NDATA-J) = VNIKX(5-J,IT) W(J+2,3+NDATA-J) = VNIKX(5-J,1) 180 CONTINUE BCOEF(N-1) = FBCR BCOEF(N) = Y(NDATA) ! SOLVE SYSTEM OF EQUATIONS ILB = 2 - JW IUB = 2 - IW NWROW = 5 IWP = IW + 1 call BNFAC(W(IWP,1), NWROW, N, ILB, IUB, IFLAG) if (IFLAG == 2) go to 190 call BNSLV(W(IWP,1), NWROW, N, ILB, IUB, BCOEF) return ! ! 190 CONTINUE call XERMSG ('SLATEC', 'BINT4', & 'THE SYSTEM OF EQUATIONS IS SINGULAR', 2, 1) return 200 CONTINUE call XERMSG ('SLATEC', 'BINT4', 'NDATA IS LESS THAN 2', 2, 1) return 210 CONTINUE call XERMSG ('SLATEC', 'BINT4', & 'X VALUES ARE NOT DISTINCT OR NOT ORDERED', 2, 1) return 220 CONTINUE call XERMSG ('SLATEC', 'BINT4', 'IBCL IS NOT 1 OR 2', 2, 1) return 230 CONTINUE call XERMSG ('SLATEC', 'BINT4', 'IBCR IS NOT 1 OR 2', 2, 1) return 240 CONTINUE call XERMSG ('SLATEC', 'BINT4', 'KNTOPT IS NOT 1, 2, OR 3', 2, 1) return 250 CONTINUE call XERMSG ('SLATEC', 'BINT4', & 'KNOT INPUT THROUGH W ARRAY IS NOT ORDERED PROPERLY', 2, 1) return end subroutine BINTK (X, Y, T, N, K, BCOEF, Q, WORK) ! !! BINTK computes the B-representation of a spline which interpolates ... ! given data. ! !***LIBRARY SLATEC !***CATEGORY E1A !***TYPE SINGLE PRECISION (BINTK-S, DBINTK-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract ! ! BINTK is the SPLINT routine of the reference. ! ! BINTK produces the B-spline coefficients, BCOEF, of the ! B-spline of order K with knots T(I), I=1,...,N+K, which ! takes on the value Y(I) at X(I), I=1,...,N. The spline or ! any of its derivatives can be evaluated by calls to BVALU. ! The I-th equation of the linear system A*BCOEF = B for the ! coefficients of the interpolant enforces interpolation at ! X(I)), I=1,...,N. Hence, B(I) = Y(I), all I, and A is ! a band matrix with 2K-1 bands if A is invertible. The matrix ! A is generated row by row and stored, diagonal by diagonal, ! in the rows of Q, with the main diagonal going into row K. ! The banded system is then solved by a call to BNFAC (which ! constructs the triangular factorization for A and stores it ! again in Q), followed by a call to BNSLV (which then ! obtains the solution BCOEF by substitution). BNFAC does no ! pivoting, since the total positivity of the matrix A makes ! this unnecessary. The linear system to be solved is ! (theoretically) invertible if and only if ! T(I) < X(I)) < T(I+K), all I. ! Equality is permitted on the left for I=1 and on the right ! for I=N when K knots are used at X(1) or X(N). Otherwise, ! violation of this condition is certain to lead to an error. ! ! Description of Arguments ! Input ! X - vector of length N containing data point abscissa ! in strictly increasing order. ! Y - corresponding vector of length N containing data ! point ordinates. ! T - knot vector of length N+K ! since T(1),..,T(K) <= X(1) and T(N+1),..,T(N+K) ! >= X(N), this leaves only N-K knots (not nec- ! essarily X(I)) values) interior to (X(1),X(N)) ! N - number of data points, N >= K ! K - order of the spline, K >= 1 ! ! Output ! BCOEF - a vector of length N containing the B-spline ! coefficients ! Q - a work vector of length (2*K-1)*N, containing ! the triangular factorization of the coefficient ! matrix of the linear system being solved. The ! coefficients for the interpolant of an ! additional data set (X(I)),YY(I)), I=1,...,N ! with the same abscissa can be obtained by loading ! YY into BCOEF and then executing ! call BNSLV (Q,2K-1,N,K-1,K-1,BCOEF) ! WORK - work vector of length 2*K ! ! Error Conditions ! Improper input is a fatal error ! Singular system of equations is a fatal error ! !***REFERENCES D. E. Amos, Computation with splines and B-splines, ! Report SAND78-1968, Sandia Laboratories, March 1979. ! Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. ! Carl de Boor, A Practical Guide to Splines, Applied ! Mathematics Series 27, Springer-Verlag, New York, ! 1978. !***ROUTINES CALLED BNFAC, BNSLV, BSPVN, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BINTK ! INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT, & LENQ, NP1 REAL BCOEF(*), Y(*), Q(*), T(*), X(*), XI, WORK(*) ! DIMENSION Q(2*K-1,N), T(N+K) !***FIRST EXECUTABLE STATEMENT BINTK if ( K < 1) go to 100 if ( N < K) go to 105 JJ = N - 1 if ( JJ == 0) go to 6 DO 5 I=1,JJ if ( X(I) >= X(I+1)) go to 110 5 CONTINUE 6 CONTINUE NP1 = N + 1 KM1 = K - 1 KPKM2 = 2*KM1 LEFT = K ! ZERO OUT ALL ENTRIES OF Q LENQ = N*(K+KM1) DO 10 I=1,LENQ Q(I) = 0.0E0 10 CONTINUE ! ! *** LOOP OVER I TO CONSTRUCT THE N INTERPOLATION EQUATIONS DO 50 I=1,N XI = X(I) ILP1MX = MIN(I+K,NP1) ! *** FIND LEFT IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT ! T(LEFT) <= X(I) < T(LEFT+1) ! MATRIX IS SINGULAR if THIS IS NOT POSSIBLE LEFT = MAX(LEFT,I) if (XI < T(LEFT)) go to 80 20 if (XI < T(LEFT+1)) go to 30 LEFT = LEFT + 1 if (LEFT < ILP1MX) go to 20 LEFT = LEFT - 1 if (XI > T(LEFT+1)) go to 80 ! *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE ! A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE K ENTRIES WITH J = ! LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE K NUMBERS ! ARE RETURNED, IN BCOEF (USED FOR TEMP. STORAGE HERE), BY THE ! FOLLOWING 30 call BSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK) ! WE THEREFORE WANT BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO ! A(I,LEFT-K+J), I.E., INTO Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE ! A(I+J,J) IS TO GO INTO Q(I+K,J), ALL I,J, if WE CONSIDER Q ! AS A TWO-DIM. ARRAY , WITH 2*K-1 ROWS (SEE COMMENTS IN ! BNFAC). IN THE PRESENT PROGRAM, WE TREAT Q AS AN EQUIVALENT ! ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON ! DIMENSION STATEMENTS) . WE THEREFORE WANT BCOEF(J) TO GO INTO ! ENTRY ! I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1) ! = I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J ! OF Q . JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1) DO 40 J=1,K JJ = JJ + KPKM2 Q(JJ) = BCOEF(J) 40 CONTINUE 50 CONTINUE ! ! ***OBTAIN FACTORIZATION OF A , STORED AGAIN IN Q. call BNFAC(Q, K+KM1, N, KM1, KM1, IFLAG) go to (60, 90), IFLAG ! *** SOLVE A*BCOEF = Y BY BACKSUBSTITUTION 60 DO 70 I=1,N BCOEF(I) = Y(I) 70 CONTINUE call BNSLV(Q, K+KM1, N, KM1, KM1, BCOEF) return ! ! 80 CONTINUE call XERMSG ('SLATEC', 'BINTK', & 'SOME ABSCISSA WAS NOT IN THE SUPPORT OF THE CORRESPONDING ' // & 'BASIS FUNCTION AND THE SYSTEM IS SINGULAR.', 2, 1) return 90 CONTINUE call XERMSG ('SLATEC', 'BINTK', & 'THE SYSTEM OF SOLVER DETECTS A SINGULAR SYSTEM ALTHOUGH ' // & 'THE THEORETICAL CONDITIONS FOR A SOLUTION WERE SATISFIED.', & 8, 1) return 100 CONTINUE call XERMSG ('SLATEC', 'BINTK', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'BINTK', 'N DOES NOT SATISFY N >= K', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'BINTK', & 'X(I) DOES NOT SATISFY X(I) < X(I+1) FOR SOME I', 2, 1) return end subroutine BISECT (N, EPS1, D, E, E2, LB, UB, MM, M, W, IND, IERR, & RV4, RV5) ! !! BISECT computes the eigenvalues of a symmetric tridiagonal matrix ... ! in a given interval using Sturm sequencing. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5, D4C2A !***TYPE SINGLE PRECISION (BISECT-S) !***KEYWORDS EIGENVALUES, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the bisection technique ! in the ALGOL procedure TRISTURM by Peters and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). ! ! This subroutine finds those eigenvalues of a TRIDIAGONAL ! SYMMETRIC matrix which lie in a specified interval, ! using bisection. ! ! On INPUT ! ! N is the order of the matrix. N is an INTEGER variable. ! ! EPS1 is an absolute error tolerance for the computed ! eigenvalues. If the input EPS1 is non-positive, ! it is reset for each submatrix to a default value, ! namely, minus the product of the relative machine ! precision and the 1-norm of the submatrix. ! EPS1 is a REAL variable. ! ! D contains the diagonal elements of the input matrix. ! D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the input matrix ! in its last N-1 positions. E(1) is arbitrary. ! E is a one-dimensional REAL array, dimensioned E(N). ! ! E2 contains the squares of the corresponding elements of E. ! E2(1) is arbitrary. E2 is a one-dimensional REAL array, ! dimensioned E2(N). ! ! LB and UB define the interval to be searched for eigenvalues. ! If LB is not less than UB, no eigenvalues will be found. ! LB and UB are REAL variables. ! ! MM should be set to an upper bound for the number of ! eigenvalues in the interval. WARNING - If more than ! MM eigenvalues are determined to lie in the interval, ! an error return is made with no eigenvalues found. ! MM is an INTEGER variable. ! ! On OUTPUT ! ! EPS1 is unaltered unless it has been reset to its ! (last) default value. ! ! D and E are unaltered. ! ! Elements of E2, corresponding to elements of E regarded ! as negligible, have been replaced by zero causing the ! matrix to split into a direct sum of submatrices. ! E2(1) is also set to zero. ! ! M is the number of eigenvalues determined to lie in (LB,UB). ! M is an INTEGER variable. ! ! W contains the M eigenvalues in ascending order. ! W is a one-dimensional REAL array, dimensioned W(MM). ! ! IND contains in its first M positions the submatrix indices ! associated with the corresponding eigenvalues in W -- ! 1 for eigenvalues belonging to the first submatrix from ! the top, 2 for those belonging to the second submatrix, etc. ! IND is an one-dimensional INTEGER array, dimensioned IND(MM). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 3*N+1 if M exceeds MM. In this case, M contains the ! number of eigenvalues determined to lie in ! (LB,UB). ! ! RV4 and RV5 are one-dimensional REAL arrays used for temporary ! storage, dimensioned RV4(N) and RV5(N). ! ! The ALGOL procedure STURMCNT contained in TRISTURM ! appears in BISECT in-line. ! ! Note that subroutine TQL1 or IMTQL1 is generally faster than ! BISECT, if more than N/4 eigenvalues are to be found. ! ! Questions and comments should be directed to B. S. Garbow, ! Applied Mathematics Division, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BISECT ! INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM REAL D(*),E(*),E2(*),W(*),RV4(*),RV5(*) REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP,S1,S2 INTEGER IND(*) LOGICAL FIRST ! SAVE FIRST, MACHEP DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT BISECT if (FIRST) THEN MACHEP = R1MACH(4) end if FIRST = .FALSE. ! IERR = 0 TAG = 0 T1 = LB T2 = UB ! .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... DO 40 I = 1, N if (I == 1) go to 20 S1 = ABS(D(I)) + ABS(D(I-1)) S2 = S1 + ABS(E(I)) if (S2 > S1) go to 40 20 E2(I) = 0.0E0 40 CONTINUE ! .......... DETERMINE THE NUMBER OF EIGENVALUES ! IN THE INTERVAL .......... P = 1 Q = N X1 = UB ISTURM = 1 go to 320 60 M = S X1 = LB ISTURM = 2 go to 320 80 M = M - S if (M > MM) go to 980 Q = 0 R = 0 ! .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING ! INTERVAL BY THE GERSCHGORIN BOUNDS .......... 100 if (R == M) go to 1001 TAG = TAG + 1 P = Q + 1 XU = D(P) X0 = D(P) U = 0.0E0 ! DO 120 Q = P, N X1 = U U = 0.0E0 V = 0.0E0 if (Q == N) go to 110 U = ABS(E(Q+1)) V = E2(Q+1) 110 XU = MIN(D(Q)-(X1+U),XU) X0 = MAX(D(Q)+(X1+U),X0) if (V == 0.0E0) go to 140 120 CONTINUE ! 140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP if (EPS1 <= 0.0E0) EPS1 = -X1 if (P /= Q) go to 180 ! .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... if (T1 > D(P) .OR. D(P) >= T2) go to 940 M1 = P M2 = P RV5(P) = D(P) go to 900 180 X1 = X1 * (Q-P+1) LB = MAX(T1,XU-X1) UB = MIN(T2,X0+X1) X1 = LB ISTURM = 3 go to 320 200 M1 = S + 1 X1 = UB ISTURM = 4 go to 320 220 M2 = S if (M1 > M2) go to 940 ! .......... FIND ROOTS BY BISECTION .......... X0 = UB ISTURM = 5 ! DO 240 I = M1, M2 RV5(I) = UB RV4(I) = LB 240 CONTINUE ! .......... LOOP FOR K-TH EIGENVALUE ! FOR K=M2 STEP -1 UNTIL M1 DO -- ! (-DO- NOT USED TO LEGALIZE -COMPUTED go to-) .......... K = M2 250 XU = LB ! .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... DO 260 II = M1, K I = M1 + K - II if (XU >= RV4(I)) go to 260 XU = RV4(I) go to 280 260 CONTINUE ! 280 if (X0 > RV5(K)) X0 = RV5(K) ! .......... NEXT BISECTION STEP .......... 300 X1 = (XU + X0) * 0.5E0 S1 = 2.0E0*(ABS(XU) + ABS(X0) + ABS(EPS1)) S2 = S1 + ABS(X0 - XU) if (S2 == S1) go to 420 ! .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... 320 S = P - 1 U = 1.0E0 ! DO 340 I = P, Q if (U /= 0.0E0) go to 325 V = ABS(E(I)) / MACHEP if (E2(I) == 0.0E0) V = 0.0E0 go to 330 325 V = E2(I) / U 330 U = D(I) - X1 - V if (U < 0.0E0) S = S + 1 340 CONTINUE ! go to (60,80,200,220,360), ISTURM ! .......... REFINE INTERVALS .......... 360 if (S >= K) go to 400 XU = X1 if (S >= M1) go to 380 RV4(M1) = X1 go to 300 380 RV4(S+1) = X1 if (RV5(S) > X1) RV5(S) = X1 go to 300 400 X0 = X1 go to 300 ! .......... K-TH EIGENVALUE FOUND .......... 420 RV5(K) = X1 K = K - 1 if (K >= M1) go to 250 ! .......... ORDER EIGENVALUES TAGGED WITH THEIR ! SUBMATRIX ASSOCIATIONS .......... 900 S = R R = R + M2 - M1 + 1 J = 1 K = M1 ! DO 920 L = 1, R if (J > S) go to 910 if (K > M2) go to 940 if (RV5(K) >= W(L)) go to 915 ! DO 905 II = J, S I = L + S - II W(I+1) = W(I) IND(I+1) = IND(I) 905 CONTINUE ! 910 W(L) = RV5(K) IND(L) = TAG K = K + 1 go to 920 915 J = J + 1 920 CONTINUE ! 940 if (Q < N) go to 100 go to 1001 ! .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF ! EIGENVALUES IN INTERVAL .......... 980 IERR = 3 * N + 1 1001 LB = T1 UB = T2 return end subroutine BKIAS (X, N, KTRMS, T, ANS, IND, MS, GMRN, H, IERR) ! !! BKIAS is subsidiary to BSKIN. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BKIAS-S, DBKIAS-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! BKIAS computes repeated integrals of the K0 Bessel function ! by the asymptotic expansion ! !***SEE ALSO BSKIN !***ROUTINES CALLED BDIFF, GAMRN, HKSEQ, R1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE BKIAS INTEGER I, II, IND, J, JMI, JN, K, KK, KM, KTRMS, MM, MP, MS, N, & IERR REAL ANS, B, BND, DEN1, DEN2, DEN3, ER, ERR, FJ, FK, FLN, FM1, & GMRN, G1, GS, H, HN, HRTPI, RAT, RG1, RXP, RZ, RZX, S, SS, SUMI, & SUMJ, T, TOL, V, W, X, XP, Z REAL GAMRN, R1MACH DIMENSION B(120), XP(16), S(31), H(*), V(52), W(52), T(50), & BND(15) SAVE B, BND, HRTPI !----------------------------------------------------------------------- ! COEFFICIENTS OF POLYNOMIAL P(J-1,X), J=1,15 !----------------------------------------------------------------------- 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), B(23), B(24) /1.00000000000000000E+00, & 1.00000000000000000E+00,-2.00000000000000000E+00, & 1.00000000000000000E+00,-8.00000000000000000E+00, & 6.00000000000000000E+00,1.00000000000000000E+00, & -2.20000000000000000E+01,5.80000000000000000E+01, & -2.40000000000000000E+01,1.00000000000000000E+00, & -5.20000000000000000E+01,3.28000000000000000E+02, & -4.44000000000000000E+02,1.20000000000000000E+02, & 1.00000000000000000E+00,-1.14000000000000000E+02, & 1.45200000000000000E+03,-4.40000000000000000E+03, & 3.70800000000000000E+03,-7.20000000000000000E+02, & 1.00000000000000000E+00,-2.40000000000000000E+02, & 5.61000000000000000E+03/ DATA B(25), B(26), B(27), B(28), B(29), B(30), B(31), B(32), & B(33), B(34), B(35), B(36), B(37), B(38), B(39), B(40), B(41), & B(42), B(43), B(44), B(45), B(46), B(47), B(48) & /-3.21200000000000000E+04,5.81400000000000000E+04, & -3.39840000000000000E+04,5.04000000000000000E+03, & 1.00000000000000000E+00,-4.94000000000000000E+02, & 1.99500000000000000E+04,-1.95800000000000000E+05, & 6.44020000000000000E+05,-7.85304000000000000E+05, & 3.41136000000000000E+05,-4.03200000000000000E+04, & 1.00000000000000000E+00,-1.00400000000000000E+03, & 6.72600000000000000E+04,-1.06250000000000000E+06, & 5.76550000000000000E+06,-1.24400640000000000E+07, & 1.10262960000000000E+07,-3.73392000000000000E+06, & 3.62880000000000000E+05,1.00000000000000000E+00, & -2.02600000000000000E+03,2.18848000000000000E+05/ DATA B(49), B(50), B(51), B(52), B(53), B(54), B(55), B(56), & B(57), B(58), B(59), B(60), B(61), B(62), B(63), B(64), B(65), & B(66), B(67), B(68), B(69), B(70), B(71), B(72) & /-5.32616000000000000E+06,4.47650000000000000E+07, & -1.55357384000000000E+08,2.38904904000000000E+08, & -1.62186912000000000E+08,4.43390400000000000E+07, & -3.62880000000000000E+06,1.00000000000000000E+00, & -4.07200000000000000E+03,6.95038000000000000E+05, & -2.52439040000000000E+07,3.14369720000000000E+08, & -1.64838430400000000E+09,4.00269508800000000E+09, & -4.64216395200000000E+09,2.50748121600000000E+09, & -5.68356480000000000E+08,3.99168000000000000E+07, & 1.00000000000000000E+00,-8.16600000000000000E+03, & 2.17062600000000000E+06,-1.14876376000000000E+08, & 2.05148277600000000E+09,-1.55489607840000000E+10/ DATA B(73), B(74), B(75), B(76), B(77), B(78), B(79), B(80), & B(81), B(82), B(83), B(84), B(85), B(86), B(87), B(88), B(89), & B(90), B(91), B(92), B(93), B(94), B(95), B(96) & /5.60413987840000000E+10,-1.01180433024000000E+11, & 9.21997902240000000E+10,-4.07883018240000000E+10, & 7.82771904000000000E+09,-4.79001600000000000E+08, & 1.00000000000000000E+00,-1.63560000000000000E+04, & 6.69969600000000000E+06,-5.07259276000000000E+08, & 1.26698177760000000E+10,-1.34323420224000000E+11, & 6.87720046384000000E+11,-1.81818864230400000E+12, & 2.54986547342400000E+12,-1.88307966182400000E+12, & 6.97929436800000000E+11,-1.15336085760000000E+11, & 6.22702080000000000E+09,1.00000000000000000E+00, & -3.27380000000000000E+04,2.05079880000000000E+07, & -2.18982980800000000E+09,7.50160522280000000E+10/ DATA B(97), B(98), B(99), B(100), B(101), B(102), B(103), B(104), & B(105), B(106), B(107), B(108), B(109), B(110), B(111), B(112), & B(113), B(114), B(115), B(116), B(117), B(118) & /-1.08467651241600000E+12,7.63483214939200000E+12, & -2.82999100661120000E+13,5.74943734645920000E+13, & -6.47283751398720000E+13,3.96895780558080000E+13, & -1.25509040179200000E+13,1.81099255680000000E+12, & -8.71782912000000000E+10,1.00000000000000000E+00, & -6.55040000000000000E+04,6.24078900000000000E+07, & -9.29252692000000000E+09,4.29826006340000000E+11, & -8.30844432796800000E+12,7.83913848313120000E+13, & -3.94365587815520000E+14,1.11174747256968000E+15, & -1.79717122069056000E+15,1.66642448627145600E+15, & -8.65023253219584000E+14,2.36908271543040000E+14/ DATA B(119), B(120) /-3.01963769856000000E+13, & 1.30767436800000000E+12/ !----------------------------------------------------------------------- ! BOUNDS B(M,K) , K=M-3 !----------------------------------------------------------------------- DATA BND(1), BND(2), BND(3), BND(4), BND(5), BND(6), BND(7), & BND(8), BND(9), BND(10), BND(11), BND(12), BND(13), BND(14), & BND(15) /1.0E0,1.0E0,1.0E0,1.0E0,3.10E0,5.18E0,11.7E0,29.8E0, & 90.4E0,297.0E0,1070.0E0,4290.0E0,18100.0E0,84700.0E0,408000.0E0/ DATA HRTPI /8.86226925452758014E-01/ ! !***FIRST EXECUTABLE STATEMENT BKIAS IERR=0 TOL = MAX(R1MACH(4),1.0E-18) FLN = N RZ = 1.0E0/(X+FLN) RZX = X*RZ Z = 0.5E0*(X+FLN) if (IND > 1) go to 10 GMRN = GAMRN(Z) 10 CONTINUE GS = HRTPI*GMRN G1 = GS + GS RG1 = 1.0E0/G1 GMRN = (RZ+RZ)/GMRN if (IND > 1) go to 70 !----------------------------------------------------------------------- ! EVALUATE ERROR FOR M=MS !----------------------------------------------------------------------- HN = 0.5E0*FLN DEN2 = KTRMS + KTRMS + N DEN3 = DEN2 - 2.0E0 DEN1 = X + DEN2 ERR = RG1*(X+X)/(DEN1-1.0E0) if (N == 0) go to 20 RAT = 1.0E0/(FLN*FLN) 20 CONTINUE if (KTRMS == 0) go to 30 FJ = KTRMS RAT = 0.25E0/(HRTPI*DEN3*SQRT(FJ)) 30 CONTINUE ERR = ERR*RAT FJ = -3.0E0 DO 50 J=1,15 if (J <= 5) ERR = ERR/DEN1 FM1 = MAX(1.0E0,FJ) FJ = FJ + 1.0E0 ER = BND(J)*ERR if (KTRMS == 0) go to 40 ER = ER/FM1 if (ER < TOL) go to 60 if (J >= 5) ERR = ERR/DEN3 go to 50 40 CONTINUE ER = ER*(1.0E0+HN/FM1) if (ER < TOL) go to 60 if (J >= 5) ERR = ERR/FLN 50 CONTINUE go to 200 60 CONTINUE MS = J 70 CONTINUE MM = MS + MS MP = MM + 1 !----------------------------------------------------------------------- ! H(K)=(-Z)**(K)*(PSI(K-1,Z)-PSI(K-1,Z+0.5))/GAMMA(K) , K=1,2,...,MM !----------------------------------------------------------------------- if (IND > 1) go to 80 call HKSEQ(Z, MM, H, IERR) go to 100 80 CONTINUE RAT = Z/(Z-0.5E0) RXP = RAT DO 90 I=1,MM H(I) = RXP*(1.0E0-H(I)) RXP = RXP*RAT 90 CONTINUE 100 CONTINUE !----------------------------------------------------------------------- ! SCALED S SEQUENCE !----------------------------------------------------------------------- S(1) = 1.0E0 FK = 1.0E0 DO 120 K=2,MP SS = 0.0E0 KM = K - 1 I = KM DO 110 J=1,KM SS = SS + S(J)*H(I) I = I - 1 110 CONTINUE S(K) = SS/FK FK = FK + 1.0E0 120 CONTINUE !----------------------------------------------------------------------- ! SCALED S-TILDA SEQUENCE !----------------------------------------------------------------------- if (KTRMS == 0) go to 160 FK = 0.0E0 SS = 0.0E0 RG1 = RG1/Z DO 130 K=1,KTRMS V(K) = Z/(Z+FK) W(K) = T(K)*V(K) SS = SS + W(K) FK = FK + 1.0E0 130 CONTINUE S(1) = S(1) - SS*RG1 DO 150 I=2,MP SS = 0.0E0 DO 140 K=1,KTRMS W(K) = W(K)*V(K) SS = SS + W(K) 140 CONTINUE S(I) = S(I) - SS*RG1 150 CONTINUE 160 CONTINUE !----------------------------------------------------------------------- ! SUM ON J !----------------------------------------------------------------------- SUMJ = 0.0E0 JN = 1 RXP = 1.0E0 XP(1) = 1.0E0 DO 190 J=1,MS JN = JN + J - 1 XP(J+1) = XP(J)*RZX RXP = RXP*RZ !----------------------------------------------------------------------- ! SUM ON I !----------------------------------------------------------------------- SUMI = 0.0E0 II = JN DO 180 I=1,J JMI = J - I + 1 KK = J + I + 1 DO 170 K=1,JMI V(K) = S(KK)*XP(K) KK = KK + 1 170 CONTINUE call BDIFF(JMI, V) SUMI = SUMI + B(II)*V(JMI)*XP(I+1) II = II + 1 180 CONTINUE SUMJ = SUMJ + SUMI*RXP 190 CONTINUE ANS = GS*(S(1)-SUMJ) return 200 CONTINUE IERR=2 return end subroutine BKISR (X, N, SUM, IERR) ! !! BKISR is subsidiary to BSKIN. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BKISR-S, DBKISR-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! BKISR computes repeated integrals of the K0 Bessel function ! by the series for N=0,1, and 2. ! !***SEE ALSO BSKIN !***ROUTINES CALLED PSIXN, R1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE BKISR INTEGER I, IERR, K, KK, KKN, K1, N, NP REAL AK, ATOL, BK, C, FK, FN, HX, HXS, POL, PR, SUM, TKP, TOL, & TRM, X, XLN REAL PSIXN, R1MACH DIMENSION C(2) SAVE C ! DATA C(1), C(2) /1.57079632679489662E+00,1.0E0/ !***FIRST EXECUTABLE STATEMENT BKISR IERR=0 TOL = MAX(R1MACH(4),1.0E-18) if (X < TOL) go to 50 PR = 1.0E0 POL = 0.0E0 if (N == 0) go to 20 DO 10 I=1,N POL = -POL*X + C(I) PR = PR*X/I 10 CONTINUE 20 CONTINUE HX = X*0.5E0 HXS = HX*HX XLN = LOG(HX) NP = N + 1 TKP = 3.0E0 FK = 2.0E0 FN = N BK = 4.0E0 AK = 2.0E0/((FN+1.0E0)*(FN+2.0E0)) SUM = AK*(PSIXN(N+3)-PSIXN(3)+PSIXN(2)-XLN) ATOL = SUM*TOL*0.75E0 DO 30 K=2,20 AK = AK*(HXS/BK)*((TKP+1.0E0)/(TKP+FN+1.0E0))*(TKP/(TKP+FN)) K1 = K + 1 KK = K1 + K KKN = KK + N TRM = (PSIXN(K1)+PSIXN(KKN)-PSIXN(KK)-XLN)*AK SUM = SUM + TRM if (ABS(TRM) <= ATOL) go to 40 TKP = TKP + 2.0E0 BK = BK + TKP FK = FK + 1.0E0 30 CONTINUE go to 80 40 CONTINUE SUM = (SUM*HXS+PSIXN(NP)-XLN)*PR if (N == 1) SUM = -SUM SUM = POL + SUM return !----------------------------------------------------------------------- ! SMALL X CASE, X < WORD TOLERANCE !----------------------------------------------------------------------- 50 CONTINUE if (N > 0) go to 60 HX = X*0.5E0 SUM = PSIXN(1) - LOG(HX) return 60 CONTINUE SUM = C(N) return 80 CONTINUE IERR=2 return end subroutine BKSOL (N, A, X) ! !! BKSOL is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BKSOL-S, DBKSOL-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! Solution of an upper triangular linear system by ! back-substitution ! ! The matrix A is assumed to be stored in a linear ! array proceeding in a row-wise manner. The ! vector X contains the given constant vector on input ! and contains the solution on return. ! The actual diagonal of A is unity while a diagonal ! scaling matrix is stored there. ! ********************************************************************** ! !***SEE ALSO BVSUP !***ROUTINES CALLED SDOT !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE BKSOL ! DIMENSION A(*),X(*) ! !***FIRST EXECUTABLE STATEMENT BKSOL M=(N*(N+1))/2 X(N)=X(N)*A(M) NM1=N-1 DO K=1,NM1 J=N-K M=M-K-1 X(J)=X(J)*A(M) - SDOT(K,A(M+1),1,X(J+1),1) end do RETURN end subroutine BLKTR1 (N, AN, BN, CN, M, AM, BM, CM, IDIMY, Y, B, W1, & W2, W3, WD, WW, WU, PRDCT, CPRDCT) ! !! BLKTR1 is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BLKTR1-S, CBLKT1-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! BLKTR1 solves the linear system set up by BLKTRI. ! ! B contains the roots of all the B polynomials. ! W1,W2,W3,WD,WW,WU are all working arrays. ! PRDCT is either PRODP or PROD depending on whether the boundary ! conditions in the M direction are periodic or not. ! CPRDCT is either CPRODP or CPROD which are the complex versions ! of PRODP and PROD. These are called in the event that some ! of the roots of the B sub P polynomial are complex. ! !***SEE ALSO BLKTRI !***ROUTINES CALLED INDXA, INDXB, INDXC !***COMMON BLOCKS CBLKT !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE BLKTR1 ! DIMENSION AN(*) ,BN(*) ,CN(*) ,AM(*) , & BM(*) ,CM(*) ,B(*) ,W1(*) , & W2(*) ,W3(*) ,WD(*) ,WW(*) , & WU(*) ,Y(IDIMY,*) COMMON /CBLKT/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT BLKTR1 KDO = K-1 DO 109 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, & M,AM,BM,CM,WD,WW,WU) if = 2**K DO 108 I=I4,IF,I4 if (I-NM) 101,101,108 101 IPI1 = I+I1 IPI2 = I+I2 IPI3 = I+I3 call INDXC (I,IR,IDXC,NC) if (I-IF) 102,108,108 102 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, & BM,CM,WD,WW,WU) if (IPI2-NM) 105,105,103 103 DO 104 J=1,M W3(J) = 0. W2(J) = 0. 104 CONTINUE go to 106 105 call PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM, & 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, & BM,CM,WD,WW,WU) 106 DO 107 J=1,M Y(J,I) = W1(J)+W2(J)+Y(J,I) 107 CONTINUE 108 CONTINUE 109 CONTINUE if (NPP) 132,110,132 ! ! THE PERIODIC CASE IS TREATED USING THE CAPACITANCE MATRIX METHOD ! 110 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, & BM,CM,WD,WW,WU) IZR = I DO 111 J=1,M W2(J) = W1(J) 111 CONTINUE DO 113 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, & CM,WD,WW,WU) DO 112 J=1,M W1(J) = Y(J,I)+W1(J) 112 CONTINUE call PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,W1,M,AM, & BM,CM,WD,WW,WU) 113 CONTINUE DO 118 LL=2,K L = K-LL+1 IR = L-1 I2 = 2**IR I1 = I2/2 I4 = I2+I2 IFD = IF-I2 DO 117 I=I2,IFD,I4 if (I-I2-IZR) 117,114,117 114 if (I-NM) 115,115,118 115 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, & BM,CM,WD,WW,WU) DO 116 J=1,M W2(J) = Y(J,I)+W2(J) 116 CONTINUE call PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W2,W2,M, & AM,BM,CM,WD,WW,WU) IZR = I if (I-NM) 117,119,117 117 CONTINUE 118 CONTINUE 119 DO 120 J=1,M Y(J,NM+1) = Y(J,NM+1)-CN(NM+1)*W1(J)-AN(NM+1)*W2(J) 120 CONTINUE call INDXB (IF/2,K-1,IM1,NM1) call INDXB (IF,K-1,IP,NP) if (NCMPLX) 121,122,121 121 call CPRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1), & Y(1,NM+1),M,AM,BM,CM,W1,W3,WW) go to 123 122 call PRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1), & Y(1,NM+1),M,AM,BM,CM,WD,WW,WU) 123 DO 124 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) 124 CONTINUE DO 126 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, & BM,CM,WD,WW,WU) call PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W1,W1,M,AM,BM, & CM,WD,WW,WU) DO 125 J=1,M Y(J,I) = Y(J,I)-W1(J) 125 CONTINUE 126 CONTINUE ! IZR = NM DO 131 L=1,KDO IR = L-1 I2 = 2**IR I1 = I2/2 I3 = I2+I1 I4 = I2+I2 IRM1 = IR-1 DO 130 I=I4,IF,I4 IPI1 = I+I1 IPI2 = I+I2 IPI3 = I+I3 if (IPI2-IZR) 127,128,127 127 if (I-IZR) 130,131,130 128 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, & AM,BM,CM,WD,WW,WU) call PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W2,W2,M,AM, & BM,CM,WD,WW,WU) DO 129 J=1,M Y(J,I) = Y(J,I)-W2(J) 129 CONTINUE IZR = I go to 131 130 CONTINUE 131 CONTINUE ! ! BEGIN BACK SUBSTITUTION PHASE ! 132 DO 144 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 143 I=I2,IFD,I4 if (I-NM) 133,133,143 133 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) 134,134,136 134 DO 135 J=1,M W1(J) = 0. 135 CONTINUE go to 137 136 call PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),Y(1,IMI2), & W1,M,AM,BM,CM,WD,WW,WU) 137 if (IPI2-NM) 140,140,138 138 DO 139 J=1,M W2(J) = 0. 139 CONTINUE go to 141 140 call PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),Y(1,IPI2), & W2,M,AM,BM,CM,WD,WW,WU) 141 DO 142 J=1,M W1(J) = Y(J,I)+W1(J)+W2(J) 142 CONTINUE call PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,Y(1,I), & M,AM,BM,CM,WD,WW,WU) 143 CONTINUE 144 CONTINUE return end subroutine BLKTRI (IFLG, NP, N, AN, BN, CN, MP, M, AM, BM, CM, & IDIMY, Y, IERROR, W) ! !! BLKTRI solves a block tridiagonal system of linear equations ... ! (usually resulting from the discretization of separable ! two-dimensional elliptic equations). ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B4B !***TYPE SINGLE PRECISION (BLKTRI-S, CBLKTR-C) !***KEYWORDS ELLIPTIC PDE, FISHPACK, TRIDIAGONAL LINEAR SYSTEM !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine BLKTRI Solves a System of Linear Equations of the Form ! ! AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J) ! ! + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J) ! ! for I = 1,2,...,M and J = 1,2,...,N. ! ! I+1 and I-1 are evaluated modulo M and J+1 and J-1 modulo N, i.e., ! ! X(I,0) = X(I,N), X(I,N+1) = X(I,1), ! X(0,J) = X(M,J), X(M+1,J) = X(1,J). ! ! These equations usually result from the discretization of ! separable elliptic equations. Boundary conditions may be ! Dirichlet, Neumann, or Periodic. ! ! ! * * * * * * * * * * ON INPUT * * * * * * * * * * ! ! IFLG ! = 0 Initialization only. Certain quantities that depend on NP, ! N, AN, BN, and CN are computed and stored in the work ! array W. ! = 1 The quantities that were computed in the initialization are ! used to obtain the solution X(I,J). ! ! NOTE A call with IFLG=0 takes approximately one half the time ! as a call with IFLG = 1 . However, the ! initialization does not have to be repeated unless NP, N, ! AN, BN, or CN change. ! ! NP ! = 0 If AN(1) and CN(N) are not zero, which corresponds to ! periodic boundary conditions. ! = 1 If AN(1) and CN(N) are zero. ! ! N ! The number of unknowns in the J-direction. N must be greater ! than 4. The operation count is proportional to MNlog2(N), hence ! N should be selected less than or equal to M. ! ! AN,BN,CN ! One-dimensional arrays of length N that specify the coefficients ! in the linear equations given above. ! ! MP ! = 0 If AM(1) and CM(M) are not zero, which corresponds to ! periodic boundary conditions. ! = 1 If AM(1) = CM(M) = 0 . ! ! M ! The number of unknowns in the I-direction. M must be greater ! than 4. ! ! AM,BM,CM ! One-dimensional arrays of length M that specify the coefficients ! in the linear equations given above. ! ! IDIMY ! The row (or first) dimension of the two-dimensional array Y as ! it appears in the program calling BLKTRI. This parameter is ! used to specify the variable dimension of Y. IDIMY must be at ! least M. ! ! Y ! A two-dimensional array that specifies the values of the right ! side of the linear system of equations given above. Y must be ! dimensioned at least M*N. ! ! W ! A one-dimensional array that must be provided by the user for ! work space. ! If NP=1 define K=INT(log2(N))+1 and set L=2**(K+1) then ! W must have dimension (K-2)*L+K+5+MAX(2N,6M) ! ! If NP=0 define K=INT(log2(N-1))+1 and set L=2**(K+1) then ! W must have dimension (K-2)*L+K+5+2N+MAX(2N,6M) ! ! **IMPORTANT** For purposes of checking, the required dimension ! of W is computed by BLKTRI and stored in W(1) ! in floating point format. ! ! * * * * * * * * * * On Output * * * * * * * * * * ! ! Y ! Contains the solution X. ! ! IERROR ! An error flag that indicates invalid input parameters. Except ! for number zero, a solution is not attempted. ! ! = 0 No error. ! = 1 M is less than 5. ! = 2 N is less than 5. ! = 3 IDIMY is less than M. ! = 4 BLKTRI failed while computing results that depend on the ! coefficient arrays AN, BN, CN. Check these arrays. ! = 5 AN(J)*CN(J-1) is less than 0 for some J. Possible reasons ! for this condition are ! 1. The arrays AN and CN are not correct. ! 2. Too large a grid spacing was used in the discretization ! of the elliptic equation. ! 3. The linear equations resulted from a partial ! differential equation which was not elliptic. ! ! W ! Contains intermediate values that must not be destroyed if ! BLKTRI will be called again with IFLG=1. W(1) contains the ! number of locations required by W in floating point format. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N) ! Arguments W(See argument list) ! ! Latest June 1979 ! Revision ! ! Required BLKTRI,BLKTRI,PROD,PRODP,CPROD,CPRODP,COMPB,INDXA, ! Subprograms INDXB,INDXC,PPADD,PSGF,PPSGF,PPSPF,BSRH,TEVLS, ! R1MACH ! ! Special The Algorithm may fail if ABS(BM(I)+BN(J)) is less ! Conditions than ABS(AM(I))+ABS(AN(J))+ABS(CM(I))+ABS(CN(J)) ! for some I and J. The Algorithm will also fail if ! AN(J)*CN(J-1) is less than zero for some J. ! See the description of the output parameter IERROR. ! ! Common CBLKT ! Blocks ! ! I/O None ! ! Precision Single ! ! Specialist Paul Swarztrauber ! ! Language FORTRAN ! ! History Version 1 September 1973 ! Version 2 April 1976 ! Version 3 June 1979 ! ! Algorithm Generalized Cyclic Reduction (See Reference below) ! ! Space ! Required Control Data 7600 ! ! Portability American National Standards Institute Fortran. ! The machine accuracy is set using function R1MACH. ! ! Required None ! Resident ! Routines ! ! References Swarztrauber,P. and R. Sweet, 'Efficient FORTRAN ! Subprograms For The Solution Of Elliptic Equations' ! NCAR TN/IA-109, July, 1975, 138 PP. ! ! Swarztrauber P. ,'A Direct Method For The Discrete ! Solution Of Separable Elliptic Equations', S.I.A.M. ! J. Numer. Anal.,11(1974) PP. 1136-1150. ! !***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran ! subprograms for the solution of elliptic equations, ! NCAR TN/IA-109, July 1975, 138 pp. ! P. N. Swarztrauber, A direct method for the discrete ! solution of separable elliptic equations, SIAM Journal ! on Numerical Analysis 11, (1974), pp. 1136-1150. !***ROUTINES CALLED BLKTR1, COMPB, CPROD, CPRODP, PROD, PRODP !***COMMON BLOCKS CBLKT !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BLKTRI ! DIMENSION AN(*) ,BN(*) ,CN(*) ,AM(*) , & BM(*) ,CM(*) ,Y(IDIMY,*) ,W(*) EXTERNAL PROD ,PRODP ,CPROD ,CPRODP COMMON /CBLKT/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT BLKTRI NM = N IERROR = 0 if (M-5) 101,102,102 101 IERROR = 1 go to 119 102 if (NM-3) 103,104,104 103 IERROR = 2 go to 119 104 if (IDIMY-M) 105,106,106 105 IERROR = 3 go to 119 106 NH = N NPP = NP if (NPP) 107,108,107 107 NH = NH+1 108 IK = 2 K = 1 109 IK = IK+IK K = K+1 if (NH-IK) 110,110,109 110 NL = IK IK = IK+IK NL = NL-1 IWAH = (K-2)*IK+K+6 if (NPP) 111,112,111 ! ! DIVIDE W INTO WORKING SUB ARRAYS ! 111 IW1 = IWAH IWBH = IW1+NM W(1) = IW1-1+MAX(2*NM,6*M) go to 113 112 IWBH = IWAH+NM+NM IW1 = IWBH W(1) = IW1-1+MAX(2*NM,6*M) NM = NM-1 ! ! SUBROUTINE COMP B COMPUTES THE ROOTS OF THE B POLYNOMIALS ! 113 if (IERROR) 119,114,119 114 IW2 = IW1+M IW3 = IW2+M IWD = IW3+M IWW = IWD+M IWU = IWW+M if (IFLG) 116,115,116 115 call COMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH)) go to 119 116 if (MP) 117,118,117 ! ! SUBROUTINE BLKTR1 SOLVES THE LINEAR SYSTEM ! 117 call BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2), & W(IW3),W(IWD),W(IWW),W(IWU),PROD,CPROD) go to 119 118 call BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2), & W(IW3),W(IWD),W(IWW),W(IWU),PRODP,CPRODP) 119 CONTINUE return end subroutine BNDACC (G, MDG, NB, IP, IR, MT, JT) ! !! BNDACC computes the LU factorization of a banded matrices using ... ! sequential accumulation of rows of the data matrix. ! Exactly one right-hand side vector is permitted. ! !***LIBRARY SLATEC !***CATEGORY D9 !***TYPE SINGLE PRECISION (BNDACC-S, DBNDAC-D) !***KEYWORDS BANDED MATRIX, CURVE FITTING, LEAST SQUARES !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! These subroutines solve the least squares problem Ax = b for ! banded matrices A using sequential accumulation of rows of the ! data matrix. Exactly one right-hand side vector is permitted. ! ! These subroutines are intended for the type of least squares ! systems that arise in applications such as curve or surface ! fitting of data. The least squares equations are accumulated and ! processed using only part of the data. This requires a certain ! user interaction during the solution of Ax = b. ! ! Specifically, suppose the data matrix (A B) is row partitioned ! into Q submatrices. Let (E F) be the T-th one of these ! submatrices where E = (0 C 0). Here the dimension of E is MT by N ! and the dimension of C is MT by NB. The value of NB is the ! bandwidth of A. The dimensions of the leading block of zeros in E ! are MT by JT-1. ! ! The user of the subroutine BNDACC provides MT,JT,C and F for ! T=1,...,Q. Not all of this data must be supplied at once. ! ! Following the processing of the various blocks (E F), the matrix ! (A B) has been transformed to the form (R D) where R is upper ! triangular and banded with bandwidth NB. The least squares ! system Rx = d is then easily solved using back substitution by ! executing the statement call BNDSOL(1,...). The sequence of ! values for JT must be nondecreasing. This may require some ! preliminary interchanges of rows and columns of the matrix A. ! ! The primary reason for these subroutines is that the total ! processing can take place in a working array of dimension MU by ! NB+1. An acceptable value for MU is ! ! MU = MAX(MT + N + 1), ! ! where N is the number of unknowns. ! ! Here the maximum is taken over all values of MT for T=1,...,Q. ! Notice that MT can be taken to be a small as one, showing that ! MU can be as small as N+2. The subprogram BNDACC processes the ! rows more efficiently if MU is large enough so that each new ! block (C F) has a distinct value of JT. ! ! The four principle parts of these algorithms are obtained by the ! following call statements ! ! call BNDACC(...) Introduce new blocks of data. ! ! call BNDSOL(1,...)Compute solution vector and length of ! residual vector. ! ! call BNDSOL(2,...)Given any row vector H solve YR = H for the ! row vector Y. ! ! call BNDSOL(3,...)Given any column vector W solve RZ = W for ! the column vector Z. ! ! The dots in the above call statements indicate additional ! arguments that will be specified in the following paragraphs. ! ! The user must dimension the array appearing in the call list.. ! G(MDG,NB+1) ! ! Description of calling sequence for BNDACC.. ! ! The entire set of parameters for BNDACC are ! ! Input.. ! ! G(*,*) The working array into which the user will ! place the MT by NB+1 block (C F) in rows IR ! through IR+MT-1, columns 1 through NB+1. ! See descriptions of IR and MT below. ! ! MDG The number of rows in the working array ! G(*,*). The value of MDG should be >= MU. ! The value of MU is defined in the abstract ! of these subprograms. ! ! NB The bandwidth of the data matrix A. ! ! IP Set by the user to the value 1 before the ! first call to BNDACC. Its subsequent value ! is controlled by BNDACC to set up for the ! next call to BNDACC. ! ! IR Index of the row of G(*,*) where the user is ! to place the new block of data (C F). Set by ! the user to the value 1 before the first call ! to BNDACC. Its subsequent value is controlled ! by BNDACC. A value of IR > MDG is considered ! an error. ! ! MT,JT Set by the user to indicate respectively the ! number of new rows of data in the block and ! the index of the first nonzero column in that ! set of rows (E F) = (0 C 0 F) being processed. ! ! Output.. ! ! G(*,*) The working array which will contain the ! processed rows of that part of the data ! matrix which has been passed to BNDACC. ! ! IP,IR The values of these arguments are advanced by ! BNDACC to be ready for storing and processing ! a new block of data in G(*,*). ! ! Description of calling sequence for BNDSOL.. ! ! The user must dimension the arrays appearing in the call list.. ! ! G(MDG,NB+1), X(N) ! ! The entire set of parameters for BNDSOL are ! ! Input.. ! ! MODE Set by the user to one of the values 1, 2, or ! 3. These values respectively indicate that ! the solution of AX = B, YR = H or RZ = W is ! required. ! ! G(*,*),MDG, These arguments all have the same meaning and ! NB,IP,IR contents as following the last call to BNDACC. ! ! X(*) With mode=2 or 3 this array contains, ! respectively, the right-side vectors H or W of ! the systems YR = H or RZ = W. ! ! N The number of variables in the solution ! vector. If any of the N diagonal terms are ! zero the subroutine BNDSOL prints an ! appropriate message. This condition is ! considered an error. ! ! Output.. ! ! X(*) This array contains the solution vectors X, ! Y or Z of the systems AX = B, YR = H or ! RZ = W depending on the value of MODE=1, ! 2 or 3. ! ! RNORM If MODE=1 RNORM is the Euclidean length of the ! residual vector AX-B. When MODE=2 or 3 RNORM ! is set to zero. ! ! Remarks.. ! ! To obtain the upper triangular matrix and transformed right-hand ! side vector D so that the super diagonals of R form the columns ! of G(*,*), execute the following Fortran statements. ! ! NBP1=NB+1 ! ! DO 10 J=1, NBP1 ! ! 10 G(IR,J) = 0.E0 ! ! MT=1 ! ! JT=N+1 ! ! call BNDACC(G,MDG,NB,IP,IR,MT,JT) ! !***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares ! Problems, Prentice-Hall, Inc., 1974, Chapter 27. !***ROUTINES CALLED H12, XERMSG !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BNDACC DIMENSION G(MDG,*) !***FIRST EXECUTABLE STATEMENT BNDACC ZERO=0. ! ! ALG. STEPS 1-4 ARE PERFORMED EXTERNAL TO THIS SUBROUTINE. ! NBP1=NB+1 if (MT <= 0.OR.NB <= 0) RETURN ! if ( .NOT.MDG < IR) go to 5 NERR=1 IOPT=2 call XERMSG ('SLATEC', 'BNDACC', 'MDG < IR, PROBABLE ERROR.', & NERR, IOPT) return 5 CONTINUE ! ! ALG. STEP 5 if (JT == IP) go to 70 ! ALG. STEPS 6-7 if (JT <= IR) go to 30 ! ALG. STEPS 8-9 DO 10 I=1,MT IG1=JT+MT-I IG2=IR+MT-I DO 10 J=1,NBP1 G(IG1,J)=G(IG2,J) 10 CONTINUE ! ALG. STEP 10 IE=JT-IR DO 20 I=1,IE IG=IR+I-1 DO 20 J=1,NBP1 G(IG,J)=ZERO 20 CONTINUE ! ALG. STEP 11 IR=JT ! ALG. STEP 12 30 MU=MIN(NB-1,IR-IP-1) if (MU == 0) go to 60 ! ALG. STEP 13 DO 50 L=1,MU ! ALG. STEP 14 K=MIN(L,JT-IP) ! 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 ! ALG. STEP 16 DO 50 I=1,K JG=NBP1-I G(IG,JG)=ZERO 50 CONTINUE ! ALG. STEP 17 60 IP=JT ! ALG. STEPS 18-19 70 MH=IR+MT-IP KH=MIN(NBP1,MH) ! ALG. STEP 20 DO 80 I=1,KH call H12 (1,I,MAX(I+1,IR-IP+1),MH,G(IP,I),1,RHO, & G(IP,I+1),1,MDG,NBP1-I) 80 CONTINUE ! ALG. STEP 21 IR=IP+KH ! ALG. STEP 22 if (KH < NBP1) go to 100 ! ALG. STEP 23 DO 90 I=1,NB G(IR-1,I)=ZERO 90 CONTINUE ! ALG. STEP 24 100 CONTINUE ! ALG. STEP 25 return end subroutine BNDSOL (MODE, G, MDG, NB, IP, IR, X, N, RNORM) ! !! BNDSOL solves the least squares problem for a banded matrix using ... ! sequential accumulation of rows of the data matrix. ! Exactly one right-hand side vector is permitted. ! !***LIBRARY SLATEC !***CATEGORY D9 !***TYPE SINGLE PRECISION (BNDSOL-S, DBNDSL-D) !***KEYWORDS BANDED MATRIX, CURVE FITTING, LEAST SQUARES !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! These subroutines solve the least squares problem Ax = b for ! banded matrices A using sequential accumulation of rows of the ! data matrix. Exactly one right-hand side vector is permitted. ! ! These subroutines are intended for the type of least squares ! systems that arise in applications such as curve or surface ! fitting of data. The least squares equations are accumulated and ! processed using only part of the data. This requires a certain ! user interaction during the solution of Ax = b. ! ! Specifically, suppose the data matrix (A B) is row partitioned ! into Q submatrices. Let (E F) be the T-th one of these ! submatrices where E = (0 C 0). Here the dimension of E is MT by N ! and the dimension of C is MT by NB. The value of NB is the ! bandwidth of A. The dimensions of the leading block of zeros in E ! are MT by JT-1. ! ! The user of the subroutine BNDACC provides MT,JT,C and F for ! T=1,...,Q. Not all of this data must be supplied at once. ! ! Following the processing of the various blocks (E F), the matrix ! (A B) has been transformed to the form (R D) where R is upper ! triangular and banded with bandwidth NB. The least squares ! system Rx = d is then easily solved using back substitution by ! executing the statement call BNDSOL(1,...). The sequence of ! values for JT must be nondecreasing. This may require some ! preliminary interchanges of rows and columns of the matrix A. ! ! The primary reason for these subroutines is that the total ! processing can take place in a working array of dimension MU by ! NB+1. An acceptable value for MU is ! ! MU = MAX(MT + N + 1), ! ! where N is the number of unknowns. ! ! Here the maximum is taken over all values of MT for T=1,...,Q. ! Notice that MT can be taken to be a small as one, showing that ! MU can be as small as N+2. The subprogram BNDACC processes the ! rows more efficiently if MU is large enough so that each new ! block (C F) has a distinct value of JT. ! ! The four principle parts of these algorithms are obtained by the ! following call statements ! ! call BNDACC(...) Introduce new blocks of data. ! ! call BNDSOL(1,...)Compute solution vector and length of ! residual vector. ! ! call BNDSOL(2,...)Given any row vector H solve YR = H for the ! row vector Y. ! ! call BNDSOL(3,...)Given any column vector W solve RZ = W for ! the column vector Z. ! ! The dots in the above call statements indicate additional ! arguments that will be specified in the following paragraphs. ! ! The user must dimension the array appearing in the call list.. ! G(MDG,NB+1) ! ! Description of calling sequence for BNDACC.. ! ! The entire set of parameters for BNDACC are ! ! Input.. ! ! G(*,*) The working array into which the user will ! place the MT by NB+1 block (C F) in rows IR ! through IR+MT-1, columns 1 through NB+1. ! See descriptions of IR and MT below. ! ! MDG The number of rows in the working array ! G(*,*). The value of MDG should be >= MU. ! The value of MU is defined in the abstract ! of these subprograms. ! ! NB The bandwidth of the data matrix A. ! ! IP Set by the user to the value 1 before the ! first call to BNDACC. Its subsequent value ! is controlled by BNDACC to set up for the ! next call to BNDACC. ! ! IR Index of the row of G(*,*) where the user is ! the user to the value 1 before the first call ! to BNDACC. Its subsequent value is controlled ! by BNDACC. A value of IR > MDG is considered ! an error. ! ! MT,JT Set by the user to indicate respectively the ! number of new rows of data in the block and ! the index of the first nonzero column in that ! set of rows (E F) = (0 C 0 F) being processed. ! Output.. ! ! G(*,*) The working array which will contain the ! processed rows of that part of the data ! matrix which has been passed to BNDACC. ! ! IP,IR The values of these arguments are advanced by ! BNDACC to be ready for storing and processing ! a new block of data in G(*,*). ! ! Description of calling sequence for BNDSOL.. ! ! The user must dimension the arrays appearing in the call list.. ! ! G(MDG,NB+1), X(N) ! ! The entire set of parameters for BNDSOL are ! ! Input.. ! ! MODE Set by the user to one of the values 1, 2, or ! 3. These values respectively indicate that ! the solution of AX = B, YR = H or RZ = W is ! required. ! ! G(*,*),MDG, These arguments all have the same meaning and ! NB,IP,IR contents as following the last call to BNDACC. ! ! X(*) With mode=2 or 3 this array contains, ! respectively, the right-side vectors H or W of ! the systems YR = H or RZ = W. ! ! N The number of variables in the solution ! vector. If any of the N diagonal terms are ! zero the subroutine BNDSOL prints an ! appropriate message. This condition is ! considered an error. ! ! Output.. ! ! X(*) This array contains the solution vectors X, ! Y or Z of the systems AX = B, YR = H or ! RZ = W depending on the value of MODE=1, ! 2 or 3. ! ! RNORM If MODE=1 RNORM is the Euclidean length of the ! residual vector AX-B. When MODE=2 or 3 RNORM ! is set to zero. ! ! Remarks.. ! ! To obtain the upper triangular matrix and transformed right-hand ! side vector D so that the super diagonals of R form the columns ! of G(*,*), execute the following Fortran statements. ! ! NBP1=NB+1 ! ! DO 10 J=1, NBP1 ! ! 10 G(IR,J) = 0.E0 ! ! MT=1 ! ! JT=N+1 ! ! call BNDACC(G,MDG,NB,IP,IR,MT,JT) ! !***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares ! Problems, Prentice-Hall, Inc., 1974, Chapter 27. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BNDSOL DIMENSION G(MDG,*),X(*) !***FIRST EXECUTABLE STATEMENT BNDSOL ZERO=0. ! RNORM=ZERO go to (10,90,50), MODE ! ********************* MODE = 1 ! ALG. STEP 26 10 DO 20 J=1,N X(J)=G(J,NB+1) 20 CONTINUE RSQ=ZERO NP1=N+1 IRM1=IR-1 if (NP1 > IRM1) go to 40 DO 30 J=NP1,IRM1 RSQ=RSQ+G(J,NB+1)**2 30 CONTINUE RNORM=SQRT(RSQ) 40 CONTINUE ! ********************* MODE = 3 ! ALG. STEP 27 50 DO 80 II=1,N I=N+1-II ! ALG. STEP 28 S=ZERO L=MAX(0,I-IP) ! ALG. STEP 29 if (I == N) go to 70 ! ALG. STEP 30 IE=MIN(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 ! ALG. STEP 31 70 if (G(I,L+1)) 80,130,80 80 X(I)=(X(I)-S)/G(I,L+1) ! ALG. STEP 32 return ! ********************* MODE = 2 90 DO 120 J=1,N S=ZERO if (J == 1) go to 110 I1=MAX(1,J-NB+1) I2=J-1 DO 100 I=I1,I2 L=J-I+1+MAX(0,I-IP) S=S+X(I)*G(I,L) 100 CONTINUE 110 L=MAX(0,J-IP) if (G(J,L+1)) 120,130,120 120 X(J)=(X(J)-S)/G(J,L+1) return ! 130 CONTINUE NERR=1 IOPT=2 call XERMSG ('SLATEC', 'BNDSOL', & 'A ZERO DIAGONAL TERM IS IN THE N BY N UPPER TRIANGULAR ' // & 'MATRIX.', NERR, IOPT) return end subroutine BNFAC (W, NROWW, NROW, NBANDL, NBANDU, IFLAG) ! !! BNFAC is subsidiary to BINT4 and BINTK. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BNFAC-S, DBNFAC-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! BNFAC is the BANFAC routine from ! * A Practical Guide to Splines * by C. de Boor ! ! Returns in W the lu-factorization (without pivoting) of the banded ! matrix A of order NROW with (NBANDL + 1 + NBANDU) bands or diag- ! onals in the work array W . ! ! ***** I N P U T ****** ! W.....Work array of size (NROWW,NROW) containing the interesting ! part of a banded matrix A , with the diagonals or bands of A ! stored in the rows of W , while columns of A correspond to ! columns of W . This is the storage mode used in LINPACK and ! results in efficient innermost loops. ! Explicitly, A has NBANDL bands below the diagonal ! + 1 (main) diagonal ! + NBANDU bands above the diagonal ! and thus, with MIDDLE = NBANDU + 1, ! A(I+J,J) is in W(I+MIDDLE,J) for I=-NBANDU,...,NBANDL ! J=1,...,NROW . ! For example, the interesting entries of A (1,2)-banded matrix ! of order 9 would appear in the first 1+1+2 = 4 rows of W ! as follows. ! 13243546576879 ! 1223344556677889 ! 112233445566778899 ! 2132435465768798 ! ! All other entries of W not identified in this way with an en- ! try of A are never referenced . ! NROWW.....Row dimension of the work array W . ! must be >= NBANDL + 1 + NBANDU . ! NBANDL.....Number of bands of A below the main diagonal ! NBANDU.....Number of bands of A above the main diagonal . ! ! ***** O U T P U T ****** ! IFLAG.....Integer indicating success( = 1) or failure ( = 2) . ! If IFLAG = 1, then ! W.....contains the LU-factorization of A into a unit lower triangu- ! lar matrix L and an upper triangular matrix U (both banded) ! and stored in customary fashion over the corresponding entries ! of A . This makes it possible to solve any particular linear ! system A*X = B for X by A ! call BNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B ) ! with the solution X contained in B on return . ! If IFLAG = 2, then ! one of NROW-1, NBANDL,NBANDU failed to be nonnegative, or else ! one of the potential pivots was found to be zero indicating ! that A does not have an LU-factorization. This implies that ! A is singular in case it is totally positive . ! ! ***** M E T H O D ****** ! Gauss elimination W I T H O U T pivoting is used. The routine is ! intended for use with matrices A which do not require row inter- ! changes during factorization, especially for the T O T A L L Y ! P O S I T I V E matrices which occur in spline calculations. ! The routine should not be used for an arbitrary banded matrix. ! !***SEE ALSO BINT4, BINTK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE BNFAC ! INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K, & KMAX, MIDDLE, MIDMK, NROWM1 REAL W(NROWW,*), FACTOR, PIVOT ! !***FIRST EXECUTABLE STATEMENT BNFAC IFLAG = 1 MIDDLE = NBANDU + 1 ! W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF A . NROWM1 = NROW - 1 if (NROWM1) 120, 110, 10 10 if (NBANDL > 0) go to 30 ! A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO . DO 20 I=1,NROWM1 if (W(MIDDLE,I) == 0.0E0) go to 120 20 CONTINUE go to 110 30 if (NBANDU > 0) go to 60 ! A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND ! DIVIDE EACH COLUMN BY ITS DIAGONAL . DO 50 I=1,NROWM1 PIVOT = W(MIDDLE,I) if (PIVOT == 0.0E0) go to 120 JMAX = MIN(NBANDL,NROW-I) DO 40 J=1,JMAX W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT 40 CONTINUE 50 CONTINUE return ! ! A IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION 60 DO 100 I=1,NROWM1 ! W(MIDDLE,I) IS PIVOT FOR I-TH STEP . PIVOT = W(MIDDLE,I) if (PIVOT == 0.0E0) go to 120 ! JMAX IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN I ! BELOW THE DIAGONAL . JMAX = MIN(NBANDL,NROW-I) ! DIVIDE EACH ENTRY IN COLUMN I BELOW DIAGONAL BY PIVOT . DO 70 J=1,JMAX W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT 70 CONTINUE ! KMAX IS THE NUMBER OF (NONZERO) ENTRIES IN ROW I TO ! THE RIGHT OF THE DIAGONAL . KMAX = MIN(NBANDU,NROW-I) ! SUBTRACT A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN ! (BELOW ROW I ) . DO 90 K=1,KMAX IPK = I + K MIDMK = MIDDLE - K FACTOR = W(MIDMK,IPK) DO 80 J=1,JMAX W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR 80 CONTINUE 90 CONTINUE 100 CONTINUE ! CHECK THE LAST DIAGONAL ENTRY . 110 if (W(MIDDLE,NROW) /= 0.0E0) RETURN 120 IFLAG = 2 return end subroutine BNSLV (W, NROWW, NROW, NBANDL, NBANDU, B) ! !! BNSLV is subsidiary to BINT4 and BINTK. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BNSLV-S, DBNSLV-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! BNSLV is the BANSLV routine from ! * A Practical Guide to Splines * by C. de Boor ! ! Companion routine to BNFAC . It returns the solution X of the ! linear system A*X = B in place of B , given the LU-factorization ! for A in the work array W from BNFAC. ! ! ***** I N P U T ****** ! W, NROWW,NROW,NBANDL,NBANDU.....Describe the LU-factorization of a ! banded matrix A of order NROW as constructed in BNFAC . ! For details, see BNFAC . ! B.....Right side of the system to be solved . ! ! ***** O U T P U T ****** ! B.....Contains the solution X , of order NROW . ! ! ***** M E T H O D ****** ! (With A = L*U, as stored in W,) the unit lower triangular system ! L(U*X) = B is solved for Y = U*X, and Y stored in B . Then the ! upper triangular system U*X = Y is solved for X . The calcul- ! ations are so arranged that the innermost loops stay within columns. ! !***SEE ALSO BINT4, BINTK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE BNSLV ! INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1 REAL W(NROWW,*), B(*) !***FIRST EXECUTABLE STATEMENT BNSLV MIDDLE = NBANDU + 1 if (NROW == 1) go to 80 NROWM1 = NROW - 1 if (NBANDL == 0) go to 30 ! FORWARD PASS ! FOR I=1,2,...,NROW-1, SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN ! OF L ) FROM RIGHT SIDE (BELOW I-TH ROW) . DO 20 I=1,NROWM1 JMAX = MIN(NBANDL,NROW-I) DO 10 J=1,JMAX B(I+J) = B(I+J) - B(I)*W(MIDDLE+J,I) 10 CONTINUE 20 CONTINUE ! BACKWARD PASS ! FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG- ! ONAL ENTRY OF U, THEN SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN ! OF U) FROM RIGHT SIDE (ABOVE I-TH ROW). 30 if (NBANDU > 0) go to 50 ! A IS LOWER TRIANGULAR . DO 40 I=1,NROW B(I) = B(I)/W(1,I) 40 CONTINUE return 50 I = NROW 60 B(I) = B(I)/W(MIDDLE,I) JMAX = MIN(NBANDU,I-1) DO 70 J=1,JMAX B(I-J) = B(I-J) - B(I)*W(MIDDLE-J,I) 70 CONTINUE I = I - 1 if (I > 1) go to 60 80 B(1) = B(1)/W(MIDDLE,1) return end subroutine BQR (NM, N, MB, A, T, R, IERR, NV, RV) ! !! BQR computes some of the eigenvalues of a real symmetric ... ! matrix using the QR method with shifts of origin. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A6 !***TYPE SINGLE PRECISION (BQR-S) !***KEYWORDS EIGENVALUES, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure BQR, ! NUM. MATH. 16, 85-92(1970) by Martin, Reinsch, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971). ! ! This subroutine finds the eigenvalue of smallest (usually) ! magnitude of a REAL SYMMETRIC BAND matrix using the ! QR algorithm with shifts of origin. Consecutive calls ! can be made to find further eigenvalues. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, A, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! MB is the (half) band width of the matrix, defined as the ! number of adjacent diagonals, including the principal ! diagonal, required to specify the non-zero portion of the ! lower triangle of the matrix. MB is an INTEGER variable. ! MB must be less than or equal to N on first call. ! ! A contains the lower triangle of the symmetric band input ! matrix stored as an N by MB array. Its lowest subdiagonal ! is stored in the last N+1-MB positions of the first column, ! its next subdiagonal in the last N+2-MB positions of the ! second column, further subdiagonals similarly, and finally ! its principal diagonal in the N positions of the last column. ! Contents of storages not part of the matrix are arbitrary. ! On a subsequent call, its output contents from the previous ! call should be passed. A is a two-dimensional REAL array, ! dimensioned A(NM,MB). ! ! T specifies the shift (of eigenvalues) applied to the diagonal ! of A in forming the input matrix. What is actually determined ! is the eigenvalue of A+TI (I is the identity matrix) nearest ! to T. On a subsequent call, the output value of T from the ! previous call should be passed if the next nearest eigenvalue ! is sought. T is a REAL variable. ! ! R should be specified as zero on the first call, and as its ! output value from the previous call on a subsequent call. ! It is used to determine when the last row and column of ! the transformed band matrix can be regarded as negligible. ! R is a REAL variable. ! ! NV must be set to the dimension of the array parameter RV ! as declared in the calling program dimension statement. ! NV is an INTEGER variable. ! ! On OUTPUT ! ! A contains the transformed band matrix. The matrix A+TI ! derived from the output parameters is similar to the ! input A+TI to within rounding errors. Its last row and ! column are null (if IERR is zero). ! ! T contains the computed eigenvalue of A+TI (if IERR is zero), ! where I is the identity matrix. ! ! R contains the maximum of its input value and the norm of the ! last column of the input matrix A. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after a total of 30 iterations. ! ! RV is a one-dimensional REAL array of dimension NV which is ! at least (2*MB**2+4*MB-3), used for temporary storage. The ! first (3*MB-2) locations correspond to the ALGOL array B, ! the next (2*MB-1) locations correspond to the ALGOL array H, ! and the final (2*MB**2-MB) locations correspond to the MB ! by (2*MB-1) ALGOL array U. ! ! NOTE. For a subsequent call, N should be replaced by N-1, but ! MB should not be altered even when it exceeds the current N. ! ! Calls PYTHAG(A,B) for SQRT(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! Applied Mathematics Division, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BQR ! INTEGER I,J,K,L,M,N,II,IK,JK,JM,KJ,KK,KM,LL,MB,MK,MN,MZ INTEGER M1,M2,M3,M4,NI,NM,NV,ITS,KJ1,M21,M31,IERR,IMULT REAL A(NM,*),RV(*) REAL F,G,Q,R,S,T,SCALE REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT BQR IERR = 0 M1 = MIN(MB,N) M = M1 - 1 M2 = M + M M21 = M2 + 1 M3 = M21 + M M31 = M3 + 1 M4 = M31 + M2 MN = M + N MZ = MB - M1 ITS = 0 ! .......... TEST FOR CONVERGENCE .......... 40 G = A(N,MB) if (M == 0) go to 360 F = 0.0E0 ! DO 50 K = 1, M MK = K + MZ F = F + ABS(A(N,MK)) 50 CONTINUE ! if (ITS == 0 .AND. F > R) R = F if (R + F <= R) go to 360 if (ITS == 30) go to 1000 ITS = ITS + 1 ! .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR .......... if (F > 0.25E0 * R .AND. ITS < 5) go to 90 F = A(N,MB-1) if (F == 0.0E0) go to 70 Q = (A(N-1,MB) - G) / (2.0E0 * F) S = PYTHAG(Q,1.0E0) G = G - F / (Q + SIGN(S,Q)) 70 T = T + G ! DO 80 I = 1, N 80 A(I,MB) = A(I,MB) - G ! 90 DO 100 K = M31, M4 100 RV(K) = 0.0E0 ! DO 350 II = 1, MN I = II - M NI = N - II if (NI < 0) go to 230 ! .......... FORM COLUMN OF SHIFTED MATRIX A-G*I .......... L = MAX(1,2-I) ! DO 110 K = 1, M3 110 RV(K) = 0.0E0 ! DO 120 K = L, M1 KM = K + M MK = K + MZ RV(KM) = A(II,MK) 120 CONTINUE ! LL = MIN(M,NI) if (LL == 0) go to 135 ! DO 130 K = 1, LL KM = K + M21 IK = II + K MK = MB - K RV(KM) = A(IK,MK) 130 CONTINUE ! .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .......... 135 LL = M2 IMULT = 0 ! .......... MULTIPLICATION PROCEDURE .......... 140 KJ = M4 - M1 ! DO 170 J = 1, LL KJ = KJ + M1 JM = J + M3 if (RV(JM) == 0.0E0) go to 170 F = 0.0E0 ! DO 150 K = 1, M1 KJ = KJ + 1 JK = J + K - 1 F = F + RV(KJ) * RV(JK) 150 CONTINUE ! F = F / RV(JM) KJ = KJ - M1 ! DO 160 K = 1, M1 KJ = KJ + 1 JK = J + K - 1 RV(JK) = RV(JK) - RV(KJ) * F 160 CONTINUE ! KJ = KJ - M1 170 CONTINUE ! if (IMULT /= 0) go to 280 ! .......... HOUSEHOLDER REFLECTION .......... F = RV(M21) S = 0.0E0 RV(M4) = 0.0E0 SCALE = 0.0E0 ! DO 180 K = M21, M3 180 SCALE = SCALE + ABS(RV(K)) ! if (SCALE == 0.0E0) go to 210 ! DO 190 K = M21, M3 190 S = S + (RV(K)/SCALE)**2 ! S = SCALE * SCALE * S G = -SIGN(SQRT(S),F) RV(M21) = G RV(M4) = S - F * G KJ = M4 + M2 * M1 + 1 RV(KJ) = F - G ! DO 200 K = 2, M1 KJ = KJ + 1 KM = K + M2 RV(KJ) = RV(KM) 200 CONTINUE ! .......... SAVE COLUMN OF TRIANGULAR FACTOR R .......... 210 DO 220 K = L, M1 KM = K + M MK = K + MZ A(II,MK) = RV(KM) 220 CONTINUE ! 230 L = MAX(1,M1+1-I) if (I <= 0) go to 300 ! .......... PERFORM ADDITIONAL STEPS .......... DO 240 K = 1, M21 240 RV(K) = 0.0E0 ! LL = MIN(M1,NI+M1) ! .......... GET ROW OF TRIANGULAR FACTOR R .......... DO 250 KK = 1, LL K = KK - 1 KM = K + M1 IK = I + K MK = MB - K RV(KM) = A(IK,MK) 250 CONTINUE ! .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .......... LL = M1 IMULT = 1 go to 140 ! .......... STORE COLUMN OF NEW A MATRIX .......... 280 DO 290 K = L, M1 MK = K + MZ A(I,MK) = RV(K) 290 CONTINUE ! .......... UPDATE HOUSEHOLDER REFLECTIONS .......... 300 if (L > 1) L = L - 1 KJ1 = M4 + L * M1 ! DO 320 J = L, M2 JM = J + M3 RV(JM) = RV(JM+1) ! DO 320 K = 1, M1 KJ1 = KJ1 + 1 KJ = KJ1 - M1 RV(KJ) = RV(KJ1) 320 CONTINUE ! 350 CONTINUE ! go to 40 ! .......... CONVERGENCE .......... 360 T = T + G ! DO 380 I = 1, N 380 A(I,MB) = A(I,MB) - G ! DO 400 K = 1, M1 MK = K + MZ A(N,MK) = 0.0E0 400 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO ! EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = N 1001 RETURN end subroutine BSGQ8 (FUN, XT, BC, N, KK, ID, A, B, INBV, ERR, ANS, & IERR, WORK) ! !! BSGQ8 is subsidiary to BFQAD. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BSGQ8-S, DBSGQ8-D) !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! BSGQ8, a modification of GAUS8, integrates the ! product of FUN(X) by the ID-th derivative of a spline ! BVALU(XT,BC,N,KK,ID,X,INBV,WORK) between limits A and B. ! ! Description of Arguments ! ! INPUT-- ! FUN - Name of external function of one argument which ! multiplies BVALU. ! XT - Knot array for BVALU ! BC - B-coefficient array for BVALU ! N - Number of B-coefficients for BVALU ! KK - Order of the spline, KK >= 1 ! ID - Order of the spline derivative, 0 <= ID <= KK-1 ! A - Lower limit of integral ! B - Upper limit of integral (may be less than A) ! INBV- Initialization parameter for BVALU ! ERR - Is a requested pseudorelative error tolerance. Normally ! pick a value of ABS(ERR) < 1E-3. ANS will normally ! have no more error than ABS(ERR) times the integral of ! the absolute value of FUN(X)*BVALU(XT,BC,N,KK,X,ID, ! INBV,WORK). ! ! ! OUTPUT-- ! ERR - Will be an estimate of the absolute error in ANS if the ! input value of ERR was negative. (ERR is unchanged if ! the input value of ERR was nonnegative.) The estimated ! error is solely for information to the user and should ! not be used as a correction to the computed integral. ! ANS - Computed value of integral ! IERR- A status code ! --Normal Codes ! 1 ANS most likely meets requested error tolerance, ! or A=B. ! -1 A and B are too nearly equal to allow normal ! integration. ANS is set to zero. ! --Abnormal Code ! 2 ANS probably does not meet requested error tolerance. ! WORK- Work vector of length 3*K for BVALU ! !***SEE ALSO BFQAD !***ROUTINES CALLED BVALU, I1MACH, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE BSGQ8 ! INTEGER ID, IERR, INBV, K, KK, KML, KMX, L, LMN, LMX, LR, MXL, & N, NBITS, NIB, NLMN, NLMX INTEGER I1MACH REAL A, AA, AE, ANIB, ANS, AREA, B, BC, C, CE, EE, EF, EPS, ERR, & EST,GL,GLR,GR,HH,SQ2,TOL,VL,VR,WORK,W1, W2, W3, W4, XT, X1, & X2, X3, X4, X, H REAL R1MACH, BVALU, G8, FUN DIMENSION XT(*), BC(*) DIMENSION AA(30), HH(30), LR(30), VL(30), GR(30) SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, NLMN, KMX, KML DATA X1, X2, X3, X4/ & 1.83434642495649805E-01, 5.25532409916328986E-01, & 7.96666477413626740E-01, 9.60289856497536232E-01/ DATA W1, W2, W3, W4/ & 3.62683783378361983E-01, 3.13706645877887287E-01, & 2.22381034453374471E-01, 1.01228536290376259E-01/ DATA SQ2/1.41421356E0/ DATA NLMN/1/,KMX/5000/,KML/6/ G8(X,H)=H*((W1*(FUN(X-X1*H)*BVALU(XT,BC,N,KK,ID,X-X1*H,INBV,WORK)+ & FUN(X+X1*H)*BVALU(XT,BC,N,KK,ID,X+X1*H,INBV,WORK)) & +W2*(FUN(X-X2*H)*BVALU(XT,BC,N,KK,ID,X-X2*H,INBV,WORK)+ & FUN(X+X2*H)*BVALU(XT,BC,N,KK,ID,X+X2*H,INBV,WORK))) & +(W3*(FUN(X-X3*H)*BVALU(XT,BC,N,KK,ID,X-X3*H,INBV,WORK)+ & FUN(X+X3*H)*BVALU(XT,BC,N,KK,ID,X+X3*H,INBV,WORK)) & +W4*(FUN(X-X4*H)*BVALU(XT,BC,N,KK,ID,X-X4*H,INBV,WORK)+ & FUN(X+X4*H)*BVALU(XT,BC,N,KK,ID,X+X4*H,INBV,WORK)))) ! ! INITIALIZE ! !***FIRST EXECUTABLE STATEMENT BSGQ8 K = I1MACH(11) ANIB = R1MACH(5)*K/0.30102000E0 NBITS = INT(ANIB) NLMX = (NBITS*5)/8 ANS = 0.0E0 IERR = 1 CE = 0.0E0 if (A == B) go to 140 LMX = NLMX LMN = NLMN if (B == 0.0E0) go to 10 if (SIGN(1.0E0,B)*A <= 0.0E0) go to 10 C = ABS(1.0E0-A/B) if (C > 0.1E0) go to 10 if (C <= 0.0E0) go to 140 ANIB = 0.5E0 - LOG(C)/0.69314718E0 NIB = INT(ANIB) LMX = MIN(NLMX,NBITS-NIB-7) if (LMX < 1) go to 130 LMN = MIN(LMN,LMX) 10 TOL = MAX(ABS(ERR),2.0E0**(5-NBITS))/2.0E0 if (ERR == 0.0E0) TOL = SQRT(R1MACH(4)) EPS = TOL HH(1) = (B-A)/4.0E0 AA(1) = A LR(1) = 1 L = 1 EST = G8(AA(L)+2.0E0*HH(L),2.0E0*HH(L)) K = 8 AREA = ABS(EST) EF = 0.5E0 MXL = 0 ! ! COMPUTE REFINED ESTIMATES, ESTIMATE THE ERROR, ETC. ! 20 GL = G8(AA(L)+HH(L),HH(L)) GR(L) = G8(AA(L)+3.0E0*HH(L),HH(L)) K = K + 16 AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) GLR = GL + GR(L) EE = ABS(EST-GLR)*EF AE = MAX(EPS*AREA,TOL*ABS(GLR)) if (EE-AE) 40, 40, 50 30 MXL = 1 40 CE = CE + (EST-GLR) if (LR(L)) 60, 60, 80 ! ! CONSIDER THE LEFT HALF OF THIS LEVEL ! 50 if (K > KMX) LMX = KML if (L >= LMX) go to 30 L = L + 1 EPS = EPS*0.5E0 EF = EF/SQ2 HH(L) = HH(L-1)*0.5E0 LR(L) = -1 AA(L) = AA(L-1) EST = GL go to 20 ! ! PROCEED TO RIGHT HALF AT THIS LEVEL ! 60 VL(L) = GLR 70 EST = GR(L-1) LR(L) = 1 AA(L) = AA(L) + 4.0E0*HH(L) go to 20 ! ! return ONE LEVEL ! 80 VR = GLR 90 if (L <= 1) go to 120 L = L - 1 EPS = EPS*2.0E0 EF = EF*SQ2 if (LR(L)) 100, 100, 110 100 VL(L) = VL(L+1) + VR go to 70 110 VR = VL(L+1) + VR go to 90 ! ! EXIT ! 120 ANS = VR if ((MXL == 0) .OR. (ABS(CE) <= 2.0E0*TOL*AREA)) go to 140 IERR = 2 call XERMSG ('SLATEC', 'BSGQ8', & 'ANS IS PROBABLY INSUFFICIENTLY ACCURATE.', 3, 1) go to 140 130 IERR = -1 call XERMSG ('SLATEC', 'BSGQ8', & 'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL INTEGRATION. ' // & ' ANS IS SET TO ZERO AND IERR TO -1.', 1, -1) 140 CONTINUE if (ERR < 0.0E0) ERR = CE return end subroutine BSKIN (X, N, KODE, M, Y, NZ, IERR) ! !! BSKIN computes repeated integrals of the K-zero Bessel function. ! !***LIBRARY SLATEC !***CATEGORY C10F !***TYPE SINGLE PRECISION (BSKIN-S, DBSKIN-D) !***KEYWORDS BICKLEY FUNCTIONS, EXPONENTIAL INTEGRAL, ! INTEGRALS OF BESSEL FUNCTIONS, K-ZERO BESSEL FUNCTION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! The following definitions are used in BSKIN: ! ! Definition 1 ! KI(0,X) = K-zero Bessel function. ! ! Definition 2 ! KI(N,X) = Bickley Function ! = integral from X to infinity of KI(N-1,t)dt ! for X .ge. 0 and N = 1,2,... ! ____________________________________________________________________ ! BSKIN computes sequences of Bickley functions (repeated integrals ! of the K0 Bessel function); i.e. for fixed X and N and K=1,..., ! BSKIN computes the M-member sequence ! ! Y(K) = KI(N+K-1,X) for KODE=1 ! or ! Y(K) = EXP(X)*KI(N+K-1,X) for KODE=2, ! ! for N.ge.0 and X.ge.0 (N and X cannot be zero simultaneously). ! ! INPUT ! X - Argument, X .ge. 0.0E0 ! N - Order of first member of the sequence N .ge. 0 ! KODE - Selection parameter ! KODE = 1 returns Y(K)= KI(N+K-1,X), K=1,M ! = 2 returns Y(K)=EXP(X)*KI(N+K-1,X), K=1,M ! M - Number of members in the sequence, M.ge.1 ! ! OUTPUT ! Y - A vector of dimension at least M containing the ! sequence selected by KODE. ! NZ - Underflow flag ! NZ = 0 means computation completed ! = M means an exponential underflow occurred on ! KODE=1. Y(K)=0.0E0, K=1,...,M is returned ! IERR - Error flag ! IERR = 0, Normal return, computation completed. ! = 1, Input error, no computation. ! = 2, Error, no computation. The ! termination condition was not met. ! ! The nominal computational accuracy is the maximum of unit ! roundoff (=R1MACH(4)) and 1.0e-18 since critical constants ! are given to only 18 digits. ! ! DBSKIN is the double precision version of BSKIN. ! ! *Long Description: ! ! Numerical recurrence on ! ! (L-1)*KI(L,X) = X(KI(L-3,X) - KI(L-1,X)) + (L-2)*KI(L-2,X) ! ! is stable where recurrence is carried forward or backward ! away from INT(X+0.5). The power series for indices 0,1 and 2 ! on 0.le.X.le. 2 starts a stable recurrence for indices ! greater than 2. If N is sufficiently large (N.gt.NLIM), the ! uniform asymptotic expansion for N to INFINITY is more ! economical. On X.gt.2 the recursion is started by evaluating ! the uniform expansion for the three members whose indices are ! closest to INT(X+0.5) within the set N,...,N+M-1. Forward ! recurrence, backward recurrence or both, complete the ! sequence depending on the relation of INT(X+0.5) to the ! indices N,...,N+M-1. ! !***REFERENCES D. E. Amos, Uniform asymptotic expansions for ! exponential integrals E(N,X) and Bickley functions ! KI(N,X), ACM Transactions on Mathematical Software, ! 1983. ! D. E. Amos, A portable Fortran subroutine for the ! Bickley functions KI(N,X), Algorithm 609, ACM ! Transactions on Mathematical Software, 1983. !***ROUTINES CALLED BKIAS, BKISR, EXINT, GAMRN, I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced statement label. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BSKIN INTEGER I, ICASE, IERR, IL, I1M, K, KK, KODE, KTRMS, M, & M3, N, NE, NFLG, NL, NLIM, NN, NP, NS, NT, NZ INTEGER I1MACH REAL A, ENLIM, EXI, FN, GR, H, HN, HRTPI, SS, TOL, T1, T2, W, X, & XLIM, XNLIM, XP, Y, YS, YSS REAL GAMRN, R1MACH DIMENSION EXI(102), A(50), YS(3), YSS(3), H(31), Y(*) SAVE A, HRTPI !----------------------------------------------------------------------- ! COEFFICIENTS IN SERIES OF EXPONENTIAL INTEGRALS !----------------------------------------------------------------------- DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), A(8), A(9), A(10), & A(11), A(12), A(13), A(14), A(15), A(16), A(17), A(18), A(19), & A(20), A(21), A(22), A(23), A(24) /1.00000000000000000E+00, & 5.00000000000000000E-01,3.75000000000000000E-01, & 3.12500000000000000E-01,2.73437500000000000E-01, & 2.46093750000000000E-01,2.25585937500000000E-01, & 2.09472656250000000E-01,1.96380615234375000E-01, & 1.85470581054687500E-01,1.76197052001953125E-01, & 1.68188095092773438E-01,1.61180257797241211E-01, & 1.54981017112731934E-01,1.49445980787277222E-01, & 1.44464448094367981E-01,1.39949934091418982E-01, & 1.35833759559318423E-01,1.32060599571559578E-01, & 1.28585320635465905E-01,1.25370687619579257E-01, & 1.22385671247684513E-01,1.19604178719328047E-01, & 1.17004087877603524E-01/ DATA A(25), A(26), A(27), A(28), A(29), A(30), A(31), A(32), & A(33), A(34), A(35), A(36), A(37), A(38), A(39), A(40), A(41), & A(42), A(43), A(44), A(45), A(46), A(47), A(48) & /1.14566502713486784E-01,1.12275172659217048E-01, & 1.10116034723462874E-01,1.08076848895250599E-01, & 1.06146905164978267E-01,1.04316786110409676E-01, & 1.02578173008569515E-01,1.00923686347140974E-01, & 9.93467537479668965E-02,9.78414999033007314E-02, & 9.64026543164874854E-02,9.50254735405376642E-02, & 9.37056752969190855E-02,9.24393823875012600E-02, & 9.12230747245078224E-02,9.00535481254756708E-02, & 8.89278787739072249E-02,8.78433924473961612E-02, & 8.67976377754033498E-02,8.57883629175498224E-02, & 8.48134951571231199E-02,8.38711229887106408E-02, & 8.29594803475290034E-02,8.20769326842574183E-02/ DATA A(49), A(50) /8.12219646354630702E-02,8.03931690779583449E-02 & / !----------------------------------------------------------------------- ! SQRT(PI)/2 !----------------------------------------------------------------------- DATA HRTPI /8.86226925452758014E-01/ ! !***FIRST EXECUTABLE STATEMENT BSKIN IERR = 0 NZ=0 if (X < 0.0E0) IERR=1 if (N < 0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (M < 1) IERR=1 if (X == 0.0E0 .AND. N == 0) IERR=1 if (IERR /= 0) RETURN if (X == 0.0E0) go to 300 I1M = -I1MACH(12) T1 = 2.3026E0*R1MACH(5)*I1M XLIM = T1 - 3.228086E0 T2 = T1 + N + M - 1 if (T2 > 1000.0E0) XLIM = T1 - 0.5E0*(LOG(T2)-0.451583E0) if (X > XLIM .AND. KODE == 1) go to 320 TOL = MAX(R1MACH(4),1.0E-18) I1M = I1MACH(11) !----------------------------------------------------------------------- ! LN(NLIM) = 0.125*LN(EPS), NLIM = 2*KTRMS+N !----------------------------------------------------------------------- XNLIM = 0.287823E0*(I1M-1)*R1MACH(5) ENLIM = EXP(XNLIM) NLIM = INT(ENLIM) + 2 NLIM = MIN(100,NLIM) NLIM = MAX(20,NLIM) M3 = MIN(M,3) NL = N + M - 1 if (X > 2.0E0) go to 130 if (N > NLIM) go to 280 !----------------------------------------------------------------------- ! COMPUTATION BY SERIES FOR 0 <= X <= 2 !----------------------------------------------------------------------- NFLG = 0 NN = N if (NL <= 2) go to 60 M3 = 3 NN = 0 NFLG = 1 60 CONTINUE XP = 1.0E0 if (KODE == 2) XP = EXP(X) DO 80 I=1,M3 call BKISR(X, NN, W, IERR) if ( IERR /= 0) RETURN W = W*XP if (NN < N) go to 70 KK = NN - N + 1 Y(KK) = W 70 CONTINUE YS(I) = W NN = NN + 1 80 CONTINUE if (NFLG == 0) RETURN NS = NN XP = 1.0E0 90 CONTINUE !----------------------------------------------------------------------- ! FORWARD RECURSION SCALED BY EXP(X) ON ICASE=0,1,2 !----------------------------------------------------------------------- FN = NS - 1 IL = NL - NS + 1 if (IL <= 0) RETURN DO 110 I=1,IL T1 = YS(2) T2 = YS(3) YS(3) = (X*(YS(1)-YS(3))+(FN-1.0E0)*YS(2))/FN YS(2) = T2 YS(1) = T1 FN = FN + 1.0E0 if (NS < N) go to 100 KK = NS - N + 1 Y(KK) = YS(3)*XP 100 CONTINUE NS = NS + 1 110 CONTINUE return !----------------------------------------------------------------------- ! COMPUTATION BY ASYMPTOTIC EXPANSION FOR X > 2 !----------------------------------------------------------------------- 130 CONTINUE W = X + 0.5E0 NT = INT(W) if (NL > NT) go to 270 !----------------------------------------------------------------------- ! CASE NL <= NT, ICASE=0 !----------------------------------------------------------------------- ICASE = 0 NN = NL NFLG = MIN(M-M3,1) 140 CONTINUE KK = (NLIM-NN)/2 KTRMS = MAX(0,KK) NS = NN + 1 NP = NN - M3 + 1 XP = 1.0E0 if (KODE == 1) XP = EXP(-X) DO 150 I=1,M3 KK = I call BKIAS(X, NP, KTRMS, A, W, KK, NE, GR, H, IERR) if ( IERR /= 0) RETURN YS(I) = W NP = NP + 1 150 CONTINUE !----------------------------------------------------------------------- ! SUM SERIES OF EXPONENTIAL INTEGRALS BACKWARD !----------------------------------------------------------------------- if (KTRMS == 0) go to 160 NE = KTRMS + KTRMS + 1 NP = NN - M3 + 2 call EXINT(X, NP, 2, NE, TOL, EXI, NZ, IERR) if ( NZ /= 0) go to 320 if ( IERR == 2) RETURN 160 CONTINUE DO 190 I=1,M3 SS = 0.0E0 if (KTRMS == 0) go to 180 KK = I + KTRMS + KTRMS - 2 IL = KTRMS DO 170 K=1,KTRMS SS = SS + A(IL)*EXI(KK) KK = KK - 2 IL = IL - 1 170 CONTINUE 180 CONTINUE YS(I) = YS(I) + SS 190 CONTINUE if (ICASE == 1) go to 200 if (NFLG /= 0) go to 220 200 CONTINUE DO 210 I=1,M3 Y(I) = YS(I)*XP 210 CONTINUE if (ICASE == 1 .AND. NFLG == 1) go to 90 return 220 CONTINUE !----------------------------------------------------------------------- ! BACKWARD RECURSION SCALED BY EXP(X) ICASE=0,2 !----------------------------------------------------------------------- KK = NN - N + 1 K = M3 DO 230 I=1,M3 Y(KK) = YS(K)*XP YSS(I) = YS(I) KK = KK - 1 K = K - 1 230 CONTINUE IL = KK if (IL <= 0) go to 250 FN = NN - 3 DO 240 I=1,IL T1 = YS(2) T2 = YS(1) YS(1) = YS(2) + ((FN+2.0E0)*YS(3)-(FN+1.0E0)*YS(1))/X YS(2) = T2 YS(3) = T1 Y(KK) = YS(1)*XP KK = KK - 1 FN = FN - 1.0E0 240 CONTINUE 250 CONTINUE if (ICASE /= 2) RETURN DO 260 I=1,M3 YS(I) = YSS(I) 260 CONTINUE go to 90 270 CONTINUE if (N < NT) go to 290 !----------------------------------------------------------------------- ! ICASE=1, NT <= N <= NL WITH FORWARD RECURSION !----------------------------------------------------------------------- 280 CONTINUE NN = N + M3 - 1 NFLG = MIN(M-M3,1) ICASE = 1 go to 140 !----------------------------------------------------------------------- ! ICASE=2, N < NT < NL WITH BOTH FORWARD AND BACKWARD RECURSION !----------------------------------------------------------------------- 290 CONTINUE NN = NT + 1 NFLG = MIN(M-M3,1) ICASE = 2 go to 140 !----------------------------------------------------------------------- ! X=0 CASE !----------------------------------------------------------------------- 300 CONTINUE FN = N HN = 0.5E0*FN GR = GAMRN(HN) Y(1) = HRTPI*GR if (M == 1) RETURN Y(2) = HRTPI/(HN*GR) if (M == 2) RETURN DO 310 K=3,M Y(K) = FN*Y(K-2)/(FN+1.0E0) FN = FN + 1.0E0 310 CONTINUE return !----------------------------------------------------------------------- ! UNDERFLOW ON KODE=1, X > XLIM !----------------------------------------------------------------------- 320 CONTINUE NZ=M DO 330 I=1,M Y(I) = 0.0E0 330 CONTINUE return end subroutine BSPDOC ! !! BSPDOC is documentation for BSPLINE, a package of subprograms for ... ! working with piecewise polynomial functions in B-representation. ! !***LIBRARY SLATEC !***CATEGORY E, E1A, K, Z !***TYPE ALL (BSPDOC-A) !***KEYWORDS B-SPLINE, DOCUMENTATION, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! BSPDOC is a non-executable, B-spline documentary routine. ! The narrative describes a B-spline and the routines ! necessary to manipulate B-splines at a fairly high level. ! The basic package described herein is that of reference ! 5 with names altered to prevent duplication and conflicts ! with routines from reference 3. The call lists used here ! are also different. Work vectors were added to ensure ! portability and proper execution in an overlay environ- ! ment. These work arrays can be used for other purposes ! except as noted in BSPVN. While most of the original ! routines in reference 5 were restricted to orders 20 ! or less, this restriction was removed from all routines ! except the quadrature routine BSQAD. (See the section ! below on differentiation and integration for details.) ! ! The subroutines referenced below are single precision ! routines. Corresponding double precision versions are also ! part of the package, and these are referenced by prefixing ! a D in front of the single precision name. For example, ! BVALU and DBVALU are the single and double precision ! versions for evaluating a B-spline or any of its deriva- ! tives in the B-representation. ! ! ****Description of B-Splines**** ! ! A collection of polynomials of fixed degree K-1 defined on a ! subdivision (X(I),X(I+1)), I=1,...,M-1 of (A,B) with X(1)=A, ! X(M)=B is called a B-spline of order K. If the spline has K-2 ! continuous derivatives on (A,B), then the B-spline is simply ! called a spline of order K. Each of the M-1 polynomial pieces ! has K coefficients, making a total of K(M-1) parameters. This ! B-spline and its derivatives have M-2 jumps at the subdivision ! points X(I), I=2,...,M-1. Continuity requirements at these ! subdivision points add constraints and reduce the number of free ! parameters. If a B-spline is continuous at each of the M-2 sub- ! division points, there are K(M-1)-(M-2) free parameters; if in ! addition the B-spline has continuous first derivatives, there ! are K(M-1)-2(M-2) free parameters, etc., until we get to a ! spline where we have K(M-1)-(K-1)(M-2) = M+K-2 free parameters. ! Thus, the principle is that increasing the continuity of ! derivatives decreases the number of free parameters and ! conversely. ! ! The points at which the polynomials are tied together by the ! continuity conditions are called knots. If two knots are ! allowed to come together at some X(I), then we say that we ! have a knot of multiplicity 2 there, and the knot values are ! the X(I) value. If we reverse the procedure of the first ! paragraph, we find that adding a knot to increase multiplicity ! increases the number of free parameters and, according to the ! principle above, we thereby introduce a discontinuity in what ! was the highest continuous derivative at that knot. Thus, the ! number of free parameters is N = NU+K-2 where NU is the sum ! of multiplicities at the X(I) values with X(1) and X(M) of ! multiplicity 1 (NU = M if all knots are simple, i.e., for a ! spline, all knots have multiplicity 1.) Each knot can have a ! multiplicity of at most K. A B-spline is commonly written in the ! B-representation ! ! Y(X) = sum( A(I)*B(I,X), I=1 , N) ! ! to show the explicit dependence of the spline on the free ! parameters or coefficients A(I)=BCOEF(I) and basis functions ! B(I,X). These basis functions are themselves special B-splines ! which are zero except on (at most) K adjoining intervals where ! each B(I,X) is positive and, in most cases, hat or bell- ! shaped. In order for the nonzero part of B(1,X) to be a spline ! covering (X(1),X(2)), it is necessary to put K-1 knots to the ! left of A and similarly for B(N,X) to the right of B. Thus, the ! total number of knots for this representation is NU+2K-2 = N+K. ! These knots are carried in an array T(*) dimensioned by at least ! N+K. From the construction, A=T(K) and B=T(N+1) and the spline is ! defined on T(K) <= X <= T(N+1). The nonzero part of each basis ! function lies in the Interval (T(I),T(I+K)). In many problems ! where extrapolation beyond A or B is not anticipated, it is common ! practice to set T(1)=T(2)=...=T(K)=A and T(N+1)=T(N+2)=...= ! T(N+K)=B. In summary, since T(K) and T(N+1) as well as ! interior knots can have multiplicity K, the number of free ! parameters N = sum of multiplicities - K. The fact that each ! B(I,X) function is nonzero over at most K intervals means that ! for a given X value, there are at most K nonzero terms of the ! sum. This leads to banded matrices in linear algebra problems, ! and references 3 and 6 take advantage of this in con- ! structing higher level routines to achieve speed and avoid ! ill-conditioning. ! ! ****Basic Routines**** ! ! The basic routines which most casual users will need are those ! concerned with direct evaluation of splines or B-splines. ! Since the B-representation, denoted by (T,BCOEF,N,K), is ! preferred because of numerical stability, the knots T(*), the ! B-spline coefficients BCOEF(*), the number of coefficients N, ! and the order K of the polynomial pieces (of degree K-1) are ! usually given. While the knot array runs from T(1) to T(N+K), ! the B-spline is normally defined on the interval T(K) <= X <= ! T(N+1). To evaluate the B-spline or any of its derivatives ! on this interval, one can use ! ! Y = BVALU(T,BCOEF,N,K,ID,X,INBV,WORK) ! ! where ID is an integer for the ID-th derivative, 0 <= ID <= K-1. ! ID=0 gives the zero-th derivative or B-spline value at X. ! If X < T(K) or X > T(N+1), whether by mistake or the result ! of round off accumulation in incrementing X, BVALU gives a ! diagnostic. INBV is an initialization parameter which is set ! to 1 on the first call. Distinct splines require distinct ! INBV parameters. WORK is a scratch vector of length at least ! 3*K. ! ! When more conventional communication is needed for publication, ! physical interpretation, etc., the B-spline coefficients can ! be converted to piecewise polynomial (PP) coefficients. Thus, ! the breakpoints (distinct knots) XI(*), the number of ! polynomial pieces LXI, and the (right) derivatives C(*,J) at ! each breakpoint XI(J) are needed to define the Taylor ! expansion to the right of XI(J) on each interval XI(J) <= ! X < XI(J+1), J=1,LXI where XI(1)=A and XI(LXI+1)=B. ! These are obtained from the (T,BCOEF,N,K) representation by ! ! call BSPPP(T,BCOEF,N,K,LDC,C,XI,LXI,WORK) ! ! where LDC >= K is the leading dimension of the matrix C and ! WORK is a scratch vector of length at least K*(N+3). ! Then the PP-representation (C,XI,LXI,K) of Y(X), denoted ! by Y(J,X) on each interval XI(J) <= X < XI(J+1), is ! ! Y(J,X) = sum( C(I,J)*((X-XI(J))**(I-1))/factorial(I-1), I=1,K) ! ! for J=1,...,LXI. One must view this conversion from the B- ! to the PP-representation with some skepticism because the ! conversion may lose significant digits when the B-spline ! varies in an almost discontinuous fashion. To evaluate ! the B-spline or any of its derivatives using the PP- ! representation, one uses ! ! Y = PPVAL(LDC,C,XI,LXI,K,ID,X,INPPV) ! ! where ID and INPPV have the same meaning and usage as ID and ! INBV in BVALU. ! ! To determine to what extent the conversion process loses ! digits, compute the relative error ABS((Y1-Y2)/Y2) over ! the X interval with Y1 from PPVAL and Y2 from BVALU. A ! major reason for considering PPVAL is that evaluation is ! much faster than that from BVALU. ! ! Recall that when multiple knots are encountered, jump type ! discontinuities in the B-spline or its derivatives occur ! at these knots, and we need to know that BVALU and PPVAL ! return right limiting values at these knots except at ! X=B where left limiting values are returned. These values ! are used for the Taylor expansions about left end points of ! breakpoint intervals. That is, the derivatives C(*,J) are ! right derivatives. Note also that a computed X value which, ! mathematically, would be a knot value may differ from the knot ! by a round off error. When this happens in evaluating a dis- ! continuous B-spline or some discontinuous derivative, the ! value at the knot and the value at X can be radically ! different. In this case, setting X to a T or XI value makes ! the computation precise. For left limiting values at knots ! other than X=B, see the prologues to BVALU and other ! routines. ! ! ****Interpolation**** ! ! BINTK is used to generate B-spline parameters (T,BCOEF,N,K) ! which will interpolate the data by calls to BVALU. A similar ! interpolation can also be done for cubic splines using BINT4 ! or the code in reference 7. If the PP-representation is given, ! one can evaluate this representation at an appropriate number of ! abscissas to create data then use BINTK or BINT4 to generate ! the B-representation. ! ! ****Differentiation and Integration**** ! ! Derivatives of B-splines are obtained from BVALU or PPVAL. ! Integrals are obtained from BSQAD using the B-representation ! (T,BCOEF,N,K) and PPQAD using the PP-representation (C,XI,LXI, ! K). More complicated integrals involving the product of a ! of a function F and some derivative of a B-spline can be ! evaluated with BFQAD or PFQAD using the B- or PP- represen- ! tations respectively. All quadrature routines, except for PPQAD, ! are limited in accuracy to 18 digits or working precision, ! whichever is smaller. PPQAD is limited to working precision ! only. In addition, the order K for BSQAD is limited to 20 or ! less. If orders greater than 20 are required, use BFQAD with ! F(X) = 1. ! ! ****Extrapolation**** ! ! Extrapolation outside the interval (A,B) can be accomplished ! easily by the PP-representation using PPVAL. However, ! caution should be exercised, especially when several knots ! are located at A or B or when the extrapolation is carried ! significantly beyond A or B. On the other hand, direct ! evaluation with BVALU outside A=T(K) <= X <= T(N+1)=B ! produces an error message, and some manipulation of the knots ! and coefficients are needed to extrapolate with BVALU. This ! process is described in reference 6. ! ! ****Curve Fitting and Smoothing**** ! ! Unless one has many accurate data points, direct inter- ! polation is not recommended for summarizing data. The ! results are often not in accordance with intuition since the ! fitted curve tends to oscillate through the set of points. ! Monotone splines (reference 7) can help curb this undulating ! tendency but constrained least squares is more likely to give an ! acceptable fit with fewer parameters. Subroutine FC, des- ! cribed in reference 6, is recommended for this purpose. The ! output from this fitting process is the B-representation. ! ! **** Routines in the B-Spline Package **** ! ! Single Precision Routines ! ! The subroutines referenced below are SINGLE PRECISION ! routines. Corresponding DOUBLE PRECISION versions are also ! part of the package and these are referenced by prefixing ! a D in front of the single precision name. For example, ! BVALU and DBVALU are the SINGLE and DOUBLE PRECISION ! versions for evaluating a B-spline or any of its deriva- ! tives in the B-representation. ! ! BINT4 - interpolates with splines of order 4 ! BINTK - interpolates with splines of order k ! BSQAD - integrates the B-representation on subintervals ! PPQAD - integrates the PP-representation ! BFQAD - integrates the product of a function F and any spline ! derivative in the B-representation ! PFQAD - integrates the product of a function F and any spline ! derivative in the PP-representation ! BVALU - evaluates the B-representation or a derivative ! PPVAL - evaluates the PP-representation or a derivative ! INTRV - gets the largest index of the knot to the left of x ! BSPPP - converts from B- to PP-representation ! BSPVD - computes nonzero basis functions and derivatives at x ! BSPDR - sets up difference array for BSPEV ! BSPEV - evaluates the B-representation and derivatives ! BSPVN - called by BSPEV, BSPVD, BSPPP and BINTK for function and ! derivative evaluations ! Auxiliary Routines ! ! BSGQ8,PPGQ8,BNSLV,BNFAC,XERMSG,DBSGQ8,DPPGQ8,DBNSLV,DBNFAC ! ! Machine Dependent Routines ! ! I1MACH, R1MACH, D1MACH ! !***REFERENCES 1. D. E. Amos, Computation with splines and ! B-splines, Report SAND78-1968, Sandia ! Laboratories, March 1979. ! 2. D. E. Amos, Quadrature subroutines for splines and ! B-splines, Report SAND79-1825, Sandia Laboratories, ! December 1979. ! 3. Carl de Boor, A Practical Guide to Splines, Applied ! Mathematics Series 27, Springer-Verlag, New York, ! 1978. ! 4. Carl de Boor, On calculating with B-Splines, Journal ! of Approximation Theory 6, (1972), pp. 50-62. ! 5. Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. ! 6. R. J. Hanson, Constrained least squares curve fitting ! to discrete data using B-splines, a users guide, ! Report SAND78-1291, Sandia Laboratories, December ! 1978. ! 7. F. N. Fritsch and R. E. Carlson, Monotone piecewise ! cubic interpolation, SIAM Journal on Numerical Ana- ! lysis 17, 2 (April 1980), pp. 238-246. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810223 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900723 PURPOSE section revised. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BSPDOC !***FIRST EXECUTABLE STATEMENT BSPDOC return end subroutine BSPDR (T, A, N, K, NDERIV, AD) ! !! BSPDR uses the B-representation to construct a divided difference ! table preparatory to a (right) derivative calculation. ! !***LIBRARY SLATEC !***CATEGORY E3 !***TYPE SINGLE PRECISION (BSPDR-S, DBSPDR-D) !***KEYWORDS B-SPLINE, DATA FITTING, DIFFERENTIATION OF SPLINES, ! INTERPOLATION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract ! BSPDR is the BSPLDR routine of the reference. ! ! BSPDR uses the B-representation (T,A,N,K) to construct a ! divided difference table ADIF preparatory to a (right) ! derivative calculation in BSPEV. The lower triangular matrix ! ADIF is stored in vector AD by columns. The arrays are ! related by ! ! ADIF(I,J) = AD(I-J+1 + (2*N-J+2)*(J-1)/2) ! ! I = J,N , J = 1,NDERIV . ! ! Description of Arguments ! Input ! T - knot vector of length N+K ! A - B-spline coefficient vector of length N ! N - number of B-spline coefficients ! N = sum of knot multiplicities-K ! K - order of the spline, K >= 1 ! NDERIV - number of derivatives, 1 <= NDERIV <= K. ! NDERIV=1 gives the zero-th derivative = function ! value ! ! Output ! AD - table of differences in a vector of length ! (2*N-NDERIV+1)*NDERIV/2 for input to BSPEV ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BSPDR ! INTEGER I, ID, II, IPKMID, JJ, JM, K, KMID, N, NDERIV REAL A, AD, DIFF, FKMID, T ! DIMENSION T(N+K), AD((2*N-NDERIV+1)*NDERIV/2) DIMENSION T(*), A(*), AD(*) !***FIRST EXECUTABLE STATEMENT BSPDR if ( K < 1) go to 100 if ( N < K) go to 105 if ( NDERIV < 1 .OR. NDERIV > K) go to 110 DO 10 I=1,N AD(I) = A(I) 10 CONTINUE if (NDERIV == 1) RETURN KMID = K JJ = N JM = 0 DO 30 ID=2,NDERIV KMID = KMID - 1 FKMID = KMID II = 1 DO 20 I=ID,N IPKMID = I + KMID DIFF = T(IPKMID) - T(I) if (DIFF /= 0.0E0) AD(II+JJ) = (AD(II+JM+1)-AD(II+JM))/ & DIFF*FKMID II = II + 1 20 CONTINUE JM = JJ JJ = JJ + N - ID + 1 30 CONTINUE return ! ! 100 CONTINUE call XERMSG ('SLATEC', 'BSPDR', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'BSPDR', 'N DOES NOT SATISFY N >= K', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'BSPDR', & 'NDERIV DOES NOT SATISFY 1 <= NDERIV <= K', 2, 1) return end subroutine BSPEV (T, AD, N, K, NDERIV, X, INEV, SVALUE, WORK) ! !! BSPEV calculates the value of the spline and its derivatives from ! the B-representation. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE SINGLE PRECISION (BSPEV-S, DBSPEV-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract ! BSPEV is the BSPLEV routine of the reference. ! ! BSPEV calculates the value of the spline and its derivatives ! at X from the B-representation (T,A,N,K) and returns them ! in SVALUE(I),I=1,NDERIV, T(K) <= X <= T(N+1). AD(I) can ! be the B-spline coefficients A(I), I=1,N if NDERIV=1. Other- ! wise AD must be computed before hand by a call to BSPDR (T,A, ! N,K,NDERIV,AD). If X=T(I),I=K,N, right limiting values are ! obtained. ! ! To compute left derivatives or left limiting values at a ! knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1. ! ! BSPEV calls INTRV, BSPVN ! ! Description of Arguments ! Input ! T - knot vector of length N+K ! AD - vector of length (2*N-NDERIV+1)*NDERIV/2 containing ! the difference table from BSPDR. ! N - number of B-spline coefficients ! N = sum of knot multiplicities-K ! K - order of the B-spline, K >= 1 ! NDERIV - number of derivatives, 1 <= NDERIV <= K. ! NDERIV=1 gives the zero-th derivative = function ! value ! X - argument, T(K) <= X <= T(N+1) ! INEV - an initialization parameter which must be set ! to 1 the first time BSPEV is called. ! ! Output ! INEV - INEV contains information for efficient process- ! ing after the initial call and INEV must not ! be changed by the user. Distinct splines require ! distinct INEV parameters. ! SVALUE - vector of length NDERIV containing the spline ! value in SVALUE(1) and the NDERIV-1 derivatives ! in the remaining components. ! WORK - work vector of length 3*K ! ! Error Conditions ! Improper input is a fatal error. ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED BSPVN, INTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BSPEV ! INTEGER I,ID,INEV,IWORK,JJ,K,KP1,KP1MN,L,LEFT,LL,MFLAG, & N, NDERIV REAL AD, SVALUE, SUM, T, WORK, X ! DIMENSION T(N+K) DIMENSION T(*), AD(*), SVALUE(*), WORK(*) !***FIRST EXECUTABLE STATEMENT BSPEV if ( K < 1) go to 100 if ( N < K) go to 105 if ( NDERIV < 1 .OR. NDERIV > K) go to 115 ID = NDERIV call INTRV(T, N+1, X, INEV, I, MFLAG) if (X < T(K)) go to 110 if (MFLAG == 0) go to 30 if (X > T(I)) go to 110 20 if (I == K) go to 120 I = I - 1 if (X == T(I)) go to 20 ! ! *I* HAS BEEN FOUND IN (K,N) SO THAT T(I) <= X < T(I+1) ! (OR <= T(I+1), if T(I) < T(I+1) = T(N+1) ). 30 KP1MN = K + 1 - ID KP1 = K + 1 call BSPVN(T, KP1MN, K, 1, X, I, WORK(1),WORK(KP1),IWORK) JJ = (N+N-ID+2)*(ID-1)/2 ! ADIF(LEFTPL,ID) = AD(LEFTPL-ID+1 + (2*N-ID+2)*(ID-1)/2) ! LEFTPL = LEFT + L 40 LEFT = I - KP1MN SUM = 0.0E0 LL = LEFT + JJ + 2 - ID DO 50 L=1,KP1MN SUM = SUM + WORK(L)*AD(LL) LL = LL + 1 50 CONTINUE SVALUE(ID) = SUM ID = ID - 1 if (ID == 0) go to 60 JJ = JJ-(N-ID+1) KP1MN = KP1MN + 1 call BSPVN(T, KP1MN, K, 2, X, I, WORK(1), WORK(KP1),IWORK) go to 40 ! 60 RETURN ! ! 100 CONTINUE call XERMSG ('SLATEC', 'BSPEV', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'BSPEV', 'N DOES NOT SATISFY N >= K', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'BSPEV', 'X IS NOT IN T(K) <= X <= T(N+1)' & , 2, 1) return 115 CONTINUE call XERMSG ('SLATEC', 'BSPEV', & 'NDERIV DOES NOT SATISFY 1 <= NDERIV <= K', 2, 1) return 120 CONTINUE call XERMSG ('SLATEC', 'BSPEV', & 'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1) return end subroutine BSPLVD (T, K, X, ILEFT, VNIKX, NDERIV) ! !! BSPLVD is subsidiary to FC. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BSPLVD-S, DFSPVD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Calculates value and deriv.s of all B-splines which do not vanish at X ! ! Fill VNIKX(J,IDERIV), J=IDERIV, ... ,K with nonzero values of ! B-splines of order K+1-IDERIV , IDERIV=NDERIV, ... ,1, by repeated ! calls to BSPLVN ! !***SEE ALSO FC !***ROUTINES CALLED BSPLVN !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE BSPLVD DIMENSION T(*),VNIKX(K,*) DIMENSION A(20,20) !***FIRST EXECUTABLE STATEMENT BSPLVD call BSPLVN(T,K+1-NDERIV,1,X,ILEFT,VNIKX(NDERIV,NDERIV)) if (NDERIV <= 1) go to 99 IDERIV = NDERIV DO 15 I=2,NDERIV IDERVM = IDERIV-1 DO 11 J=IDERIV,K 11 VNIKX(J-1,IDERVM) = VNIKX(J,IDERIV) IDERIV = IDERVM call BSPLVN(T,0,2,X,ILEFT,VNIKX(IDERIV,IDERIV)) 15 CONTINUE ! DO 20 I=1,K DO 19 J=1,K 19 A(I,J) = 0. 20 A(I,I) = 1. KMD = K DO 40 M=2,NDERIV KMD = KMD-1 FKMD = KMD I = ILEFT J = K 21 JM1 = J-1 IPKMD = I + KMD DIFF = T(IPKMD) - T(I) if (JM1 == 0) go to 26 if (DIFF == 0.) go to 25 DO 24 L=1,J 24 A(L,J) = (A(L,J) - A(L,J-1))/DIFF*FKMD 25 J = JM1 I = I - 1 go to 21 26 if (DIFF == 0.) go to 30 A(1,1) = A(1,1)/DIFF*FKMD ! 30 DO 40 I=1,K V = 0. JLOW = MAX(I,M) DO 35 J=JLOW,K 35 V = A(I,J)*VNIKX(J,M) + V 40 VNIKX(I,M) = V 99 return end subroutine BSPLVN (T, JHIGH, INDEX, X, ILEFT, VNIKX) ! !! BSPLVN is subsidiary to FC. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BSPLVN-S, DFSPVN-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Calculates the value of all possibly nonzero B-splines at *X* of ! order MAX(JHIGH,(J+1)(INDEX-1)) on *T*. ! !***SEE ALSO FC !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE BSPLVN DIMENSION T(*),VNIKX(*) DIMENSION DELTAM(20),DELTAP(20) SAVE J, DELTAM, DELTAP DATA J/1/,(DELTAM(I),I=1,20),(DELTAP(I),I=1,20)/40*0./ !***FIRST EXECUTABLE STATEMENT BSPLVN go to (10,20),INDEX 10 J = 1 VNIKX(1) = 1. if (J >= JHIGH) go to 99 ! 20 IPJ = ILEFT+J DELTAP(J) = T(IPJ) - X IMJP1 = ILEFT-J+1 DELTAM(J) = X - T(IMJP1) VMPREV = 0. JP1 = J+1 DO 26 L=1,J JP1ML = JP1-L VM = VNIKX(L)/(DELTAP(L) + DELTAM(JP1ML)) VNIKX(L) = VM*DELTAP(L) + VMPREV 26 VMPREV = VM*DELTAM(JP1ML) VNIKX(JP1) = VMPREV J = JP1 if (J < JHIGH) go to 20 ! 99 return end subroutine BSPPP (T, A, N, K, LDC, C, XI, LXI, WORK) ! !! BSPPP converts the B-representation of a B-spline to the piecewise ... ! polynomial (PP) form. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE SINGLE PRECISION (BSPPP-S, DBSPPP-D) !***KEYWORDS B-SPLINE, PIECEWISE POLYNOMIAL !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract ! BSPPP is the BSPLPP routine of the reference. ! ! BSPPP converts the B-representation (T,A,N,K) to the ! piecewise polynomial (PP) form (C,XI,LXI,K) for use with ! PPVAL. Here XI(*), the break point array of length LXI, is ! the knot array T(*) with multiplicities removed. The columns ! of the matrix C(I,J) contain the right Taylor derivatives ! for the polynomial expansion about XI(J) for the intervals ! XI(J) <= X <= XI(J+1), I=1,K, J=1,LXI. Function PPVAL ! makes this evaluation at a specified point X in ! XI(1) <= X <= XI(LXI(1) <= X <= XI+1) ! ! Description of Arguments ! Input ! T - knot vector of length N+K ! A - B-spline coefficient vector of length N ! N - number of B-spline coefficients ! N = sum of knot multiplicities-K ! K - order of the B-spline, K >= 1 ! LDC - leading dimension of C, LDC >= K ! ! Output ! C - matrix of dimension at least (K,LXI) containing ! right derivatives at break points ! XI - XI break point vector of length LXI+1 ! LXI - number of break points, LXI <= N-K+1 ! WORK - work vector of length K*(N+3) ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED BSPDR, BSPEV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BSPPP ! INTEGER ILEFT, INEV, K, LDC, LXI, N, NK REAL A, C, T, WORK, XI ! DIMENSION T(N+K),XI(LXI+1),C(LDC,*) ! HERE, * = THE FINAL VALUE OF THE OUTPUT PARAMETER LXI. DIMENSION T(*), A(*), WORK(*), XI(*), C(LDC,*) !***FIRST EXECUTABLE STATEMENT BSPPP if ( K < 1) go to 100 if ( N < K) go to 105 if ( LDC < K) go to 110 call BSPDR(T, A, N, K, K, WORK) LXI = 0 XI(1) = T(K) INEV = 1 NK = N*K + 1 DO 10 ILEFT=K,N if (T(ILEFT+1) == T(ILEFT)) go to 10 LXI = LXI + 1 XI(LXI+1) = T(ILEFT+1) call BSPEV(T,WORK(1),N,K, K,XI(LXI),INEV,C(1,LXI),WORK(NK)) 10 CONTINUE return 100 CONTINUE call XERMSG ('SLATEC', 'BSPPP', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'BSPPP', 'N DOES NOT SATISFY N >= K', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'BSPPP', 'LDC DOES NOT SATISFY LDC >= K', & 2, 1) return end subroutine BSPVD (T, K, NDERIV, X, ILEFT, LDVNIK, VNIKX, WORK) ! !! BSPVD calculates the value and all derivatives of order less than ... ! NDERIV of all basis functions which do not vanish at X. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE SINGLE PRECISION (BSPVD-S, DBSPVD-D) !***KEYWORDS DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract ! BSPVD is the BSPLVD routine of the reference. ! ! BSPVD calculates the value and all derivatives of order ! less than NDERIV of all basis functions which do not ! (possibly) vanish at X. ILEFT is input such that ! T(ILEFT) <= X < T(ILEFT+1). A call to INTRV(T,N+1,X, ! ILO,ILEFT,MFLAG) will produce the proper ILEFT. The output of ! BSPVD is a matrix VNIKX(I,J) of dimension at least (K,NDERIV) ! whose columns contain the K nonzero basis functions and ! their NDERIV-1 right derivatives at X, I=1,K, J=1,NDERIV. ! These basis functions have indices ILEFT-K+I, I=1,K, ! K <= ILEFT <= N. The nonzero part of the I-th basis ! function lies in (T(I),T(I+K)), I=1,N. ! ! If X=T(ILEFT+1) then VNIKX contains left limiting values ! (left derivatives) at T(ILEFT+1). In particular, ILEFT = N ! produces left limiting values at the right end point ! X=T(N+1). To obtain left limiting values at T(I), I=K+1,N+1, ! set X= next lower distinct knot, call INTRV to get ILEFT, ! set X=T(I), and then call BSPVD. ! ! Description of Arguments ! Input ! T - knot vector of length N+K, where ! N = number of B-spline basis functions ! N = sum of knot multiplicities-K ! K - order of the B-spline, K >= 1 ! NDERIV - number of derivatives = NDERIV-1, ! 1 <= NDERIV <= K ! X - argument of basis functions, ! T(K) <= X <= T(N+1) ! ILEFT - largest integer such that ! T(ILEFT) <= X < T(ILEFT+1) ! LDVNIK - leading dimension of matrix VNIKX ! ! Output ! VNIKX - matrix of dimension at least (K,NDERIV) contain- ! ing the nonzero basis functions at X and their ! derivatives columnwise. ! WORK - a work vector of length (K+1)*(K+2)/2 ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED BSPVN, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BSPVD ! INTEGER I,IDERIV,ILEFT,IPKMD,J,JJ,JLOW,JM,JP1MID,K,KMD, KP1, L, & LDUMMY, M, MHIGH, NDERIV REAL FACTOR, FKMD, T, V, VNIKX, WORK, X ! DIMENSION T(ILEFT+K), WORK((K+1)*(K+2)/2) ! A(I,J) = WORK(I+J*(J+1)/2), I=1,J+1 J=1,K-1 ! A(I,K) = W0RK(I+K*(K-1)/2) I=1.K ! WORK(1) AND WORK((K+1)*(K+2)/2) ARE NOT USED. DIMENSION T(*), VNIKX(LDVNIK,*), WORK(*) !***FIRST EXECUTABLE STATEMENT BSPVD if ( K < 1) go to 200 if ( NDERIV < 1 .OR. NDERIV > K) go to 205 if ( LDVNIK < K) go to 210 IDERIV = NDERIV KP1 = K + 1 JJ = KP1 - IDERIV call BSPVN(T, JJ, K, 1, X, ILEFT, VNIKX, WORK, IWORK) if (IDERIV == 1) go to 100 MHIGH = IDERIV DO 20 M=2,MHIGH JP1MID = 1 DO 10 J=IDERIV,K VNIKX(J,IDERIV) = VNIKX(JP1MID,1) JP1MID = JP1MID + 1 10 CONTINUE IDERIV = IDERIV - 1 JJ = KP1 - IDERIV call BSPVN(T, JJ, K, 2, X, ILEFT, VNIKX, WORK, IWORK) 20 CONTINUE ! JM = KP1*(KP1+1)/2 DO 30 L = 1,JM WORK(L) = 0.0E0 30 CONTINUE ! A(I,I) = WORK(I*(I+3)/2) = 1.0 I = 1,K L = 2 J = 0 DO 40 I = 1,K J = J + L WORK(J) = 1.0E0 L = L + 1 40 CONTINUE KMD = K DO 90 M=2,MHIGH KMD = KMD - 1 FKMD = KMD I = ILEFT J = K JJ = J*(J+1)/2 JM = JJ - J DO 60 LDUMMY=1,KMD IPKMD = I + KMD FACTOR = FKMD/(T(IPKMD)-T(I)) DO 50 L=1,J WORK(L+JJ) = (WORK(L+JJ)-WORK(L+JM))*FACTOR 50 CONTINUE I = I - 1 J = J - 1 JJ = JM JM = JM - J 60 CONTINUE ! DO 80 I=1,K V = 0.0E0 JLOW = MAX(I,M) JJ = JLOW*(JLOW+1)/2 DO 70 J=JLOW,K V = WORK(I+JJ)*VNIKX(J,M) + V JJ = JJ + J + 1 70 CONTINUE VNIKX(I,M) = V 80 CONTINUE 90 CONTINUE 100 RETURN ! ! 200 CONTINUE call XERMSG ('SLATEC', 'BSPVD', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 205 CONTINUE call XERMSG ('SLATEC', 'BSPVD', & 'NDERIV DOES NOT SATISFY 1 <= NDERIV <= K', 2, 1) return 210 CONTINUE call XERMSG ('SLATEC', 'BSPVD', & 'LDVNIK DOES NOT SATISFY LDVNIK >= K', 2, 1) return end subroutine BSPVN (T, JHIGH, K, INDEX, X, ILEFT, VNIKX, WORK, & IWORK) ! !! BSPVN calculates the value of all (possibly) nonzero basis ... ! functions at X. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE SINGLE PRECISION (BSPVN-S, DBSPVN-D) !***KEYWORDS EVALUATION OF B-SPLINE !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract ! BSPVN is the BSPLVN routine of the reference. ! ! BSPVN calculates the value of all (possibly) nonzero basis ! functions at X of order MAX(JHIGH,(J+1)*(INDEX-1)), where ! T(K) <= X <= T(N+1) and J=IWORK is set inside the routine ! on the first call when INDEX=1. ILEFT is such that T(ILEFT) ! <= X < T(ILEFT+1). A call to INTRV(T,N+1,X,ILO,ILEFT, ! MFLAG) produces the proper ILEFT. BSPVN calculates using the ! basic algorithm needed in BSPVD. If only basis functions are ! desired, setting JHIGH=K and INDEX=1 can be faster than ! calling BSPVD, but extra coding is required for derivatives ! (INDEX=2) and BSPVD is set up for this purpose. ! ! Left limiting values are set up as described in BSPVD. ! ! Description of Arguments ! Input ! T - knot vector of length N+K, where ! N = number of B-spline basis functions ! N = sum of knot multiplicities-K ! JHIGH - order of B-spline, 1 <= JHIGH <= K ! K - highest possible order ! INDEX - INDEX = 1 gives basis functions of order JHIGH ! = 2 denotes previous entry with WORK, IWORK ! values saved for subsequent calls to ! BSPVN. ! X - argument of basis functions, ! T(K) <= X <= T(N+1) ! ILEFT - largest integer such that ! T(ILEFT) <= X < T(ILEFT+1) ! ! Output ! VNIKX - vector of length K for spline values. ! WORK - a work vector of length 2*K ! IWORK - a work parameter. Both WORK and IWORK contain ! information necessary to continue for INDEX = 2. ! When INDEX = 1 exclusively, these are scratch ! variables and can be used for other purposes. ! ! Error Conditions ! Improper input is a fatal error. ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BSPVN ! INTEGER ILEFT, IMJP1, INDEX, IPJ, IWORK, JHIGH, JP1, JP1ML, K, L REAL T, VM, VMPREV, VNIKX, WORK, X ! DIMENSION T(ILEFT+JHIGH) DIMENSION T(*), VNIKX(*), WORK(*) ! CONTENT OF J, DELTAM, DELTAP IS EXPECTED UNCHANGED BETWEEN CALLS. ! WORK(I) = DELTAP(I), WORK(K+I) = DELTAM(I), I = 1,K !***FIRST EXECUTABLE STATEMENT BSPVN if ( K < 1) go to 90 if ( JHIGH > K .OR. JHIGH < 1) go to 100 if ( INDEX < 1 .OR. INDEX > 2) go to 105 if ( X < T(ILEFT) .OR. X > T(ILEFT+1)) go to 110 go to (10, 20), INDEX 10 IWORK = 1 VNIKX(1) = 1.0E0 if (IWORK >= JHIGH) go to 40 ! 20 IPJ = ILEFT + IWORK WORK(IWORK) = T(IPJ) - X IMJP1 = ILEFT - IWORK + 1 WORK(K+IWORK) = X - T(IMJP1) VMPREV = 0.0E0 JP1 = IWORK + 1 DO 30 L=1,IWORK JP1ML = JP1 - L VM = VNIKX(L)/(WORK(L)+WORK(K+JP1ML)) VNIKX(L) = VM*WORK(L) + VMPREV VMPREV = VM*WORK(K+JP1ML) 30 CONTINUE VNIKX(JP1) = VMPREV IWORK = JP1 if (IWORK < JHIGH) go to 20 ! 40 RETURN ! ! 90 CONTINUE call XERMSG ('SLATEC', 'BSPVN', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 100 CONTINUE call XERMSG ('SLATEC', 'BSPVN', & 'JHIGH DOES NOT SATISFY 1 <= JHIGH <= K', 2, 1) return 105 CONTINUE call XERMSG ('SLATEC', 'BSPVN', 'INDEX IS NOT 1 OR 2', 2, 1) return 110 CONTINUE call XERMSG ('SLATEC', 'BSPVN', & 'X DOES NOT SATISFY T(ILEFT) <= X <= T(ILEFT+1)', 2, 1) return end subroutine BSQAD (T, BCOEF, N, K, X1, X2, BQUAD, WORK) ! !! BSQAD computes the integral of a K-th order B-spline using the ... ! B-representation. ! !***LIBRARY SLATEC !***CATEGORY H2A2A1, E3, K6 !***TYPE SINGLE PRECISION (BSQAD-S, DBSQAD-D) !***KEYWORDS INTEGRAL OF B-SPLINES, QUADRATURE !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! BSQAD computes the integral on (X1,X2) of a K-th order ! B-spline using the B-representation (T,BCOEF,N,K). Orders ! K as high as 20 are permitted by applying a 2, 6, or 10 ! point Gauss formula on subintervals of (X1,X2) which are ! formed by included (distinct) knots. ! ! If orders K greater than 20 are needed, use BFQAD with ! F(X) = 1. ! ! Description of Arguments ! Input ! T - knot array of length N+K ! BCOEF - B-spline coefficient array of length N ! N - length of coefficient array ! K - order of B-spline, 1 <= K <= 20 ! X1,X2 - end points of quadrature interval in ! T(K) <= X <= T(N+1) ! ! Output ! BQUAD - integral of the B-spline over (X1,X2) ! WORK - work vector of length 3*K ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES D. E. Amos, Quadrature subroutines for splines and ! B-splines, Report SAND79-1825, Sandia Laboratories, ! December 1979. !***ROUTINES CALLED BVALU, INTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BSQAD ! INTEGER I,IL1,IL2,ILO,INBV, JF,K,LEFT,M,MF,MFLAG,N, NPK, NP1 REAL A, AA, B, BB, BCOEF, BMA, BPA, BQUAD, C1, GPTS, GWTS, GX, Q, & SUM, T, TA, TB, WORK, X1, X2, Y1, Y2 REAL BVALU DIMENSION T(*), BCOEF(*), GPTS(9), GWTS(9), SUM(5), WORK(*) ! SAVE GPTS, GWTS DATA GPTS(1), GPTS(2), GPTS(3), GPTS(4), GPTS(5), GPTS(6), & GPTS(7), GPTS(8), GPTS(9)/ & 5.77350269189625764E-01, 2.38619186083196909E-01, & 6.61209386466264514E-01, 9.32469514203152028E-01, & 1.48874338981631211E-01, 4.33395394129247191E-01, & 6.79409568299024406E-01, 8.65063366688984511E-01, & 9.73906528517171720E-01/ DATA GWTS(1), GWTS(2), GWTS(3), GWTS(4), GWTS(5), GWTS(6), & GWTS(7), GWTS(8), GWTS(9)/ & 1.00000000000000000E+00, 4.67913934572691047E-01, & 3.60761573048138608E-01, 1.71324492379170345E-01, & 2.95524224714752870E-01, 2.69266719309996355E-01, & 2.19086362515982044E-01, 1.49451349150580593E-01, & 6.66713443086881376E-02/ ! !***FIRST EXECUTABLE STATEMENT BSQAD BQUAD = 0.0E0 if ( K < 1 .OR. K > 20) go to 65 if ( N < K) go to 70 AA = MIN(X1,X2) BB = MAX(X1,X2) if (AA < T(K)) go to 60 NP1 = N + 1 if (BB > T(NP1)) go to 60 if (AA == BB) RETURN NPK = N + K ! SELECTION OF 2, 6, OR 10 POINT GAUSS FORMULA JF = 0 MF = 1 if (K <= 4) go to 10 JF = 1 MF = 3 if (K <= 12) go to 10 JF = 4 MF = 5 10 CONTINUE ! DO 20 I=1,MF SUM(I) = 0.0E0 20 CONTINUE ILO = 1 INBV = 1 call INTRV(T, NPK, AA, ILO, IL1, MFLAG) call INTRV(T, NPK, BB, ILO, IL2, MFLAG) if (IL2 >= NP1) IL2 = N DO 40 LEFT=IL1,IL2 TA = T(LEFT) TB = T(LEFT+1) if (TA == TB) go to 40 A = MAX(AA,TA) B = MIN(BB,TB) BMA = 0.5E0*(B-A) BPA = 0.5E0*(B+A) DO 30 M=1,MF C1 = BMA*GPTS(JF+M) GX = -C1 + BPA Y2 = BVALU(T,BCOEF,N,K,0,GX,INBV,WORK) GX = C1 + BPA Y1 = BVALU(T,BCOEF,N,K,0,GX,INBV,WORK) SUM(M) = SUM(M) + (Y1+Y2)*BMA 30 CONTINUE 40 CONTINUE Q = 0.0E0 DO 50 M=1,MF Q = Q + GWTS(JF+M)*SUM(M) 50 CONTINUE if (X1 > X2) Q = -Q BQUAD = Q return ! ! 60 CONTINUE call XERMSG ('SLATEC', 'BSQAD', & 'X1 OR X2 OR BOTH DO NOT SATISFY T(K) <= X <= T(N+1)', 2, 1) return 65 CONTINUE call XERMSG ('SLATEC', 'BSQAD', 'K DOES NOT SATISFY 1 <= K <= 20' & , 2, 1) return 70 CONTINUE call XERMSG ('SLATEC', 'BSQAD', 'N DOES NOT SATISFY N >= K', 2, & 1) return end function BSRH (XLL, XRR, IZ, C, A, BH, F, SGN) ! !! BSRH is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BCRH-S, BSRH-S) !***AUTHOR (UNKNOWN) !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CBLKT !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE BSRH DIMENSION A(*) ,C(*) ,BH(*) COMMON /CBLKT/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT BSRH XL = XLL XR = XRR DX = .5*ABS(XR-XL) 101 X = .5*(XL+XR) if (SGN*F(X,IZ,C,A,BH)) 103,105,102 102 XR = X go to 104 103 XL = X 104 DX = .5*DX if (DX-CNV) 105,105,101 105 BSRH = .5*(XL+XR) return end function BVALU (T, A, N, K, IDERIV, X, INBV, WORK) ! !! BVALU evaluates the B-representation of a B-spline at X for the ! function value or any of its derivatives. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE SINGLE PRECISION (BVALU-S, DBVALU-D) !***KEYWORDS DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract ! BVALU is the BVALUE function of the reference. ! ! BVALU evaluates the B-representation (T,A,N,K) of a B-spline ! at X for the function value on IDERIV = 0 or any of its ! derivatives on IDERIV = 1,2,...,K-1. Right limiting values ! (right derivatives) are returned except at the right end ! point X=T(N+1) where left limiting values are computed. The ! spline is defined on T(K) <= X <= T(N+1). BVALU returns ! a fatal error message when X is outside of this interval. ! ! To compute left derivatives or left limiting values at a ! knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1. ! ! BVALU calls INTRV ! ! Description of Arguments ! Input ! T - knot vector of length N+K ! A - B-spline coefficient vector of length N ! N - number of B-spline coefficients ! N = sum of knot multiplicities-K ! K - order of the B-spline, K >= 1 ! IDERIV - order of the derivative, 0 <= IDERIV <= K-1 ! IDERIV=0 returns the B-spline value ! X - argument, T(K) <= X <= T(N+1) ! INBV - an initialization parameter which must be set ! to 1 the first time BVALU is called. ! ! Output ! INBV - INBV contains information for efficient process- ! ing after the initial call and INBV must not ! be changed by the user. Distinct splines require ! distinct INBV parameters. ! WORK - work vector of length 3*K. ! BVALU - value of the IDERIV-th derivative at X ! ! Error Conditions ! An improper input is a fatal error ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED INTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BVALU ! INTEGER I,IDERIV,IDERP1,IHI,IHMKMJ,ILO,IMK,IMKPJ, INBV, IPJ, & IP1, IP1MJ, J, JJ, J1, J2, K, KMIDER, KMJ, KM1, KPK, MFLAG, N REAL A, FKMJ, T, WORK, X ! DIMENSION T(N+K), WORK(3*K) DIMENSION T(*), A(*), WORK(*) !***FIRST EXECUTABLE STATEMENT BVALU BVALU = 0.0E0 if ( K < 1) go to 102 if ( N < K) go to 101 if ( IDERIV < 0 .OR. IDERIV >= K) go to 110 KMIDER = K - IDERIV ! ! *** FIND *I* IN (K,N) SUCH THAT T(I) <= X < T(I+1) ! (OR, <= T(I+1) if T(I) < T(I+1) = T(N+1)). KM1 = K - 1 call INTRV(T, N+1, X, INBV, I, MFLAG) if (X < T(K)) go to 120 if (MFLAG == 0) go to 20 if (X > T(I)) go to 130 10 if (I == K) go to 140 I = I - 1 if (X == T(I)) go to 10 ! ! *** DIFFERENCE THE COEFFICIENTS *IDERIV* TIMES ! WORK(I) = AJ(I), WORK(K+I) = DP(I), WORK(K+K+I) = DM(I), I=1.K ! 20 IMK = I - K DO 30 J=1,K IMKPJ = IMK + J WORK(J) = A(IMKPJ) 30 CONTINUE if (IDERIV == 0) go to 60 DO 50 J=1,IDERIV KMJ = K - J FKMJ = KMJ DO 40 JJ=1,KMJ IHI = I + JJ IHMKMJ = IHI - KMJ WORK(JJ) = (WORK(JJ+1)-WORK(JJ))/(T(IHI)-T(IHMKMJ))*FKMJ 40 CONTINUE 50 CONTINUE ! ! *** COMPUTE VALUE AT *X* IN (T(I),(T(I+1)) OF IDERIV-TH DERIVATIVE, ! GIVEN ITS RELEVANT B-SPLINE COEFF. IN AJ(1),...,AJ(K-IDERIV). 60 if (IDERIV == KM1) go to 100 IP1 = I + 1 KPK = K + K J1 = K + 1 J2 = KPK + 1 DO 70 J=1,KMIDER IPJ = I + J WORK(J1) = T(IPJ) - X IP1MJ = IP1 - J WORK(J2) = X - T(IP1MJ) J1 = J1 + 1 J2 = J2 + 1 70 CONTINUE IDERP1 = IDERIV + 1 DO 90 J=IDERP1,KM1 KMJ = K - J ILO = KMJ DO 80 JJ=1,KMJ WORK(JJ) = (WORK(JJ+1)*WORK(KPK+ILO)+WORK(JJ) & *WORK(K+JJ))/(WORK(KPK+ILO)+WORK(K+JJ)) ILO = ILO - 1 80 CONTINUE 90 CONTINUE 100 BVALU = WORK(1) return ! ! 101 CONTINUE call XERMSG ('SLATEC', 'BVALU', 'N DOES NOT SATISFY N >= K', 2, & 1) return 102 CONTINUE call XERMSG ('SLATEC', 'BVALU', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'BVALU', & 'IDERIV DOES NOT SATISFY 0 <= IDERIV < K', 2, 1) return 120 CONTINUE call XERMSG ('SLATEC', 'BVALU', & 'X IS N0T GREATER THAN OR EQUAL TO T(K)', 2, 1) return 130 CONTINUE call XERMSG ('SLATEC', 'BVALU', & 'X IS NOT LESS THAN OR EQUAL TO T(N+1)', 2, 1) return 140 CONTINUE call XERMSG ('SLATEC', 'BVALU', & 'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1) return end subroutine BVDER ( X, Y, YP, G, IPAR, fmat, gvec, uivp, uvec ) ! !! BVDER is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BVDER-S, DBVDER-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! NFC = Number of base solution vectors ! ! NCOMP = Number of components per solution vector ! ! 1 -- Nonzero particular solution ! INHOMO = ! 2 or 3 -- Zero particular solution ! ! 0 -- Inhomogeneous vector term G(X) identically zero ! IGOFX = ! 1 -- Inhomogeneous vector term G(X) not identically zero ! ! G = Inhomogeneous vector term G(X) ! ! XSAV = Previous value of X ! ! C = Normalization factor for the particular solution ! ! 0 ( if NEQIVP = 0 ) ! IVP = ! Number of differential equations integrated due to ! the original boundary value problem ( if NEQIVP > 0 ) ! ! NOFST - For problems with auxiliary initial value equations, ! NOFST communicates to the routine FMAT how to access ! the dependent variables corresponding to this initial ! value problem. For example, during any call to FMAT, ! the first dependent variable for the initial value ! problem is in position Y(NOFST + 1). ! See example in SAND77-1328. ! ********************************************************************** ! !***SEE ALSO BVSUP !***ROUTINES CALLED (NONE) !***COMMON BLOCKS ML8SZ, MLIVP !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910701 Corrected ROUTINES CALLED section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920618 Minor restructuring of code. (RWC, WRB) !***END PROLOGUE BVDER ! external fmat external gvec external uivp external uvec DIMENSION Y(*),YP(*),G(*) ! ! ********************************************************************** ! COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC ! ! ********************************************************************** ! The COMMON block below is used to communicate with the user ! supplied subroutine FMAT. The user should not alter this ! COMMON block. ! COMMON /MLIVP/ NOFST ! ********************************************************************** ! !***FIRST EXECUTABLE STATEMENT BVDER if (IVP > 0) call UIVP(X,Y(IVP+1),YP(IVP+1)) NOFST = IVP NA = 1 DO 10 K=1,NFC call FMAT(X,Y(NA),YP(NA)) NOFST = NOFST - NCOMP NA = NA + NCOMP 10 CONTINUE ! if (INHOMO /= 1) RETURN call FMAT(X,Y(NA),YP(NA)) ! if (IGOFX == 0) RETURN if (X /= XSAV) THEN if (IVP == 0) call GVEC(X,G) if (IVP > 0) call UVEC(X,Y(IVP+1),G) XSAV = X end if ! ! If the user has chosen not to normalize the particular ! solution, then C is defined in BVPOR to be 1.0 ! ! The following loop is just ! call SAXPY (NCOMP, 1.0E0/C, G, 1, YP(NA), 1) ! DO 20 J=1,NCOMP L = NA + J - 1 YP(L) = YP(L) + G(J)/C 20 CONTINUE return end subroutine BVPOR (Y, NROWY, NCOMP, XPTS, NXPTS, A, NROWA, ALPHA, & NIC, B, NROWB, BETA, NFC, IFLAG, Z, MXNON, P, NTP, IP, W, NIV, & YHP, U, V, COEF, S, STOWA, G, WORK, IWORK, NFCC) ! !! BVPOR is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (BVPOR-S, DBVPOR-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! INPUT to BVPOR (items not defined in BVSUP comments) ! ********************************************************************** ! ! NOPG = 0 -- Orthonormalization points not pre-assigned ! = 1 -- Orthonormalization points pre-assigned ! ! MXNON = Maximum number of orthogonalizations allowed. ! ! NDISK = 0 -- IN-CORE storage ! = 1 -- DISK storage. Value of NTAPE in data statement ! is set to 13. If another value is desired, ! the data statement must be changed. ! ! INTEG = Type of integrator and associated test to be used ! to determine when to orthonormalize. ! ! 1 -- Use GRAM-SCHMIDT test and DERKF ! 2 -- Use GRAM-SCHMIDT test and DEABM ! ! TOL = Tolerance for allowable error in orthogonalization test. ! ! NPS = 0 Normalize particular solution to unit length at each ! point of orthonormalization. ! = 1 Do not normalize particular solution. ! ! NTP = Must be >= NFC*(NFC+1)/2. ! ! ! NFCC = 2*NFC for special treatment of a complex valued problem ! ! ICOCO = 0 Skip final computations (superposition coefficients ! and ,hence, boundary problem solution) ! = 1 Calculate superposition coefficients and obtain ! solution to the boundary value problem ! ! ********************************************************************** ! OUTPUT from BVPOR ! ********************************************************************** ! ! Y(NROWY,NXPTS) = Solution at specified output points. ! ! MXNON = Number of orthonormalizations performed by BVPOR. ! ! Z(MXNON+1) = Locations of orthonormalizations performed by BVPOR. ! ! NIV = Number of independent vectors returned from MGSBV. Normally ! this parameter will be meaningful only when MGSBV returns with ! MFLAG = 2. ! ! ********************************************************************** ! ! The following variables are in the argument list because of ! variable dimensioning. In general, they contain no information of ! use to the user. The amount of storage set aside by the user must ! be greater than or equal to that indicated by the dimension ! statements. For the DISK storage mode, NON = 0 and KPTS = 1, ! while for the IN-CORE storage mode, NON = MXNON and KPTS = NXPTS. ! ! P(NTP,NON+1) ! IP(NFCC,NON+1) ! YHP(NCOMP,NFC+1) plus an additional column of the length NEQIVP ! U(NCOMP,NFC,KPTS) ! V(NCOMP,KPTS) ! W(NFCC,NON+1) ! COEF(NFCC) ! S(NFC+1) ! STOWA(NCOMP*(NFC+1)+NEQIVP+1) ! G(NCOMP) ! WORK(KKKWS) ! IWORK(LLLIWS) ! ! ********************************************************************** ! Subroutines used by BVPOR ! LSSUDS -- Solves an underdetermined system of linear ! equations. This routine is used to get a full ! set of initial conditions for integration. ! Called by BVPOR ! ! SVECS -- Obtains starting vectors for special treatment ! of complex valued problems , called by BVPOR ! ! RKFAB -- Routine which conducts integration using DERKF or ! DEABM ! ! STWAY -- Storage for backup capability, called by ! BVPOR and REORT ! ! STOR1 -- Storage at output points, called by BVPOR, ! RKFAB, REORT and STWAY. ! ! SDOT -- Single precision vector inner product routine, ! called by BVPOR, SCOEF, LSSUDS, MGSBV, ! BKSOL, REORT and PRVEC. ! ** NOTE ** ! A considerable improvement in speed can be achieved if a ! machine language version is used for SDOT. ! ! SCOEF -- Computes the superposition constants from the ! boundary conditions at Xfinal. ! ! BKSOL -- Solves an upper triangular set of linear equations. ! ! ********************************************************************** ! !***SEE ALSO BVSUP !***ROUTINES CALLED BKSOL, LSSUDS, RKFAB, SCOEF, SDOT, STOR1, STWAY, ! SVECS !***COMMON BLOCKS ML15TO, ML18JR, ML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE BVPOR ! DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*), & BETA(*),P(NTP,*),IP(NFCC,*), & U(NCOMP,NFC,*),V(NCOMP,*),W(NFCC,*), & COEF(*),Z(*),YHP(NCOMP,*),XPTS(*),S(*), & WORK(*),IWORK(*),STOWA(*),G(*) ! ! ********************************************************************** ! COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /ML18JR/ AE,RE,TOL,NXPTSD,NICD,NOPG,MXNOND,NDISK,NTAPE, & NEQ,INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD, & ICOCO ! ! ********************************************************************** ! !***FIRST EXECUTABLE STATEMENT BVPOR NFCP1 = NFC + 1 NUMORT = 0 C = 1.0 ! ! ********************************************************************** ! CALCULATE INITIAL CONDITIONS WHICH SATISFY ! A*YH(XINITIAL)=0 AND A*YP(XINITIAL)=ALPHA. ! WHEN NFC /= NFCC LSSUDS DEFINES VALUES YHP IN A MATRIX OF SIZE ! (NFCC+1)*NCOMP AND ,HENCE, OVERFLOWS THE STORAGE ALLOCATION INTO ! THE U ARRAY. HOWEVER, THIS IS OKAY SINCE PLENTY OF SPACE IS ! AVAILABLE IN U AND IT HAS NOT YET BEEN USED. ! NDW = NROWA * NCOMP KWS = NDW + NIC + 1 KWD = KWS + NIC KWT = KWD + NIC KWC = KWT + NIC IFLAG = 0 call LSSUDS(A,YHP(1,NFCC+1),ALPHA,NIC,NCOMP,NROWA,YHP,NCOMP, & IFLAG,1,IRA,0,WORK(1),WORK(NDW+1),IWORK,WORK(KWS), & WORK(KWD),WORK(KWT),ISFLG,WORK(KWC)) if (IFLAG == 1) go to 3 IFLAG=-4 go to 250 3 if (NFC /= NFCC) call SVECS(NCOMP,NFC,YHP,WORK,IWORK, & INHOMO,IFLAG) if (IFLAG == 1) go to 5 IFLAG=-5 go to 250 ! ! ********************************************************************** ! DETERMINE THE NUMBER OF DIFFERENTIAL EQUATIONS TO BE INTEGRATED, ! INITIALIZE VARIABLES FOR AUXILIARY INITIAL VALUE PROBLEM AND ! STORE INITIAL CONDITIONS. ! 5 NEQ = NCOMP * NFC if (INHOMO == 1) NEQ = NEQ + NCOMP IVP = 0 if (NEQIVP == 0) go to 10 IVP = NEQ NEQ = NEQ + NEQIVP NFCP2 = NFCP1 if (INHOMO == 1) NFCP2 = NFCP1 + 1 DO 7 K = 1,NEQIVP 7 YHP(K,NFCP2) = ALPHA(NIC+K) 10 call STOR1(U,YHP,V,YHP(1,NFCP1),0,NDISK,NTAPE) ! ! ********************************************************************** ! SET UP DATA FOR THE ORTHONORMALIZATION TESTING PROCEDURE AND ! SAVE INITIAL CONDITIONS IN CASE A RESTART IS NECESSARY. ! NSWOT=1 KNSWOT=0 LOTJP=1 TND=LOG10(10.*TOL) PWCND=LOG10(SQRT(TOL)) X=XBEG PX=X XOT=XEND XOP=X KOP=1 call STWAY(U,V,YHP,0,STOWA) ! ! ********************************************************************** ! ******** FORWARD INTEGRATION OF ALL INITIAL VALUE EQUATIONS ********** ! ********************************************************************** ! call RKFAB(NCOMP,XPTS,NXPTS,NFC,IFLAG,Z,MXNON,P,NTP,IP, & YHP,NIV,U,V,W,S,STOWA,G,WORK,IWORK,NFCC) if (IFLAG /= 0 .OR. ICOCO == 0) go to 250 ! ! ********************************************************************** ! **************** BACKWARD SWEEP TO OBTAIN SOLUTION ******************* ! ********************************************************************** ! ! CALCULATE SUPERPOSITION COEFFICIENTS AT XFINAL. ! ! FOR THE DISK STORAGE VERSION, IT IS NOT NECESSARY TO READ U AND V ! AT THE LAST OUTPUT POINT, SINCE THE LOCAL COPY OF EACH STILL EXISTS. ! KOD = 1 if (NDISK == 0) KOD = NXPTS I1=1+NFCC*NFCC I2=I1+NFCC call SCOEF(U(1,1,KOD),V(1,KOD),NCOMP,NROWB,NFC,NIC,B,BETA,COEF, & INHOMO,RE,AE,WORK,WORK(I1),WORK(I2),IWORK,IFLAG,NFCC) ! ! ********************************************************************** ! CALCULATE SOLUTION AT OUTPUT POINTS BY RECURRING BACKWARDS. ! AS WE RECUR BACKWARDS FROM XFINAL TO XINITIAL WE MUST CALCULATE ! NEW SUPERPOSITION COEFFICIENTS EACH TIME WE CROSS A POINT OF ! ORTHONORMALIZATION. ! K = NUMORT NCOMP2=NCOMP/2 IC=1 if (NFC /= NFCC) IC=2 DO 200 J = 1,NXPTS KPTS = NXPTS - J + 1 KOD = KPTS if (NDISK == 1) KOD = 1 135 if (K == 0) go to 170 if (XEND > XBEG .AND. XPTS(KPTS) >= Z(K)) go to 170 if (XEND < XBEG .AND. XPTS(KPTS) <= Z(K)) go to 170 NON = K if (NDISK == 0) go to 136 NON = 1 BACKSPACE NTAPE READ (NTAPE) (IP(I,1), I = 1,NFCC),(P(I,1), I = 1,NTP) BACKSPACE NTAPE 136 if (INHOMO /= 1) go to 150 if (NDISK == 0) go to 138 BACKSPACE NTAPE READ (NTAPE) (W(I,1), I = 1,NFCC) BACKSPACE NTAPE 138 DO 140 N = 1,NFCC 140 COEF(N) = COEF(N) - W(N,NON) 150 call BKSOL(NFCC,P(1,NON),COEF) DO 155 M = 1,NFCC 155 WORK(M) = COEF(M) DO 160 M = 1,NFCC L = IP(M,NON) 160 COEF(L) = WORK(M) K = K - 1 go to 135 170 if (NDISK == 0) go to 175 BACKSPACE NTAPE READ (NTAPE) (V(I,1), I = 1,NCOMP), & ((U(I,M,1), I = 1,NCOMP), M = 1,NFC) BACKSPACE NTAPE 175 DO 180 N = 1,NCOMP 180 Y(N,KPTS) = V(N,KOD) + SDOT(NFC,U(N,1,KOD),NCOMP,COEF,IC) if (NFC == NFCC) go to 200 DO 190 N=1,NCOMP2 NN=NCOMP2+N Y(N,KPTS)=Y(N,KPTS) - SDOT(NFC,U(NN,1,KOD),NCOMP,COEF(2),2) 190 Y(NN,KPTS)=Y(NN,KPTS) + SDOT(NFC,U(N,1,KOD),NCOMP,COEF(2),2) 200 CONTINUE ! ! ********************************************************************** ! 250 MXNON = NUMORT return end subroutine BVSUP (Y, NROWY, NCOMP, XPTS, NXPTS, A, NROWA, ALPHA, & NIC, B, NROWB, BETA, NFC, IGOFX, RE, AE, IFLAG, WORK, NDW, & IWORK, NDIW, NEQIVP) ! !! BVSUP solves a linear two-point boundary value problem using ... ! superposition coupled with an orthonormalization procedure ! and a variable-step integration scheme. ! !***LIBRARY SLATEC !***CATEGORY I1B1 !***TYPE SINGLE PRECISION (BVSUP-S, DBVSUP-D) !***KEYWORDS ORTHONORMALIZATION, SHOOTING, ! TWO-POINT BOUNDARY VALUE PROBLEM !***AUTHOR Scott, M. R., (SNLA) ! Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! Subroutine BVSUP solves a LINEAR two-point boundary-value problem ! of the form ! dY/dX = MATRIX(X,U)*Y(X) + G(X,U) ! A*Y(Xinitial) = ALPHA , B*Y(Xfinal) = BETA ! ! Coupled with the solution of the initial value problem ! ! dU/dX = F(X,U) ! U(Xinitial) = ETA ! ! ********************************************************************** ! Abstract ! The method of solution uses superposition coupled with an ! orthonormalization procedure and a variable-step integration ! scheme. Each time the superposition solutions start to ! lose their numerical linear independence, the vectors are ! reorthonormalized before integration proceeds. The underlying ! principle of the algorithm is then to piece together the ! intermediate (orthogonalized) solutions, defined on the various ! subintervals, to obtain the desired solutions. ! ! ********************************************************************** ! INPUT to BVSUP ! ********************************************************************** ! ! NROWY = Actual row dimension of Y in calling program. ! NROWY must be >= NCOMP ! ! NCOMP = Number of components per solution vector. ! NCOMP is equal to number of original differential ! equations. NCOMP = NIC + NFC. ! ! XPTS = Desired output points for solution. They must be monotonic. ! Xinitial = XPTS(1) ! Xfinal = XPTS(NXPTS) ! ! NXPTS = Number of output points ! ! A(NROWA,NCOMP) = Boundary condition matrix at Xinitial, ! must be contained in (NIC,NCOMP) sub-matrix. ! ! NROWA = Actual row dimension of A in calling program, ! NROWA must be >= NIC. ! ! ALPHA(NIC+NEQIVP) = Boundary conditions at Xinitial. ! If NEQIVP > 0 (see below), the boundary ! conditions at Xinitial for the initial value ! equations must be stored starting in ! position (NIC + 1) of ALPHA. ! Thus, ALPHA(NIC+K) = ETA(K). ! ! NIC = Number of boundary conditions at Xinitial. ! ! B(NROWB,NCOMP) = Boundary condition matrix at Xfinal, ! must be contained in (NFC,NCOMP) sub-matrix. ! ! NROWB = Actual row dimension of B in calling program, ! NROWB must be >= NFC. ! ! BETA(NFC) = Boundary conditions at Xfinal. ! ! NFC = Number of boundary conditions at Xfinal ! ! IGOFX =0 -- The inhomogeneous term G(X) is identically zero. ! =1 -- The inhomogeneous term G(X) is not identically zero. ! (if IGOFX=1, then subroutine GVEC (or UVEC) must be ! supplied). ! ! RE = Relative error tolerance used by the integrator ! (see one of the integrators) ! ! AE = Absolute error tolerance used by the integrator ! (see one of the integrators) ! **NOTE- RE and AE should not both be zero. ! ! IFLAG = A status parameter used principally for output. ! However, for efficient solution of problems which ! are originally defined as complex valued (but ! converted to real systems to use this code), the ! user must set IFLAG=13 on input. See the comment below ! for more information on solving such problems. ! ! WORK(NDW) = Floating point array used for internal storage. ! ! NDW = Actual dimension of WORK array allocated by user. ! An estimate for NDW can be computed from the following ! NDW = 130 + NCOMP**2 * (6 + NXPTS/2 + expected number of ! orthonormalizations/8) ! For the DISK or TAPE storage mode, ! NDW = 6 * NCOMP**2 + 10 * NCOMP + 130 ! However, when the ADAMS integrator is to be used, the estimates are ! NDW = 130 + NCOMP**2 * (13 + NXPTS/2 + expected number of ! orthonormalizations/8) ! and NDW = 13 * NCOMP**2 + 22 * NCOMP + 130 , respectively. ! ! IWORK(NDIW) = Integer array used for internal storage. ! ! NDIW = Actual dimension of IWORK array allocated by user. ! An estimate for NDIW can be computed from the following ! NDIW = 68 + NCOMP * (1 + expected number of ! orthonormalizations) ! **NOTE -- The amount of storage required is problem dependent and may ! be difficult to predict in advance. Experience has shown ! that for most problems 20 or fewer orthonormalizations ! should suffice. If the problem cannot be completed with the ! allotted storage, then a message will be printed which ! estimates the amount of storage necessary. In any case, the ! user can examine the IWORK array for the actual storage ! requirements, as described in the output information below. ! ! NEQIVP = Number of auxiliary initial value equations being added ! to the boundary value problem. ! **NOTE -- Occasionally the coefficients MATRIX and/or G may be ! functions which depend on the independent variable X and ! on U, the solution of an auxiliary initial value problem. ! In order to avoid the difficulties associated with ! interpolation, the auxiliary equations may be solved ! simultaneously with the given boundary value problem. ! This initial value problem may be LINEAR or NONLINEAR. ! See SAND77-1328 for an example. ! ! ! The user must supply subroutines FMAT, GVEC, UIVP and UVEC, when ! needed (they MUST be so named), to evaluate the derivatives ! as follows ! ! A. FMAT must be supplied. ! ! SUBROUTINE FMAT(X,Y,YP) ! X = Independent variable (input to FMAT) ! Y = Dependent variable vector (input to FMAT) ! YP = dY/dX = Derivative vector (output from FMAT) ! ! Compute the derivatives for the HOMOGENEOUS problem ! YP(I) = dY(I)/dX = MATRIX(X) * Y(I) , I = 1,...,NCOMP ! ! When (NEQIVP > 0) and MATRIX is dependent on U as ! well as on X, the following common statement must be ! included in FMAT ! COMMON /MLIVP/ NOFST ! For convenience, the U vector is stored at the bottom ! of the Y array. Thus, during any call to FMAT, ! U(I) is referenced by Y(NOFST + I). ! ! ! Subroutine BVDER calls FMAT NFC times to evaluate the ! homogeneous equations and, if necessary, it calls FMAT once ! in evaluating the particular solution. Since X remains ! unchanged in this sequence of calls it is possible to ! realize considerable computational savings for complicated ! and expensive evaluations of the MATRIX entries. To do this ! the user merely passes a variable, say XS, via COMMON where ! XS is defined in the main program to be any value except ! the initial X. Then the non-constant elements of MATRIX(X) ! appearing in the differential equations need only be ! computed if X is unequal to XS, whereupon XS is reset to X. ! ! ! B. If NEQIVP > 0 , UIVP must also be supplied. ! ! SUBROUTINE UIVP(X,U,UP) ! X = Independent variable (input to UIVP) ! U = Dependent variable vector (input to UIVP) ! UP = dU/dX = Derivative vector (output from UIVP) ! ! Compute the derivatives for the auxiliary initial value eqs ! UP(I) = dU(I)/dX, I = 1,...,NEQIVP. ! ! Subroutine BVDER calls UIVP once to evaluate the ! derivatives for the auxiliary initial value equations. ! ! ! C. If NEQIVP = 0 and IGOFX = 1 , GVEC must be supplied. ! ! SUBROUTINE GVEC(X,G) ! X = Independent variable (input to GVEC) ! G = Vector of inhomogeneous terms G(X) (output from GVEC) ! ! Compute the inhomogeneous terms G(X) ! G(I) = G(X) values for I = 1,...,NCOMP. ! ! Subroutine BVDER calls GVEC in evaluating the particular ! solution provided G(X) is NOT identically zero. Thus, when ! IGOFX=0, the user need NOT write a GVEC subroutine. Also, ! the user does not have to bother with the computational ! savings scheme for GVEC as this is automatically achieved ! via the BVDER subroutine. ! ! ! D. If NEQIVP > 0 and IGOFX = 1 , UVEC must be supplied. ! ! SUBROUTINE UVEC(X,U,G) ! X = Independent variable (input to UVEC) ! U = Dependent variable vector from the auxiliary initial ! value problem (input to UVEC) ! G = Array of inhomogeneous terms G(X,U)(output from UVEC) ! ! Compute the inhomogeneous terms G(X,U) ! G(I) = G(X,U) values for I = 1,...,NCOMP. ! ! Subroutine BVDER calls UVEC in evaluating the particular ! solution provided G(X,U) is NOT identically zero. Thus, ! when IGOFX=0, the user need NOT write a UVEC subroutine. ! ! ! ! The following is optional input to BVSUP to give the user more ! flexibility in use of the code. See SAND75-0198 , SAND77-1328 , ! SAND77-1690,SAND78-0522, and SAND78-1501 for more information. ! ! ****CAUTION -- The user MUST zero out IWORK(1),...,IWORK(15) ! prior to calling BVSUP. These locations define optional ! input and MUST be zero UNLESS set to special values by ! the user as described below. ! ! IWORK(1) -- Number of orthonormalization points. ! A value need be set only if IWORK(11) = 1 ! ! IWORK(9) -- Integrator and orthonormalization parameter ! (default value is 1) ! 1 = RUNGE-KUTTA-FEHLBERG code using GRAM-SCHMIDT test. ! 2 = ADAMS code using GRAM-SCHMIDT TEST. ! ! IWORK(11) -- Orthonormalization points parameter ! (default value is 0) ! 0 - Orthonormalization points not pre-assigned. ! 1 - Orthonormalization points pre-assigned in ! the first IWORK(1) positions of WORK. ! ! IWORK(12) -- Storage parameter ! (default value is 0) ! 0 - All storage IN CORE ! LUN - Homogeneous and inhomogeneous solutions at ! output points and orthonormalization information ! are stored on DISK. The logical unit number to be ! used for DISK I/O (NTAPE) is set to IWORK(12). ! ! WORK(1),... -- Pre-assigned orthonormalization points, stored ! monotonically, corresponding to the direction ! of integration. ! ! ! ! ****************************** ! *** COMPLEX VALUED PROBLEM *** ! ****************************** ! **NOTE*** ! Suppose the original boundary value problem is NC equations ! of the form ! dW/dX = MAT(X,U)*W(X) + H(X,U) ! R*W(Xinitial)=GAMMA , S*W(Xfinal)=DELTA ! ! where all variables are complex valued. The BVSUP code can be ! used by converting to a real system of size 2*NC. To solve the ! larger dimensioned problem efficiently, the user must initialize ! IFLAG=13 on input and order the vector components according to ! Y(1)=real(W(1)),...,Y(NC)=real(W(NC)),Y(NC+1)=imag(W(1)),...., ! Y(2*NC)=imag(W(NC)). Then define ! ........................... ! . real(MAT) -imag(MAT) . ! MATRIX = . . ! . imag(MAT) real(MAT) . ! ........................... ! ! The matrices A,B and vectors G,ALPHA,BETA must be defined ! similarly. Further details can be found in SAND78-1501. ! ! ! ********************************************************************** ! OUTPUT from BVSUP ! ********************************************************************** ! ! Y(NROWY,NXPTS) = Solution at specified output points. ! ! IFLAG output values ! =-5 Algorithm ,for obtaining starting vectors for the ! special complex problem structure, was unable to obtain ! the initial vectors satisfying the necessary ! independence criteria. ! =-4 Rank of boundary condition matrix A is less than NIC, ! as determined by LSSUDS. ! =-2 Invalid input parameters. ! =-1 Insufficient number of storage locations allocated for ! WORK or IWORK. ! ! =0 Indicates successful solution ! ! =1 A computed solution is returned but UNIQUENESS of the ! solution of the boundary-value problem is questionable. ! For an eigenvalue problem, this should be treated as a ! successful execution since this is the expected mode ! of return. ! =2 A computed solution is returned but the EXISTENCE of the ! solution to the boundary-value problem is questionable. ! =3 A nontrivial solution approximation is returned although ! the boundary condition matrix B*Y(Xfinal) is found to be ! nonsingular (to the desired accuracy level) while the ! right hand side vector is zero. To eliminate this type ! of return, the accuracy of the eigenvalue parameter ! must be improved. ! ***NOTE- We attempt to diagnose the correct problem behavior ! and report possible difficulties by the appropriate ! error flag. However, the user should probably resolve ! the problem using smaller error tolerances and/or ! perturbations in the boundary conditions or other ! parameters. This will often reveal the correct ! interpretation for the problem posed. ! ! =13 Maximum number of orthonormalizations attained before ! reaching Xfinal. ! =20-flag from integrator (DERKF or DEABM) values can range ! from 21 to 25. ! =30 Solution vectors form a dependent set. ! ! WORK(1),...,WORK(IWORK(1)) = Orthonormalization points ! determined by BVPOR. ! ! IWORK(1) = Number of orthonormalizations performed by BVPOR. ! ! IWORK(2) = Maximum number of orthonormalizations allowed as ! calculated from storage allocated by user. ! ! IWORK(3),IWORK(4),IWORK(5),IWORK(6) Give information about ! actual storage requirements for WORK and IWORK ! arrays. In particular, ! required storage for WORK array is ! IWORK(3) + IWORK(4)*(expected number of orthonormalizations) ! ! required storage for IWORK array is ! IWORK(5) + IWORK(6)*(expected number of orthonormalizations) ! ! IWORK(8) = Final value of exponent parameter used in tolerance ! test for orthonormalization. ! ! IWORK(16) = Number of independent vectors returned from MGSBV. ! It is only of interest when IFLAG=30 is obtained. ! ! IWORK(17) = Numerically estimated rank of the boundary ! condition matrix defined from B*Y(Xfinal) ! ! ********************************************************************** ! ! Necessary machine constants are defined in the function ! routine R1MACH. The user must make sure that the values ! set in R1MACH are relevant to the computer being used. ! ! ********************************************************************** ! !***REFERENCES M. R. Scott and H. A. Watts, SUPORT - a computer code ! for two-point boundary-value problems via ! orthonormalization, SIAM Journal of Numerical ! Analysis 14, (1977), pp. 40-70. ! B. L. Darlow, M. R. Scott and H. A. Watts, Modifications ! of SUPORT, a linear boundary value problem solver ! Part I - pre-assigning orthonormalization points, ! auxiliary initial value problem, disk or tape storage, ! Report SAND77-1328, Sandia Laboratories, Albuquerque, ! New Mexico, 1977. ! B. L. Darlow, M. R. Scott and H. A. Watts, Modifications ! of SUPORT, a linear boundary value problem solver ! Part II - inclusion of an Adams integrator, Report ! SAND77-1690, Sandia Laboratories, Albuquerque, ! New Mexico, 1977. ! M. E. Lord and H. A. Watts, Modifications of SUPORT, ! a linear boundary value problem solver Part III - ! orthonormalization improvements, Report SAND78-0522, ! Sandia Laboratories, Albuquerque, New Mexico, 1978. ! H. A. Watts, M. R. Scott and M. E. Lord, Computational ! solution of complex*16 valued boundary problems, ! Report SAND78-1501, Sandia Laboratories, ! Albuquerque, New Mexico, 1978. !***ROUTINES CALLED EXBVP, MACON, XERMSG !***COMMON BLOCKS ML15TO, ML17BW, ML18JR, ML5MCO, ML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 890921 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE BVSUP ! ********************************************************************** ! ! DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*), & BETA(*),WORK(*),IWORK(*),XPTS(*) CHARACTER*8 XERN1, XERN2, XERN3, XERN4 ! ! ********************************************************************** ! THE COMMON BLOCK BELOW IS USED TO COMMUNICATE WITH SUBROUTINE ! BVDER. THE USER SHOULD NOT ALTER OR USE THIS COMMON BLOCK IN THE ! CALLING PROGRAM. ! COMMON /ML8SZ/ C,XSAV,IGOFXD,INHOMO,IVP,NCOMPD,NFCD ! ! ********************************************************************** ! THESE COMMON BLOCKS AID IN REDUCING THE NUMBER OF SUBROUTINE ! ARGUMENTS PREVALENT IN THIS MODULAR STRUCTURE ! COMMON /ML18JR/ AED,RED,TOL,NXPTSD,NICD,NOPG,MXNON,NDISK,NTAPE, & NEQ,INDPVT,INTEG,NPS,NTP,NEQIVD,NUMORT,NFCC, & ICOCO COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, & K10,K11,L1,L2,KKKINT,LLLINT ! ! ********************************************************************** ! THIS COMMON BLOCK IS USED IN SUBROUTINES BVSUP,BVPOR,RKFAB, ! REORT, AND STWAY. IT CONTAINS INFORMATION NECESSARY ! FOR THE ORTHONORMALIZATION TESTING PROCEDURE AND A BACKUP ! RESTARTING CAPABILITY. ! COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT ! ! ********************************************************************** ! THIS COMMON BLOCK CONTAINS THE MACHINE DEPENDENT PARAMETERS ! USED BY THE CODE ! COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR ! ! ********************************************************************** ! SET UP MACHINE DEPENDENT CONSTANTS. ! !***FIRST EXECUTABLE STATEMENT BVSUP call MACON ! ! ********************************************************************** ! TEST FOR INVALID INPUT ! if (NROWY < NCOMP) go to 20 if (NCOMP /= NIC+NFC) go to 20 if (NXPTS < 2) go to 20 if (NIC <= 0) go to 20 if (NROWA < NIC) go to 20 if (NFC <= 0) go to 20 if (NROWB < NFC) go to 20 if (IGOFX < 0 .OR. IGOFX > 1) go to 20 if (RE < 0.0) go to 20 if (AE < 0.0) go to 20 if (RE == 0.0 .AND. AE == 0.0) go to 20 IS = 1 if (XPTS(NXPTS) < XPTS(1)) IS = 2 NXPTSM = NXPTS - 1 DO 13 K = 1,NXPTSM if (IS == 2) go to 12 if (XPTS(K+1) <= XPTS(K)) go to 20 go to 13 12 if (XPTS(K) <= XPTS(K+1)) go to 20 13 CONTINUE go to 30 20 IFLAG = -2 return 30 CONTINUE ! ! ********************************************************************** ! CHECK FOR DISK STORAGE ! KPTS = NXPTS NDISK = 0 if (IWORK(12) == 0) go to 35 NTAPE = IWORK(12) KPTS = 1 NDISK = 1 35 CONTINUE ! ! ********************************************************************** ! SET INTEG PARAMETER ACCORDING TO CHOICE OF INTEGRATOR. ! INTEG = 1 if (IWORK(9) == 2) INTEG = 2 ! ! ********************************************************************** ! COMPUTE INHOMO ! if (IGOFX == 1) go to 43 DO 40 J = 1,NIC if (ALPHA(J) /= 0.0) go to 43 40 CONTINUE DO 41 J = 1,NFC if (BETA(J) /= 0.0) go to 42 41 CONTINUE INHOMO = 3 go to 45 42 INHOMO = 2 go to 45 43 INHOMO = 1 45 CONTINUE ! ! ********************************************************************** ! TO TAKE ADVANTAGE OF THE SPECIAL STRUCTURE WHEN SOLVING A ! COMPLEX VALUED PROBLEM,WE INTRODUCE NFCC=NFC WHILE CHANGING ! THE INTERNAL VALUE OF NFC ! NFCC=NFC if (IFLAG == 13) NFC=NFC/2 ! ! ********************************************************************** ! DETERMINE NECESSARY STORAGE REQUIREMENTS ! ! FOR BASIC ARRAYS IN BVPOR KKKYHP = NCOMP*(NFC+1) + NEQIVP KKKU = NCOMP*NFC*KPTS KKKV = NCOMP*KPTS KKKCOE = NFCC KKKS = NFC+1 KKKSTO = NCOMP*(NFC+1) + NEQIVP + 1 KKKG = NCOMP ! ! FOR ORTHONORMALIZATION RELATED MATTERS NTP = (NFCC*(NFCC+1))/2 KKKZPW = 1 + NTP + NFCC LLLIP = NFCC ! ! FOR ADDITIONAL REQUIRED WORK SPACE ! (LSSUDS) KKKSUD = 4*NIC + (NROWA+1)*NCOMP LLLSUD = NIC ! (SVECS) KKKSVC = 1 + 4*NFCC + 2*NFCC**2 LLLSVC = 2*NFCC ! NDEQ=NCOMP*NFC+NEQIVP if (INHOMO == 1) NDEQ=NDEQ+NCOMP go to (51,52),INTEG ! (DERKF) 51 KKKINT = 33 + 7*NDEQ LLLINT = 34 go to 55 ! (DEABM) 52 KKKINT = 130 + 21*NDEQ LLLINT = 51 ! ! (COEF) 55 KKKCOF = 5*NFCC + NFCC**2 LLLCOF = 3 + NFCC ! KKKWS = MAX(KKKSUD,KKKSVC,KKKINT,KKKCOF) LLLIWS = MAX(LLLSUD,LLLSVC,LLLINT,LLLCOF) ! NEEDW = KKKYHP + KKKU + KKKV + KKKCOE + KKKS + KKKSTO + KKKG + & KKKZPW + KKKWS NEEDIW = 17 + LLLIP + LLLIWS ! ********************************************************************** ! COMPUTE THE NUMBER OF POSSIBLE ORTHONORMALIZATIONS WITH THE ! ALLOTTED STORAGE ! IWORK(3) = NEEDW IWORK(4) = KKKZPW IWORK(5) = NEEDIW IWORK(6) = LLLIP NRTEMP = NDW - NEEDW NITEMP = NDIW - NEEDIW if (NRTEMP < 0) go to 70 if (NITEMP >= 0) go to 75 ! 70 IFLAG = -1 if (NDISK /= 1) THEN WRITE (XERN1, '(I8)') NEEDW WRITE (XERN2, '(I8)') KKKZPW WRITE (XERN3, '(I8)') NEEDIW WRITE (XERN4, '(I8)') LLLIP call XERMSG ('SLATEC', 'BVSUP', & 'REQUIRED STORAGE FOR WORK ARRAY IS ' // XERN1 // ' + ' // & XERN2 // '*(EXPECTED NUMBER OF ORTHONORMALIZATIONS) $$' // & 'REQUIRED STORAGE FOR IWORK ARRAY IS ' // XERN3 // ' + ' // & XERN4 // '*(EXPECTED NUMBER OF ORTHONORMALIZATIONS)', 1, 0) ELSE WRITE (XERN1, '(I8)') NEEDW WRITE (XERN2, '(I8)') NEEDIW call XERMSG ('SLATEC', 'BVSUP', & 'REQUIRED STORAGE FOR WORK ARRAY IS ' // XERN1 // & ' + NUMBER OF ORTHONOMALIZATIONS. $$' // & 'REQUIRED STORAGE FOR IWORK ARRAY IS ' // XERN2, 1, 0) end if return ! 75 if (NDISK == 0) go to 77 NON = 0 MXNON = NRTEMP go to 78 ! 77 MXNONR = NRTEMP / KKKZPW MXNONI = NITEMP / LLLIP MXNON = MIN(MXNONR,MXNONI) NON = MXNON ! 78 IWORK(2) = MXNON ! ! ********************************************************************** ! CHECK FOR PRE-ASSIGNED ORTHONORMALIZATION POINTS ! NOPG = 0 if (IWORK(11) /= 1) go to 85 if (MXNON < IWORK(1)) go to 70 NOPG = 1 MXNON = IWORK(1) WORK(MXNON+1) = 2. * XPTS(NXPTS) - XPTS(1) 85 CONTINUE ! ! ********************************************************************** ! ALLOCATE STORAGE FROM WORK AND IWORK ARRAYS ! ! (Z) K1 = 1 + (MXNON+1) ! (P) K2 = K1 + NTP*(NON+1) ! (W) K3 = K2 + NFCC*(NON+1) ! (YHP) K4 = K3 + KKKYHP ! (U) K5 = K4 + KKKU ! (V) K6 = K5 + KKKV ! (COEF) K7 = K6 + KKKCOE ! (S) K8 = K7 + KKKS ! (STOWA) K9 = K8 + KKKSTO ! (G) K10 = K9 + KKKG K11 = K10 + KKKWS ! REQUIRED ADDITIONAL REAL WORK SPACE STARTS AT WORK(K10) ! AND EXTENDS TO WORK(K11-1) ! ! FIRST 17 LOCATIONS OF IWORK ARE USED FOR OPTIONAL ! INPUT AND OUTPUT ITEMS ! (IP) L1 = 18 + NFCC*(NON+1) L2 = L1 + LLLIWS ! REQUIRED INTEGER WORK SPACE STARTS AT IWORK(L1) ! AND EXTENDS TO IWORK(L2-1) ! ! ********************************************************************** ! SET INDICATOR FOR NORMALIZATION OF PARTICULAR SOLUTION ! NPS = 0 if (IWORK(10) == 1) NPS = 1 ! ! ********************************************************************** ! SET PIVOTING PARAMETER ! INDPVT=0 if (IWORK(15) == 1) INDPVT=1 ! ! ********************************************************************** ! SET OTHER COMMON BLOCK PARAMETERS ! NFCD = NFC NCOMPD = NCOMP IGOFXD = IGOFX NXPTSD = NXPTS NICD = NIC RED = RE AED = AE NEQIVD = NEQIVP MNSWOT = 20 if (IWORK(13) == -1) MNSWOT=MAX(1,IWORK(14)) XBEG=XPTS(1) XEND=XPTS(NXPTS) XSAV=XEND ICOCO=1 if (INHOMO == 3 .AND. NOPG == 1) WORK(MXNON+1)=XEND ! ! ********************************************************************** ! call EXBVP(Y,NROWY,XPTS,A,NROWA,ALPHA,B,NROWB,BETA,IFLAG,WORK, & IWORK) NFC=NFCC IWORK(17)=IWORK(L1) return end FUNCTION C0LGMC (Z) ! !! C0LGMC evaluates (Z+0.5)*LOG((Z+1.)/Z) - 1.0 with relative accuracy. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE COMPLEX (C0LGMC-C) !***KEYWORDS FNLIB, GAMMA FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate (Z+0.5)*LOG((Z+1.0)/Z) - 1.0 with relative error accuracy ! Let Q = 1.0/Z so that ! (Z+0.5)*LOG(1+1/Z) - 1 = (Z+0.5)*(LOG(1+Q) - Q + Q*Q/2) - Q*Q/4 ! = (Z+0.5)*Q**3*C9LN2R(Q) - Q**2/4, ! where C9LN2R is (LOG(1+Q) - Q + 0.5*Q**2) / Q**3. ! !***REFERENCES (NONE) !***ROUTINES CALLED C9LN2R, R1MACH !***REVISION HISTORY (YYMMDD) ! 780401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE C0LGMC COMPLEX C0LGMC COMPLEX Z, Q, C9LN2R SAVE RBIG DATA RBIG / 0.0 / !***FIRST EXECUTABLE STATEMENT C0LGMC if (RBIG == 0.0) RBIG = 1.0/R1MACH(3) CABSZ = ABS(Z) if ( CABSZ > RBIG ) then C0LGMC = -(Z+0.5)*LOG(Z) - Z RETURN end if Q = 1.0/Z if (CABSZ <= 1.23) C0LGMC = (Z+0.5)*LOG(1.0+Q) - 1.0 if (CABSZ > 1.23) C0LGMC = ((1.+.5*Q)*C9LN2R(Q) - .25) * Q**2 return end subroutine C1MERG (TCOS, I1, M1, I2, M2, I3) ! !! C1MERG merges two strings of complex numbers. Each string is ... ! ascending by the real part. ! !***LIBRARY SLATEC !***TYPE COMPLEX (S1MERG-S, D1MERG-D, C1MERG-C, I1MERG-I) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine merges two ascending strings of numbers in the ! array TCOS. The first string is of length M1 and starts at ! TCOS(I1+1). The second string is of length M2 and starts at ! TCOS(I2+1). The merged string goes into TCOS(I3+1). The ordering ! is on the real part. ! !***SEE ALSO CMGNBN !***ROUTINES CALLED CCOPY !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 910408 Modified to use IF-THEN-ELSE. Make it look like MERGE ! which was modified earlier due to compiler problems on ! the IBM RS6000. (RWC) ! 920130 Code name changed from CMPMRG to C1MERG. (WRB) !***END PROLOGUE C1MERG INTEGER I1, I2, I3, M1, M2 COMPLEX TCOS(*) ! INTEGER J1, J2, J3 ! !***FIRST EXECUTABLE STATEMENT C1MERG if (M1 == 0 .AND. M2 == 0) RETURN ! if (M1 == 0 .AND. M2 /= 0) THEN call CCOPY (M2, TCOS(I2+1), 1, TCOS(I3+1), 1) return end if ! if (M1 /= 0 .AND. M2 == 0) THEN call CCOPY (M1, TCOS(I1+1), 1, TCOS(I3+1), 1) return end if ! J1 = 1 J2 = 1 J3 = 1 ! 10 if (REAL(TCOS(J1+I1)) <= REAL(TCOS(I2+J2))) THEN TCOS(I3+J3) = TCOS(I1+J1) J1 = J1+1 if (J1 > M1) THEN call CCOPY (M2-J2+1, TCOS(I2+J2), 1, TCOS(I3+J3+1), 1) return ENDIF ELSE TCOS(I3+J3) = TCOS(I2+J2) J2 = J2+1 if (J2 > M2) THEN call CCOPY (M1-J1+1, TCOS(I1+J1), 1, TCOS(I3+J3+1), 1) return ENDIF end if J3 = J3+1 go to 10 end FUNCTION C9LGMC (ZIN) ! !! C9LGMC computes the log gamma correction factor so that ... ! LOG(CGAMMA(Z)) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z + C9LGMC(Z). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE COMPLEX (R9LGMC-S, D9LGMC-D, C9LGMC-C) !***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, ! LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute the LOG GAMMA correction term for large ABS(Z) when REAL(Z) ! >= 0.0 and for large ABS(AIMAG(Y)) when REAL(Z) < 0.0. We find ! C9LGMC so that ! LOG(Z) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z + C9LGMC(Z) ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 780401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE C9LGMC COMPLEX C9LGMC COMPLEX ZIN, Z, Z2INV DIMENSION BERN(11) LOGICAL FIRST SAVE BERN, NTERM, BOUND, XBIG, XMAX, FIRST DATA BERN( 1) / .083333333333333333E0 / DATA BERN( 2) / -.0027777777777777778E0 / DATA BERN( 3) / .00079365079365079365E0 / DATA BERN( 4) / -.00059523809523809524E0 / DATA BERN( 5) / .00084175084175084175E0 / DATA BERN( 6) / -.0019175269175269175E0 / DATA BERN( 7) / .0064102564102564103E0 / DATA BERN( 8) / -.029550653594771242E0 / DATA BERN( 9) / .17964437236883057E0 / DATA BERN(10) / -1.3924322169059011E0 / DATA BERN(11) / 13.402864044168392E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT C9LGMC if (FIRST) THEN NTERM = -0.30*LOG(R1MACH(3)) BOUND = 0.1170*NTERM*(0.1*R1MACH(3))**(-1./(2*NTERM-1)) XBIG = 1.0/SQRT(R1MACH(3)) XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.*R1MACH(1))) ) end if FIRST = .FALSE. ! Z = ZIN X = REAL (Z) Y = AIMAG(Z) CABSZ = ABS(Z) if (X < 0.0 .AND. ABS(Y) < BOUND) call XERMSG ('SLATEC', & 'C9LGMC', 'NOT VALID FOR NEGATIVE REAL(Z) AND SMALL ' // & 'ABS(AIMAG(Z))', 2, 2) if (CABSZ < BOUND) call XERMSG ('SLATEC', 'C9LGMC', & 'NOT VALID FOR SMALL ABS(Z)', 3, 2) if (CABSZ >= XMAX) go to 50 if (CABSZ >= XBIG) C9LGMC = 1.0/(12.0*Z) if (CABSZ >= XBIG) RETURN Z2INV = 1.0/Z**2 C9LGMC = (0.0, 0.0) DO I=1,NTERM NDX = NTERM + 1 - I C9LGMC = BERN(NDX) + C9LGMC*Z2INV end do C9LGMC = C9LGMC/Z return 50 C9LGMC = (0.0, 0.0) call XERMSG ('SLATEC', 'C9LGMC', 'Z SO BIG C9LGMC UNDERFLOWS', 1, & 1) return end FUNCTION C9LN2R (Z) ! !! C9LN2R evaluates LOG(1+Z) from second order relative accuracy so ... ! that LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4B !***TYPE COMPLEX (R9LN2R-S, D9LN2R-D, C9LN2R-C) !***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM, SECOND ORDER !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate LOG(1+Z) from 2-nd order with relative error accuracy so ! that LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z). ! ! Now LOG(1+Z) = 0.5*LOG(1+2*X+ABS(Z)**2) + I*CARG(1+Z), ! where X = REAL(Z) and Y = AIMAG(Z). ! We find ! Z**3 * C9LN2R(Z) = -X*ABS(Z)**2 - 0.25*ABS(Z)**4 ! + (2*X+ABS(Z)**2)**3 * R9LN2R(2*X+ABS(Z)**2) ! + I * (CARG(1+Z) + (X-1)*Y) ! The imaginary part must be evaluated carefully as ! (ATAN(Y/(1+X)) - Y/(1+X)) + Y/(1+X) - (1-X)*Y ! = (Y/(1+X))**3 * R9ATN1(Y/(1+X)) + X**2*Y/(1+X) ! ! Now we divide through by Z**3 carefully. Write ! 1/Z**3 = (X-I*Y)/ABS(Z)**3 * (1/ABS(Z)**3) ! then C9LN2R(Z) = ((X-I*Y)/ABS(Z))**3 * (-X/ABS(Z) - ABS(Z)/4 ! + 0.5*((2*X+ABS(Z)**2)/ABS(Z))**3 * R9LN2R(2*X+ABS(Z)**2) ! + I*Y/(ABS(Z)*(1+X)) * ((X/ABS(Z))**2 + ! + (Y/(ABS(Z)*(1+X)))**2 * R9ATN1(Y/(1+X)) ) ) ! ! If we let XZ = X/ABS(Z) and YZ = Y/ABS(Z) we may write ! C9LN2R(Z) = (XZ-I*YZ)**3 * (-XZ - ABS(Z)/4 ! + 0.5*(2*XZ+ABS(Z))**3 * R9LN2R(2*X+ABS(Z)**2) ! + I*YZ/(1+X) * (XZ**2 + (YZ/(1+X))**2*R9ATN1(Y/(1+X)) )) ! !***REFERENCES (NONE) !***ROUTINES CALLED R9ATN1, R9LN2R !***REVISION HISTORY (YYMMDD) ! 780401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE C9LN2R COMPLEX C9LN2R COMPLEX Z !***FIRST EXECUTABLE STATEMENT C9LN2R X = REAL (Z) Y = AIMAG (Z) ! CABSZ = ABS(Z) if (CABSZ > 0.8125) go to 20 ! C9LN2R = CMPLX (1.0/3.0, 0.0) if (CABSZ == 0.0) RETURN ! XZ = X/CABSZ YZ = Y/CABSZ ! ARG = 2.0*XZ + CABSZ RPART = 0.5*ARG**3*R9LN2R(CABSZ*ARG) - XZ - 0.25*CABSZ Y1X = YZ/(1.0+X) AIPART = Y1X * (XZ**2 + Y1X**2*R9ATN1(CABSZ*Y1X) ) ! C9LN2R = CMPLX(XZ,-YZ)**3 * CMPLX(RPART,AIPART) return ! 20 C9LN2R = (LOG(1.0+Z) - Z*(1.0-0.5*Z)) / Z**3 return ! end subroutine CACAI (Z, FNU, KODE, MR, N, Y, NZ, RL, TOL, ELIM, ALIM) ! !! CACAI is subsidiary to CAIRY. ! !***LIBRARY SLATEC !***TYPE ALL (CACAI-A, ZACAI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CACAI APPLIES THE ANALYTIC CONTINUATION FORMULA ! ! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) ! MP=PI*MR*CMPLX(0.0,1.0) ! ! TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT ! HALF Z PLANE FOR USE WITH CAIRY WHERE FNU=1/3 OR 2/3 AND N=1. ! CACAI IS THE SAME AS CACON WITH THE PARTS FOR LARGER ORDERS AND ! RECURRENCE REMOVED. A RECURSIVE call TO CACON CAN RESULT if CACON ! IS CALLED FROM CAIRY. ! !***SEE ALSO CAIRY !***ROUTINES CALLED CASYI, CBKNU, CMLRI, CS1S2, CSERI, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CACAI COMPLEX CSGN, CSPN, C1, C2, Y, Z, ZN, CY REAL ALIM, ARG, ASCLE, AZ, CPN, DFNU, ELIM, FMR, FNU, PI, RL, & SGN, SPN, TOL, YY, R1MACH INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ DIMENSION Y(N), CY(2) DATA PI / 3.14159265358979324E0 / !***FIRST EXECUTABLE STATEMENT CACAI NZ = 0 ZN = -Z AZ = ABS(Z) NN = N DFNU = FNU + (N-1) if (AZ <= 2.0E0) go to 10 if (AZ*AZ*0.25E0 > DFNU+1.0E0) go to 20 10 CONTINUE !----------------------------------------------------------------------- ! POWER SERIES FOR THE I FUNCTION !----------------------------------------------------------------------- call CSERI(ZN, FNU, KODE, NN, Y, NW, TOL, ELIM, ALIM) go to 40 20 CONTINUE if (AZ < RL) go to 30 !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION !----------------------------------------------------------------------- call CASYI(ZN, FNU, KODE, NN, Y, NW, RL, TOL, ELIM, ALIM) if (NW < 0) go to 70 go to 40 30 CONTINUE !----------------------------------------------------------------------- ! MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION !----------------------------------------------------------------------- call CMLRI(ZN, FNU, KODE, NN, Y, NW, TOL) if ( NW < 0) go to 70 40 CONTINUE !----------------------------------------------------------------------- ! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION !----------------------------------------------------------------------- call CBKNU(ZN, FNU, KODE, 1, CY, NW, TOL, ELIM, ALIM) if (NW /= 0) go to 70 FMR = MR SGN = -SIGN(PI,FMR) CSGN = CMPLX(0.0E0,SGN) if (KODE == 1) go to 50 YY = -AIMAG(ZN) CPN = COS(YY) SPN = SIN(YY) CSGN = CSGN*CMPLX(CPN,SPN) 50 CONTINUE !----------------------------------------------------------------------- ! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE !----------------------------------------------------------------------- INU = FNU ARG = (FNU-INU)*SGN CPN = COS(ARG) SPN = SIN(ARG) CSPN = CMPLX(CPN,SPN) if (MOD(INU,2) == 1) CSPN = -CSPN C1 = CY(1) C2 = Y(1) if (KODE == 1) go to 60 IUF = 0 ASCLE = 1.0E+3*R1MACH(1)/TOL call CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) NZ = NZ + NW 60 CONTINUE Y(1) = CSPN*C1 + CSGN*C2 return 70 CONTINUE NZ = -1 if ( NW == (-2)) NZ=-2 return end subroutine CACON (Z, FNU, KODE, MR, N, Y, NZ, RL, FNUL, TOL, ELIM, & ALIM) ! !! CACON is subsidiary to CBESH and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CACON-A, ZACON-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CACON APPLIES THE ANALYTIC CONTINUATION FORMULA ! ! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) ! MP=PI*MR*CMPLX(0.0,1.0) ! ! TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT ! HALF Z PLANE ! !***SEE ALSO CBESH, CBESK !***ROUTINES CALLED CBINU, CBKNU, CS1S2, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CACON COMPLEX CK, CONE, CS, CSCL, CSCR, CSGN, CSPN, CSS, CSR, C1, C2, & RZ, SC1, SC2, ST, S1, S2, Y, Z, ZN, CY REAL ALIM, ARG, ASCLE, AS2, BSCLE, BRY, CPN, C1I, C1M, C1R, ELIM, & FMR, FNU, FNUL, PI, RL, SGN, SPN, TOL, YY, R1MACH INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ DIMENSION Y(N), CY(2), CSS(3), CSR(3), BRY(3) DATA PI / 3.14159265358979324E0 / DATA CONE / (1.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CACON NZ = 0 ZN = -Z NN = N call CBINU(ZN, FNU, KODE, NN, Y, NW, RL, FNUL, TOL, ELIM, ALIM) if (NW < 0) go to 80 !----------------------------------------------------------------------- ! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION !----------------------------------------------------------------------- NN = MIN(2,N) call CBKNU(ZN, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM) if (NW /= 0) go to 80 S1 = CY(1) FMR = MR SGN = -SIGN(PI,FMR) CSGN = CMPLX(0.0E0,SGN) if (KODE == 1) go to 10 YY = -AIMAG(ZN) CPN = COS(YY) SPN = SIN(YY) CSGN = CSGN*CMPLX(CPN,SPN) 10 CONTINUE !----------------------------------------------------------------------- ! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE !----------------------------------------------------------------------- INU = FNU ARG = (FNU-INU)*SGN CPN = COS(ARG) SPN = SIN(ARG) CSPN = CMPLX(CPN,SPN) if (MOD(INU,2) == 1) CSPN = -CSPN IUF = 0 C1 = S1 C2 = Y(1) ASCLE = 1.0E+3*R1MACH(1)/TOL if (KODE == 1) go to 20 call CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC1 = C1 20 CONTINUE Y(1) = CSPN*C1 + CSGN*C2 if (N == 1) RETURN CSPN = -CSPN S2 = CY(2) C1 = S2 C2 = Y(2) if (KODE == 1) go to 30 call CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC2 = C1 30 CONTINUE Y(2) = CSPN*C1 + CSGN*C2 if (N == 2) RETURN CSPN = -CSPN RZ = CMPLX(2.0E0,0.0E0)/ZN CK = CMPLX(FNU+1.0E0,0.0E0)*RZ !----------------------------------------------------------------------- ! SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS !----------------------------------------------------------------------- CSCL = CMPLX(1.0E0/TOL,0.0E0) CSCR = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CSCR CSR(1) = CSCR CSR(2) = CONE CSR(3) = CSCL BRY(1) = ASCLE BRY(2) = 1.0E0/ASCLE BRY(3) = R1MACH(2) AS2 = ABS(S2) KFLAG = 2 if (AS2 > BRY(1)) go to 40 KFLAG = 1 go to 50 40 CONTINUE if (AS2 < BRY(2)) go to 50 KFLAG = 3 50 CONTINUE BSCLE = BRY(KFLAG) S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) CS = CSR(KFLAG) DO 70 I=3,N ST = S2 S2 = CK*S2 + S1 S1 = ST C1 = S2*CS ST = C1 C2 = Y(I) if (KODE == 1) go to 60 if (IUF < 0) go to 60 call CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC1 = SC2 SC2 = C1 if (IUF /= 3) go to 60 IUF = -4 S1 = SC1*CSS(KFLAG) S2 = SC2*CSS(KFLAG) ST = SC2 60 CONTINUE Y(I) = CSPN*C1 + CSGN*C2 CK = CK + RZ CSPN = -CSPN if (KFLAG >= 3) go to 70 C1R = REAL(C1) C1I = AIMAG(C1) C1R = ABS(C1R) C1I = ABS(C1I) C1M = MAX(C1R,C1I) if (C1M <= BSCLE) go to 70 KFLAG = KFLAG + 1 BSCLE = BRY(KFLAG) S1 = S1*CS S2 = ST S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) CS = CSR(KFLAG) 70 CONTINUE return 80 CONTINUE NZ = -1 if ( NW == (-2)) NZ=-2 return end FUNCTION CACOS (Z) ! !! CACOS computes the complex arc cosine. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE COMPLEX (CACOS-C) !***KEYWORDS ARC COSINE, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CACOS(Z) calculates the complex trigonometric arc cosine of Z. ! The result is in units of radians, and the real part is in the ! first or second quadrant. ! !***REFERENCES (NONE) !***ROUTINES CALLED CASIN !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CACOS COMPLEX CACOS COMPLEX Z, CASIN SAVE PI2 DATA PI2 /1.57079632679489661923E0/ !***FIRST EXECUTABLE STATEMENT CACOS CACOS = PI2 - CASIN (Z) ! return end FUNCTION CACOSH (Z) ! !! CACOSH computes the arc hyperbolic cosine. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE COMPLEX (ACOSH-S, DACOSH-D, CACOSH-C) !***KEYWORDS ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB, ! INVERSE HYPERBOLIC COSINE !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CACOSH(Z) calculates the complex arc hyperbolic cosine of Z. ! !***REFERENCES (NONE) !***ROUTINES CALLED CACOS !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CACOSH COMPLEX CACOSH COMPLEX Z, CI, CACOS SAVE CI DATA CI /(0.,1.)/ !***FIRST EXECUTABLE STATEMENT CACOSH CACOSH = CI*CACOS(Z) ! return end subroutine CAIRY (Z, ID, KODE, AI, NZ, IERR) ! !! CAIRY computes the Airy function Ai(z) or its derivative dAi/dz ... ! for complex argument z. A scaling option is available ... ! to help avoid underflow and overflow. ! !***LIBRARY SLATEC !***CATEGORY C10D !***TYPE COMPLEX (CAIRY-C, ZAIRY-C) !***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, ! BESSEL FUNCTION OF ORDER TWO THIRDS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! On KODE=1, CAIRY computes the complex Airy function Ai(z) ! or its derivative dAi/dz on ID=0 or ID=1 respectively. On ! KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz ! is provided to remove the exponential decay in -pi/31 and from power series when abs(z)<=1. ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z is large, losses ! of significance by argument reduction occur. Consequently, if ! the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), ! then losses exceeding half precision are likely and an error ! flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. ! Also, if the magnitude of ZETA is larger than U2=0.5/UR, then ! all significance is lost and IERR=4. In order to use the INT ! function, ZETA must be further restricted not to exceed ! U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA ! must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, ! and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single ! precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. ! This makes U2 limiting is single precision and U3 limiting ! in double precision. This means that the magnitude of Z ! cannot exceed approximately 3.4E+4 in single precision and ! 2.1E+6 in double precision. This also means that one can ! expect to retain, in the worst cases on 32-bit machines, ! no digits in single precision and only 6 digits in double ! precision. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 3. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 4. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED CACAI, CBKNU, I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE CAIRY COMPLEX AI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3 REAL AA, AD, AK, ALIM, ATRM, AZ, AZ3, BK, CK, COEF, C1, C2, DIG, & DK, D1, D2, ELIM, FID, FNU, RL, R1M5, SFAC, TOL, TTH, ZI, ZR, & Z3I, Z3R, R1MACH, BB, ALAZ INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH DIMENSION CY(1) DATA TTH, C1, C2, COEF /6.66666666666666667E-01, & 3.55028053887817240E-01,2.58819403792806799E-01, & 1.83776298473930683E-01/ DATA CONE / (1.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CAIRY IERR = 0 NZ=0 if (ID < 0 .OR. ID > 1) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (IERR /= 0) RETURN AZ = ABS(Z) TOL = MAX(R1MACH(4),1.0E-18) FID = ID if (AZ > 1.0E0) go to 60 !----------------------------------------------------------------------- ! POWER SERIES FOR ABS(Z) <= 1. !----------------------------------------------------------------------- S1 = CONE S2 = CONE if (AZ < TOL) go to 160 AA = AZ*AZ if (AA < TOL/AZ) go to 40 TRM1 = CONE TRM2 = CONE ATRM = 1.0E0 Z3 = Z*Z*Z AZ3 = AZ*AA AK = 2.0E0 + FID BK = 3.0E0 - FID - FID CK = 4.0E0 - FID DK = 3.0E0 + FID + FID D1 = AK*DK D2 = BK*CK AD = MIN(D1,D2) AK = 24.0E0 + 9.0E0*FID BK = 30.0E0 - 9.0E0*FID Z3R = REAL(Z3) Z3I = AIMAG(Z3) DO 30 K=1,25 TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1) S1 = S1 + TRM1 TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2) S2 = S2 + TRM2 ATRM = ATRM*AZ3/AD D1 = D1 + AK D2 = D2 + BK AD = MIN(D1,D2) if (ATRM < TOL*AD) go to 40 AK = AK + 18.0E0 BK = BK + 18.0E0 30 CONTINUE 40 CONTINUE if (ID == 1) go to 50 AI = S1*CMPLX(C1,0.0E0) - Z*S2*CMPLX(C2,0.0E0) if (KODE == 1) RETURN ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) AI = AI*CEXP(ZTA) return 50 CONTINUE AI = -S2*CMPLX(C2,0.0E0) if (AZ > TOL) AI = AI + Z*Z*S1*CMPLX(C1/(1.0E0+FID),0.0E0) if (KODE == 1) RETURN ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) AI = AI*CEXP(ZTA) return !----------------------------------------------------------------------- ! CASE FOR ABS(Z) > 1.0 !----------------------------------------------------------------------- 60 CONTINUE FNU = (1.0E0+FID)/3.0E0 !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). !----------------------------------------------------------------------- K1 = I1MACH(12) K2 = I1MACH(13) R1M5 = R1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) K1 = I1MACH(11) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0E0) AA = AA*2.303E0 ALIM = ELIM + MAX(-AA,-41.45E0) RL = 1.2E0*DIG + 3.0E0 ALAZ=ALOG(AZ) !----------------------------------------------------------------------- ! TEST FOR RANGE !----------------------------------------------------------------------- AA=0.5E0/TOL BB=I1MACH(9)*0.5E0 AA=MIN(AA,BB) AA=AA**TTH if (AZ > AA) go to 260 AA=SQRT(AA) if (AZ > AA) IERR=3 CSQ=CSQRT(Z) ZTA=Z*CSQ*CMPLX(TTH,0.0E0) !----------------------------------------------------------------------- ! RE(ZTA) <= 0 WHEN RE(Z) < 0, ESPECIALLY WHEN IM(Z) IS SMALL !----------------------------------------------------------------------- IFLAG = 0 SFAC = 1.0E0 ZI = AIMAG(Z) ZR = REAL(Z) AK = AIMAG(ZTA) if (ZR >= 0.0E0) go to 70 BK = REAL(ZTA) CK = -ABS(BK) ZTA = CMPLX(CK,AK) 70 CONTINUE if (ZI /= 0.0E0) go to 80 if (ZR > 0.0E0) go to 80 ZTA = CMPLX(0.0E0,AK) 80 CONTINUE AA = REAL(ZTA) if (AA >= 0.0E0 .AND. ZR > 0.0E0) go to 100 if (KODE == 2) go to 90 !----------------------------------------------------------------------- ! OVERFLOW TEST !----------------------------------------------------------------------- if (AA > (-ALIM)) go to 90 AA = -AA + 0.25E0*ALAZ IFLAG = 1 SFAC = TOL if (AA > ELIM) go to 240 90 CONTINUE !----------------------------------------------------------------------- ! CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 !----------------------------------------------------------------------- MR = 1 if (ZI < 0.0E0) MR = -1 call CACAI(ZTA, FNU, KODE, MR, 1, CY, NN, RL, TOL, ELIM, ALIM) if (NN < 0) go to 250 NZ = NZ + NN go to 120 100 CONTINUE if (KODE == 2) go to 110 !----------------------------------------------------------------------- ! UNDERFLOW TEST !----------------------------------------------------------------------- if (AA < ALIM) go to 110 AA = -AA - 0.25E0*ALAZ IFLAG = 2 SFAC = 1.0E0/TOL if (AA < (-ELIM)) go to 180 110 CONTINUE call CBKNU(ZTA, FNU, KODE, 1, CY, NZ, TOL, ELIM, ALIM) 120 CONTINUE S1 = CY(1)*CMPLX(COEF,0.0E0) if (IFLAG /= 0) go to 140 if (ID == 1) go to 130 AI = CSQ*S1 return 130 AI = -Z*S1 return 140 CONTINUE S1 = S1*CMPLX(SFAC,0.0E0) if (ID == 1) go to 150 S1 = S1*CSQ AI = S1*CMPLX(1.0E0/SFAC,0.0E0) return 150 CONTINUE S1 = -S1*Z AI = S1*CMPLX(1.0E0/SFAC,0.0E0) return 160 CONTINUE AA = 1.0E+3*R1MACH(1) S1 = CMPLX(0.0E0,0.0E0) if (ID == 1) go to 170 if (AZ > AA) S1 = CMPLX(C2,0.0E0)*Z AI = CMPLX(C1,0.0E0) - S1 return 170 CONTINUE AI = -CMPLX(C2,0.0E0) AA = SQRT(AA) if (AZ > AA) S1 = Z*Z*CMPLX(0.5E0,0.0E0) AI = AI + S1*CMPLX(C1,0.0E0) return 180 CONTINUE NZ = 1 AI = CMPLX(0.0E0,0.0E0) return 240 CONTINUE NZ = 0 IERR=2 return 250 CONTINUE if ( NN == (-1)) go to 240 NZ=0 IERR=5 return 260 CONTINUE IERR=4 NZ=0 return end function CARG (Z) ! !! CARG computes the argument of a complex number. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY A4A !***TYPE COMPLEX (CARG-C) !***KEYWORDS ARGUMENT OF A COMPLEX NUMBER, ELEMENTARY FUNCTIONS, FNLIB !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CARG(Z) calculates the argument of the complex number Z. Note ! that CARG returns a real result. If Z = X+iY, then ! CARG is ATAN(Y/X), except when both X and Y are zero, in which ! case the result will be zero. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CARG ! real carg complex Z ! !***FIRST EXECUTABLE STATEMENT CARG ! CARG = 0.0 if (REAL(Z) /= 0. .OR. AIMAG(Z) /= 0.) then CARG = ATAN2 ( AIMAG(Z), REAL(Z) ) end if return end FUNCTION CASIN (ZINP) ! !! CASIN computes the complex arc sine. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE COMPLEX (CASIN-C) !***KEYWORDS ARC SINE, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CASIN(ZINP) calculates the complex trigonometric arc sine of ZINP. ! The result is in units of radians, and the real part is in the first ! or fourth quadrant. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CASIN COMPLEX CASIN COMPLEX ZINP, Z, Z2, SQZP1, CI LOGICAL FIRST SAVE PI2, PI, CI, NTERMS, RMIN, FIRST DATA PI2 /1.57079632679489661923E0/ DATA PI /3.14159265358979324E0/ DATA CI /(0.,1.)/ DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT CASIN if (FIRST) THEN ! NTERMS = LOG(EPS)/LOG(RMAX) WHERE RMAX = 0.1 NTERMS = -0.4343*LOG(R1MACH(3)) RMIN = SQRT (6.0*R1MACH(3)) end if FIRST = .FALSE. ! Z = ZINP R = ABS (Z) if (R > 0.1) go to 30 ! CASIN = Z if (R < RMIN) RETURN ! CASIN = (0.0, 0.0) Z2 = Z*Z DO 20 I=1,NTERMS TWOI = 2*(NTERMS-I) + 1 CASIN = 1.0/TWOI + TWOI*CASIN*Z2/(TWOI+1.0) 20 CONTINUE CASIN = Z*CASIN return ! 30 if (REAL(ZINP) < 0.0) Z = -ZINP ! SQZP1 = SQRT (Z+1.0) if (AIMAG(SQZP1) < 0.) SQZP1 = -SQZP1 CASIN = PI2 - CI * LOG (Z + SQZP1*SQRT(Z-1.0)) ! if (REAL(CASIN) > PI2) CASIN = PI - CASIN if (REAL(CASIN) <= (-PI2)) CASIN = -PI - CASIN if (REAL(ZINP) < 0.) CASIN = -CASIN return end FUNCTION CASINH (Z) ! !! CASINH computes the arc hyperbolic sine. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE COMPLEX (ASINH-S, DASINH-D, CASINH-C) !***KEYWORDS ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB, ! INVERSE HYPERBOLIC SINE !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CASINH(Z) calculates the complex arc hyperbolic sine of Z. ! !***REFERENCES (NONE) !***ROUTINES CALLED CASIN !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CASINH COMPLEX CASINH COMPLEX Z, CI, CASIN SAVE CI DATA CI /(0.,1.)/ !***FIRST EXECUTABLE STATEMENT CASINH CASINH = -CI*CASIN (CI*Z) ! return end subroutine CASYI (Z, FNU, KODE, N, Y, NZ, RL, TOL, ELIM, ALIM) ! !! CASYI is subsidiary to CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CASYI-A, ZASYI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z) >= 0.0 BY ! MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE ABS(Z) IN THE ! REGION ABS(Z) > MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. ! NZ < 0 INDICATES AN OVERFLOW ON KODE=1. ! !***SEE ALSO CBESI, CBESK !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CASYI COMPLEX AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, RZ, S2, & Y, Z REAL AA, ACZ, AEZ, AK, ALIM, ARG, ARM, ATOL, AZ, BB, BK, DFNU, & DNU2, ELIM, FDN, FNU, PI, RL, RTPI, RTR1, S, SGN, SQK, TOL, X, & YY, R1MACH INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ DIMENSION Y(N) DATA PI, RTPI /3.14159265358979324E0 , 0.159154943091895336E0 / DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CASYI NZ = 0 AZ = ABS(Z) X = REAL(Z) ARM = 1.0E+3*R1MACH(1) RTR1 = SQRT(ARM) IL = MIN(2,N) DFNU = FNU + (N-IL) !----------------------------------------------------------------------- ! OVERFLOW TEST !----------------------------------------------------------------------- AK1 = CMPLX(RTPI,0.0E0)/Z AK1 = CSQRT(AK1) CZ = Z if (KODE == 2) CZ = Z - CMPLX(X,0.0E0) ACZ = REAL(CZ) if (ABS(ACZ) > ELIM) go to 80 DNU2 = DFNU + DFNU KODED = 1 if ((ABS(ACZ) > ALIM) .AND. (N > 2)) go to 10 KODED = 0 AK1 = AK1*CEXP(CZ) 10 CONTINUE FDN = 0.0E0 if (DNU2 > RTR1) FDN = DNU2*DNU2 EZ = Z*CMPLX(8.0E0,0.0E0) !----------------------------------------------------------------------- ! WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE ! FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE ! EXPANSION FOR THE IMAGINARY PART. !----------------------------------------------------------------------- AEZ = 8.0E0*AZ S = TOL/AEZ JL = RL+RL + 2 YY = AIMAG(Z) P1 = CZERO if (YY == 0.0E0) go to 20 !----------------------------------------------------------------------- ! CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF ! SIGNIFICANCE WHEN FNU OR N IS LARGE !----------------------------------------------------------------------- INU = FNU ARG = (FNU-INU)*PI INU = INU + N - IL AK = -SIN(ARG) BK = COS(ARG) if (YY < 0.0E0) BK = -BK P1 = CMPLX(AK,BK) if (MOD(INU,2) == 1) P1 = -P1 20 CONTINUE DO 50 K=1,IL SQK = FDN - 1.0E0 ATOL = S*ABS(SQK) SGN = 1.0E0 CS1 = CONE CS2 = CONE CK = CONE AK = 0.0E0 AA = 1.0E0 BB = AEZ DK = EZ DO 30 J=1,JL CK = CK*CMPLX(SQK,0.0E0)/DK CS2 = CS2 + CK SGN = -SGN CS1 = CS1 + CK*CMPLX(SGN,0.0E0) DK = DK + EZ AA = AA*ABS(SQK)/BB BB = BB + AEZ AK = AK + 8.0E0 SQK = SQK - AK if (AA <= ATOL) go to 40 30 CONTINUE go to 90 40 CONTINUE S2 = CS1 if (X+X < ELIM) S2 = S2 + P1*CS2*CEXP(-Z-Z) FDN = FDN + 8.0E0*DFNU + 4.0E0 P1 = -P1 M = N - IL + K Y(M) = S2*AK1 50 CONTINUE if (N <= 2) RETURN NN = N K = NN - 2 AK = K RZ = (CONE+CONE)/Z IB = 3 DO 60 I=IB,NN Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) AK = AK - 1.0E0 K = K - 1 60 CONTINUE if (KODED == 0) RETURN CK = CEXP(CZ) DO 70 I=1,NN Y(I) = Y(I)*CK 70 CONTINUE return 80 CONTINUE NZ = -1 return 90 CONTINUE NZ=-2 return end FUNCTION CATAN2 (CSN, CCS) ! !! CATAN2 computes the complex arc tangent in the proper quadrant. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE COMPLEX (CATAN2-C) !***KEYWORDS ARC TANGENT, ELEMENTARY FUNCTIONS, FNLIB, POLAR ANGEL, ! QUADRANT, TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CATAN2(CSN,CCS) calculates the complex trigonometric arc ! tangent of the ratio CSN/CCS and returns a result whose real ! part is in the correct quadrant (within a multiple of 2*PI). The ! result is in units of radians and the real part is between -PI ! and +PI. ! !***REFERENCES (NONE) !***ROUTINES CALLED CATAN, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE CATAN2 COMPLEX CATAN2 COMPLEX CSN, CCS, CATAN SAVE PI DATA PI / 3.14159265358979323846E0 / !***FIRST EXECUTABLE STATEMENT CATAN2 if (ABS(CCS) == 0.) go to 10 ! CATAN2 = CATAN (CSN/CCS) if (REAL(CCS) < 0.) CATAN2 = CATAN2 + PI if (REAL(CATAN2) > PI) CATAN2 = CATAN2 - 2.0*PI return ! 10 if (ABS(CSN) == 0.) call XERMSG ('SLATEC', 'CATAN2', & 'CALLED WITH BOTH ARGUMENTS ZERO', 1, 2) ! CATAN2 = CMPLX (SIGN(0.5*PI,REAL(CSN)), 0.0) ! return end FUNCTION CATAN (Z) ! !! CATAN computes the complex arc tangent. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE COMPLEX (CATAN-C) !***KEYWORDS ARC TANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CATAN(Z) calculates the complex trigonometric arc tangent of Z. ! The result is in units of radians, and the real part is in the first ! or fourth quadrant. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE CATAN COMPLEX CATAN COMPLEX Z, Z2 LOGICAL FIRST SAVE PI2, NTERMS, SQEPS, RMIN, RMAX, FIRST DATA PI2 / 1.57079632679489661923E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT CATAN if (FIRST) THEN ! NTERMS = LOG(EPS)/LOG(RBND) WHERE RBND = 0.1 NTERMS = -0.4343*LOG(R1MACH(3)) + 1.0 SQEPS = SQRT(R1MACH(4)) RMIN = SQRT (3.0*R1MACH(3)) RMAX = 1.0/R1MACH(3) end if FIRST = .FALSE. ! R = ABS(Z) if (R > 0.1) go to 30 ! CATAN = Z if (R < RMIN) RETURN ! CATAN = (0.0, 0.0) Z2 = Z*Z DO 20 I=1,NTERMS TWOI = 2*(NTERMS-I) + 1 CATAN = 1.0/TWOI - Z2*CATAN 20 CONTINUE CATAN = Z*CATAN return ! 30 if (R > RMAX) go to 50 X = REAL(Z) Y = AIMAG(Z) R2 = R*R if (R2 == 1.0 .AND. X == 0.0) call XERMSG ('SLATEC', 'CATAN', & 'Z IS +I OR -I', 2, 2) if (ABS(R2-1.0) > SQEPS) go to 40 if (ABS(CMPLX(1.0, 0.0)+Z*Z) < SQEPS) call XERMSG ('SLATEC', & 'CATAN', 'ANSWER LT HALF PRECISION, Z**2 CLOSE TO -1', 1, 1) ! 40 XANS = 0.5*ATAN2(2.0*X, 1.0-R2) YANS = 0.25*LOG((R2+2.0*Y+1.0)/(R2-2.0*Y+1.0)) CATAN = CMPLX (XANS, YANS) return ! 50 CATAN = CMPLX (PI2, 0.) if (REAL(Z) < 0.0) CATAN = CMPLX(-PI2,0.0) return ! end FUNCTION CATANH (Z) ! !! CATANH computes the arc hyperbolic tangent. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE COMPLEX (ATANH-S, DATANH-D, CATANH-C) !***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, ! FNLIB, INVERSE HYPERBOLIC TANGENT !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CATANH(Z) calculates the complex arc hyperbolic tangent of Z. ! !***REFERENCES (NONE) !***ROUTINES CALLED CATAN !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CATANH COMPLEX CATANH COMPLEX Z, CI, CATAN SAVE CI DATA CI /(0.,1.)/ !***FIRST EXECUTABLE STATEMENT CATANH CATANH = -CI*CATAN(CI*Z) ! return end subroutine CAXPY (N, CA, CX, INCX, CY, INCY) ! !! CAXPY computes a constant times a vector plus a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A7 !***TYPE COMPLEX (SAXPY-S, DAXPY-D, CAXPY-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, TRIAD, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! CA complex scalar multiplier ! CX complex vector with N elements ! INCX storage spacing between elements of CX ! CY complex vector with N elements ! INCY storage spacing between elements of CY ! ! --Output-- ! CY complex result (unchanged if N <= 0) ! ! Overwrite complex CY with complex CA*CX + CY. ! For I = 0 to N-1, replace CY(LY+I*INCY) with CA*CX(LX+I*INCX) + ! CY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 920801 Removed variable CANORM. (RWC, WRB) !***END PROLOGUE CAXPY COMPLEX CX(*), CY(*), CA !***FIRST EXECUTABLE STATEMENT CAXPY if (N <= 0 .OR. CA == (0.0E0,0.0E0)) RETURN if (INCX == INCY .AND. INCX > 0) go to 20 ! ! Code for unequal or nonpositive increments. ! KX = 1 KY = 1 if (INCX < 0) KX = 1+(1-N)*INCX if (INCY < 0) KY = 1+(1-N)*INCY DO 10 I = 1,N CY(KY) = CY(KY) + CA*CX(KX) KX = KX + INCX KY = KY + INCY 10 CONTINUE return ! ! Code for equal, positive, non-unit increments. ! 20 NS = N*INCX DO 30 I = 1,NS,INCX CY(I) = CA*CX(I) + CY(I) 30 CONTINUE return end subroutine CBABK2 (NM, N, LOW, IGH, SCALE, M, ZR, ZI) ! !! CBABK2 forms the eigenvectors of a complex general matrix from the ... ! eigenvectors of matrix output from CBAL. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE COMPLEX (BALBAK-S, CBABK2-C) !***KEYWORDS EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure ! CBABK2, which is a complex version of BALBAK, ! NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). ! ! This subroutine forms the eigenvectors of a COMPLEX GENERAL ! matrix by back transforming those of the corresponding ! balanced matrix determined by CBAL. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, ZR and ZI, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix Z=(ZR,ZI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! LOW and IGH are INTEGER variables determined by CBAL. ! ! SCALE contains information determining the permutations and ! scaling factors used by CBAL. SCALE is a one-dimensional ! REAL array, dimensioned SCALE(N). ! ! M is the number of eigenvectors to be back transformed. ! M is an INTEGER variable. ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the eigenvectors to be back transformed in their first ! M columns. ZR and ZI are two-dimensional REAL arrays, ! dimensioned ZR(NM,M) and ZI(NM,M). ! ! On OUTPUT ! ! ZR and ZI contain the real and imaginary parts, ! respectively, of the transformed eigenvectors ! in their first M columns. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CBABK2 ! INTEGER I,J,K,M,N,II,NM,IGH,LOW REAL SCALE(*),ZR(NM,*),ZI(NM,*) REAL S ! !***FIRST EXECUTABLE STATEMENT CBABK2 if (M == 0) go to 200 if (IGH == LOW) go to 120 ! DO 110 I = LOW, IGH S = SCALE(I) ! .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED ! if THE FOREGOING STATEMENT IS REPLACED BY ! S=1.0E0/SCALE(I). .......... DO 100 J = 1, M ZR(I,J) = ZR(I,J) * S ZI(I,J) = ZI(I,J) * S 100 CONTINUE ! 110 CONTINUE ! .......... FOR I=LOW-1 STEP -1 UNTIL 1, ! IGH+1 STEP 1 UNTIL N DO -- .......... 120 DO 140 II = 1, N I = II if (I >= LOW .AND. I <= IGH) go to 140 if (I < LOW) I = LOW - II K = SCALE(I) if (K == I) go to 140 ! 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 ! 140 CONTINUE ! 200 RETURN end subroutine CBAL (NM, N, AR, AI, LOW, IGH, SCALE) ! !! CBAL balances a complex general matrix and isolates eigenvalues ... ! when possible. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1A !***TYPE COMPLEX (BALANC-S, CBAL-C) !***KEYWORDS EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure ! CBALANCE, which is a complex version of BALANCE, ! NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). ! ! This subroutine balances a COMPLEX matrix and isolates ! eigenvalues whenever possible. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, AR and AI, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A=(AR,AI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! AR and AI contain the real and imaginary parts, ! respectively, of the complex matrix to be balanced. ! AR and AI are two-dimensional REAL arrays, dimensioned ! AR(NM,N) and AI(NM,N). ! ! On OUTPUT ! ! AR and AI contain the real and imaginary parts, ! respectively, of the balanced matrix. ! ! LOW and IGH are two INTEGER variables such that AR(I,J) ! and AI(I,J) are equal to zero if ! (1) I is greater than J and ! (2) J=1,...,LOW-1 or I=IGH+1,...,N. ! ! SCALE contains information determining the permutations and ! scaling factors used. SCALE is a one-dimensional REAL array, ! dimensioned SCALE(N). ! ! Suppose that the principal submatrix in rows LOW through IGH ! has been balanced, that P(J) denotes the index interchanged ! with J during the permutation step, and that the elements ! of the diagonal matrix used are denoted by D(I,J). Then ! SCALE(J) = P(J), for J = 1,...,LOW-1 ! = D(J,J) J = LOW,...,IGH ! = P(J) J = IGH+1,...,N. ! The order in which the interchanges are made is N to IGH+1, ! then 1 to LOW-1. ! ! Note that 1 is returned for IGH if IGH is zero formally. ! ! The ALGOL procedure EXC contained in CBALANCE appears in ! CBAL in line. (Note that the ALGOL roles of identifiers ! K,L have been reversed.) ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CBAL ! INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC REAL AR(NM,*),AI(NM,*),SCALE(*) REAL C,F,G,R,S,B2,RADIX LOGICAL NOCONV ! ! THE FOLLOWING PORTABLE VALUE OF RADIX WORKS WELL ENOUGH ! FOR ALL MACHINES WHOSE BASE IS A POWER OF TWO. ! !***FIRST EXECUTABLE STATEMENT CBAL RADIX = 16 ! B2 = RADIX * RADIX K = 1 L = N go to 100 ! .......... IN-LINE PROCEDURE FOR ROW AND ! COLUMN EXCHANGE .......... 20 SCALE(M) = J if (J == M) go to 50 ! 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 ! 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 ! 50 go to (80,130), IEXC ! .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE ! AND PUSH THEM DOWN .......... 80 if (L == 1) go to 280 L = L - 1 ! .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... 100 DO 120 JJ = 1, L J = L + 1 - JJ ! DO 110 I = 1, L if (I == J) go to 110 if (AR(J,I) /= 0.0E0 .OR. AI(J,I) /= 0.0E0) go to 120 110 CONTINUE ! M = L IEXC = 1 go to 20 120 CONTINUE ! go to 140 ! .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE ! AND PUSH THEM LEFT .......... 130 K = K + 1 ! 140 DO 170 J = K, L ! DO 150 I = K, L if (I == J) go to 150 if (AR(I,J) /= 0.0E0 .OR. AI(I,J) /= 0.0E0) go to 170 150 CONTINUE ! M = K IEXC = 2 go to 20 170 CONTINUE ! .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... DO 180 I = K, L 180 SCALE(I) = 1.0E0 ! .......... ITERATIVE LOOP FOR NORM REDUCTION .......... 190 NOCONV = .FALSE. ! DO 270 I = K, L C = 0.0E0 R = 0.0E0 ! DO 200 J = K, L if (J == 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 ! .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... if (C == 0.0E0 .OR. R == 0.0E0) go to 270 G = R / RADIX F = 1.0E0 S = C + R 210 if (C >= G) go to 220 F = F * RADIX C = C * B2 go to 210 220 G = R * RADIX 230 if (C < G) go to 240 F = F / RADIX C = C / B2 go to 230 ! .......... NOW BALANCE .......... 240 if ((C + R) / F >= 0.95E0 * S) go to 270 G = 1.0E0 / F SCALE(I) = SCALE(I) * F NOCONV = .TRUE. ! DO 250 J = K, N AR(I,J) = AR(I,J) * G AI(I,J) = AI(I,J) * G 250 CONTINUE ! DO 260 J = 1, L AR(J,I) = AR(J,I) * F AI(J,I) = AI(J,I) * F 260 CONTINUE ! 270 CONTINUE ! if (NOCONV) go to 190 ! 280 LOW = K IGH = L return end subroutine CBESH (Z, FNU, KODE, M, N, CY, NZ, IERR) ! !! CBESH computes a sequence of the Hankel functions H(m,a,z) ... ! for superscript m=1 or 2, real nonnegative orders a=b, ... ! b+1,... where b>0, and nonzero complex argument z. A ... ! scaling option is available to help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CBESH-C, ZBESH-C) !***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, ! BESSEL FUNCTIONS OF THE THIRD KIND, H BESSEL FUNCTIONS, ! HANKEL FUNCTIONS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! On KODE=1, CBESH computes an N member sequence of complex ! Hankel (Bessel) functions CY(L)=H(M,FNU+L-1,Z) for super- ! script M=1 or 2, real nonnegative orders FNU+L-1, L=1,..., ! N, and complex nonzero Z in the cut plane -pi=0 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! CY(L)=H(M,FNU+L-1,Z), L=1,...,N ! =2 returns ! CY(L)=H(M,FNU+L-1,Z)*exp(-(3-2M)*Z*i), ! L=1,...,N ! M - Superscript of Hankel function, M=1 or 2 ! N - Number of terms in the sequence, N>=1 ! ! Output ! CY - Result vector of type COMPLEX ! NZ - Number of underflows set to zero ! NZ=0 Normal return ! NZ>0 CY(L)=0 for NZ values of L (if M=1 and ! Im(Z)>0 or if M=2 and Im(Z)<0, then ! CY(L)=0 for L=1,...,NZ; in the com- ! plementary half planes, the underflows ! may not be in an uninterrupted sequence) ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (abs(Z) too small and/or FNU+N-1 ! too large) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has half precision or less ! because abs(Z) or FNU+N-1 is large) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision because ! abs(Z) or FNU+N-1 is too large) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! The computation is carried out by the formula ! ! H(m,a,z) = (1/t)*exp(-a*t)*K(a,z*exp(-t)) ! t = (3-2*m)*i*pi/2 ! ! where the K Bessel function is computed as described in the ! prologue to CBESK. ! ! Exponential decay of H(m,a,z) occurs in the upper half z ! plane for m=1 and the lower half z plane for m=2. Exponential ! growth occurs in the complementary half planes. Scaling ! by exp(-(3-2*m)*z*i) removes the exponential behavior in the ! whole z plane as z goes to infinity. ! ! For negative orders, the formula ! ! H(m,-a,z) = H(m,a,z)*exp((3-2*m)*a*pi*i) ! ! can be used. ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z or FNU+N-1 is ! large, losses of significance by argument reduction occur. ! Consequently, if either one exceeds U1=SQRT(0.5/UR), then ! losses exceeding half precision are likely and an error flag ! IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. Also, ! if either is larger than U2=0.5/UR, then all significance is ! lost and IERR=4. In order to use the INT function, arguments ! must be further restricted not to exceed the largest machine ! integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 ! is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and ! U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision ! and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This ! makes U2 limiting in single precision and U3 limiting in ! double precision. This means that one can expect to retain, ! in the worst cases on IEEE machines, no digits in single pre- ! cision and only 6 digits in double precision. Similar con- ! siderations hold for other machines. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument, Report SAND83-0086, Sandia National ! Laboratories, Albuquerque, NM, May 1983. ! 3. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 4. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 5. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED CACON, CBKNU, CBUNK, CUOIK, I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE CBESH ! COMPLEX CY, Z, ZN, ZT, CSGN REAL AA, ALIM, ALN, ARG, AZ, CPN, DIG, ELIM, FMM, FN, FNU, FNUL, & HPI, RHPI, RL, R1M5, SGN, SPN, TOL, UFL, XN, XX, YN, YY, R1MACH, & BB, ASCLE, RTOL, ATOL INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, & MM, MR, N, NN, NUF, NW, NZ, I1MACH DIMENSION CY(N) ! DATA HPI /1.57079632679489662E0/ ! !***FIRST EXECUTABLE STATEMENT CBESH NZ=0 XX = REAL(Z) YY = AIMAG(Z) IERR = 0 if (XX == 0.0E0 .AND. YY == 0.0E0) IERR=1 if (FNU < 0.0E0) IERR=1 if (M < 1 .OR. M > 2) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (N < 1) IERR=1 if (IERR /= 0) RETURN NN = N !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU !----------------------------------------------------------------------- TOL = MAX(R1MACH(4),1.0E-18) K1 = I1MACH(12) K2 = I1MACH(13) R1M5 = R1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) K1 = I1MACH(11) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0E0) AA = AA*2.303E0 ALIM = ELIM + MAX(-AA,-41.45E0) FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) RL = 1.2E0*DIG + 3.0E0 FN = FNU + (NN-1) MM = 3 - M - M FMM = MM ZN = Z*CMPLX(0.0E0,-FMM) XN = REAL(ZN) YN = AIMAG(ZN) AZ = ABS(Z) !----------------------------------------------------------------------- ! TEST FOR RANGE !----------------------------------------------------------------------- AA = 0.5E0/TOL BB=I1MACH(9)*0.5E0 AA=MIN(AA,BB) if ( AZ > AA) go to 240 if ( FN > AA) go to 240 AA=SQRT(AA) if ( AZ > AA) IERR=3 if ( FN > AA) IERR=3 !----------------------------------------------------------------------- ! OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE !----------------------------------------------------------------------- UFL = R1MACH(1)*1.0E+3 if (AZ < UFL) go to 220 if (FNU > FNUL) go to 90 if (FN <= 1.0E0) go to 70 if (FN > 2.0E0) go to 60 if (AZ > TOL) go to 70 ARG = 0.5E0*AZ ALN = -FN*ALOG(ARG) if (ALN > ELIM) go to 220 go to 70 60 CONTINUE call CUOIK(ZN, FNU, KODE, 2, NN, CY, NUF, TOL, ELIM, ALIM) if (NUF < 0) go to 220 NZ = NZ + NUF NN = NN - NUF !----------------------------------------------------------------------- ! HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK ! if NUF=NN, THEN CY(I)=CZERO FOR ALL I !----------------------------------------------------------------------- if (NN == 0) go to 130 70 CONTINUE if ((XN < 0.0E0) .OR. (XN == 0.0E0 .AND. YN < 0.0E0 .AND. & M == 2)) go to 80 !----------------------------------------------------------------------- ! RIGHT HALF PLANE COMPUTATION, XN >= 0. .AND. (XN /= 0. .OR. ! YN >= 0. .OR. M=1) !----------------------------------------------------------------------- call CBKNU(ZN, FNU, KODE, NN, CY, NZ, TOL, ELIM, ALIM) go to 110 !----------------------------------------------------------------------- ! LEFT HALF PLANE COMPUTATION !----------------------------------------------------------------------- 80 CONTINUE MR = -MM call CACON(ZN, FNU, KODE, MR, NN, CY, NW, RL, FNUL, TOL, ELIM, & ALIM) if (NW < 0) go to 230 NZ=NW go to 110 90 CONTINUE !----------------------------------------------------------------------- ! UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU > FNUL !----------------------------------------------------------------------- MR = 0 if ((XN >= 0.0E0) .AND. (XN /= 0.0E0 .OR. YN >= 0.0E0 .OR. & M /= 2)) go to 100 MR = -MM if (XN == 0.0E0 .AND. YN < 0.0E0) ZN = -ZN 100 CONTINUE call CBUNK(ZN, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM) if (NW < 0) go to 230 NZ = NZ + NW 110 CONTINUE !----------------------------------------------------------------------- ! H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) ! ! ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 !----------------------------------------------------------------------- SGN = SIGN(HPI,-FMM) !----------------------------------------------------------------------- ! CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE !----------------------------------------------------------------------- INU = FNU INUH = INU/2 IR = INU - 2*INUH ARG = (FNU-(INU-IR))*SGN RHPI = 1.0E0/SGN CPN = RHPI*COS(ARG) SPN = RHPI*SIN(ARG) ! ZN = CMPLX(-SPN,CPN) CSGN = CMPLX(-SPN,CPN) ! if (MOD(INUH,2) == 1) ZN = -ZN if (MOD(INUH,2) == 1) CSGN = -CSGN ZT = CMPLX(0.0E0,-FMM) RTOL = 1.0E0/TOL ASCLE = UFL*RTOL DO 120 I=1,NN ! CY(I) = CY(I)*ZN ! ZN = ZN*ZT ZN=CY(I) AA=REAL(ZN) BB=AIMAG(ZN) ATOL=1.0E0 if (MAX(ABS(AA),ABS(BB)) > ASCLE) go to 125 ZN = ZN*CMPLX(RTOL,0.0E0) ATOL = TOL 125 CONTINUE ZN = ZN*CSGN CY(I) = ZN*CMPLX(ATOL,0.0E0) CSGN = CSGN*ZT 120 CONTINUE return 130 CONTINUE if (XN < 0.0E0) go to 220 return 220 CONTINUE IERR=2 NZ=0 return 230 CONTINUE if ( NW == (-1)) go to 220 NZ=0 IERR=5 return 240 CONTINUE NZ=0 IERR=4 return end subroutine CBESI (Z, FNU, KODE, N, CY, NZ, IERR) ! !! CBESI computes a sequence of the Bessel functions I(a,z) for ... ! complex argument z and real nonnegative orders a=b,b+1, ... ! b+2,... where b>0. A scaling option is available to ... ! help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10B4 !***TYPE COMPLEX (CBESI-C, ZBESI-C) !***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, I BESSEL FUNCTIONS, ! MODIFIED BESSEL FUNCTIONS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! On KODE=1, CBESI computes an N-member sequence of complex ! Bessel functions CY(L)=I(FNU+L-1,Z) for real nonnegative ! orders FNU+L-1, L=1,...,N and complex Z in the cut plane ! -pi=0 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! CY(L)=I(FNU+L-1,Z), L=1,...,N ! =2 returns ! CY(L)=exp(-abs(X))*I(FNU+L-1,Z), L=1,...,N ! where X=Re(Z) ! N - Number of terms in the sequence, N>=1 ! ! Output ! CY - Result vector of type COMPLEX ! NZ - Number of underflows set to zero ! NZ=0 Normal return ! NZ>0 CY(L)=0, L=N-NZ+1,...,N ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (Re(Z) too large on KODE=1) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has half precision or less ! because abs(Z) or FNU+N-1 is large) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision because ! abs(Z) or FNU+N-1 is too large) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! The computation of I(a,z) is carried out by the power series ! for small abs(z), the asymptotic expansion for large abs(z), ! the Miller algorithm normalized by the Wronskian and a ! Neumann series for intermediate magnitudes of z, and the ! uniform asymptotic expansions for I(a,z) and J(a,z) for ! large orders a. Backward recurrence is used to generate ! sequences or reduce orders when necessary. ! ! The calculations above are done in the right half plane and ! continued into the left half plane by the formula ! ! I(a,z*exp(t)) = exp(t*a)*I(a,z), Re(z)>0 ! t = i*pi or -i*pi ! ! For negative orders, the formula ! ! I(-a,z) = I(a,z) + (2/pi)*sin(pi*a)*K(a,z) ! ! can be used. However, for large orders close to integers the ! the function changes radically. When a is a large positive ! integer, the magnitude of I(-a,z)=I(a,z) is a large ! negative power of ten. But when a is not an integer, ! K(a,z) dominates in magnitude with a large positive power of ! ten and the most that the second term can be reduced is by ! unit roundoff from the coefficient. Thus, wide changes can ! occur within unit roundoff of a large integer for a. Here, ! large means a>abs(z). ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z or FNU+N-1 is ! large, losses of significance by argument reduction occur. ! Consequently, if either one exceeds U1=SQRT(0.5/UR), then ! losses exceeding half precision are likely and an error flag ! IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. Also, ! if either is larger than U2=0.5/UR, then all significance is ! lost and IERR=4. In order to use the INT function, arguments ! must be further restricted not to exceed the largest machine ! integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 ! is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and ! U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision ! and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This ! makes U2 limiting in single precision and U3 limiting in ! double precision. This means that one can expect to retain, ! in the worst cases on IEEE machines, no digits in single pre- ! cision and only 6 digits in double precision. Similar con- ! siderations hold for other machines. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument, Report SAND83-0086, Sandia National ! Laboratories, Albuquerque, NM, May 1983. ! 3. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 4. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 5. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED CBINU, I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE CBESI COMPLEX CONE, CSGN, CY, Z, ZN REAL AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, S1, S2, & TOL, XX, YY, R1MACH, AZ, FN, BB, ASCLE, RTOL, ATOL INTEGER I, IERR, INU, K, KODE, K1, K2, N, NN, NZ, I1MACH DIMENSION CY(N) DATA PI /3.14159265358979324E0/ DATA CONE / (1.0E0,0.0E0) / ! !***FIRST EXECUTABLE STATEMENT CBESI IERR = 0 NZ=0 if (FNU < 0.0E0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (N < 1) IERR=1 if (IERR /= 0) RETURN XX = REAL(Z) YY = AIMAG(Z) !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. !----------------------------------------------------------------------- TOL = MAX(R1MACH(4),1.0E-18) K1 = I1MACH(12) K2 = I1MACH(13) R1M5 = R1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) K1 = I1MACH(11) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0E0) AA = AA*2.303E0 ALIM = ELIM + MAX(-AA,-41.45E0) RL = 1.2E0*DIG + 3.0E0 FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) AZ = ABS(Z) !----------------------------------------------------------------------- ! TEST FOR RANGE !----------------------------------------------------------------------- AA = 0.5E0/TOL BB=I1MACH(9)*0.5E0 AA=MIN(AA,BB) if ( AZ > AA) go to 140 FN=FNU+(N-1) if ( FN > AA) go to 140 AA=SQRT(AA) if ( AZ > AA) IERR=3 if ( FN > AA) IERR=3 ZN = Z CSGN = CONE if (XX >= 0.0E0) go to 40 ZN = -Z !----------------------------------------------------------------------- ! CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE !----------------------------------------------------------------------- INU = FNU ARG = (FNU-INU)*PI if (YY < 0.0E0) ARG = -ARG S1 = COS(ARG) S2 = SIN(ARG) CSGN = CMPLX(S1,S2) if (MOD(INU,2) == 1) CSGN = -CSGN 40 CONTINUE call CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) if (NZ < 0) go to 120 if (XX >= 0.0E0) RETURN !----------------------------------------------------------------------- ! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE !----------------------------------------------------------------------- NN = N - NZ if (NN == 0) RETURN RTOL = 1.0E0/TOL ASCLE = R1MACH(1)*RTOL*1.0E+3 DO 50 I=1,NN ! CY(I) = CY(I)*CSGN ZN=CY(I) AA=REAL(ZN) BB=AIMAG(ZN) ATOL=1.0E0 if (MAX(ABS(AA),ABS(BB)) > ASCLE) go to 55 ZN = ZN*CMPLX(RTOL,0.0E0) ATOL = TOL 55 CONTINUE ZN = ZN*CSGN CY(I) = ZN*CMPLX(ATOL,0.0E0) CSGN = -CSGN 50 CONTINUE return 120 CONTINUE if ( NZ == (-2)) go to 130 NZ = 0 IERR=2 return 130 CONTINUE NZ=0 IERR=5 return 140 CONTINUE NZ=0 IERR=4 return end subroutine CBESJ (Z, FNU, KODE, N, CY, NZ, IERR) ! !! CBESJ computes a sequence of the Bessel functions J(a,z) for ... ! complex argument z and real nonnegative orders a=b,b+1, ... ! b+2,... where b>0. A scaling option is available to ... ! help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CBESJ-C, ZBESJ-C) !***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, ! BESSEL FUNCTIONS OF THE FIRST KIND, J BESSEL FUNCTIONS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! On KODE=1, CBESJ computes an N member sequence of complex ! Bessel functions CY(L)=J(FNU+L-1,Z) for real nonnegative ! orders FNU+L-1, L=1,...,N and complex Z in the cut plane ! -pi=0 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! CY(L)=J(FNU+L-1,Z), L=1,...,N ! =2 returns ! CY(L)=J(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N ! where Y=Im(Z) ! N - Number of terms in the sequence, N>=1 ! ! Output ! CY - Result vector of type COMPLEX ! NZ - Number of underflows set to zero ! NZ=0 Normal return ! NZ>0 CY(L)=0, L=N-NZ+1,...,N ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (Im(Z) too large on KODE=1) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has half precision or less ! because abs(Z) or FNU+N-1 is large) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision because ! abs(Z) or FNU+N-1 is too large) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! The computation is carried out by the formulae ! ! J(a,z) = exp( a*pi*i/2)*I(a,-i*z), Im(z)>=0 ! ! J(a,z) = exp(-a*pi*i/2)*I(a, i*z), Im(z)<0 ! ! where the I Bessel function is computed as described in the ! prologue to CBESI. ! ! For negative orders, the formula ! ! J(-a,z) = J(a,z)*cos(a*pi) - Y(a,z)*sin(a*pi) ! ! can be used. However, for large orders close to integers, the ! the function changes radically. When a is a large positive ! integer, the magnitude of J(-a,z)=J(a,z)*cos(a*pi) is a ! large negative power of ten. But when a is not an integer, ! Y(a,z) dominates in magnitude with a large positive power of ! ten and the most that the second term can be reduced is by ! unit roundoff from the coefficient. Thus, wide changes can ! occur within unit roundoff of a large integer for a. Here, ! large means a>abs(z). ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z or FNU+N-1 is ! large, losses of significance by argument reduction occur. ! Consequently, if either one exceeds U1=SQRT(0.5/UR), then ! losses exceeding half precision are likely and an error flag ! IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. Also, ! if either is larger than U2=0.5/UR, then all significance is ! lost and IERR=4. In order to use the INT function, arguments ! must be further restricted not to exceed the largest machine ! integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 ! is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and ! U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision ! and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This ! makes U2 limiting in single precision and U3 limiting in ! double precision. This means that one can expect to retain, ! in the worst cases on IEEE machines, no digits in single pre- ! cision and only 6 digits in double precision. Similar con- ! siderations hold for other machines. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument, Report SAND83-0086, Sandia National ! Laboratories, Albuquerque, NM, May 1983. ! 3. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 4. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 5. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED CBINU, I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE CBESJ ! COMPLEX CI, CSGN, CY, Z, ZN REAL AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, HPI, RL, R1, R1M5, R2, & TOL, YY, R1MACH, AZ, FN, BB, ASCLE, RTOL, ATOL INTEGER I, IERR, INU, INUH, IR, KODE, K1, K2, N, NL, NZ, I1MACH, K DIMENSION CY(N) DATA HPI /1.57079632679489662E0/ ! !***FIRST EXECUTABLE STATEMENT CBESJ IERR = 0 NZ=0 if (FNU < 0.0E0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (N < 1) IERR=1 if (IERR /= 0) RETURN !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. !----------------------------------------------------------------------- TOL = MAX(R1MACH(4),1.0E-18) K1 = I1MACH(12) K2 = I1MACH(13) R1M5 = R1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) K1 = I1MACH(11) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0E0) AA = AA*2.303E0 ALIM = ELIM + MAX(-AA,-41.45E0) RL = 1.2E0*DIG + 3.0E0 FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) CI = CMPLX(0.0E0,1.0E0) YY = AIMAG(Z) AZ = ABS(Z) !----------------------------------------------------------------------- ! TEST FOR RANGE !----------------------------------------------------------------------- AA = 0.5E0/TOL BB=I1MACH(9)*0.5E0 AA=MIN(AA,BB) FN=FNU+(N-1) if ( AZ > AA) go to 140 if ( FN > AA) go to 140 AA=SQRT(AA) if ( AZ > AA) IERR=3 if ( FN > AA) IERR=3 !----------------------------------------------------------------------- ! CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE !----------------------------------------------------------------------- INU = FNU INUH = INU/2 IR = INU - 2*INUH ARG = (FNU-(INU-IR))*HPI R1 = COS(ARG) R2 = SIN(ARG) CSGN = CMPLX(R1,R2) if (MOD(INUH,2) == 1) CSGN = -CSGN !----------------------------------------------------------------------- ! ZN IS IN THE RIGHT HALF PLANE !----------------------------------------------------------------------- ZN = -Z*CI if (YY >= 0.0E0) go to 40 ZN = -ZN CSGN = CONJG(CSGN) CI = CONJG(CI) 40 CONTINUE call CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) if (NZ < 0) go to 120 NL = N - NZ if (NL == 0) RETURN RTOL = 1.0E0/TOL ASCLE = R1MACH(1)*RTOL*1.0E+3 DO 50 I=1,NL ! CY(I)=CY(I)*CSGN ZN=CY(I) AA=REAL(ZN) BB=AIMAG(ZN) ATOL=1.0E0 if (MAX(ABS(AA),ABS(BB)) > ASCLE) go to 55 ZN = ZN*CMPLX(RTOL,0.0E0) ATOL = TOL 55 CONTINUE ZN = ZN*CSGN CY(I) = ZN*CMPLX(ATOL,0.0E0) CSGN = CSGN*CI 50 CONTINUE return 120 CONTINUE if ( NZ == (-2)) go to 130 NZ = 0 IERR = 2 return 130 CONTINUE NZ=0 IERR=5 return 140 CONTINUE NZ=0 IERR=4 return end subroutine CBESK (Z, FNU, KODE, N, CY, NZ, IERR) ! !! CBESK computes a sequence of the Bessel functions K(a,z) for ... ! complex argument z and real nonnegative orders a=b,b+1, ... ! b+2,... where b>0. A scaling option is available to ... ! help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10B4 !***TYPE COMPLEX (CBESK-C, ZBESK-C) !***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, K BESSEL FUNCTIONS, ! MODIFIED BESSEL FUNCTIONS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! On KODE=1, CBESK computes an N member sequence of complex ! Bessel functions CY(L)=K(FNU+L-1,Z) for real nonnegative ! orders FNU+L-1, L=1,...,N and complex Z /= 0 in the cut ! plane -pi=0 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! CY(L)=K(FNU+L-1,Z), L=1,...,N ! =2 returns ! CY(L)=K(FNU+L-1,Z)*EXP(Z), L=1,...,N ! N - Number of terms in the sequence, N>=1 ! ! Output ! CY - Result vector of type COMPLEX ! NZ - Number of underflows set to zero ! NZ=0 Normal return ! NZ>0 CY(L)=0 for NZ values of L (if Re(Z)>0 ! then CY(L)=0 for L=1,...,NZ; in the ! complementary half plane the underflows ! may not be in an uninterrupted sequence) ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (abs(Z) too small and/or FNU+N-1 ! too large) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has half precision or less ! because abs(Z) or FNU+N-1 is large) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision because ! abs(Z) or FNU+N-1 is too large) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! Equations of the reference are implemented to compute K(a,z) ! for small orders a and a+1 in the right half plane Re(z)>=0. ! Forward recurrence generates higher orders. The formula ! ! K(a,z*exp((t)) = exp(-t)*K(a,z) - t*I(a,z), Re(z)>0 ! t = i*pi or -i*pi ! ! continues K to the left half plane. ! ! For large orders, K(a,z) is computed by means of its uniform ! asymptotic expansion. ! ! For negative orders, the formula ! ! K(-a,z) = K(a,z) ! ! can be used. ! ! CBESK assumes that a significant digit sinh function is ! available. ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z or FNU+N-1 is ! large, losses of significance by argument reduction occur. ! Consequently, if either one exceeds U1=SQRT(0.5/UR), then ! losses exceeding half precision are likely and an error flag ! IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. Also, ! if either is larger than U2=0.5/UR, then all significance is ! lost and IERR=4. In order to use the INT function, arguments ! must be further restricted not to exceed the largest machine ! integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 ! is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and ! U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision ! and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This ! makes U2 limiting in single precision and U3 limiting in ! double precision. This means that one can expect to retain, ! in the worst cases on IEEE machines, no digits in single pre- ! cision and only 6 digits in double precision. Similar con- ! siderations hold for other machines. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument, Report SAND83-0086, Sandia National ! Laboratories, Albuquerque, NM, May 1983. ! 3. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 4. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 5. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED CACON, CBKNU, CBUNK, CUOIK, I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE CBESK ! COMPLEX CY, Z REAL AA, ALIM, ALN, ARG, AZ, DIG, ELIM, FN, FNU, FNUL, RL, R1M5, & TOL, UFL, XX, YY, R1MACH, BB INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH DIMENSION CY(N) !***FIRST EXECUTABLE STATEMENT CBESK IERR = 0 NZ=0 XX = REAL(Z) YY = AIMAG(Z) if (YY == 0.0E0 .AND. XX == 0.0E0) IERR=1 if (FNU < 0.0E0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (N < 1) IERR=1 if (IERR /= 0) RETURN NN = N !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU !----------------------------------------------------------------------- TOL = MAX(R1MACH(4),1.0E-18) K1 = I1MACH(12) K2 = I1MACH(13) R1M5 = R1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) K1 = I1MACH(11) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0E0) AA = AA*2.303E0 ALIM = ELIM + MAX(-AA,-41.45E0) FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) RL = 1.2E0*DIG + 3.0E0 AZ = ABS(Z) FN = FNU + (NN-1) !----------------------------------------------------------------------- ! TEST FOR RANGE !----------------------------------------------------------------------- AA = 0.5E0/TOL BB=I1MACH(9)*0.5E0 AA=MIN(AA,BB) if ( AZ > AA) go to 210 if ( FN > AA) go to 210 AA=SQRT(AA) if ( AZ > AA) IERR=3 if ( FN > AA) IERR=3 !----------------------------------------------------------------------- ! OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE !----------------------------------------------------------------------- ! UFL = EXP(-ELIM) UFL = R1MACH(1)*1.0E+3 if (AZ < UFL) go to 180 if (FNU > FNUL) go to 80 if (FN <= 1.0E0) go to 60 if (FN > 2.0E0) go to 50 if (AZ > TOL) go to 60 ARG = 0.5E0*AZ ALN = -FN*ALOG(ARG) if (ALN > ELIM) go to 180 go to 60 50 CONTINUE call CUOIK(Z, FNU, KODE, 2, NN, CY, NUF, TOL, ELIM, ALIM) if (NUF < 0) go to 180 NZ = NZ + NUF NN = NN - NUF !----------------------------------------------------------------------- ! HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK ! if NUF=NN, THEN CY(I)=CZERO FOR ALL I !----------------------------------------------------------------------- if (NN == 0) go to 100 60 CONTINUE if (XX < 0.0E0) go to 70 !----------------------------------------------------------------------- ! RIGHT HALF PLANE COMPUTATION, REAL(Z) >= 0. !----------------------------------------------------------------------- call CBKNU(Z, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM) if (NW < 0) go to 200 NZ=NW return !----------------------------------------------------------------------- ! LEFT HALF PLANE COMPUTATION ! PI/2 < ARG(Z) <= PI AND -PI < ARG(Z) < -PI/2. !----------------------------------------------------------------------- 70 CONTINUE if (NZ /= 0) go to 180 MR = 1 if (YY < 0.0E0) MR = -1 call CACON(Z, FNU, KODE, MR, NN, CY, NW, RL, FNUL, TOL, ELIM, & ALIM) if (NW < 0) go to 200 NZ=NW return !----------------------------------------------------------------------- ! UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU > FNUL !----------------------------------------------------------------------- 80 CONTINUE MR = 0 if (XX >= 0.0E0) go to 90 MR = 1 if (YY < 0.0E0) MR = -1 90 CONTINUE call CBUNK(Z, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM) if (NW < 0) go to 200 NZ = NZ + NW return 100 CONTINUE if (XX < 0.0E0) go to 180 return 180 CONTINUE NZ = 0 IERR=2 return 200 CONTINUE if ( NW == (-1)) go to 180 NZ=0 IERR=5 return 210 CONTINUE NZ=0 IERR=4 return end subroutine CBESY (Z, FNU, KODE, N, CY, NZ, CWRK, IERR) ! !! CBESY computes a sequence of the Bessel functions Y(a,z) for ... ! complex argument z and real nonnegative orders a=b,b+1, ... ! b+2,... where b>0. A scaling option is available to ... ! help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CBESY-C, ZBESY-C) !***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, ! BESSEL FUNCTIONS OF SECOND KIND, WEBER'S FUNCTION, ! Y BESSEL FUNCTIONS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! On KODE=1, CBESY computes an N member sequence of complex ! Bessel functions CY(L)=Y(FNU+L-1,Z) for real nonnegative ! orders FNU+L-1, L=1,...,N and complex Z in the cut plane ! -pi=0 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! CY(L)=Y(FNU+L-1,Z), L=1,...,N ! =2 returns ! CY(L)=Y(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N ! where Y=Im(Z) ! N - Number of terms in the sequence, N>=1 ! CWRK - A work vector of type COMPLEX and dimension N ! ! Output ! CY - Result vector of type COMPLEX ! NZ - Number of underflows set to zero ! NZ=0 Normal return ! NZ>0 CY(L)=0 for NZ values of L, usually on ! KODE=2 (the underflows may not be in an ! uninterrupted sequence) ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (abs(Z) too small and/or FNU+N-1 ! too large) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has half precision or less ! because abs(Z) or FNU+N-1 is large) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision because ! abs(Z) or FNU+N-1 is too large) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! The computation is carried out by the formula ! ! Y(a,z) = (H(1,a,z) - H(2,a,z))/(2*i) ! ! where the Hankel functions are computed as described in CBESH. ! ! For negative orders, the formula ! ! Y(-a,z) = Y(a,z)*cos(a*pi) + J(a,z)*sin(a*pi) ! ! can be used. However, for large orders close to half odd ! integers the function changes radically. When a is a large ! positive half odd integer, the magnitude of Y(-a,z)=J(a,z)* ! sin(a*pi) is a large negative power of ten. But when a is ! not a half odd integer, Y(a,z) dominates in magnitude with a ! large positive power of ten and the most that the second term ! can be reduced is by unit roundoff from the coefficient. ! Thus, wide changes can occur within unit roundoff of a large ! half odd integer. Here, large means a>abs(z). ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z or FNU+N-1 is ! large, losses of significance by argument reduction occur. ! Consequently, if either one exceeds U1=SQRT(0.5/UR), then ! losses exceeding half precision are likely and an error flag ! IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. Also, ! if either is larger than U2=0.5/UR, then all significance is ! lost and IERR=4. In order to use the INT function, arguments ! must be further restricted not to exceed the largest machine ! integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 ! is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and ! U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision ! and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This ! makes U2 limiting in single precision and U3 limiting in ! double precision. This means that one can expect to retain, ! in the worst cases on IEEE machines, no digits in single pre- ! cision and only 6 digits in double precision. Similar con- ! siderations hold for other machines. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument, Report SAND83-0086, Sandia National ! Laboratories, Albuquerque, NM, May 1983. ! 3. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 4. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 5. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED CBESH, I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE CBESY ! COMPLEX CWRK, CY, C1, C2, EX, HCI, Z, ZU, ZV REAL ELIM, EY, FNU, R1, R2, TAY, XX, YY, R1MACH, R1M5, ASCLE, & RTOL, ATOL, TOL, AA, BB INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH DIMENSION CY(N), CWRK(N) !***FIRST EXECUTABLE STATEMENT CBESY XX = REAL(Z) YY = AIMAG(Z) IERR = 0 NZ=0 if (XX == 0.0E0 .AND. YY == 0.0E0) IERR=1 if (FNU < 0.0E0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (N < 1) IERR=1 if (IERR /= 0) RETURN HCI = CMPLX(0.0E0,0.5E0) call CBESH(Z, FNU, KODE, 1, N, CY, NZ1, IERR) if (IERR /= 0.AND.IERR /= 3) go to 170 call CBESH(Z, FNU, KODE, 2, N, CWRK, NZ2, IERR) if (IERR /= 0.AND.IERR /= 3) go to 170 NZ = MIN(NZ1,NZ2) if (KODE == 2) go to 60 DO 50 I=1,N CY(I) = HCI*(CWRK(I)-CY(I)) 50 CONTINUE return 60 CONTINUE TOL = MAX(R1MACH(4),1.0E-18) K1 = I1MACH(12) K2 = I1MACH(13) K = MIN(ABS(K1),ABS(K2)) R1M5 = R1MACH(5) !----------------------------------------------------------------------- ! ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT !----------------------------------------------------------------------- ELIM = 2.303E0*(K*R1M5-3.0E0) R1 = COS(XX) R2 = SIN(XX) EX = CMPLX(R1,R2) EY = 0.0E0 TAY = ABS(YY+YY) if (TAY < ELIM) EY = EXP(-TAY) if (YY < 0.0E0) go to 90 C1 = EX*CMPLX(EY,0.0E0) C2 = CONJG(EX) 70 CONTINUE NZ = 0 RTOL = 1.0E0/TOL ASCLE = R1MACH(1)*RTOL*1.0E+3 DO 80 I=1,N ! CY(I) = HCI*(C2*CWRK(I)-C1*CY(I)) ZV = CWRK(I) AA=REAL(ZV) BB=AIMAG(ZV) ATOL=1.0E0 if (MAX(ABS(AA),ABS(BB)) > ASCLE) go to 75 ZV = ZV*CMPLX(RTOL,0.0E0) ATOL = TOL 75 CONTINUE ZV = ZV*C2*HCI ZV = ZV*CMPLX(ATOL,0.0E0) ZU=CY(I) AA=REAL(ZU) BB=AIMAG(ZU) ATOL=1.0E0 if (MAX(ABS(AA),ABS(BB)) > ASCLE) go to 85 ZU = ZU*CMPLX(RTOL,0.0E0) ATOL = TOL 85 CONTINUE ZU = ZU*C1*HCI ZU = ZU*CMPLX(ATOL,0.0E0) CY(I) = ZV - ZU if (CY(I) == CMPLX(0.0E0,0.0E0) .AND. EY == 0.0E0) NZ = NZ + 1 80 CONTINUE return 90 CONTINUE C1 = EX C2 = CONJG(EX)*CMPLX(EY,0.0E0) go to 70 170 CONTINUE NZ = 0 return end FUNCTION CBETA (A, B) ! !! CBETA computes the complete Beta function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7B !***TYPE COMPLEX (BETA-S, DBETA-D, CBETA-C) !***KEYWORDS COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CBETA computes the complete beta function of complex parameters A ! and B. ! Input Parameters: ! A complex and the real part of A positive ! B complex and the real part of B positive ! !***REFERENCES (NONE) !***ROUTINES CALLED CGAMMA, CLBETA, GAMLIM, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE CBETA COMPLEX CBETA COMPLEX A, B, CGAMMA, CLBETA EXTERNAL CGAMMA SAVE XMAX DATA XMAX / 0.0 / !***FIRST EXECUTABLE STATEMENT CBETA if (XMAX == 0.0) THEN call GAMLIM (XMIN, XMAXT) XMAX = XMAXT end if ! if (REAL(A) <= 0.0 .OR. REAL(B) <= 0.0) call XERMSG ('SLATEC', & 'CBETA', 'REAL PART OF BOTH ARGUMENTS MUST BE GT 0', 1, 2) ! if (REAL(A)+REAL(B) < XMAX) CBETA = CGAMMA(A) * (CGAMMA(B)/ & CGAMMA(A+B) ) if (REAL(A)+REAL(B) < XMAX) RETURN ! CBETA = EXP (CLBETA(A, B)) ! return end subroutine CBINU (Z, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) ! !! CBINU is subsidiary to CAIRY, CBESH, CBESI, CBESJ, CBESK and CBIRY. ! !***LIBRARY SLATEC !***TYPE ALL (CBINU-A, ZBINU-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE ! !***SEE ALSO CAIRY, CBESH, CBESI, CBESJ, CBESK, CBIRY !***ROUTINES CALLED CASYI, CBUNI, CMLRI, CSERI, CUOIK, CWRSK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CBINU COMPLEX CW, CY, CZERO, Z REAL ALIM, AZ, DFNU, ELIM, FNU, FNUL, RL, TOL INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ DIMENSION CY(N), CW(2) DATA CZERO / (0.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CBINU NZ = 0 AZ = ABS(Z) NN = N DFNU = FNU + (N-1) if (AZ <= 2.0E0) go to 10 if (AZ*AZ*0.25E0 > DFNU+1.0E0) go to 20 10 CONTINUE !----------------------------------------------------------------------- ! POWER SERIES !----------------------------------------------------------------------- call CSERI(Z, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM) INW = ABS(NW) NZ = NZ + INW NN = NN - INW if (NN == 0) RETURN if (NW >= 0) go to 120 DFNU = FNU + (NN-1) 20 CONTINUE if (AZ < RL) go to 40 if (DFNU <= 1.0E0) go to 30 if (AZ+AZ < DFNU*DFNU) go to 50 !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR LARGE Z !----------------------------------------------------------------------- 30 CONTINUE call CASYI(Z, FNU, KODE, NN, CY, NW, RL, TOL, ELIM, ALIM) if (NW < 0) go to 130 go to 120 40 CONTINUE if (DFNU <= 1.0E0) go to 70 50 CONTINUE !----------------------------------------------------------------------- ! OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM !----------------------------------------------------------------------- call CUOIK(Z, FNU, KODE, 1, NN, CY, NW, TOL, ELIM, ALIM) if (NW < 0) go to 130 NZ = NZ + NW NN = NN - NW if (NN == 0) RETURN DFNU = FNU+(NN-1) if (DFNU > FNUL) go to 110 if (AZ > FNUL) go to 110 60 CONTINUE if (AZ > RL) go to 80 70 CONTINUE !----------------------------------------------------------------------- ! MILLER ALGORITHM NORMALIZED BY THE SERIES !----------------------------------------------------------------------- call CMLRI(Z, FNU, KODE, NN, CY, NW, TOL) if ( NW < 0) go to 130 go to 120 80 CONTINUE !----------------------------------------------------------------------- ! MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN !----------------------------------------------------------------------- call CUOIK(Z, FNU, KODE, 2, 2, CW, NW, TOL, ELIM, ALIM) if (NW >= 0) go to 100 NZ = NN DO 90 I=1,NN CY(I) = CZERO 90 CONTINUE return 100 CONTINUE if (NW > 0) go to 130 call CWRSK(Z, FNU, KODE, NN, CY, NW, CW, TOL, ELIM, ALIM) if (NW < 0) go to 130 go to 120 110 CONTINUE !----------------------------------------------------------------------- ! INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD !----------------------------------------------------------------------- NUI = FNUL-DFNU + 1 NUI = MAX(NUI,0) call CBUNI(Z, FNU, KODE, NN, CY, NW, NUI, NLAST, FNUL, TOL, ELIM, & ALIM) if (NW < 0) go to 130 NZ = NZ + NW if (NLAST == 0) go to 120 NN = NLAST go to 60 120 CONTINUE return 130 CONTINUE NZ = -1 if ( NW == (-2)) NZ=-2 return end subroutine CBIRY (Z, ID, KODE, BI, IERR) ! !! CBIRY computes the Airy function Bi(z) or its derivative dBi/dz ... ! for complex argument z. A scaling option is available ... ! to help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10D !***TYPE COMPLEX (CBIRY-C, ZBIRY-C) !***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, ! BESSEL FUNCTION OF ORDER TWO THIRDS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! On KODE=1, CBIRY computes the complex Airy function Bi(z) ! or its derivative dBi/dz on ID=0 or ID=1 respectively. ! On KODE=2, a scaling option exp(abs(Re(zeta)))*Bi(z) or ! exp(abs(Re(zeta)))*dBi/dz is provided to remove the ! exponential behavior in both the left and right half planes ! where zeta=(2/3)*z**(3/2). ! ! The Airy functions Bi(z) and dBi/dz are analytic in the ! whole z-plane, and the scaling option does not destroy this ! property. ! ! Input ! Z - Argument of type COMPLEX ! ID - Order of derivative, ID=0 or ID=1 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! BI=Bi(z) on ID=0 ! BI=dBi/dz on ID=1 ! at z=Z ! =2 returns ! BI=exp(abs(Re(zeta)))*Bi(z) on ID=0 ! BI=exp(abs(Re(zeta)))*dBi/dz on ID=1 ! at z=Z where zeta=(2/3)*z**(3/2) ! ! Output ! BI - Result of type COMPLEX ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (Re(Z) too large with KODE=1) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has less than half precision) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! Bi(z) and dBi/dz are computed from I Bessel functions by ! ! Bi(z) = c*sqrt(z)*( I(-1/3,zeta) + I(1/3,zeta) ) ! dBi/dz = c* z *( I(-2/3,zeta) + I(2/3,zeta) ) ! c = 1/sqrt(3) ! zeta = (2/3)*z**(3/2) ! ! when abs(z)>1 and from power series when abs(z)<=1. ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z is large, losses ! of significance by argument reduction occur. Consequently, if ! the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), ! then losses exceeding half precision are likely and an error ! flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. ! Also, if the magnitude of ZETA is larger than U2=0.5/UR, then ! all significance is lost and IERR=4. In order to use the INT ! function, ZETA must be further restricted not to exceed ! U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA ! must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, ! and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single ! precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. ! This makes U2 limiting is single precision and U3 limiting ! in double precision. This means that the magnitude of Z ! cannot exceed approximately 3.4E+4 in single precision and ! 2.1E+6 in double precision. This also means that one can ! expect to retain, in the worst cases on 32-bit machines, ! no digits in single precision and only 6 digits in double ! precision. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 3. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 4. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED CBINU, I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE CBIRY COMPLEX BI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3 REAL AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BK, CK, COEF, C1, C2, & DIG, DK, D1, D2, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, SFAC, & TOL, TTH, ZI, ZR, Z3I, Z3R, R1MACH INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH DIMENSION CY(2) DATA TTH, C1, C2, COEF, PI /6.66666666666666667E-01, & 6.14926627446000736E-01,4.48288357353826359E-01, & 5.77350269189625765E-01,3.14159265358979324E+00/ DATA CONE / (1.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CBIRY IERR = 0 NZ=0 if (ID < 0 .OR. ID > 1) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (IERR /= 0) RETURN AZ = ABS(Z) TOL = MAX(R1MACH(4),1.0E-18) FID = ID if (AZ > 1.0E0) go to 60 !----------------------------------------------------------------------- ! POWER SERIES FOR ABS(Z) <= 1. !----------------------------------------------------------------------- S1 = CONE S2 = CONE if (AZ < TOL) go to 110 AA = AZ*AZ if (AA < TOL/AZ) go to 40 TRM1 = CONE TRM2 = CONE ATRM = 1.0E0 Z3 = Z*Z*Z AZ3 = AZ*AA AK = 2.0E0 + FID BK = 3.0E0 - FID - FID CK = 4.0E0 - FID DK = 3.0E0 + FID + FID D1 = AK*DK D2 = BK*CK AD = MIN(D1,D2) AK = 24.0E0 + 9.0E0*FID BK = 30.0E0 - 9.0E0*FID Z3R = REAL(Z3) Z3I = AIMAG(Z3) DO 30 K=1,25 TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1) S1 = S1 + TRM1 TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2) S2 = S2 + TRM2 ATRM = ATRM*AZ3/AD D1 = D1 + AK D2 = D2 + BK AD = MIN(D1,D2) if (ATRM < TOL*AD) go to 40 AK = AK + 18.0E0 BK = BK + 18.0E0 30 CONTINUE 40 CONTINUE if (ID == 1) go to 50 BI = S1*CMPLX(C1,0.0E0) + Z*S2*CMPLX(C2,0.0E0) if (KODE == 1) RETURN ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) AA = REAL(ZTA) AA = -ABS(AA) BI = BI*CMPLX(EXP(AA),0.0E0) return 50 CONTINUE BI = S2*CMPLX(C2,0.0E0) if (AZ > TOL) BI = BI + Z*Z*S1*CMPLX(C1/(1.0E0+FID),0.0E0) if (KODE == 1) RETURN ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0) AA = REAL(ZTA) AA = -ABS(AA) BI = BI*CMPLX(EXP(AA),0.0E0) return !----------------------------------------------------------------------- ! CASE FOR ABS(Z) > 1.0 !----------------------------------------------------------------------- 60 CONTINUE FNU = (1.0E0+FID)/3.0E0 !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. !----------------------------------------------------------------------- K1 = I1MACH(12) K2 = I1MACH(13) R1M5 = R1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) K1 = I1MACH(11) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0E0) AA = AA*2.303E0 ALIM = ELIM + MAX(-AA,-41.45E0) RL = 1.2E0*DIG + 3.0E0 FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) !----------------------------------------------------------------------- ! TEST FOR RANGE !----------------------------------------------------------------------- AA=0.5E0/TOL BB=I1MACH(9)*0.5E0 AA=MIN(AA,BB) AA=AA**TTH if (AZ > AA) go to 190 AA=SQRT(AA) if (AZ > AA) IERR=3 CSQ=CSQRT(Z) ZTA=Z*CSQ*CMPLX(TTH,0.0E0) !----------------------------------------------------------------------- ! RE(ZTA) <= 0 WHEN RE(Z) < 0, ESPECIALLY WHEN IM(Z) IS SMALL !----------------------------------------------------------------------- SFAC = 1.0E0 ZI = AIMAG(Z) ZR = REAL(Z) AK = AIMAG(ZTA) if (ZR >= 0.0E0) go to 70 BK = REAL(ZTA) CK = -ABS(BK) ZTA = CMPLX(CK,AK) 70 CONTINUE if (ZI == 0.0E0 .AND. ZR <= 0.0E0) ZTA = CMPLX(0.0E0,AK) AA = REAL(ZTA) if (KODE == 2) go to 80 !----------------------------------------------------------------------- ! OVERFLOW TEST !----------------------------------------------------------------------- BB = ABS(AA) if (BB < ALIM) go to 80 BB = BB + 0.25E0*ALOG(AZ) SFAC = TOL if (BB > ELIM) go to 170 80 CONTINUE FMR = 0.0E0 if (AA >= 0.0E0 .AND. ZR > 0.0E0) go to 90 FMR = PI if (ZI < 0.0E0) FMR = -PI ZTA = -ZTA 90 CONTINUE !----------------------------------------------------------------------- ! AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) ! KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBINU !----------------------------------------------------------------------- call CBINU(ZTA, FNU, KODE, 1, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) if (NZ < 0) go to 180 AA = FMR*FNU Z3 = CMPLX(SFAC,0.0E0) S1 = CY(1)*CMPLX(COS(AA),SIN(AA))*Z3 FNU = (2.0E0-FID)/3.0E0 call CBINU(ZTA, FNU, KODE, 2, CY, NZ, RL, FNUL, TOL, ELIM, ALIM) CY(1) = CY(1)*Z3 CY(2) = CY(2)*Z3 !----------------------------------------------------------------------- ! BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 !----------------------------------------------------------------------- S2 = CY(1)*CMPLX(FNU+FNU,0.0E0)/ZTA + CY(2) AA = FMR*(FNU-1.0E0) S1 = (S1+S2*CMPLX(COS(AA),SIN(AA)))*CMPLX(COEF,0.0E0) if (ID == 1) go to 100 S1 = CSQ*S1 BI = S1*CMPLX(1.0E0/SFAC,0.0E0) return 100 CONTINUE S1 = Z*S1 BI = S1*CMPLX(1.0E0/SFAC,0.0E0) return 110 CONTINUE AA = C1*(1.0E0-FID) + FID*C2 BI = CMPLX(AA,0.0E0) return 170 CONTINUE NZ=0 IERR=2 return 180 CONTINUE if ( NZ == (-1)) go to 170 NZ=0 IERR=5 return 190 CONTINUE IERR=4 NZ=0 return end subroutine CBKNU (Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM) ! !! CBKNU is subsidiary to CAIRY, CBESH, CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CBKNU-A, ZBKNU-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE ! !***SEE ALSO CAIRY, CBESH, CBESI, CBESK !***ROUTINES CALLED CKSCL, CSHCH, CUCHK, GAMLN, I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CBKNU ! COMPLEX CCH, CK, COEF, CONE, CRSC, CS, CSCL, CSH, CSR, CSS, CTWO, & CZ, CZERO, F, FMU, P, PT, P1, P2, Q, RZ, SMU, ST, S1, S2, Y, Z, & ZD, CELM, CY REAL AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, CC, DNU, & DNU2, ELIM, ETEST, FC, FHS, FK, FKS, FNU, FPI, G1, G2, HPI, PI, & P2I, P2M, P2R, RK, RTHPI, R1, S, SPI, TM, TOL, TTH, T1, T2, XX, & YY, GAMLN, R1MACH, HELIM, ELM, XD, YD, ALAS, AS INTEGER I, IDUM, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, & NZ, I1MACH, NW, J, IC, INUB DIMENSION BRY(3), CC(8), CSS(3), CSR(3), Y(N), CY(2) ! DATA KMAX / 30 / DATA R1 / 2.0E0 / DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/ ! DATA PI, RTHPI, SPI ,HPI, FPI, TTH / & 3.14159265358979324E0, 1.25331413731550025E0, & 1.90985931710274403E0, 1.57079632679489662E0, & 1.89769999331517738E0, 6.66666666666666666E-01/ ! DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ & 5.77215664901532861E-01, -4.20026350340952355E-02, & -4.21977345555443367E-02, 7.21894324666309954E-03, & -2.15241674114950973E-04, -2.01348547807882387E-05, & 1.13302723198169588E-06, 6.11609510448141582E-09/ ! !***FIRST EXECUTABLE STATEMENT CBKNU XX = REAL(Z) YY = AIMAG(Z) CAZ = ABS(Z) CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = 1.0E+3*R1MACH(1)/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = R1MACH(2) NZ = 0 IFLAG = 0 KODED = KODE RZ = CTWO/Z INU = FNU+0.5E0 DNU = FNU - INU if (ABS(DNU) == 0.5E0) go to 110 DNU2 = 0.0E0 if (ABS(DNU) > TOL) DNU2 = DNU*DNU if (CAZ > R1) go to 110 !----------------------------------------------------------------------- ! SERIES FOR ABS(Z) <= R1 !----------------------------------------------------------------------- FC = 1.0E0 SMU = CLOG(RZ) FMU = SMU*CMPLX(DNU,0.0E0) call CSHCH(FMU, CSH, CCH) if (DNU == 0.0E0) go to 10 FC = DNU*PI FC = FC/SIN(FC) SMU = CSH*CMPLX(1.0E0/DNU,0.0E0) 10 CONTINUE A2 = 1.0E0 + DNU !----------------------------------------------------------------------- ! GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) !----------------------------------------------------------------------- T2 = EXP(-GAMLN(A2,IDUM)) T1 = 1.0E0/(T2*FC) if (ABS(DNU) > 0.1E0) go to 40 !----------------------------------------------------------------------- ! SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) !----------------------------------------------------------------------- AK = 1.0E0 S = CC(1) DO 20 K=2,8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM if (ABS(TM) < TOL) go to 30 20 CONTINUE 30 G1 = -S go to 50 40 CONTINUE G1 = (T1-T2)/(DNU+DNU) 50 CONTINUE G2 = 0.5E0*(T1+T2)*FC G1 = G1*FC F = CMPLX(G1,0.0E0)*CCH + SMU*CMPLX(G2,0.0E0) PT = CEXP(FMU) P = CMPLX(0.5E0/T2,0.0E0)*PT Q = CMPLX(0.5E0/T1,0.0E0)/PT S1 = F S2 = P AK = 1.0E0 A1 = 1.0E0 CK = CONE BK = 1.0E0 - DNU2 if (INU > 0 .OR. N > 1) go to 80 !----------------------------------------------------------------------- ! GENERATE K(FNU,Z), 0.0D0 <= FNU < 0.5D0 AND N=1 !----------------------------------------------------------------------- if (CAZ < TOL) go to 70 CZ = Z*Z*CMPLX(0.25E0,0.0E0) T1 = 0.25E0*CAZ*CAZ 60 CONTINUE F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) RK = 1.0E0/AK CK = CK*CZ*CMPLX(RK,0.0) S1 = S1 + CK*F A1 = A1*T1*RK BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 if (A1 > TOL) go to 60 70 CONTINUE Y(1) = S1 if (KODED == 1) RETURN Y(1) = S1*CEXP(Z) return !----------------------------------------------------------------------- ! GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE !----------------------------------------------------------------------- 80 CONTINUE if (CAZ < TOL) go to 100 CZ = Z*Z*CMPLX(0.25E0,0.0E0) T1 = 0.25E0*CAZ*CAZ 90 CONTINUE F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0) P = P*CMPLX(1.0E0/(AK-DNU),0.0E0) Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0) RK = 1.0E0/AK CK = CK*CZ*CMPLX(RK,0.0E0) S1 = S1 + CK*F S2 = S2 + CK*(P-F*CMPLX(AK,0.0E0)) A1 = A1*T1*RK BK = BK + AK + AK + 1.0E0 AK = AK + 1.0E0 if (A1 > TOL) go to 90 100 CONTINUE KFLAG = 2 BK = REAL(SMU) A1 = FNU + 1.0E0 AK = A1*ABS(BK) if (AK > ALIM) KFLAG = 3 P2 = S2*CSS(KFLAG) S2 = P2*RZ S1 = S1*CSS(KFLAG) if (KODED == 1) go to 210 F = CEXP(Z) S1 = S1*F S2 = S2*F go to 210 !----------------------------------------------------------------------- ! IFLAG=0 MEANS NO UNDERFLOW OCCURRED ! IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH ! KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD ! RECURSION !----------------------------------------------------------------------- 110 CONTINUE COEF = CMPLX(RTHPI,0.0E0)/CSQRT(Z) KFLAG = 2 if (KODED == 2) go to 120 if (XX > ALIM) go to 290 ! BLANK LINE A1 = EXP(-XX)*REAL(CSS(KFLAG)) PT = CMPLX(A1,0.0E0)*CMPLX(COS(YY),-SIN(YY)) COEF = COEF*PT 120 CONTINUE if (ABS(DNU) == 0.5E0) go to 300 !----------------------------------------------------------------------- ! MILLER ALGORITHM FOR ABS(Z) > R1 !----------------------------------------------------------------------- AK = COS(PI*DNU) AK = ABS(AK) if (AK == 0.0E0) go to 300 FHS = ABS(0.25E0-DNU2) if (FHS == 0.0E0) go to 300 !----------------------------------------------------------------------- ! COMPUTE R2=F(E). if ABS(Z) >= R2, USE FORWARD RECURRENCE TO ! DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON ! 12 <= E <= 60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(11))= ! TOL WHERE B IS THE BASE OF THE ARITHMETIC. !----------------------------------------------------------------------- T1 = (I1MACH(11)-1)*R1MACH(5)*3.321928094E0 T1 = MAX(T1,12.0E0) T1 = MIN(T1,60.0E0) T2 = TTH*T1 - 6.0E0 if (XX /= 0.0E0) go to 130 T1 = HPI go to 140 130 CONTINUE T1 = ATAN(YY/XX) T1 = ABS(T1) 140 CONTINUE if (T2 > CAZ) go to 170 !----------------------------------------------------------------------- ! FORWARD RECURRENCE LOOP WHEN ABS(Z) >= R2 !----------------------------------------------------------------------- ETEST = AK/(PI*CAZ*TOL) FK = 1.0E0 if (ETEST < 1.0E0) go to 180 FKS = 2.0E0 RK = CAZ + CAZ + 2.0E0 A1 = 0.0E0 A2 = 1.0E0 DO 150 I=1,KMAX AK = FHS/FKS BK = RK/(FK+1.0E0) TM = A2 A2 = BK*A2 - AK*A1 A1 = TM RK = RK + 2.0E0 FKS = FKS + FK + FK + 2.0E0 FHS = FHS + FK + FK FK = FK + 1.0E0 TM = ABS(A2)*FK if (ETEST < TM) go to 160 150 CONTINUE go to 310 160 CONTINUE FK = FK + SPI*T1*SQRT(T2/CAZ) FHS = ABS(0.25E0-DNU2) go to 180 170 CONTINUE !----------------------------------------------------------------------- ! COMPUTE BACKWARD INDEX K FOR ABS(Z) < R2 !----------------------------------------------------------------------- A2 = SQRT(CAZ) AK = FPI*AK/(TOL*SQRT(A2)) AA = 3.0E0*T1/(1.0E0+CAZ) BB = 14.7E0*T1/(28.0E0+CAZ) AK = (ALOG(AK)+CAZ*COS(AA)/(1.0E0+0.008E0*CAZ))/COS(BB) FK = 0.12125E0*AK*AK/CAZ + 1.5E0 180 CONTINUE K = FK !----------------------------------------------------------------------- ! BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM !----------------------------------------------------------------------- FK = K FKS = FK*FK P1 = CZERO P2 = CMPLX(TOL,0.0E0) CS = P2 DO 190 I=1,K A1 = FKS - FK A2 = (FKS+FK)/(A1+FHS) RK = 2.0E0/(FK+1.0E0) T1 = (FK+XX)*RK T2 = YY*RK PT = P2 P2 = (P2*CMPLX(T1,T2)-P1)*CMPLX(A2,0.0E0) P1 = PT CS = CS + P2 FKS = A1 - FK + 1.0E0 FK = FK - 1.0E0 190 CONTINUE !----------------------------------------------------------------------- ! COMPUTE (P2/CS)=(P2/ABS(CS))*(CONJG(CS)/ABS(CS)) FOR BETTER ! SCALING !----------------------------------------------------------------------- TM = ABS(CS) PT = CMPLX(1.0E0/TM,0.0E0) S1 = PT*P2 CS = CONJG(CS)*PT S1 = COEF*S1*CS if (INU > 0 .OR. N > 1) go to 200 ZD = Z if ( IFLAG == 1) go to 270 go to 240 200 CONTINUE !----------------------------------------------------------------------- ! COMPUTE P1/P2=(P1/ABS(P2)*CONJG(P2)/ABS(P2) FOR SCALING !----------------------------------------------------------------------- TM = ABS(P2) PT = CMPLX(1.0E0/TM,0.0E0) P1 = PT*P1 P2 = CONJG(P2)*PT PT = P1*P2 S2 = S1*(CONE+(CMPLX(DNU+0.5E0,0.0E0)-PT)/Z) !----------------------------------------------------------------------- ! FORWARD RECURSION ON THE THREE TERM RECURSION RELATION WITH ! SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 !----------------------------------------------------------------------- 210 CONTINUE CK = CMPLX(DNU+1.0E0,0.0E0)*RZ if (N == 1) INU = INU - 1 if (INU > 0) go to 220 if (N == 1) S1=S2 ZD = Z if ( IFLAG == 1) go to 270 go to 240 220 CONTINUE INUB = 1 if (IFLAG == 1) go to 261 225 CONTINUE P1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 230 I=INUB,INU ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RZ if (KFLAG >= 3) go to 230 P2 = S2*P1 P2R = REAL(P2) P2I = AIMAG(P2) P2R = ABS(P2R) P2I = ABS(P2I) P2M = MAX(P2R,P2I) if (P2M <= ASCLE) go to 230 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*P1 S2 = P2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) P1 = CSR(KFLAG) 230 CONTINUE if (N == 1) S1 = S2 240 CONTINUE Y(1) = S1*CSR(KFLAG) if (N == 1) RETURN Y(2) = S2*CSR(KFLAG) if (N == 2) RETURN KK = 2 250 CONTINUE KK = KK + 1 if (KK > N) RETURN P1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 260 I=KK,N P2 = S2 S2 = CK*S2 + S1 S1 = P2 CK = CK + RZ P2 = S2*P1 Y(I) = P2 if (KFLAG >= 3) go to 260 P2R = REAL(P2) P2I = AIMAG(P2) P2R = ABS(P2R) P2I = ABS(P2I) P2M = MAX(P2R,P2I) if (P2M <= ASCLE) go to 260 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*P1 S2 = P2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) P1 = CSR(KFLAG) 260 CONTINUE return !----------------------------------------------------------------------- ! IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW !----------------------------------------------------------------------- 261 CONTINUE HELIM = 0.5E0*ELIM ELM = EXP(-ELIM) CELM = CMPLX(ELM,0.0) ASCLE = BRY(1) ZD = Z XD = XX YD = YY IC = -1 J = 2 DO 262 I=1,INU ST = S2 S2 = CK*S2+S1 S1 = ST CK = CK+RZ AS = ABS(S2) ALAS = ALOG(AS) P2R = -XD+ALAS if ( P2R < (-ELIM)) go to 263 P2 = -ZD+CLOG(S2) P2R = REAL(P2) P2I = AIMAG(P2) P2M = EXP(P2R)/TOL P1 = CMPLX(P2M,0.0E0)*CMPLX(COS(P2I),SIN(P2I)) call CUCHK(P1,NW,ASCLE,TOL) if ( NW /= 0) go to 263 J=3-J CY(J) = P1 if ( IC == (I-1)) go to 264 IC = I go to 262 263 CONTINUE if ( ALAS < HELIM) go to 262 XD = XD-ELIM S1 = S1*CELM S2 = S2*CELM ZD = CMPLX(XD,YD) 262 CONTINUE if ( N == 1) S1 = S2 go to 270 264 CONTINUE KFLAG = 1 INUB = I+1 S2 = CY(J) J = 3 - J S1 = CY(J) if ( INUB <= INU) go to 225 if ( N == 1) S1 = S2 go to 240 270 CONTINUE Y(1) = S1 if (N == 1) go to 280 Y(2) = S2 280 CONTINUE ASCLE = BRY(1) call CKSCL(ZD, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM) INU = N - NZ if (INU <= 0) RETURN KK = NZ + 1 S1 = Y(KK) Y(KK) = S1*CSR(1) if (INU == 1) RETURN KK = NZ + 2 S2 = Y(KK) Y(KK) = S2*CSR(1) if (INU == 2) RETURN T2 = FNU + (KK-1) CK = CMPLX(T2,0.0E0)*RZ KFLAG = 1 go to 250 290 CONTINUE !----------------------------------------------------------------------- ! SCALE BY EXP(Z), IFLAG = 1 CASES !----------------------------------------------------------------------- KODED = 2 IFLAG = 1 KFLAG = 2 go to 120 !----------------------------------------------------------------------- ! FNU=HALF ODD INTEGER CASE, DNU=-0.5 !----------------------------------------------------------------------- 300 CONTINUE S1 = COEF S2 = COEF go to 210 310 CONTINUE NZ=-2 return end subroutine CBLKT1 (N, AN, BN, CN, M, AM, BM, CM, IDIMY, Y, B, W1, & W2, W3, WD, WW, WU, PRDCT, CPRDCT) ! !! CBLKT1 is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE COMPLEX (BLKTR1-S, CBLKT1-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! CBLKT1 solves the linear system of routine CBLKTR. ! ! B contains the roots of all the B polynomials. ! W1,W2,W3,WD,WW,WU are all working arrays. ! PRDCT is either PROCP or PROC depending on whether the boundary ! conditions in the M direction are periodic or not. ! CPRDCT is either CPROCP or CPROC which are called if some of the zeros ! of the B polynomials are complex. ! !***SEE ALSO CBLKTR !***ROUTINES CALLED INXCA, INXCB, INXCC !***COMMON BLOCKS CCBLK !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CBLKT1 ! DIMENSION AN(*) ,BN(*) ,CN(*) ,AM(*) , & BM(*) ,CM(*) ,B(*) ,W1(*) , & W2(*) ,W3(*) ,WD(*) ,WW(*) , & WU(*) ,Y(IDIMY,*) COMMON /CCBLK/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK COMPLEX AM ,BM ,CM ,Y , & W1 ,W2 ,W3 ,WD , & WW ,WU !***FIRST EXECUTABLE STATEMENT CBLKT1 KDO = K-1 DO 109 L=1,KDO IR = L-1 I2 = 2**IR I1 = I2/2 I3 = I2+I1 I4 = I2+I2 IRM1 = IR-1 call INXCB (I2,IR,IM2,NM2) call INXCB (I1,IRM1,IM3,NM3) call INXCB (I3,IRM1,IM1,NM1) call PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,Y(1,I2),W3, & M,AM,BM,CM,WD,WW,WU) if = 2**K DO 108 I=I4,IF,I4 if (I-NM) 101,101,108 101 IPI1 = I+I1 IPI2 = I+I2 IPI3 = I+I3 call INXCC (I,IR,IDXC,NC) if (I-IF) 102,108,108 102 call INXCA (I,IR,IDXA,NA) call INXCB (I-I1,IRM1,IM1,NM1) call INXCB (IPI2,IR,IP2,NP2) call INXCB (IPI1,IRM1,IP1,NP1) call INXCB (IPI3,IRM1,IP3,NP3) call PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W3,W1,M,AM, & BM,CM,WD,WW,WU) if (IPI2-NM) 105,105,103 103 DO 104 J=1,M W3(J) = (0.,0.) W2(J) = (0.,0.) 104 CONTINUE go to 106 105 call PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM, & 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, & BM,CM,WD,WW,WU) 106 DO 107 J=1,M Y(J,I) = W1(J)+W2(J)+Y(J,I) 107 CONTINUE 108 CONTINUE 109 CONTINUE if (NPP) 132,110,132 ! ! THE PERIODIC CASE IS TREATED USING THE CAPACITANCE MATRIX METHOD ! 110 if = 2**K I = IF/2 I1 = I/2 call INXCB (I-I1,K-2,IM1,NM1) call INXCB (I+I1,K-2,IP1,NP1) call INXCB (I,K-1,IZ,NZ) call PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,Y(1,I),W1,M,AM, & BM,CM,WD,WW,WU) IZR = I DO 111 J=1,M W2(J) = W1(J) 111 CONTINUE DO 113 LL=2,K L = K-LL+1 IR = L-1 I2 = 2**IR I1 = I2/2 I = I2 call INXCC (I,IR,IDXC,NC) call INXCB (I,IR,IZ,NZ) call INXCB (I-I1,IR-1,IM1,NM1) call INXCB (I+I1,IR-1,IP1,NP1) call PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W1,W1,M,AM,BM, & CM,WD,WW,WU) DO 112 J=1,M W1(J) = Y(J,I)+W1(J) 112 CONTINUE call PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,W1,M,AM, & BM,CM,WD,WW,WU) 113 CONTINUE DO 118 LL=2,K L = K-LL+1 IR = L-1 I2 = 2**IR I1 = I2/2 I4 = I2+I2 IFD = IF-I2 DO 117 I=I2,IFD,I4 if (I-I2-IZR) 117,114,117 114 if (I-NM) 115,115,118 115 call INXCA (I,IR,IDXA,NA) call INXCB (I,IR,IZ,NZ) call INXCB (I-I1,IR-1,IM1,NM1) call INXCB (I+I1,IR-1,IP1,NP1) call PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W2,W2,M,AM, & BM,CM,WD,WW,WU) DO 116 J=1,M W2(J) = Y(J,I)+W2(J) 116 CONTINUE call PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W2,W2,M, & AM,BM,CM,WD,WW,WU) IZR = I if (I-NM) 117,119,117 117 CONTINUE 118 CONTINUE 119 DO 120 J=1,M Y(J,NM+1) = Y(J,NM+1)-CN(NM+1)*W1(J)-AN(NM+1)*W2(J) 120 CONTINUE call INXCB (IF/2,K-1,IM1,NM1) call INXCB (IF,K-1,IP,NP) if (NCMPLX) 121,122,121 121 call CPRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1), & Y(1,NM+1),M,AM,BM,CM,W1,W3,WW) go to 123 122 call PRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1), & Y(1,NM+1),M,AM,BM,CM,WD,WW,WU) 123 DO 124 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) 124 CONTINUE DO 126 L=1,KDO IR = L-1 I2 = 2**IR I4 = I2+I2 I1 = I2/2 I = I4 call INXCA (I,IR,IDXA,NA) call INXCB (I-I2,IR,IM2,NM2) call INXCB (I-I2-I1,IR-1,IM3,NM3) call INXCB (I-I1,IR-1,IM1,NM1) call PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,W1,W1,M,AM, & BM,CM,WD,WW,WU) call PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W1,W1,M,AM,BM, & CM,WD,WW,WU) DO 125 J=1,M Y(J,I) = Y(J,I)-W1(J) 125 CONTINUE 126 CONTINUE ! IZR = NM DO 131 L=1,KDO IR = L-1 I2 = 2**IR I1 = I2/2 I3 = I2+I1 I4 = I2+I2 IRM1 = IR-1 DO 130 I=I4,IF,I4 IPI1 = I+I1 IPI2 = I+I2 IPI3 = I+I3 if (IPI2-IZR) 127,128,127 127 if (I-IZR) 130,131,130 128 call INXCC (I,IR,IDXC,NC) call INXCB (IPI2,IR,IP2,NP2) call INXCB (IPI1,IRM1,IP1,NP1) call INXCB (IPI3,IRM1,IP3,NP3) call PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,W2,W2,M, & AM,BM,CM,WD,WW,WU) call PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W2,W2,M,AM, & BM,CM,WD,WW,WU) DO 129 J=1,M Y(J,I) = Y(J,I)-W2(J) 129 CONTINUE IZR = I go to 131 130 CONTINUE 131 CONTINUE ! ! BEGIN BACK SUBSTITUTION PHASE ! 132 DO 144 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 143 I=I2,IFD,I4 if (I-NM) 133,133,143 133 IMI1 = I-I1 IMI2 = I-I2 IPI1 = I+I1 IPI2 = I+I2 call INXCA (I,IR,IDXA,NA) call INXCC (I,IR,IDXC,NC) call INXCB (I,IR,IZ,NZ) call INXCB (IMI1,IRM1,IM1,NM1) call INXCB (IPI1,IRM1,IP1,NP1) if (I-I2) 134,134,136 134 DO 135 J=1,M W1(J) = (0.,0.) 135 CONTINUE go to 137 136 call PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),Y(1,IMI2), & W1,M,AM,BM,CM,WD,WW,WU) 137 if (IPI2-NM) 140,140,138 138 DO 139 J=1,M W2(J) = (0.,0.) 139 CONTINUE go to 141 140 call PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),Y(1,IPI2), & W2,M,AM,BM,CM,WD,WW,WU) 141 DO 142 J=1,M W1(J) = Y(J,I)+W1(J)+W2(J) 142 CONTINUE call PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,Y(1,I), & M,AM,BM,CM,WD,WW,WU) 143 CONTINUE 144 CONTINUE return end subroutine CBLKTR (IFLG, NP, N, AN, BN, CN, MP, M, AM, BM, CM, & IDIMY, Y, IERROR, W) ! !! CBLKTR solves a block tridiagonal system of linear equations ... ! (usually resulting from the discretization of separable ... ! two-dimensional elliptic equations). ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B4B !***TYPE COMPLEX (BLKTRI-S, CBLKTR-C) !***KEYWORDS ELLIPTIC PDE, FISHPACK, TRIDIAGONAL LINEAR SYSTEM !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine CBLKTR is a complex version of subroutine BLKTRI. ! Both subroutines solve a system of linear equations of the form ! ! AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J) ! ! + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J) ! ! For I = 1,2,...,M and J = 1,2,...,N. ! ! I+1 and I-1 are evaluated modulo M and J+1 and J-1 modulo N, i.e., ! ! X(I,0) = X(I,N), X(I,N+1) = X(I,1), ! X(0,J) = X(M,J), X(M+1,J) = X(1,J). ! ! These equations usually result from the discretization of ! separable elliptic equations. Boundary conditions may be ! Dirichlet, Neumann, or periodic. ! ! ! * * * * * * * * * * On INPUT * * * * * * * * * * ! ! IFLG ! = 0 Initialization only. Certain quantities that depend on NP, ! N, AN, BN, and CN are computed and stored in the work ! array W. ! = 1 The quantities that were computed in the initialization are ! used to obtain the solution X(I,J). ! ! NOTE A call with IFLG=0 takes approximately one half the time ! time as a call with IFLG = 1. However, the ! initialization does not have to be repeated unless NP, N, ! AN, BN, or CN change. ! ! NP ! = 0 If AN(1) and CN(N) are not zero, which corresponds to ! periodic boundary conditions. ! = 1 If AN(1) and CN(N) are zero. ! ! N ! The number of unknowns in the J-direction. N must be greater ! than 4. The operation count is proportional to MNlog2(N), hence ! N should be selected less than or equal to M. ! ! AN,BN,CN ! Real one-dimensional arrays of length N that specify the ! coefficients in the linear equations given above. ! ! MP ! = 0 If AM(1) and CM(M) are not zero, which corresponds to ! periodic boundary conditions. ! = 1 If AM(1) = CM(M) = 0 . ! ! M ! The number of unknowns in the I-direction. M must be greater ! than 4. ! ! AM,BM,CM ! Complex one-dimensional arrays of length M that specify the ! coefficients in the linear equations given above. ! ! IDIMY ! The row (or first) dimension of the two-dimensional array Y as ! it appears in the program calling BLKTRI. This parameter is ! used to specify the variable dimension of Y. IDIMY must be at ! least M. ! ! Y ! A complex two-dimensional array that specifies the values of ! the right side of the linear system of equations given above. ! Y must be dimensioned Y(IDIMY,N) with IDIMY >= M. ! ! W ! A one-dimensional array that must be provided by the user for ! work space. ! If NP=1 define K=INT(log2(N))+1 and set L=2**(K+1) then ! W must have dimension (K-2)*L+K+5+MAX(2N,12M) ! ! If NP=0 define K=INT(log2(N-1))+1 and set L=2**(K+1) then ! W must have dimension (K-2)*L+K+5+2N+MAX(2N,12M) ! ! **IMPORTANT** For purposes of checking, the required dimension ! of W is computed by BLKTRI and stored in W(1) ! in floating point format. ! ! * * * * * * * * * * On Output * * * * * * * * * * ! ! Y ! Contains the solution X. ! ! IERROR ! An error flag that indicates invalid input parameters. Except ! for number zero, a solution is not attempted. ! ! = 0 No error. ! = 1 M is less than 5. ! = 2 N is less than 5. ! = 3 IDIMY is less than M. ! = 4 BLKTRI failed while computing results that depend on the ! coefficient arrays AN, BN, CN. Check these arrays. ! = 5 AN(J)*CN(J-1) is less than 0 for some J. Possible reasons ! for this condition are ! 1. The arrays AN and CN are not correct. ! 2. Too large a grid spacing was used in the discretization ! of the elliptic equation. ! 3. The linear equations resulted from a partial ! differential equation which was not elliptic. ! ! W ! Contains intermediate values that must not be destroyed if ! CBLKTR will be called again with IFLG=1. W(1) contains the ! number of locations required by W in floating point format. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N) ! Arguments W(see argument list) ! ! Latest June 1979 ! Revision ! ! Required CBLKTR,CBLKT1,PROC,PROCP,CPROC,CPROCP,CCMPB,INXCA, ! Subprograms INXCB,INXCC,CPADD,PGSF,PPGSF,PPPSF,BCRH,TEVLC, ! R1MACH ! ! Special The algorithm may fail if ABS(BM(I)+BN(J)) is less ! Conditions than ABS(AM(I))+ABS(AN(J))+ABS(CM(I))+ABS(CN(J)) ! for some I and J. The algorithm will also fail if ! AN(J)*CN(J-1) is less than zero for some J. ! See the description of the output parameter IERROR. ! ! Common CCBLK ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Paul Swarztrauber ! ! Language FORTRAN ! ! History CBLKTR is a complex version of BLKTRI (version 3) ! ! Algorithm Generalized Cyclic Reduction (see reference below) ! ! Space ! Required CONTROL DATA 7600 ! ! Portability American National Standards Institute FORTRAN. ! The machine accuracy is set using function R1MACH. ! ! Required NONE ! Resident ! Routines ! ! References Swarztrauber,P. and R. SWEET, 'Efficient Fortran ! Subprograms for the solution of elliptic equations' ! NCAR TN/IA-109, July, 1975, 138 PP. ! ! SWARZTRAUBER P. ,'A Direct Method for The Discrete ! Solution of Separable Elliptic Equations', SIAM ! J. Numer. Anal.,11(1974) PP. 1136-1150. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran ! subprograms for the solution of elliptic equations, ! NCAR TN/IA-109, July 1975, 138 pp. ! P. N. Swarztrauber, A direct method for the discrete ! solution of separable elliptic equations, SIAM Journal ! on Numerical Analysis 11, (1974), pp. 1136-1150. !***ROUTINES CALLED CBLKT1, CCMPB, CPROC, CPROCP, PROC, PROCP !***COMMON BLOCKS CCBLK !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CBLKTR ! DIMENSION AN(*) ,BN(*) ,CN(*) ,AM(*) , & BM(*) ,CM(*) ,Y(IDIMY,*) ,W(*) EXTERNAL PROC ,PROCP ,CPROC ,CPROCP COMMON /CCBLK/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK COMPLEX AM ,BM ,CM ,Y !***FIRST EXECUTABLE STATEMENT CBLKTR NM = N M2 = M+M IERROR = 0 if (M-5) 101,102,102 101 IERROR = 1 go to 119 102 if (NM-3) 103,104,104 103 IERROR = 2 go to 119 104 if (IDIMY-M) 105,106,106 105 IERROR = 3 go to 119 106 NH = N NPP = NP if (NPP) 107,108,107 107 NH = NH+1 108 IK = 2 K = 1 109 IK = IK+IK K = K+1 if (NH-IK) 110,110,109 110 NL = IK IK = IK+IK NL = NL-1 IWAH = (K-2)*IK+K+6 if (NPP) 111,112,111 ! ! DIVIDE W INTO WORKING SUB ARRAYS ! 111 IW1 = IWAH IWBH = IW1+NM W(1) = IW1-1+MAX(2*NM,12*M) go to 113 112 IWBH = IWAH+NM+NM IW1 = IWBH W(1) = IW1-1+MAX(2*NM,12*M) NM = NM-1 ! ! SUBROUTINE CCMPB COMPUTES THE ROOTS OF THE B POLYNOMIALS ! 113 if (IERROR) 119,114,119 114 IW2 = IW1+M2 IW3 = IW2+M2 IWD = IW3+M2 IWW = IWD+M2 IWU = IWW+M2 if (IFLG) 116,115,116 115 call CCMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH)) go to 119 116 if (MP) 117,118,117 ! ! SUBROUTINE CBLKT1 SOLVES THE LINEAR SYSTEM ! 117 call CBLKT1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2), & W(IW3),W(IWD),W(IWW),W(IWU),PROC,CPROC) go to 119 118 call CBLKT1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2), & W(IW3),W(IWD),W(IWW),W(IWU),PROCP,CPROCP) 119 CONTINUE return end function CBRT (X) ! !! CBRT computes the cube root. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C2 !***TYPE SINGLE PRECISION (CBRT-S, DCBRT-D, CCBRT-C) !***KEYWORDS CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CBRT(X) calculates the cube root of X. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, R9PAK, R9UPAK !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CBRT ! real cbrt DIMENSION CBRT2(5) SAVE CBRT2, NITER DATA CBRT2(1) / 0.62996052494743658E0 / DATA CBRT2(2) / 0.79370052598409974E0 / DATA CBRT2(3) / 1.0E0 / DATA CBRT2(4) / 1.25992104989487316E0 / DATA CBRT2(5) / 1.58740105196819947E0 / DATA NITER / 0 / !***FIRST EXECUTABLE STATEMENT CBRT if (NITER == 0) NITER = 1.443*LOG(-.106*LOG(0.1*R1MACH(3))) + 1. ! CBRT = 0.0 if (X == 0.) RETURN ! call R9UPAK (ABS(X), Y, N) IXPNT = N/3 IREM = N - 3*IXPNT + 3 ! ! THE APPROXIMATION BELOW IS A GENERALIZED CHEBYSHEV SERIES CONVERTED ! TO POLYNOMIAL FORM. THE APPROX IS NEARLY BEST IN THE SENSE OF ! RELATIVE ERROR WITH 4.085 DIGITS ACCURACY. ! CBRT = .439581E0 + Y*(.928549E0 + Y*(-.512653E0 + Y*.144586E0)) ! DO 10 ITER=1,NITER CBRTSQ = CBRT * CBRT CBRT = CBRT + (Y - CBRT *CBRTSQ )/(3.0*CBRTSQ) 10 CONTINUE ! CBRT = R9PAK (CBRT2(IREM)*SIGN(CBRT ,X), IXPNT) return ! end subroutine CBUNI (Z, FNU, KODE, N, Y, NZ, NUI, NLAST, FNUL, TOL, & ELIM, ALIM) ! !! CBUNI is subsidiary to CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CBUNI-A, ZBUNI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE ABS(Z) > ! FNUL AND FNU+N-1 < FNUL. THE ORDER IS INCREASED FROM ! FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING ! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) ! ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 ! !***SEE ALSO CBESI, CBESK !***ROUTINES CALLED CUNI1, CUNI2, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CBUNI COMPLEX CSCL, CSCR, CY, RZ, ST, S1, S2, Y, Z REAL ALIM, AX, AY, DFNU, ELIM, FNU, FNUI, FNUL, GNU, TOL, XX, YY, & ASCLE, BRY, STR, STI, STM, R1MACH INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ DIMENSION Y(N), CY(2), BRY(3) !***FIRST EXECUTABLE STATEMENT CBUNI NZ = 0 XX = REAL(Z) YY = AIMAG(Z) AX = ABS(XX)*1.7321E0 AY = ABS(YY) IFORM = 1 if (AY > AX) IFORM = 2 if (NUI == 0) go to 60 FNUI = NUI DFNU = FNU + (N-1) GNU = DFNU + FNUI if (IFORM == 2) go to 10 !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 !----------------------------------------------------------------------- call CUNI1(Z, GNU, KODE, 2, CY, NW, NLAST, FNUL, TOL, ELIM, ALIM) go to 20 10 CONTINUE !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 !----------------------------------------------------------------------- call CUNI2(Z, GNU, KODE, 2, CY, NW, NLAST, FNUL, TOL, ELIM, ALIM) 20 CONTINUE if (NW < 0) go to 50 if (NW /= 0) go to 90 AY = ABS(CY(1)) !---------------------------------------------------------------------- ! SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED !---------------------------------------------------------------------- BRY(1) = 1.0E+3*R1MACH(1)/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = BRY(2) IFLAG = 2 ASCLE = BRY(2) AX = 1.0E0 CSCL = CMPLX(AX,0.0E0) if (AY > BRY(1)) go to 21 IFLAG = 1 ASCLE = BRY(1) AX = 1.0E0/TOL CSCL = CMPLX(AX,0.0E0) go to 25 21 CONTINUE if (AY < BRY(2)) go to 25 IFLAG = 3 ASCLE = BRY(3) AX = TOL CSCL = CMPLX(AX,0.0E0) 25 CONTINUE AY = 1.0E0/AX CSCR = CMPLX(AY,0.0E0) S1 = CY(2)*CSCL S2 = CY(1)*CSCL RZ = CMPLX(2.0E0,0.0E0)/Z DO 30 I=1,NUI ST = S2 S2 = CMPLX(DFNU+FNUI,0.0E0)*RZ*S2 + S1 S1 = ST FNUI = FNUI - 1.0E0 if (IFLAG >= 3) go to 30 ST = S2*CSCR STR = REAL(ST) STI = AIMAG(ST) STR = ABS(STR) STI = ABS(STI) STM = MAX(STR,STI) if (STM <= ASCLE) go to 30 IFLAG = IFLAG+1 ASCLE = BRY(IFLAG) S1 = S1*CSCR S2 = ST AX = AX*TOL AY = 1.0E0/AX CSCL = CMPLX(AX,0.0E0) CSCR = CMPLX(AY,0.0E0) S1 = S1*CSCL S2 = S2*CSCL 30 CONTINUE Y(N) = S2*CSCR if (N == 1) RETURN NL = N - 1 FNUI = NL K = NL DO 40 I=1,NL ST = S2 S2 = CMPLX(FNU+FNUI,0.0E0)*RZ*S2 + S1 S1 = ST ST = S2*CSCR Y(K) = ST FNUI = FNUI - 1.0E0 K = K - 1 if (IFLAG >= 3) go to 40 STR = REAL(ST) STI = AIMAG(ST) STR = ABS(STR) STI = ABS(STI) STM = MAX(STR,STI) if (STM <= ASCLE) go to 40 IFLAG = IFLAG+1 ASCLE = BRY(IFLAG) S1 = S1*CSCR S2 = ST AX = AX*TOL AY = 1.0E0/AX CSCL = CMPLX(AX,0.0E0) CSCR = CMPLX(AY,0.0E0) S1 = S1*CSCL S2 = S2*CSCL 40 CONTINUE return 50 CONTINUE NZ = -1 if ( NW == (-2)) NZ=-2 return 60 CONTINUE if (IFORM == 2) go to 70 !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 !----------------------------------------------------------------------- call CUNI1(Z, FNU, KODE, N, Y, NW, NLAST, FNUL, TOL, ELIM, ALIM) go to 80 70 CONTINUE !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 !----------------------------------------------------------------------- call CUNI2(Z, FNU, KODE, N, Y, NW, NLAST, FNUL, TOL, ELIM, ALIM) 80 CONTINUE if (NW < 0) go to 50 NZ = NW return 90 CONTINUE NLAST = N return end subroutine CBUNK (Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) ! !! CBUNK is subsidiary to CBESH and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CBUNK-A, ZBUNK-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU > FNUL. ! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) ! IN CUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN CUNK2 ! !***SEE ALSO CBESH, CBESK !***ROUTINES CALLED CUNK1, CUNK2 !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CBUNK COMPLEX Y, Z REAL ALIM, AX, AY, ELIM, FNU, TOL, XX, YY INTEGER KODE, MR, N, NZ DIMENSION Y(N) !***FIRST EXECUTABLE STATEMENT CBUNK NZ = 0 XX = REAL(Z) YY = AIMAG(Z) AX = ABS(XX)*1.7321E0 AY = ABS(YY) if (AY > AX) go to 10 !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 !----------------------------------------------------------------------- call CUNK1(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) go to 20 10 CONTINUE !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 !----------------------------------------------------------------------- call CUNK2(Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) 20 CONTINUE return end FUNCTION CCBRT (Z) ! !! CCBRT computes the cube root. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C2 !***TYPE COMPLEX (CBRT-S, DCBRT-D, CCBRT-C) !***KEYWORDS CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CCBRT(Z) calculates the complex cube root of Z. The principal root ! for which -PI < arg(Z) <= +PI is returned. ! !***REFERENCES (NONE) !***ROUTINES CALLED CARG, CBRT !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CCBRT ! COMPLEX CCBRT COMPLEX Z !***FIRST EXECUTABLE STATEMENT CCBRT THETA = CARG(Z) / 3.0 R = CBRT (ABS(Z)) ! CCBRT = CMPLX (R*COS(THETA), R*SIN(THETA)) ! return end subroutine CCHDC (A, LDA, P, WORK, JPVT, JOB, INFO) ! !! CCHDC computes the Cholesky decomposition of a positive definite ... ! matrix. A pivoting option allows the user to estimate the ... ! condition number of a positive definite matrix or determine ... ! the rank of a positive semidefinite matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1B !***TYPE COMPLEX (SCHDC-S, DCHDC-D, CCHDC-C) !***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, ! POSITIVE DEFINITE !***AUTHOR Dongarra, J., (ANL) ! Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! CCHDC computes the Cholesky decomposition of a positive definite ! matrix. A pivoting option allows the user to estimate the ! condition of a positive definite matrix or determine the rank ! of a positive semidefinite matrix. ! ! On Entry ! ! A COMPLEX(LDA,P). ! A contains the matrix whose decomposition is to ! be computed. Only the upper half of A need be stored. ! The lower part of The array A is not referenced. ! ! LDA INTEGER. ! LDA is the leading dimension of the array A. ! ! P INTEGER. ! P is the order of the matrix. ! ! WORK COMPLEX. ! WORK is a work array. ! ! JPVT INTEGER(P). ! JPVT contains integers that control the selection ! of the pivot elements, if pivoting has been requested. ! Each diagonal element A(K,K) ! is placed in one of three classes according to the ! value of JPVT(K)). ! ! If JPVT(K)) > 0, then X(K) is an initial ! element. ! ! If JPVT(K)) == 0, then X(K) is a free element. ! ! If JPVT(K)) < 0, then X(K) is a final element. ! ! Before the decomposition is computed, initial elements ! are moved by symmetric row and column interchanges to ! the beginning of the array A and final ! elements to the end. Both initial and final elements ! are frozen in place during the computation and only ! free elements are moved. At the K-th stage of the ! reduction, if A(K,K) is occupied by a free element ! it is interchanged with the largest free element ! A(L,L) with L >= K. JPVT is not referenced if ! JOB == 0. ! ! JOB INTEGER. ! JOB is an integer that initiates column pivoting. ! if JOB == 0, no pivoting is done. ! if JOB /= 0, pivoting is done. ! ! On Return ! ! A A contains in its upper half the Cholesky factor ! of the matrix A as it has been permuted by pivoting. ! ! JPVT JPVT(J) contains the index of the diagonal element ! of A that was moved into the J-th position, ! provided pivoting was requested. ! ! INFO contains the index of the last positive diagonal ! element of the Cholesky factor. ! ! For positive definite matrices INFO = P is the normal return. ! For pivoting with positive semidefinite matrices INFO will ! in general be less than P. However, INFO may be greater than ! the rank of A, since rounding error can cause an otherwise zero ! element to be positive. Indefinite systems will always cause ! INFO to be less than P. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSWAP !***REVISION HISTORY (YYMMDD) ! 790319 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CCHDC INTEGER LDA,P,JPVT(*),JOB,INFO COMPLEX A(LDA,*),WORK(*) ! INTEGER PU,PL,PLP1,J,JP,JT,K,KB,KM1,KP1,L,MAXL COMPLEX TEMP REAL MAXDIA LOGICAL SWAPK,NEGK !***FIRST EXECUTABLE STATEMENT CCHDC PL = 1 PU = 0 INFO = P if (JOB == 0) go to 160 ! ! PIVOTING HAS BEEN REQUESTED. REARRANGE THE ! THE ELEMENTS ACCORDING TO JPVT. ! DO 70 K = 1, P SWAPK = JPVT(K) > 0 NEGK = JPVT(K) < 0 JPVT(K) = K if (NEGK) JPVT(K) = -JPVT(K) if (.NOT.SWAPK) go to 60 if (K == PL) go to 50 call CSWAP(PL-1,A(1,K),1,A(1,PL),1) TEMP = A(K,K) A(K,K) = A(PL,PL) A(PL,PL) = TEMP A(PL,K) = CONJG(A(PL,K)) PLP1 = PL + 1 if (P < PLP1) go to 40 DO 30 J = PLP1, P if (J >= K) go to 10 TEMP = CONJG(A(PL,J)) A(PL,J) = CONJG(A(J,K)) A(J,K) = TEMP go to 20 10 CONTINUE if (J == K) go to 20 TEMP = A(K,J) A(K,J) = A(PL,J) A(PL,J) = TEMP 20 CONTINUE 30 CONTINUE 40 CONTINUE JPVT(K) = JPVT(PL) JPVT(PL) = K 50 CONTINUE PL = PL + 1 60 CONTINUE 70 CONTINUE PU = P if (P < PL) go to 150 DO 140 KB = PL, P K = P - KB + PL if (JPVT(K) >= 0) go to 130 JPVT(K) = -JPVT(K) if (PU == K) go to 120 call CSWAP(K-1,A(1,K),1,A(1,PU),1) TEMP = A(K,K) A(K,K) = A(PU,PU) A(PU,PU) = TEMP A(K,PU) = CONJG(A(K,PU)) KP1 = K + 1 if (P < KP1) go to 110 DO 100 J = KP1, P if (J >= PU) go to 80 TEMP = CONJG(A(K,J)) A(K,J) = CONJG(A(J,PU)) A(J,PU) = TEMP go to 90 80 CONTINUE if (J == PU) go to 90 TEMP = A(K,J) A(K,J) = A(PU,J) A(PU,J) = TEMP 90 CONTINUE 100 CONTINUE 110 CONTINUE JT = JPVT(K) JPVT(K) = JPVT(PU) JPVT(PU) = JT 120 CONTINUE PU = PU - 1 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE DO 270 K = 1, P ! ! REDUCTION LOOP. ! MAXDIA = REAL(A(K,K)) KP1 = K + 1 MAXL = K ! ! DETERMINE THE PIVOT ELEMENT. ! if (K < PL .OR. K >= PU) go to 190 DO 180 L = KP1, PU if (REAL(A(L,L)) <= MAXDIA) go to 170 MAXDIA = REAL(A(L,L)) MAXL = L 170 CONTINUE 180 CONTINUE 190 CONTINUE ! ! QUIT if THE PIVOT ELEMENT IS NOT POSITIVE. ! if (MAXDIA > 0.0E0) go to 200 INFO = K - 1 go to 280 200 CONTINUE if (K == MAXL) go to 210 ! ! START THE PIVOTING AND UPDATE JPVT. ! KM1 = K - 1 call CSWAP(KM1,A(1,K),1,A(1,MAXL),1) A(MAXL,MAXL) = A(K,K) A(K,K) = CMPLX(MAXDIA,0.0E0) JP = JPVT(MAXL) JPVT(MAXL) = JPVT(K) JPVT(K) = JP A(K,MAXL) = CONJG(A(K,MAXL)) 210 CONTINUE ! ! REDUCTION STEP. PIVOTING IS CONTAINED ACROSS THE ROWS. ! WORK(K) = CMPLX(SQRT(REAL(A(K,K))),0.0E0) A(K,K) = WORK(K) if (P < KP1) go to 260 DO 250 J = KP1, P if (K == MAXL) go to 240 if (J >= MAXL) go to 220 TEMP = CONJG(A(K,J)) A(K,J) = CONJG(A(J,MAXL)) A(J,MAXL) = TEMP go to 230 220 CONTINUE if (J == MAXL) go to 230 TEMP = A(K,J) A(K,J) = A(MAXL,J) A(MAXL,J) = TEMP 230 CONTINUE 240 CONTINUE A(K,J) = A(K,J)/WORK(K) WORK(J) = CONJG(A(K,J)) TEMP = -A(K,J) call CAXPY(J-K,TEMP,WORK(KP1),1,A(KP1,J),1) 250 CONTINUE 260 CONTINUE 270 CONTINUE 280 CONTINUE return end subroutine CCHDD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S, INFO) ! !! CCHDD downdates an augmented Cholesky decomposition or the ... ! triangular factor of an augmented QR decomposition. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D7B !***TYPE COMPLEX (SCHDD-S, DCHDD-D, CCHDD-C) !***KEYWORDS CHOLESKY DECOMPOSITION, DOWNDATE, LINEAR ALGEBRA, LINPACK, ! MATRIX !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! CCHDD downdates an augmented Cholesky decomposition or the ! triangular factor of an augmented QR decomposition. ! Specifically, given an upper triangular matrix R of order P, a ! row vector X, a column vector Z, and a scalar Y, CCHDD ! determines a unitary matrix U and a scalar ZETA such that ! ! (R Z ) (RR ZZ) ! U * ( ) = ( ) , ! (0 ZETA) ( X Y) ! ! where RR is upper triangular. If R and Z have been obtained ! from the factorization of a least squares problem, then ! RR and ZZ are the factors corresponding to the problem ! with the observation (X,Y) removed. In this case, if RHO ! is the norm of the residual vector, then the norm of ! the residual vector of the downdated problem is ! SQRT(RHO**2 - ZETA**2). CCHDD will simultaneously downdate ! several triplets (Z,Y,RHO) along with R. ! For a less terse description of what CCHDD does and how ! it may be applied, see the LINPACK Guide. ! ! The matrix U is determined as the product U(1)*...*U(P) ! where U(I) is a rotation in the (P+1,I)-plane of the ! form ! ! ( C(I) -CONJG(S(I)) ) ! ( ) . ! ( S(I) C(I) ) ! ! the rotations are chosen so that C(I) is real. ! ! The user is warned that a given downdating problem may ! be impossible to accomplish or may produce ! inaccurate results. For example, this can happen ! if X is near a vector whose removal will reduce the ! rank of R. Beware. ! ! On Entry ! ! R COMPLEX(LDR,P), where LDR >= P. ! R contains the upper triangular matrix ! that is to be downdated. The part of R ! below the diagonal is not referenced. ! ! LDR INTEGER. ! LDR is the leading dimension of the array R. ! ! p INTEGER. ! P is the order of the matrix R. ! ! X COMPLEX(P). ! X contains the row vector that is to ! be removed from R. X is not altered by CCHDD. ! ! Z COMPLEX(LDZ,NZ), where LDZ >= P. ! Z is an array of NZ P-vectors which ! are to be downdated along with R. ! ! LDZ INTEGER. ! LDZ is the leading dimension of the array Z. ! ! NZ INTEGER. ! NZ is the number of vectors to be downdated ! NZ may be zero, in which case Z, Y, and RHO ! are not referenced. ! ! Y COMPLEX(NZ). ! Y contains the scalars for the downdating ! of the vectors Z. Y is not altered by CCHDD. ! ! RHO REAL(NZ). ! RHO contains the norms of the residual ! vectors that are to be downdated. ! ! On Return ! ! R ! Z contain the downdated quantities. ! RHO ! ! C REAL(P). ! C contains the cosines of the transforming ! rotations. ! ! S COMPLEX(P). ! S contains the sines of the transforming ! rotations. ! ! INFO INTEGER. ! INFO is set as follows. ! ! INFO = 0 if the entire downdating ! was successful. ! ! INFO =-1 if R could not be downdated. ! in this case, all quantities ! are left unaltered. ! ! INFO = 1 if some RHO could not be ! downdated. The offending RHO's are ! set to -1. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CDOTC, SCNRM2 !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CCHDD INTEGER LDR,P,LDZ,NZ,INFO COMPLEX R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) REAL RHO(*),C(*) ! INTEGER I,II,J REAL A,ALPHA,AZETA,NORM,SCNRM2 COMPLEX CDOTC,T,ZETA,B,XX ! ! SOLVE THE SYSTEM CTRANS(R)*A = X, PLACING THE RESULT ! IN THE ARRAY S. ! !***FIRST EXECUTABLE STATEMENT CCHDD INFO = 0 S(1) = CONJG(X(1))/CONJG(R(1,1)) if (P < 2) go to 20 DO 10 J = 2, P S(J) = CONJG(X(J)) - CDOTC(J-1,R(1,J),1,S,1) S(J) = S(J)/CONJG(R(J,J)) 10 CONTINUE 20 CONTINUE NORM = SCNRM2(P,S,1) if (NORM < 1.0E0) go to 30 INFO = -1 go to 120 30 CONTINUE ALPHA = SQRT(1.0E0-NORM**2) ! ! DETERMINE THE TRANSFORMATIONS. ! DO 40 II = 1, P I = P - II + 1 SCALE = ALPHA + ABS(S(I)) A = ALPHA/SCALE B = S(I)/SCALE NORM = SQRT(A**2+REAL(B)**2+AIMAG(B)**2) C(I) = A/NORM S(I) = CONJG(B)/NORM ALPHA = SCALE*NORM 40 CONTINUE ! ! APPLY THE TRANSFORMATIONS TO R. ! DO 60 J = 1, P XX = (0.0E0,0.0E0) DO 50 II = 1, J I = J - II + 1 T = C(I)*XX + S(I)*R(I,J) R(I,J) = C(I)*R(I,J) - CONJG(S(I))*XX XX = T 50 CONTINUE 60 CONTINUE ! ! if REQUIRED, DOWNDATE Z AND RHO. ! if (NZ < 1) go to 110 DO 100 J = 1, NZ ZETA = Y(J) DO 70 I = 1, P Z(I,J) = (Z(I,J) - CONJG(S(I))*ZETA)/C(I) ZETA = C(I)*ZETA - S(I)*Z(I,J) 70 CONTINUE AZETA = ABS(ZETA) if (AZETA <= RHO(J)) go to 80 INFO = 1 RHO(J) = -1.0E0 go to 90 80 CONTINUE RHO(J) = RHO(J)*SQRT(1.0E0-(AZETA/RHO(J))**2) 90 CONTINUE 100 CONTINUE 110 CONTINUE 120 CONTINUE return end subroutine CCHEX (R, LDR, P, K, L, Z, LDZ, NZ, C, S, JOB) ! !! CCHEX updates the Cholesky factorization A=TRANS(R)*R of a ... ! positive definite matrix A of order P under diagonal ... ! permutations of the form TRANS(E)*A*E, where E is a ... ! permutation matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D7B !***TYPE COMPLEX (SCHEX-S, DCHEX-D, CCHEX-C) !***KEYWORDS CHOLESKY DECOMPOSITION, EXCHANGE, LINEAR ALGEBRA, LINPACK, ! MATRIX, POSITIVE DEFINITE !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! CCHEX updates the Cholesky factorization ! ! A = CTRANS(R)*R ! ! of a positive definite matrix A of order P under diagonal ! permutations of the form ! ! TRANS(E)*A*E ! ! where E is a permutation matrix. Specifically, given ! an upper triangular matrix R and a permutation matrix ! E (which is specified by K, L, and JOB), CCHEX determines ! a unitary matrix U such that ! ! U*R*E = RR, ! ! where RR is upper triangular. At the users option, the ! transformation U will be multiplied into the array Z. ! If A = CTRANS(X)*X, so that R is the triangular part of the ! QR factorization of X, then RR is the triangular part of the ! QR factorization of X*E, i.e. X with its columns permuted. ! For a less terse description of what CCHEX does and how ! it may be applied, see the LINPACK Guide. ! ! The matrix Q is determined as the product U(L-K)*...*U(1) ! of plane rotations of the form ! ! ( C(I) S(I) ) ! ( ) , ! ( -CONJG(S(I)) C(I) ) ! ! where C(I) is real. The rows these rotations operate on ! are described below. ! ! There are two types of permutations, which are determined ! by the value of JOB. ! ! 1. Right circular shift (JOB = 1). ! ! The columns are rearranged in the following order. ! ! 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. ! ! U is the product of L-K rotations U(I), where U(I) ! acts in the (L-I,L-I+1)-plane. ! ! 2. Left circular shift (JOB = 2). ! The columns are rearranged in the following order ! ! 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. ! ! U is the product of L-K rotations U(I), where U(I) ! acts in the (K+I-1,K+I)-plane. ! ! On Entry ! ! R COMPLEX(LDR,P), where LDR >= P. ! R contains the upper triangular factor ! that is to be updated. Elements of R ! below the diagonal are not referenced. ! ! LDR INTEGER. ! LDR is the leading dimension of the array R. ! ! P INTEGER. ! P is the order of the matrix R. ! ! K INTEGER. ! K is the first column to be permuted. ! ! L INTEGER. ! L is the last column to be permuted. ! L must be strictly greater than K. ! ! Z COMPLEX(LDZ,NZ), where LDZ >= P. ! Z is an array of NZ P-vectors into which the ! transformation U is multiplied. Z is ! not referenced if NZ = 0. ! ! LDZ INTEGER. ! LDZ is the leading dimension of the array Z. ! ! NZ INTEGER. ! NZ is the number of columns of the matrix Z. ! ! JOB INTEGER. ! JOB determines the type of permutation. ! JOB = 1 right circular shift. ! JOB = 2 left circular shift. ! ! On Return ! ! R contains the updated factor. ! ! Z contains the updated matrix Z. ! ! C REAL(P). ! C contains the cosines of the transforming rotations. ! ! S COMPLEX(P). ! S contains the sines of the transforming rotations. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CROTG !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CCHEX INTEGER LDR,P,K,L,LDZ,NZ,JOB COMPLEX R(LDR,*),Z(LDZ,*),S(*) REAL C(*) ! INTEGER I,II,IL,IU,J,JJ,KM1,KP1,LMK,LM1 COMPLEX T ! ! INITIALIZE ! !***FIRST EXECUTABLE STATEMENT CCHEX KM1 = K - 1 KP1 = K + 1 LMK = L - K LM1 = L - 1 ! ! PERFORM THE APPROPRIATE TASK. ! go to (10,130), JOB ! ! RIGHT CIRCULAR SHIFT. ! 10 CONTINUE ! ! REORDER THE COLUMNS. ! DO 20 I = 1, L II = L - I + 1 S(I) = R(II,L) 20 CONTINUE DO 40 JJ = K, LM1 J = LM1 - JJ + K DO 30 I = 1, J R(I,J+1) = R(I,J) 30 CONTINUE R(J+1,J+1) = (0.0E0,0.0E0) 40 CONTINUE if (K == 1) go to 60 DO 50 I = 1, KM1 II = L - I + 1 R(I,K) = S(II) 50 CONTINUE 60 CONTINUE ! ! CALCULATE THE ROTATIONS. ! T = S(1) DO 70 I = 1, LMK call CROTG(S(I+1),T,C(I),S(I)) T = S(I+1) 70 CONTINUE R(K,K) = T DO 90 J = KP1, P IL = MAX(1,L-J+1) DO 80 II = IL, LMK I = L - II T = C(II)*R(I,J) + S(II)*R(I+1,J) R(I+1,J) = C(II)*R(I+1,J) - CONJG(S(II))*R(I,J) R(I,J) = T 80 CONTINUE 90 CONTINUE ! ! if REQUIRED, APPLY THE TRANSFORMATIONS TO Z. ! if (NZ < 1) go to 120 DO 110 J = 1, NZ DO 100 II = 1, LMK I = L - II T = C(II)*Z(I,J) + S(II)*Z(I+1,J) Z(I+1,J) = C(II)*Z(I+1,J) - CONJG(S(II))*Z(I,J) Z(I,J) = T 100 CONTINUE 110 CONTINUE 120 CONTINUE go to 260 ! ! LEFT CIRCULAR SHIFT ! 130 CONTINUE ! ! REORDER THE COLUMNS ! DO 140 I = 1, K II = LMK + I S(II) = R(I,K) 140 CONTINUE DO 160 J = K, LM1 DO 150 I = 1, J R(I,J) = R(I,J+1) 150 CONTINUE JJ = J - KM1 S(JJ) = R(J+1,J+1) 160 CONTINUE DO 170 I = 1, K II = LMK + I R(I,L) = S(II) 170 CONTINUE DO 180 I = KP1, L R(I,L) = (0.0E0,0.0E0) 180 CONTINUE ! ! REDUCTION LOOP. ! DO 220 J = K, P if (J == K) go to 200 ! ! APPLY THE ROTATIONS. ! IU = MIN(J-1,L-1) DO 190 I = K, IU II = I - K + 1 T = C(II)*R(I,J) + S(II)*R(I+1,J) R(I+1,J) = C(II)*R(I+1,J) - CONJG(S(II))*R(I,J) R(I,J) = T 190 CONTINUE 200 CONTINUE if (J >= L) go to 210 JJ = J - K + 1 T = S(JJ) call CROTG(R(J,J),T,C(JJ),S(JJ)) 210 CONTINUE 220 CONTINUE ! ! APPLY THE ROTATIONS TO Z. ! if (NZ < 1) go to 250 DO 240 J = 1, NZ DO 230 I = K, LM1 II = I - KM1 T = C(II)*Z(I,J) + S(II)*Z(I+1,J) Z(I+1,J) = C(II)*Z(I+1,J) - CONJG(S(II))*Z(I,J) Z(I,J) = T 230 CONTINUE 240 CONTINUE 250 CONTINUE 260 CONTINUE return end subroutine CCHUD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S) ! !! CCHUD updates an augmented Cholesky decomposition of the ... ! triangular part of an augmented QR decomposition. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D7B !***TYPE COMPLEX (SCHUD-S, DCHUD-D, CCHUD-C) !***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, ! UPDATE !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! CCHUD updates an augmented Cholesky decomposition of the ! triangular part of an augmented QR decomposition. Specifically, ! given an upper triangular matrix R of order P, a row vector ! X, a column vector Z, and a scalar Y, CCHUD determines a ! unitary matrix U and a scalar ZETA such that ! ! ! (R Z) (RR ZZ ) ! U * ( ) = ( ) , ! (X Y) ( 0 ZETA) ! ! where RR is upper triangular. If R and Z have been ! obtained from the factorization of a least squares ! problem, then RR and ZZ are the factors corresponding to ! the problem with the observation (X,Y) appended. In this ! case, if RHO is the norm of the residual vector, then the ! norm of the residual vector of the updated problem is ! SQRT(RHO**2 + ZETA**2). CCHUD will simultaneously update ! several triplets (Z,Y,RHO). ! ! For a less terse description of what CCHUD does and how ! it may be applied see the LINPACK Guide. ! ! The matrix U is determined as the product U(P)*...*U(1), ! where U(I) is a rotation in the (I,P+1) plane of the ! form ! ! ( (CI) S(I) ) ! ( ) . ! ( -CONJG(S(I)) (CI) ) ! ! The rotations are chosen so that C(I) is real. ! ! On Entry ! ! R COMPLEX(LDR,P), where LDR >= P. ! R contains the upper triangular matrix ! that is to be updated. The part of R ! below the diagonal is not referenced. ! ! LDR INTEGER. ! LDR is the leading dimension of the array R. ! ! P INTEGER. ! P is the order of the matrix R. ! ! X COMPLEX(P). ! X contains the row to be added to R. X is ! not altered by CCHUD. ! ! Z COMPLEX(LDZ,NZ), where LDZ >= P. ! Z is an array containing NZ P-vectors to ! be updated with R. ! ! LDZ INTEGER. ! LDZ is the leading dimension of the array Z. ! ! NZ INTEGER. ! NZ is the number of vectors to be updated ! NZ may be zero, in which case Z, Y, and RHO ! are not referenced. ! ! Y COMPLEX(NZ). ! Y contains the scalars for updating the vectors ! Z. Y is not altered by CCHUD. ! ! RHO REAL(NZ). ! RHO contains the norms of the residual ! vectors that are to be updated. If RHO(J) ! is negative, it is left unaltered. ! ! On Return ! ! RC ! RHO contain the updated quantities. ! Z ! ! C REAL(P). ! C contains the cosines of the transforming ! rotations. ! ! S COMPLEX(P). ! S contains the sines of the transforming ! rotations. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CROTG !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CCHUD INTEGER LDR,P,LDZ,NZ REAL RHO(*),C(*) COMPLEX R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) ! INTEGER I,J,JM1 REAL AZETA,SCALE COMPLEX T,XJ,ZETA ! ! UPDATE R. ! !***FIRST EXECUTABLE STATEMENT CCHUD DO 30 J = 1, P XJ = X(J) ! ! APPLY THE PREVIOUS ROTATIONS. ! JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 T = C(I)*R(I,J) + S(I)*XJ XJ = C(I)*XJ - CONJG(S(I))*R(I,J) R(I,J) = T 10 CONTINUE 20 CONTINUE ! ! COMPUTE THE NEXT ROTATION. ! call CROTG(R(J,J),XJ,C(J),S(J)) 30 CONTINUE ! ! if REQUIRED, UPDATE Z AND RHO. ! if (NZ < 1) go to 70 DO 60 J = 1, NZ ZETA = Y(J) DO 40 I = 1, P T = C(I)*Z(I,J) + S(I)*ZETA ZETA = C(I)*ZETA - CONJG(S(I))*Z(I,J) Z(I,J) = T 40 CONTINUE AZETA = ABS(ZETA) if (AZETA == 0.0E0 .OR. RHO(J) < 0.0E0) go to 50 SCALE = AZETA + RHO(J) RHO(J) = SCALE*SQRT((AZETA/SCALE)**2+(RHO(J)/SCALE)**2) 50 CONTINUE 60 CONTINUE 70 CONTINUE return end subroutine CCMPB (N, IERROR, AN, BN, CN, B, AH, BH) ! !! CCMPB is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE COMPLEX (COMPB-S, CCMPB-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! CCMPB computes the roots of the B polynomials using subroutine ! TEVLC which is a modification the EISPACK program TQLRAT. ! IERROR is set to 4 if either TEVLC fails or if A(J+1)*C(J) is ! less than zero for some J. AH,BH are temporary work arrays. ! !***SEE ALSO CBLKTR !***ROUTINES CALLED CPADD, INXCB, R1MACH, TEVLC !***COMMON BLOCKS CCBLK !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CCMPB ! DIMENSION AN(*) ,BN(*) ,CN(*) ,B(*) , & AH(*) ,BH(*) COMMON /CCBLK/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT CCMPB EPS = R1MACH(4) BNORM = ABS(BN(1)) DO 102 J=2,NM BNORM = MAX(BNORM,ABS(BN(J))) ARG = AN(J)*CN(J-1) if (ARG) 119,101,101 101 B(J) = SIGN(SQRT(ARG),AN(J)) 102 CONTINUE CNV = EPS*BNORM if = 2**K KDO = K-1 DO 108 L=1,KDO IR = L-1 I2 = 2**IR I4 = I2+I2 IPL = I4-1 IFD = IF-I4 DO 107 I=I4,IFD,I4 call INXCB (I,L,IB,NB) if (NB) 108,108,103 103 JS = I-IPL JF = JS+NB-1 LS = 0 DO 104 J=JS,JF LS = LS+1 BH(LS) = BN(J) AH(LS) = B(J) 104 CONTINUE call TEVLC (NB,BH,AH,IERROR) if (IERROR) 118,105,118 105 LH = IB-1 DO 106 J=1,NB LH = LH+1 B(LH) = -BH(J) 106 CONTINUE 107 CONTINUE 108 CONTINUE DO 109 J=1,NM B(J) = -BN(J) 109 CONTINUE if (NPP) 117,110,117 110 NMP = NM+1 NB = NM+NMP DO 112 J=1,NB L1 = MOD(J-1,NMP)+1 L2 = MOD(J+NM-1,NMP)+1 ARG = AN(L1)*CN(L2) if (ARG) 119,111,111 111 BH(J) = SIGN(SQRT(ARG),-AN(L1)) AH(J) = -BN(L1) 112 CONTINUE call TEVLC (NB,AH,BH,IERROR) if (IERROR) 118,113,118 113 call INXCB (IF,K-1,J2,LH) call INXCB (IF/2,K-1,J1,LH) J2 = J2+1 LH = J2 N2M2 = J2+NM+NM-2 114 D1 = ABS(B(J1)-B(J2-1)) D2 = ABS(B(J1)-B(J2)) D3 = ABS(B(J1)-B(J2+1)) if ((D2 < D1) .AND. (D2 < D3)) go to 115 B(LH) = B(J2) J2 = J2+1 LH = LH+1 if (J2-N2M2) 114,114,116 115 J2 = J2+1 J1 = J1+1 if (J2-N2M2) 114,114,116 116 B(LH) = B(N2M2+1) call INXCB (IF,K-1,J1,J2) J2 = J1+NMP+NMP call CPADD (NM+1,IERROR,AN,CN,B(J1),B(J1),B(J2)) 117 RETURN 118 IERROR = 4 return 119 IERROR = 5 return end subroutine CCOPY (N, CX, INCX, CY, INCY) ! !! CCOPY copies a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A5 !***TYPE COMPLEX (SCOPY-S, DCOPY-D, CCOPY-C, ICOPY-I) !***KEYWORDS BLAS, COPY, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! CX complex vector with N elements ! INCX storage spacing between elements of CX ! CY complex vector with N elements ! INCY storage spacing between elements of CY ! ! --Output-- ! CY copy of vector CX (unchanged if N <= 0) ! ! Copy complex CX to complex CY. ! For I = 0 to N-1, copy CX(LX+I*INCX) to CY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CCOPY COMPLEX CX(*),CY(*) !***FIRST EXECUTABLE STATEMENT CCOPY if (N <= 0) RETURN if (INCX == INCY .AND. INCX > 0) go to 20 ! ! Code for unequal or nonpositive increments. ! KX = 1 KY = 1 if (INCX < 0) KX = 1+(1-N)*INCX if (INCY < 0) KY = 1+(1-N)*INCY DO 10 I = 1,N CY(KY) = CX(KX) KX = KX + INCX KY = KY + INCY 10 CONTINUE return ! ! Code for equal, positive increments. ! 20 NS = N*INCX DO 30 I = 1,NS,INCX CY(I) = CX(I) 30 CONTINUE return end FUNCTION CCOSH (Z) ! !! CCOSH computes the complex hyperbolic cosine. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE COMPLEX (CCOSH-C) !***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, HYPERBOLIC COSINE !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CCOSH(Z) calculates the complex hyperbolic cosine of Z. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CCOSH COMPLEX CCOSH COMPLEX Z, CI SAVE CI DATA CI /(0.,1.)/ !***FIRST EXECUTABLE STATEMENT CCOSH CCOSH = COS (CI*Z) ! return end FUNCTION CCOT (Z) ! !! CCOT computes the cotangent. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE COMPLEX (COT-S, DCOT-D, CCOT-C) !***KEYWORDS COTANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CCOT(Z) calculates the complex trigonometric cotangent of Z. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERCLR, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE CCOT COMPLEX CCOT COMPLEX Z SAVE SQEPS DATA SQEPS /0./ !***FIRST EXECUTABLE STATEMENT CCOT if (SQEPS == 0.) SQEPS = SQRT (R1MACH(4)) ! X2 = 2.0*REAL(Z) Y2 = 2.0*AIMAG(Z) ! SN2X = SIN (X2) call XERCLR ! DEN = COSH(Y2) - COS(X2) if (DEN == 0.) call XERMSG ('SLATEC', 'CCOT', & 'COT IS SINGULAR FOR INPUT Z (X IS 0 OR PI AND Y IS 0)', 2, 2) ! if (ABS(DEN) > MAX(ABS(X2),1.)*SQEPS) go to 10 call XERCLR call XERMSG ('SLATEC', 'CCOT', & 'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X TOO NEAR ' // & '0 OR PI', 1, 1) ! 10 CCOT = CMPLX (SN2X/DEN, -SINH(Y2)/DEN) ! return end FUNCTION CDCDOT (N, CB, CX, INCX, CY, INCY) ! !! CDCDOT computes the inner product of two vectors with extended ... ! precision accumulation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A4 !***TYPE COMPLEX (SDSDOT-S, CDCDOT-C) !***KEYWORDS BLAS, DOT PRODUCT, INNER PRODUCT, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! CB complex scalar to be added to inner product ! CX complex vector with N elements ! INCX storage spacing between elements of CX ! CY complex vector with N elements ! INCY storage spacing between elements of CY ! ! --Output-- ! CDCDOT complex dot product (CB if N <= 0) ! ! Returns complex result with dot product accumulated in D.P. ! CDCDOT = CB + sum for I = 0 to N-1 of CX(LX+I*INCY)*CY(LY+I*INCY) ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CDCDOT COMPLEX CDCDOT INTEGER N, INCX, INCY, I, KX, KY COMPLEX CX(*), CY(*), CB DOUBLE PRECISION DSDOTR, DSDOTI, DT1, DT2, DT3, DT4 !***FIRST EXECUTABLE STATEMENT CDCDOT DSDOTR = DBLE(REAL(CB)) DSDOTI = DBLE(AIMAG(CB)) if (N <= 0) go to 10 KX = 1 KY = 1 if ( INCX < 0) KX = 1+(1-N)*INCX if ( INCY < 0) KY = 1+(1-N)*INCY DO 5 I = 1,N DT1 = DBLE(REAL(CX(KX))) DT2 = DBLE(REAL(CY(KY))) DT3 = DBLE(AIMAG(CX(KX))) DT4 = DBLE(AIMAG(CY(KY))) DSDOTR = DSDOTR+(DT1*DT2)-(DT3*DT4) DSDOTI = DSDOTI+(DT1*DT4)+(DT3*DT2) KX = KX+INCX KY = KY+INCY 5 CONTINUE 10 CDCDOT = CMPLX(REAL(DSDOTR),REAL(DSDOTI)) return end subroutine CDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, & MITER, ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, SAVE1, & SAVE2, A, D, JSTATE) ! !! CDCOR computes corrections to the Y array. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE COMPLEX (SDCOR-S, DDCOR-D, CDCOR-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! In the case of functional iteration, update Y directly from the ! result of the last call to F. ! In the case of the chord method, compute the corrector error and ! solve the linear system with that as right hand side and DFDY as ! coefficient matrix, using the LU decomposition if MITER is 1, 2, 4, ! or 5. ! !***ROUTINES CALLED CGBSL, CGESL, SCNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDCOR INTEGER I, IERROR, IFLAG, IMPL, J, JSTATE, MATDIM, MITER, ML, MU, & MW, N, NDE, NQ COMPLEX A(MATDIM,*), DFDY(MATDIM,*), SAVE1(*), SAVE2(*), Y(*), & YH(N,*), YWT(*) REAL D, EL(13,12), H, SCNRM2, T INTEGER IPVT(*) LOGICAL EVALFA !***FIRST EXECUTABLE STATEMENT CDCOR if (MITER == 0) THEN if (IERROR == 1 .OR. IERROR == 5) THEN DO 100 I = 1,N 100 SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/YWT(I) ELSE DO 102 I = 1,N SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/ & MAX(ABS(Y(I)), ABS(YWT(I))) 102 CONTINUE end if D = SCNRM2(N, SAVE1, 1)/SQRT(REAL(N)) DO 105 I = 1,N 105 SAVE1(I) = H*SAVE2(I) - YH(I,2) ELSE if (MITER == 1 .OR. MITER == 2) THEN if (IMPL == 0) THEN DO 130 I = 1,N 130 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) ELSE if (IMPL == 1) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 150 I = 1,N 150 SAVE2(I) = H*SAVE2(I) DO 160 J = 1,N DO 160 I = 1,N 160 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) ELSE if (IMPL == 2) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 180 I = 1,N 180 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) ELSE if (IMPL == 3) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 140 I = 1,N 140 SAVE2(I) = H*SAVE2(I) DO 170 J = 1,NDE DO 170 I = 1,NDE 170 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) end if call CGESL (DFDY, MATDIM, N, IPVT, SAVE2, 0) if (IERROR == 1 .OR. IERROR == 5) THEN DO 200 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 200 SAVE2(I) = SAVE2(I)/YWT(I) ELSE DO 205 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 205 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), ABS(YWT(I))) end if D = SCNRM2(N, SAVE2, 1)/SQRT(REAL(N)) ELSE if (MITER == 4 .OR. MITER == 5) THEN if (IMPL == 0) THEN DO 230 I = 1,N 230 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) ELSE if (IMPL == 1) THEN if (EVALFA) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 250 I = 1,N 250 SAVE2(I) = H*SAVE2(I) MW = ML + 1 + MU DO 260 J = 1,N DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) SAVE2(I+J-MW) = SAVE2(I+J-MW) & - A(I,J)*(YH(J,2) + SAVE1(J)) 260 CONTINUE ELSE if (IMPL == 2) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 280 I = 1,N 280 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) ELSE if (IMPL == 3) THEN if (EVALFA) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 270 I = 1,N 270 SAVE2(I) = H*SAVE2(I) MW = ML + 1 + MU DO 290 J = 1,NDE DO 290 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) SAVE2(I+J-MW) = SAVE2(I+J-MW) & - A(I,J)*(YH(J,2) + SAVE1(J)) 290 CONTINUE end if call CGBSL (DFDY, MATDIM, N, ML, MU, IPVT, SAVE2, 0) if (IERROR == 1 .OR. IERROR == 5) THEN DO 300 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 300 SAVE2(I) = SAVE2(I)/YWT(I) ELSE DO 305 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 305 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), ABS(YWT(I))) end if D = SCNRM2(N, SAVE2, 1)/SQRT(REAL(N)) ELSE if (MITER == 3) THEN IFLAG = 2 call USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, & N, NDE, IFLAG) if (N == 0) THEN JSTATE = 10 return end if if (IERROR == 1 .OR. IERROR == 5) THEN DO 320 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 320 SAVE2(I) = SAVE2(I)/YWT(I) ELSE DO 325 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 325 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), ABS(YWT(I))) end if D = SCNRM2(N, SAVE2, 1)/SQRT(REAL(N)) end if return end subroutine CDCST (MAXORD, MINT, ISWFLG, EL, TQ) ! !! CDCST sets coefficients used by the core integrator CDSTP. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE COMPLEX (SDCST-S, DDCST-D, CDCST-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! CDCST is called by CDNTL. The array EL determines the basic method. ! The array TQ is involved in adjusting the step size in relation ! to truncation error. EL and TQ depend upon MINT, and are calculated ! for orders 1 to MAXORD( <= 12). For each order NQ, the coefficients ! EL are calculated from the generating polynomial: ! L(T) = EL(1,NQ) + EL(2,NQ)*T + ... + EL(NQ+1,NQ)*T**NQ. ! For the implicit Adams methods, L(T) is given by ! dL/dT = (1+T)*(2+T)* ... *(NQ-1+T)/K, L(-1) = 0, ! where K = factorial(NQ-1). ! For the Gear methods, ! L(T) = (1+T)*(2+T)* ... *(NQ+T)/K, ! where K = factorial(NQ)*(1 + 1/2 + ... + 1/NQ). ! For each order NQ, there are three components of TQ. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDCST REAL EL(13,12), FACTRL(12), GAMMA(14), SUM, TQ(3,12) INTEGER I, ISWFLG, J, MAXORD, MINT, MXRD !***FIRST EXECUTABLE STATEMENT CDCST FACTRL(1) = 1.E0 DO 10 I = 2,MAXORD 10 FACTRL(I) = I*FACTRL(I-1) ! Compute Adams coefficients if (MINT == 1) THEN GAMMA(1) = 1.E0 DO 40 I = 1,MAXORD+1 SUM = 0.E0 DO 30 J = 1,I 30 SUM = SUM - GAMMA(J)/(I-J+2) 40 GAMMA(I+1) = SUM EL(1,1) = 1.E0 EL(2,1) = 1.E0 EL(2,2) = 1.E0 EL(3,2) = 1.E0 DO 60 J = 3,MAXORD EL(2,J) = FACTRL(J-1) DO 50 I = 3,J 50 EL(I,J) = (J-1)*EL(I,J-1) + EL(I-1,J-1) 60 EL(J+1,J) = 1.E0 DO 80 J = 2,MAXORD EL(1,J) = EL(1,J-1) + GAMMA(J) EL(2,J) = 1.E0 DO 80 I = 3,J+1 80 EL(I,J) = EL(I,J)/((I-1)*FACTRL(J-1)) DO 100 J = 1,MAXORD TQ(1,J) = -1.E0/(FACTRL(J)*GAMMA(J)) TQ(2,J) = -1.E0/GAMMA(J+1) 100 TQ(3,J) = -1.E0/GAMMA(J+2) ! Compute Gear coefficients ELSE if (MINT == 2) THEN EL(1,1) = 1.E0 EL(2,1) = 1.E0 DO 130 J = 2,MAXORD EL(1,J) = FACTRL(J) DO 120 I = 2,J 120 EL(I,J) = J*EL(I,J-1) + EL(I-1,J-1) 130 EL(J+1,J) = 1.E0 SUM = 1.E0 DO 150 J = 2,MAXORD SUM = SUM + 1.E0/J DO 150 I = 1,J+1 150 EL(I,J) = EL(I,J)/(FACTRL(J)*SUM) DO 170 J = 1,MAXORD if (J > 1) TQ(1,J) = 1.E0/FACTRL(J-1) TQ(2,J) = (J+1)/EL(1,J) 170 TQ(3,J) = (J+2)/EL(1,J) end if ! Compute constants used in the stiffness test. ! These are the ratio of TQ(2,NQ) for the Gear ! methods to those for the Adams methods. if (ISWFLG == 3) THEN MXRD = MIN(MAXORD, 5) if (MINT == 2) THEN GAMMA(1) = 1.E0 DO 190 I = 1,MXRD SUM = 0.E0 DO 180 J = 1,I 180 SUM = SUM - GAMMA(J)/(I-J+2) 190 GAMMA(I+1) = SUM end if SUM = 1.E0 DO 200 I = 2,MXRD SUM = SUM + 1.E0/I 200 EL(1+I,1) = -(I+1)*SUM*GAMMA(I+1) end if return end subroutine CDIV (AR, AI, BR, BI, CR, CI) ! !! CDIV computes the complex quotient of two complex numbers. ! !***LIBRARY SLATEC !***TYPE COMPLEX (CDIV-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Complex division, (CR,CI) = (AR,AI)/(BR,BI) ! !***SEE ALSO EISDOC !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811101 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CDIV REAL AR,AI,BR,BI,CR,CI ! REAL S,ARS,AIS,BRS,BIS !***FIRST EXECUTABLE STATEMENT CDIV S = ABS(BR) + ABS(BI) ARS = AR/S AIS = AI/S BRS = BR/S BIS = BI/S S = BRS**2 + BIS**2 CR = (ARS*BRS + AIS*BIS)/S CI = (AIS*BRS - ARS*BIS)/S return end subroutine CDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, UROUND, USERS, & Y, YWT, H, MNTOLD, MTROLD, NFE, RC, YH, A, CONVRG, EL, FAC, & IER, IPVT, NQ, NWAIT, RH, RMAX, SAVE2, TQ, TREND, ISWFLG, & JSTATE) ! !! CDNTL sets parameters on the first call to CDSTP, on an internal ... ! restart, or when the user has altered MINT, MITER, and/or H. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE COMPLEX (SDNTL-S, DDNTL-D, CDNTL-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! On the first call, the order is set to 1 and the initial derivatives ! are calculated. RMAX is the maximum ratio by which H can be ! increased in one step. It is initially RMINIT to compensate ! for the small initial H, but then is normally equal to RMNORM. ! If a failure occurs (in corrector convergence or error test), RMAX ! is set at RMFAIL for the next increase. ! If the caller has changed MINT, or if JTASK = 0, CDCST is called ! to set the coefficients of the method. If the caller has changed H, ! YH must be rescaled. If H or MINT has been changed, NWAIT is ! reset to NQ + 2 to prevent further increases in H for that many ! steps. Also, RC is reset. RC is the ratio of new to old values of ! the coefficient L(0)*H. If the caller has changed MITER, RC is ! set to 0 to force the partials to be updated, if partials are used. ! !***ROUTINES CALLED CDCST, CDSCL, CGBFA, CGBSL, CGEFA, CGESL, SCNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDNTL INTEGER I, IFLAG, IMPL, INFO, ISWFLG, JSTATE, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, MU, N, NDE, NFE, & NQ, NWAIT COMPLEX A(MATDIM,*), FAC(*), SAVE1(*), SAVE2(*), Y(*), YH(N,*), & YWT(*) REAL EL(13,12), EPS, H, HMAX, HOLD, OLDL0, RC, RH, RMAX, & RMINIT, SCNRM2, SUM, T, TQ(3,12), TREND, UROUND INTEGER IPVT(*) LOGICAL CONVRG, IER PARAMETER(RMINIT = 10000.E0) !***FIRST EXECUTABLE STATEMENT CDNTL IER = .FALSE. if (JTASK >= 0) THEN if (JTASK == 0) THEN call CDCST (MAXORD, MINT, ISWFLG, EL, TQ) RMAX = RMINIT end if RC = 0.E0 CONVRG = .FALSE. TREND = 1.E0 NQ = 1 NWAIT = 3 call F (N, T, Y, SAVE2) if (N == 0) THEN JSTATE = 6 return end if NFE = NFE + 1 if (IMPL /= 0) THEN if (MITER == 3) THEN IFLAG = 0 call USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, IMPL, N, & NDE, IFLAG) if (IFLAG == -1) THEN IER = .TRUE. return end if if (N == 0) THEN JSTATE = 10 return end if ELSE if (IMPL == 1) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call CGEFA (A, MATDIM, N, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call CGESL (A, MATDIM, N, IPVT, SAVE2, 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call CGBFA (A, MATDIM, N, ML, MU, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call CGBSL (A, MATDIM, N, ML, MU, IPVT, SAVE2, 0) end if ELSE if (IMPL == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 150 I = 1,NDE if (A(I,1) == 0.E0) THEN IER = .TRUE. return ELSE SAVE2(I) = SAVE2(I)/A(I,1) end if 150 CONTINUE DO 155 I = NDE+1,N 155 A(I,1) = 0.E0 ELSE if (IMPL == 3) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call CGEFA (A, MATDIM, NDE, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call CGESL (A, MATDIM, NDE, IPVT, SAVE2, 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call CGBFA (A, MATDIM, NDE, ML, MU, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call CGBSL (A, MATDIM, NDE, ML, MU, IPVT, SAVE2, 0) end if end if end if DO 170 I = 1,NDE 170 SAVE1(I) = SAVE2(I)/MAX(1.E0, ABS(YWT(I))) SUM = SCNRM2(NDE, SAVE1, 1)/SQRT(REAL(NDE)) if (SUM > EPS/ABS(H)) H = SIGN(EPS/SUM, H) DO 180 I = 1,N 180 YH(I,2) = H*SAVE2(I) if (MITER == 2 .OR. MITER == 5 .OR. ISWFLG == 3) THEN DO 20 I = 1,N 20 FAC(I) = SQRT(UROUND) end if ELSE if (MITER /= MTROLD) THEN MTROLD = MITER RC = 0.E0 CONVRG = .FALSE. end if if (MINT /= MNTOLD) THEN MNTOLD = MINT OLDL0 = EL(1,NQ) call CDCST (MAXORD, MINT, ISWFLG, EL, TQ) RC = RC*EL(1,NQ)/OLDL0 NWAIT = NQ + 2 end if if (H /= HOLD) THEN NWAIT = NQ + 2 RH = H/HOLD call CDSCL (HMAX, N, NQ, RMAX, HOLD, RC, RH, YH) end if end if return end subroutine CDNTP (H, K, N, NQ, T, TOUT, YH, Y) ! !! CDNTP interpolates the K-th derivative of Y at TOUT, using the data ... ! in the YH array. If K has a value greater than NQ, the NQ-th derivative ... ! is calculated. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE COMPLEX (SDNTP-S, DDNTP-D, CDNTP-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDNTP INTEGER I, J, JJ, K, KK, KUSED, N, NQ COMPLEX Y(*), YH(N,*) REAL FACTOR, H, R, T, TOUT !***FIRST EXECUTABLE STATEMENT CDNTP if (K == 0) THEN DO 10 I = 1,N 10 Y(I) = YH(I,NQ+1) R = ((TOUT - T)/H) DO 20 JJ = 1,NQ J = NQ + 1 - JJ DO 20 I = 1,N 20 Y(I) = YH(I,J) + R*Y(I) ELSE KUSED = MIN(K, NQ) FACTOR = 1.E0 DO 40 KK = 1,KUSED 40 FACTOR = FACTOR*(NQ+1-KK) DO 50 I = 1,N 50 Y(I) = FACTOR*YH(I,NQ+1) R = ((TOUT - T)/H) DO 80 JJ = KUSED+1,NQ J = KUSED + 1 + NQ - JJ FACTOR = 1.E0 DO 60 KK = 1,KUSED 60 FACTOR = FACTOR*(J-KK) DO 70 I = 1,N 70 Y(I) = FACTOR*YH(I,J) + R*Y(I) 80 CONTINUE DO 100 I = 1,N 100 Y(I) = Y(I)*H**(-KUSED) end if return end FUNCTION CDOTC (N, CX, INCX, CY, INCY) ! !! CDOTC computes the dot product of two complex vectors using the complex ... ! conjugate of the first vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A4 !***TYPE COMPLEX (CDOTC-C) !***KEYWORDS BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! CX complex vector with N elements ! INCX storage spacing between elements of CX ! CY complex vector with N elements ! INCY storage spacing between elements of CY ! ! --Output-- ! CDOTC complex result (zero if N <= 0) ! ! Returns the dot product of complex CX and CY, using CONJUGATE(CX) ! CDOTC = SUM for I = 0 to N-1 of CONJ(CX(LX+I*INCX))*CY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CDOTC COMPLEX CDOTC COMPLEX CX(*),CY(*) !***FIRST EXECUTABLE STATEMENT CDOTC CDOTC = (0.0,0.0) if (N <= 0) RETURN if (INCX == INCY .AND. INCX > 0) go to 20 ! ! Code for unequal or nonpositive increments. ! KX = 1 KY = 1 if (INCX < 0) KX = 1+(1-N)*INCX if (INCY < 0) KY = 1+(1-N)*INCY DO 10 I = 1,N CDOTC = CDOTC + CONJG(CX(KX))*CY(KY) KX = KX + INCX KY = KY + INCY 10 CONTINUE return ! ! Code for equal, positive increments. ! 20 NS = N*INCX DO 30 I = 1,NS,INCX CDOTC = CDOTC + CONJG(CX(I))*CY(I) 30 CONTINUE return end FUNCTION CDOTU (N, CX, INCX, CY, INCY) ! !! CDOTU computes the inner product of two vectors. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A4 !***TYPE COMPLEX (SDOT-S, DDOT-D, CDOTU-C) !***KEYWORDS BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of parameters ! ! --Input-- ! N number of elements in input vector(s) ! CX complex vector with N elements ! INCX storage spacing between elements of CX ! CY complex vector with N elements ! INCY storage spacing between elements of CY ! ! --Output-- ! CDOTU complex result (zero if N <= 0) ! ! Returns the dot product of complex CX and CY, no conjugation ! CDOTU = SUM for I = 0 to N-1 of CX(LX+I*INCX) * CY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CDOTU complex CDOTU COMPLEX CX(*),CY(*) !***FIRST EXECUTABLE STATEMENT CDOTU CDOTU = (0.0,0.0) if (N <= 0) RETURN if (INCX == INCY .AND. INCX > 0) go to 20 ! ! Code for unequal or nonpositive increments. ! KX = 1 KY = 1 if (INCX < 0) KX = 1+(1-N)*INCX if (INCY < 0) KY = 1+(1-N)*INCY DO 10 I = 1,N CDOTU = CDOTU + CX(KX)*CY(KY) KX = KX + INCX KY = KY + INCY 10 CONTINUE return ! ! Code for equal, positive increments. ! 20 NS = N*INCX DO 30 I = 1,NS,INCX CDOTU = CDOTU + CX(I)*CY(I) 30 CONTINUE return end subroutine CDPSC (KSGN, N, NQ, YH) ! !! CDPSC computes the predicted YH values by effectively multiplying ... ! the YH array by the Pascal triangle matrix when KSGN is +1, and ... ! performs the inverse function when KSGN is -1. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE COMPLEX (SDPSC-S, DDPSC-D, CDPSC-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDPSC INTEGER I, J, J1, J2, KSGN, N, NQ COMPLEX YH(N,*) !***FIRST EXECUTABLE STATEMENT CDPSC if (KSGN > 0) THEN DO 10 J1 = 1,NQ DO 10 J2 = J1,NQ J = NQ - J2 + J1 DO 10 I = 1,N 10 YH(I,J) = YH(I,J) + YH(I,J+1) ELSE DO 30 J1 = 1,NQ DO 30 J2 = J1,NQ J = NQ - J2 + J1 DO 30 I = 1,N 30 YH(I,J) = YH(I,J) - YH(I,J+1) end if return end subroutine CDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, & MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, NFE, NJE, & A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, BND, JSTATE) ! !! CDPST evaluates the Jacobian matrix of the right hand side ... ! of the differential equations. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE COMPLEX (SDPST-S, DDPST-D, CDPST-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! If MITER is 1, 2, 4, or 5, the matrix ! P = I - L(0)*H*Jacobian is stored in DFDY and subjected to LU ! decomposition, with the results also stored in DFDY. ! !***ROUTINES CALLED CGBFA, CGEFA, SCNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDPST INTEGER I, IFLAG, IMAX, IMPL, INFO, ISWFLG, J, J2, JSTATE, K, & MATDIM, MITER, ML, MU, MW, N, NDE, NFE, NJE, NQ COMPLEX A(MATDIM,*), CFCTR, DFDY(MATDIM,*), DY, FAC(*), SAVE1(*), & SAVE2(*), Y(*), YH(N,*), YJ, YS, YWT(*) REAL BL, BND, BP, BR, BU, DFDYMX, DIFF, EL(13,12), FACMAX, FACMIN, & FACTOR, H, SCALE, SCNRM2, T, UROUND, ZMAX, ZMIN INTEGER IPVT(*) LOGICAL IER PARAMETER(FACMAX = .5E0, BU = 0.5E0) !***FIRST EXECUTABLE STATEMENT CDPST NJE = NJE + 1 IER = .FALSE. if (MITER == 1 .OR. MITER == 2) THEN if (MITER == 1) THEN call JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) if (N == 0) THEN JSTATE = 8 return end if if (ISWFLG == 3) BND = SCNRM2(N*N, DFDY, 1) FACTOR = -EL(1,NQ)*H DO 110 J = 1,N DO 110 I = 1,N 110 DFDY(I,J) = FACTOR*DFDY(I,J) ELSE if (MITER == 2) THEN BR = UROUND**(.875E0) BL = UROUND**(.75E0) BP = UROUND**(-.15E0) FACMIN = UROUND**(.78E0) DO 170 J = 1,N if (ABS(Y(J)) > ABS(YWT(J))) THEN YS = Y(J) ELSE YS = YWT(J) end if 120 DY = FAC(J)*YS if (DY == 0.E0) THEN if (REAL(FAC(J)) < FACMAX) THEN FAC(J) = MIN(100.E0*REAL(FAC(J)), FACMAX) go to 120 ELSE DY = YS end if end if DY = (Y(J) + DY) - Y(J) YJ = Y(J) Y(J) = Y(J) + DY call F (N, T, Y, SAVE1) if (N == 0) THEN JSTATE = 6 return end if Y(J) = YJ CFCTR = -EL(1,NQ)*H/DY DO 140 I = 1,N 140 DFDY(I,J) = (SAVE1(I) - SAVE2(I))*CFCTR ! Step 1 DIFF = ABS(SAVE2(1) - SAVE1(1)) IMAX = 1 DO 150 I = 2,N if (ABS(SAVE2(I) - SAVE1(I)) > DIFF) THEN IMAX = I DIFF = ABS(SAVE2(I) - SAVE1(I)) end if 150 CONTINUE ! Step 2 if (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) > 0.E0) THEN SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) ! Step 3 if (DIFF > BU*SCALE) THEN FAC(J) = MAX(FACMIN, REAL(FAC(J))*.5E0) ELSE if (BR*SCALE <= DIFF .AND. DIFF <= BL*SCALE) THEN FAC(J) = MIN(REAL(FAC(J))*2.E0, FACMAX) ! Step 4 ELSE if (DIFF < BR*SCALE) THEN FAC(J) = MIN(BP*REAL(FAC(J)), FACMAX) end if end if 170 CONTINUE if (ISWFLG == 3) BND = SCNRM2(N*N, DFDY, 1)/(-EL(1,NQ)*H) NFE = NFE + N end if if (IMPL == 0) THEN DO 190 I = 1,N 190 DFDY(I,I) = DFDY(I,I) + 1.E0 ELSE if (IMPL == 1) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 210 J = 1,N DO 210 I = 1,N 210 DFDY(I,J) = DFDY(I,J) + A(I,J) ELSE if (IMPL == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 230 I = 1,NDE 230 DFDY(I,I) = DFDY(I,I) + A(I,1) ELSE if (IMPL == 3) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 220 J = 1,NDE DO 220 I = 1,NDE 220 DFDY(I,J) = DFDY(I,J) + A(I,J) end if call CGEFA (DFDY, MATDIM, N, IPVT, INFO) if (INFO /= 0) IER = .TRUE. ELSE if (MITER == 4 .OR. MITER == 5) THEN if (MITER == 4) THEN call JACOBN (N, T, Y, DFDY(ML+1,1), MATDIM, ML, MU) if (N == 0) THEN JSTATE = 8 return end if FACTOR = -EL(1,NQ)*H MW = ML + MU + 1 DO 260 J = 1,N DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) 260 DFDY(I,J) = FACTOR*DFDY(I,J) ELSE if (MITER == 5) THEN BR = UROUND**(.875E0) BL = UROUND**(.75E0) BP = UROUND**(-.15E0) FACMIN = UROUND**(.78E0) MW = ML + MU + 1 J2 = MIN(MW, N) DO 340 J = 1,J2 DO 290 K = J,N,MW if (ABS(Y(K)) > ABS(YWT(K))) THEN YS = Y(K) ELSE YS = YWT(K) end if 280 DY = FAC(K)*YS if (DY == 0.E0) THEN if (REAL(FAC(K)) < FACMAX) THEN FAC(K) = MIN(100.E0*REAL(FAC(K)), FACMAX) go to 280 ELSE DY = YS end if end if DY = (Y(K) + DY) - Y(K) DFDY(MW,K) = Y(K) 290 Y(K) = Y(K) + DY call F (N, T, Y, SAVE1) if (N == 0) THEN JSTATE = 6 return end if DO 330 K = J,N,MW DY = Y(K) - DFDY(MW,K) Y(K) = DFDY(MW,K) CFCTR = -EL(1,NQ)*H/DY DO 300 I = MAX(ML+1, MW+1-K), MIN(MW+N-K, MW+ML) 300 DFDY(I,K) = CFCTR*(SAVE1(I+K-MW) - SAVE2(I+K-MW)) ! Step 1 IMAX = MAX(1, K - MU) DIFF = ABS(SAVE2(IMAX) - SAVE1(IMAX)) DO 310 I = MAX(1, K - MU)+1, MIN(K + ML, N) if (ABS(SAVE2(I) - SAVE1(I)) > DIFF) THEN IMAX = I DIFF = ABS(SAVE2(I) - SAVE1(I)) end if 310 CONTINUE ! Step 2 if (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) > 0.E0) THEN SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) ! Step 3 if (DIFF > BU*SCALE) THEN FAC(J) = MAX(FACMIN, REAL(FAC(J))*.5E0) ELSE if (BR*SCALE <= DIFF .AND. DIFF <= BL*SCALE) THEN FAC(J) = MIN(REAL(FAC(J))*2.E0, FACMAX) ! Step 4 ELSE if (DIFF < BR*SCALE) THEN FAC(K) = MIN(BP*REAL(FAC(K)), FACMAX) end if end if 330 CONTINUE 340 CONTINUE NFE = NFE + J2 end if if (ISWFLG == 3) THEN DFDYMX = 0.E0 DO 345 J = 1,N DO 345 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) ZMAX = MAX(ABS(REAL(DFDY(I,J))), ABS(AIMAG(DFDY(I,J)))) ZMIN = MIN(ABS(REAL(DFDY(I,J))), ABS(AIMAG(DFDY(I,J)))) if (ZMAX /= 0.E0) & DFDYMX = MAX(DFDYMX, ZMAX*SQRT(1.E0+ (ZMIN/ZMAX)**2)) 345 CONTINUE BND = 0.E0 if (DFDYMX /= 0.E0) THEN DO 350 J = 1,N DO 350 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) BND = BND + (REAL(DFDY(I,J))/DFDYMX)**2 + & (AIMAG(DFDY(I,J))/DFDYMX)**2 350 CONTINUE BND = DFDYMX*SQRT(BND)/(-EL(1,NQ)*H) end if end if if (IMPL == 0) THEN DO 360 J = 1,N 360 DFDY(MW,J) = DFDY(MW,J) + 1.E0 ELSE if (IMPL == 1) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 380 J = 1,N DO 380 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) 380 DFDY(I,J) = DFDY(I,J) + A(I,J) ELSE if (IMPL == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 400 J = 1,NDE 400 DFDY(MW,J) = DFDY(MW,J) + A(J,1) ELSE if (IMPL == 3) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 390 J = 1,NDE DO 390 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) 390 DFDY(I,J) = DFDY(I,J) + A(I,J) end if call CGBFA (DFDY, MATDIM, N, ML, MU, IPVT, INFO) if (INFO /= 0) IER = .TRUE. ELSE if (MITER == 3) THEN IFLAG = 1 call USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, & N, NDE, IFLAG) if (IFLAG == -1) THEN IER = .TRUE. return end if if (N == 0) THEN JSTATE = 10 return end if end if return end subroutine CDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, & IERFLG) ! !! CDRIV1 solves N (200 or fewer) ordinary differential equations ... ! of the form dY(I)/dT = F(Y(I),T), given the initial conditions ... ! Y(I) = YI. CDRIV1 allows complex-valued differential equations. ! !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE COMPLEX (SDRIV1-S, DDRIV1-D, CDRIV1-C) !***KEYWORDS COMPLEX VALUED, GEAR'S METHOD, INITIAL VALUE PROBLEMS, ! ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! Version 92.1 ! ! I. CHOOSING THE CORRECT ROUTINE ................................... ! ! SDRIV ! DDRIV ! CDRIV ! These are the generic names for three packages for solving ! initial value problems for ordinary differential equations. ! SDRIV uses single precision arithmetic. DDRIV uses double ! precision arithmetic. CDRIV allows complex-valued ! differential equations, integrated with respect to a single, ! real, independent variable. ! ! As an aid in selecting the proper program, the following is a ! discussion of the important options or restrictions associated with ! each program: ! ! A. CDRIV1 should be tried first for those routine problems with ! no more than 200 differential equations (CDRIV2 and CDRIV3 ! have no such restriction.) Internally this routine has two ! important technical defaults: ! 1. Numerical approximation of the Jacobian matrix of the ! right hand side is used. ! 2. The stiff solver option is used. ! Most users of CDRIV1 should not have to concern themselves ! with these details. ! ! B. CDRIV2 should be considered for those problems for which ! CDRIV1 is inadequate. For example, CDRIV1 may have difficulty ! with problems having zero initial conditions and zero ! derivatives. In this case CDRIV2, with an appropriate value ! of the parameter EWT, should perform more efficiently. CDRIV2 ! provides three important additional options: ! 1. The nonstiff equation solver (as well as the stiff ! solver) is available. ! 2. The root-finding option is available. ! 3. The program can dynamically select either the non-stiff ! or the stiff methods. ! Internally this routine also defaults to the numerical ! approximation of the Jacobian matrix of the right hand side. ! ! C. CDRIV3 is the most flexible, and hence the most complex, of ! the programs. Its important additional features include: ! 1. The ability to exploit band structure in the Jacobian ! matrix. ! 2. The ability to solve some implicit differential ! equations, i.e., those having the form: ! A(Y,T)*dY/dT = F(Y,T). ! 3. The option of integrating in the one step mode. ! 4. The option of allowing the user to provide a routine ! which computes the analytic Jacobian matrix of the right ! hand side. ! 5. The option of allowing the user to provide a routine ! which does all the matrix algebra associated with ! corrections to the solution components. ! ! II. PARAMETERS .................................................... ! ! The user should use parameter names in the call sequence of CDRIV1 ! for those quantities whose value may be altered by CDRIV1. The ! parameters in the call sequence are: ! ! N = (Input) The number of differential equations, N <= 200 ! ! T = (Real) The independent variable. On input for the first ! call, T is the initial point. On output, T is the point ! at which the solution is given. ! ! Y = (Complex) The vector of dependent variables. Y is used as ! input on the first call, to set the initial values. On ! output, Y is the computed solution vector. This array Y ! is passed in the call sequence of the user-provided ! routine F. Thus parameters required by F can be stored in ! this array in components N+1 and above. (Note: Changes by ! the user to the first N components of this array will take ! effect only after a restart, i.e., after setting MSTATE to ! +1(-1).) ! ! F = A subroutine supplied by the user. The name must be ! declared EXTERNAL in the user's calling program. This ! subroutine is of the form: ! SUBROUTINE F (N, T, Y, YDOT) ! COMPLEX Y(*), YDOT(*) ! . ! . ! YDOT(1) = ... ! . ! . ! YDOT(N) = ... ! END (Sample) ! This computes YDOT = F(Y,T), the right hand side of the ! differential equations. Here Y is a vector of length at ! least N. The actual length of Y is determined by the ! user's declaration in the program which calls CDRIV1. ! Thus the dimensioning of Y in F, while required by FORTRAN ! convention, does not actually allocate any storage. When ! this subroutine is called, the first N components of Y are ! intermediate approximations to the solution components. ! The user should not alter these values. Here YDOT is a ! vector of length N. The user should only compute YDOT(I) ! for I from 1 to N. Normally a return from F passes ! control back to CDRIV1. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls CDRIV1, he should set N to zero. ! CDRIV1 will signal this by returning a value of MSTATE ! equal to +5(-5). Altering the value of N in F has no ! effect on the value of N in the call sequence of CDRIV1. ! ! TOUT = (Input, Real) The point at which the solution is desired. ! ! MSTATE = An integer describing the status of integration. The user ! must initialize MSTATE to +1 or -1. If MSTATE is ! positive, the routine will integrate past TOUT and ! interpolate the solution. This is the most efficient ! mode. If MSTATE is negative, the routine will adjust its ! internal step to reach TOUT exactly (useful if a ! singularity exists beyond TOUT.) The meaning of the ! magnitude of MSTATE: ! 1 (Input) Means the first call to the routine. This ! value must be set by the user. On all subsequent ! calls the value of MSTATE should be tested by the ! user. Unless CDRIV1 is to be reinitialized, only the ! sign of MSTATE may be changed by the user. (As a ! convenience to the user who may wish to put out the ! initial conditions, CDRIV1 can be called with ! MSTATE=+1(-1), and TOUT=T. In this case the program ! will return with MSTATE unchanged, i.e., ! MSTATE=+1(-1).) ! 2 (Output) Means a successful integration. If a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance TOUT and call ! again. All other parameters are automatically set. ! 3 (Output)(Unsuccessful) Means the integrator has taken ! 1000 steps without reaching TOUT. The user can ! continue the integration by simply calling CDRIV1 ! again. ! 4 (Output)(Unsuccessful) Means too much accuracy has ! been requested. EPS has been increased to a value ! the program estimates is appropriate. The user can ! continue the integration by simply calling CDRIV1 ! again. ! 5 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE F. ! 6 (Output)(Successful) For MSTATE negative, T is beyond ! TOUT. The solution was obtained by interpolation. ! The user can continue the integration by simply ! advancing TOUT and calling CDRIV1 again. ! 7 (Output)(Unsuccessful) The solution could not be ! obtained. The value of IERFLG (see description ! below) for a "Recoverable" situation indicates the ! type of difficulty encountered: either an illegal ! value for a parameter or an inability to continue the ! solution. For this condition the user should take ! corrective action and reset MSTATE to +1(-1) before ! calling CDRIV1 again. Otherwise the program will ! terminate the run. ! ! EPS = (Real) On input, the requested relative accuracy in all ! solution components. On output, the adjusted relative ! accuracy if the input value was too small. The value of ! EPS should be set as large as is reasonable, because the ! amount of work done by CDRIV1 increases as EPS decreases. ! ! WORK ! LENW = (Input) ! WORK is an array of LENW complex words used ! internally for temporary storage. The user must allocate ! space for this array in the calling program by a statement ! such as ! COMPLEX WORK(...) ! The length of WORK should be at least N*N + 11*N + 300 ! and LENW should be set to the value used. The contents of ! WORK should not be disturbed between calls to CDRIV1. ! ! IERFLG = An error flag. The error number associated with a ! diagnostic message (see Section IV-A below) is the same as ! the corresponding value of IERFLG. The meaning of IERFLG: ! 0 The routine completed successfully. (No message is ! issued.) ! 3 (Warning) The number of steps required to reach TOUT ! exceeds 1000 . ! 4 (Warning) The value of EPS is too small. ! 11 (Warning) For MSTATE negative, T is beyond TOUT. ! The solution was obtained by interpolation. ! 15 (Warning) The integration step size is below the ! roundoff level of T. (The program issues this ! message as a warning but does not return control to ! the user.) ! 21 (Recoverable) N is greater than 200 . ! 22 (Recoverable) N is not positive. ! 26 (Recoverable) The magnitude of MSTATE is either 0 or ! greater than 7 . ! 27 (Recoverable) EPS is less than zero. ! 32 (Recoverable) Insufficient storage has been allocated ! for the WORK array. ! 41 (Recoverable) The integration step size has gone ! to zero. ! 42 (Recoverable) The integration step size has been ! reduced about 50 times without advancing the ! solution. The problem setup may not be correct. ! 999 (Fatal) The magnitude of MSTATE is 7 . ! ! III. USAGE ........................................................ ! ! PROGRAM SAMPLE ! EXTERNAL F ! COMPLEX ALFA ! REAL EPS, T, TOUT ! C N is the number of equations ! PARAMETER(ALFA = (1.E0, 1.E0), N = 3, ! 8 LENW = N*N + 11*N + 300) ! COMPLEX WORK(LENW), Y(N+1) ! C Initial point ! T = 0.00001E0 ! C Set initial conditions ! Y(1) = 10.E0 ! Y(2) = 0.E0 ! Y(3) = 10.E0 ! C Pass parameter ! Y(4) = ALFA ! TOUT = T ! MSTATE = 1 ! EPS = .001E0 ! 10 call CDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, ! 8 IERFLG) ! if (MSTATE > 2) STOP ! WRITE(*, '(5E12.3)') TOUT, (Y(I), I=1,3) ! TOUT = 10.E0*TOUT ! if (TOUT < 50.E0) go to 10 ! END ! ! SUBROUTINE F (N, T, Y, YDOT) ! COMPLEX ALFA, Y(*), YDOT(*) ! REAL T ! ALFA = Y(N+1) ! YDOT(1) = 1.E0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) ! YDOT(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) ! YDOT(3) = 1.E0 - Y(3)*(Y(1) + Y(2)) ! END ! ! IV. OTHER COMMUNICATION TO THE USER ............................... ! ! A. The solver communicates to the user through the parameters ! above. In addition it writes diagnostic messages through the ! standard error handling program XERMSG. A complete description ! of XERMSG is given in "Guide to the SLATEC Common Mathematical ! Library" by Kirby W. Fong et al.. At installations which do not ! have this error handling package the short but serviceable ! routine, XERMSG, available with this package, can be used. That ! program uses the file named OUTPUT to transmit messages. ! ! B. The number of evaluations of the right hand side can be found ! in the WORK array in the location determined by: ! LENW - (N + 50) + 4 ! ! V. REMARKS ........................................................ ! ! For other information, see Section IV of the writeup for CDRIV3. ! !***REFERENCES C. W. Gear, Numerical Initial Value Problems in ! Ordinary Differential Equations, Prentice-Hall, 1971. !***ROUTINES CALLED CDRIV3, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDRIV1 EXTERNAL F COMPLEX WORK(*), Y(*) REAL EPS, EWTCOM(1), HMAX, T, TOUT INTEGER I, IDLIW, IERFLG, IERROR, IMPL, LENIW, LENW, LENWCM, & LNWCHK, MINT, MITER, ML, MSTATE, MU, MXN, MXORD, MXSTEP, & N, NDE, NROOT, NSTATE, NTASK PARAMETER(MXN = 200, IDLIW = 50) INTEGER IWORK(IDLIW+MXN) CHARACTER INTGR1*8 PARAMETER(NROOT = 0, IERROR = 2, MINT = 2, MITER = 2, IMPL = 0, & MXORD = 5, MXSTEP = 1000) DATA EWTCOM(1) /1.E0/ !***FIRST EXECUTABLE STATEMENT CDRIV1 if (ABS(MSTATE) == 0 .OR. ABS(MSTATE) > 7) THEN WRITE(INTGR1, '(I8)') MSTATE IERFLG = 26 call XERMSG('SLATEC', 'CDRIV1', & 'Illegal input. The magnitude of MSTATE, '//INTGR1// & ', is not in the range 1 to 6 .', IERFLG, 1) MSTATE = SIGN(7, MSTATE) return ELSE if (ABS(MSTATE) == 7) THEN IERFLG = 999 call XERMSG('SLATEC', 'CDRIV1', & 'Illegal input. The magnitude of MSTATE is 7 .', IERFLG, 2) return end if if (N > MXN) THEN WRITE(INTGR1, '(I8)') N IERFLG = 21 call XERMSG('SLATEC', 'CDRIV1', & 'Illegal input. The number of equations, '//INTGR1// & ', is greater than the maximum allowed: 200 .', IERFLG, 1) MSTATE = SIGN(7, MSTATE) return end if if (MSTATE > 0) THEN NSTATE = MSTATE NTASK = 1 ELSE NSTATE = - MSTATE NTASK = 3 end if HMAX = 2.E0*ABS(TOUT - T) LENIW = N + IDLIW LENWCM = LENW - LENIW if (LENWCM < (N*N + 10*N + 250)) THEN LNWCHK = N*N + 10*N + 250 + LENIW WRITE(INTGR1, '(I8)') LNWCHK IERFLG = 32 call XERMSG('SLATEC', 'CDRIV1', & 'Insufficient storage allocated for the work array. '// & 'The required storage is at least '//INTGR1//' .', IERFLG, 1) MSTATE = SIGN(7, MSTATE) return end if if (NSTATE /= 1) THEN DO 20 I = 1,LENIW 20 IWORK(I) = WORK(I+LENWCM) end if call CDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, & IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, & LENWCM, IWORK, LENIW, F, F, NDE, MXSTEP, F, F, & IERFLG) DO 40 I = 1,LENIW 40 WORK(I+LENWCM) = IWORK(I) if (NSTATE <= 4) THEN MSTATE = SIGN(NSTATE, MSTATE) ELSE if (NSTATE == 6) THEN MSTATE = SIGN(5, MSTATE) ELSE if (IERFLG == 11) THEN MSTATE = SIGN(6, MSTATE) ELSE if (IERFLG > 11) THEN MSTATE = SIGN(7, MSTATE) end if return end subroutine CDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, & MINT, WORK, LENW, IWORK, LENIW, G, IERFLG) ! !! CDRIV2 solves N ordinary differential equations of the form ... ! dY(I)/dT = F(Y(I),T), given the initial conditions Y(I) = YI. ... ! The program has options to ... ! allow the solution of both stiff and non-stiff differential ... ! equations. CDRIV2 allows complex-valued differential equations. ! !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE COMPLEX (SDRIV2-S, DDRIV2-D, CDRIV2-C) !***KEYWORDS COMPLEX VALUED, GEAR'S METHOD, INITIAL VALUE PROBLEMS, ! ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! I. PARAMETERS ..................................................... ! ! The user should use parameter names in the call sequence of CDRIV2 ! for those quantities whose value may be altered by CDRIV2. The ! parameters in the call sequence are: ! ! N = (Input) The number of differential equations. ! ! T = (Real) The independent variable. On input for the first ! call, T is the initial point. On output, T is the point ! at which the solution is given. ! ! Y = (Complex) The vector of dependent variables. Y is used as ! input on the first call, to set the initial values. On ! output, Y is the computed solution vector. This array Y ! is passed in the call sequence of the user-provided ! routines F and G. Thus parameters required by F and G can ! be stored in this array in components N+1 and above. ! (Note: Changes by the user to the first N components of ! this array will take effect only after a restart, i.e., ! after setting MSTATE to +1(-1).) ! ! F = A subroutine supplied by the user. The name must be ! declared EXTERNAL in the user's calling program. This ! subroutine is of the form: ! SUBROUTINE F (N, T, Y, YDOT) ! COMPLEX Y(*), YDOT(*) ! . ! . ! YDOT(1) = ... ! . ! . ! YDOT(N) = ... ! END (Sample) ! This computes YDOT = F(Y,T), the right hand side of the ! differential equations. Here Y is a vector of length at ! least N. The actual length of Y is determined by the ! user's declaration in the program which calls CDRIV2. ! Thus the dimensioning of Y in F, while required by FORTRAN ! convention, does not actually allocate any storage. When ! this subroutine is called, the first N components of Y are ! intermediate approximations to the solution components. ! The user should not alter these values. Here YDOT is a ! vector of length N. The user should only compute YDOT(I) ! for I from 1 to N. Normally a return from F passes ! control back to CDRIV2. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls CDRIV2, he should set N to zero. ! CDRIV2 will signal this by returning a value of MSTATE ! equal to +6(-6). Altering the value of N in F has no ! effect on the value of N in the call sequence of CDRIV2. ! ! TOUT = (Input, Real) The point at which the solution is desired. ! ! MSTATE = An integer describing the status of integration. The user ! must initialize MSTATE to +1 or -1. If MSTATE is ! positive, the routine will integrate past TOUT and ! interpolate the solution. This is the most efficient ! mode. If MSTATE is negative, the routine will adjust its ! internal step to reach TOUT exactly (useful if a ! singularity exists beyond TOUT.) The meaning of the ! magnitude of MSTATE: ! 1 (Input) Means the first call to the routine. This ! value must be set by the user. On all subsequent ! calls the value of MSTATE should be tested by the ! user. Unless CDRIV2 is to be reinitialized, only the ! sign of MSTATE may be changed by the user. (As a ! convenience to the user who may wish to put out the ! initial conditions, CDRIV2 can be called with ! MSTATE=+1(-1), and TOUT=T. In this case the program ! will return with MSTATE unchanged, i.e., ! MSTATE=+1(-1).) ! 2 (Output) Means a successful integration. If a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance TOUT and call ! again. All other parameters are automatically set. ! 3 (Output)(Unsuccessful) Means the integrator has taken ! 1000 steps without reaching TOUT. The user can ! continue the integration by simply calling CDRIV2 ! again. Other than an error in problem setup, the ! most likely cause for this condition is trying to ! integrate a stiff set of equations with the non-stiff ! integrator option. (See description of MINT below.) ! 4 (Output)(Unsuccessful) Means too much accuracy has ! been requested. EPS has been increased to a value ! the program estimates is appropriate. The user can ! continue the integration by simply calling CDRIV2 ! again. ! 5 (Output) A root was found at a point less than TOUT. ! The user can continue the integration toward TOUT by ! simply calling CDRIV2 again. ! 6 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE F. ! 7 (Output)(Unsuccessful) N has been set to zero in ! FUNCTION G. See description of G below. ! 8 (Output)(Successful) For MSTATE negative, T is beyond ! TOUT. The solution was obtained by interpolation. ! The user can continue the integration by simply ! advancing TOUT and calling CDRIV2 again. ! 9 (Output)(Unsuccessful) The solution could not be ! obtained. The value of IERFLG (see description ! below) for a "Recoverable" situation indicates the ! type of difficulty encountered: either an illegal ! value for a parameter or an inability to continue the ! solution. For this condition the user should take ! corrective action and reset MSTATE to +1(-1) before ! calling CDRIV2 again. Otherwise the program will ! terminate the run. ! ! NROOT = (Input) The number of equations whose roots are desired. ! If NROOT is zero, the root search is not active. This ! option is useful for obtaining output at points which are ! not known in advance, but depend upon the solution, e.g., ! when some solution component takes on a specified value. ! The root search is carried out using the user-written ! function G (see description of G below.) CDRIV2 attempts ! to find the value of T at which one of the equations ! changes sign. CDRIV2 can find at most one root per ! equation per internal integration step, and will then ! return the solution either at TOUT or at a root, whichever ! occurs first in the direction of integration. The initial ! point is never reported as a root. The index of the ! equation whose root is being reported is stored in the ! sixth element of IWORK. ! NOTE: NROOT is never altered by this program. ! ! EPS = (Real) On input, the requested relative accuracy in all ! solution components. EPS = 0 is allowed. On output, the ! adjusted relative accuracy if the input value was too ! small. The value of EPS should be set as large as is ! reasonable, because the amount of work done by CDRIV2 ! increases as EPS decreases. ! ! EWT = (Input, Real) Problem zero, i.e., the smallest physically ! meaningful value for the solution. This is used inter- ! nally to compute an array YWT(I) = MAX(ABS(Y(I)), EWT). ! One step error estimates divided by YWT(I) are kept less ! than EPS. Setting EWT to zero provides pure relative ! error control. However, setting EWT smaller than ! necessary can adversely affect the running time. ! ! MINT = (Input) The integration method flag. ! MINT = 1 Means the Adams methods, and is used for ! non-stiff problems. ! MINT = 2 Means the stiff methods of Gear (i.e., the ! backward differentiation formulas), and is ! used for stiff problems. ! MINT = 3 Means the program dynamically selects the ! Adams methods when the problem is non-stiff ! and the Gear methods when the problem is ! stiff. ! MINT may not be changed without restarting, i.e., setting ! the magnitude of MSTATE to 1. ! ! WORK ! LENW = (Input) ! WORK is an array of LENW complex words used ! internally for temporary storage. The user must allocate ! space for this array in the calling program by a statement ! such as ! COMPLEX WORK(...) ! The length of WORK should be at least ! 16*N + 2*NROOT + 250 if MINT is 1, or ! N*N + 10*N + 2*NROOT + 250 if MINT is 2, or ! N*N + 17*N + 2*NROOT + 250 if MINT is 3, ! and LENW should be set to the value used. The contents of ! WORK should not be disturbed between calls to CDRIV2. ! ! IWORK ! LENIW = (Input) ! IWORK is an integer array of length LENIW used internally ! for temporary storage. The user must allocate space for ! this array in the calling program by a statement such as ! INTEGER IWORK(...) ! The length of IWORK should be at least ! 50 if MINT is 1, or ! N+50 if MINT is 2 or 3, ! and LENIW should be set to the value used. The contents ! of IWORK should not be disturbed between calls to CDRIV2. ! ! G = A real FORTRAN function supplied by the user ! if NROOT is not 0. In this case, the name must be ! declared EXTERNAL in the user's calling program. G is ! repeatedly called with different values of IROOT to ! obtain the value of each of the NROOT equations for which ! a root is desired. G is of the form: ! REAL FUNCTION G (N, T, Y, IROOT) ! COMPLEX Y(*) ! go to (10, ...), IROOT ! 10 G = ... ! . ! . ! END (Sample) ! Here, Y is a vector of length at least N, whose first N ! components are the solution components at the point T. ! The user should not alter these values. The actual length ! of Y is determined by the user's declaration in the ! program which calls CDRIV2. Thus the dimensioning of Y in ! G, while required by FORTRAN convention, does not actually ! allocate any storage. Normally a return from G passes ! control back to CDRIV2. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls CDRIV2, he should set N to zero. ! CDRIV2 will signal this by returning a value of MSTATE ! equal to +7(-7). In this case, the index of the equation ! being evaluated is stored in the sixth element of IWORK. ! Altering the value of N in G has no effect on the value of ! N in the call sequence of CDRIV2. ! ! IERFLG = An error flag. The error number associated with a ! diagnostic message (see Section II-A below) is the same as ! the corresponding value of IERFLG. The meaning of IERFLG: ! 0 The routine completed successfully. (No message is ! issued.) ! 3 (Warning) The number of steps required to reach TOUT ! exceeds MXSTEP. ! 4 (Warning) The value of EPS is too small. ! 11 (Warning) For MSTATE negative, T is beyond TOUT. ! The solution was obtained by interpolation. ! 15 (Warning) The integration step size is below the ! roundoff level of T. (The program issues this ! message as a warning but does not return control to ! the user.) ! 22 (Recoverable) N is not positive. ! 23 (Recoverable) MINT is less than 1 or greater than 3 . ! 26 (Recoverable) The magnitude of MSTATE is either 0 or ! greater than 9 . ! 27 (Recoverable) EPS is less than zero. ! 32 (Recoverable) Insufficient storage has been allocated ! for the WORK array. ! 33 (Recoverable) Insufficient storage has been allocated ! for the IWORK array. ! 41 (Recoverable) The integration step size has gone ! to zero. ! 42 (Recoverable) The integration step size has been ! reduced about 50 times without advancing the ! solution. The problem setup may not be correct. ! 999 (Fatal) The magnitude of MSTATE is 9 . ! ! II. OTHER COMMUNICATION TO THE USER ............................... ! ! A. The solver communicates to the user through the parameters ! above. In addition it writes diagnostic messages through the ! standard error handling program XERMSG. A complete description ! of XERMSG is given in "Guide to the SLATEC Common Mathematical ! Library" by Kirby W. Fong et al.. At installations which do not ! have this error handling package the short but serviceable ! routine, XERMSG, available with this package, can be used. That ! program uses the file named OUTPUT to transmit messages. ! ! B. The first three elements of WORK and the first five elements of ! IWORK will contain the following statistical data: ! AVGH The average step size used. ! HUSED The step size last used (successfully). ! AVGORD The average order used. ! IMXERR The index of the element of the solution vector that ! contributed most to the last error test. ! NQUSED The order last used (successfully). ! NSTEP The number of steps taken since last initialization. ! NFE The number of evaluations of the right hand side. ! NJE The number of evaluations of the Jacobian matrix. ! ! III. REMARKS ...................................................... ! ! A. On any return from CDRIV2 all information necessary to continue ! the calculation is contained in the call sequence parameters, ! including the work arrays. Thus it is possible to suspend one ! problem, integrate another, and then return to the first. ! ! B. If this package is to be used in an overlay situation, the user ! must declare in the primary overlay the variables in the call ! sequence to CDRIV2. ! ! C. When the routine G is not required, difficulties associated with ! an unsatisfied external can be avoided by using the name of the ! routine which calculates the right hand side of the differential ! equations in place of G in the call sequence of CDRIV2. ! ! IV. USAGE ......................................................... ! ! PROGRAM SAMPLE ! EXTERNAL F ! PARAMETER(MINT = 1, NROOT = 0, N = ..., ! 8 LENW = 16*N + 2*NROOT + 250, LENIW = 50) ! C N is the number of equations ! COMPLEX WORK(LENW), Y(N) ! REAL EPS, EWT, T, TOUT ! INTEGER IWORK(LENIW) ! OPEN(FILE='TAPE6', UNIT=6, STATUS='NEW') ! C Initial point ! T = 0. ! C Set initial conditions ! DO 10 I = 1,N ! 10 Y(I) = ... ! TOUT = T ! EWT = ... ! MSTATE = 1 ! EPS = ... ! 20 call CDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, ! 8 MINT, WORK, LENW, IWORK, LENIW, F, IERFLG) ! C Next to last argument is not ! C F if rootfinding is used. ! if (MSTATE > 2) STOP ! WRITE(6, 100) TOUT, (Y(I), I=1,N) ! TOUT = TOUT + 1. ! if (TOUT <= 10.) go to 20 ! 100 FORMAT(...) ! END (Sample) ! !***REFERENCES C. W. Gear, Numerical Initial Value Problems in ! Ordinary Differential Equations, Prentice-Hall, 1971. !***ROUTINES CALLED CDRIV3, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDRIV2 EXTERNAL F, G COMPLEX WORK(*), Y(*) REAL EPS, EWT, EWTCOM(1), G, HMAX, T, TOUT INTEGER IWORK(*) INTEGER IERFLG, IERROR, IMPL, LENIW, LENW, MINT, MITER, ML, & MSTATE, MU, MXORD, MXSTEP, N, NDE, NROOT, NSTATE, NTASK CHARACTER INTGR1*8 PARAMETER(IMPL = 0, MXSTEP = 1000) !***FIRST EXECUTABLE STATEMENT CDRIV2 if (ABS(MSTATE) == 9) THEN IERFLG = 999 call XERMSG('SLATEC', 'CDRIV2', & 'Illegal input. The magnitude of MSTATE IS 9 .', & IERFLG, 2) return ELSE if (ABS(MSTATE) == 0 .OR. ABS(MSTATE) > 9) THEN WRITE(INTGR1, '(I8)') MSTATE IERFLG = 26 call XERMSG('SLATEC', 'CDRIV2', & 'Illegal input. The magnitude of MSTATE, '//INTGR1// & ' is not in the range 1 to 8 .', IERFLG, 1) MSTATE = SIGN(9, MSTATE) return end if if (MINT < 1 .OR. MINT > 3) THEN WRITE(INTGR1, '(I8)') MINT IERFLG = 23 call XERMSG('SLATEC', 'CDRIV2', & 'Illegal input. Improper value for the integration method '// & 'flag, '//INTGR1//' .', IERFLG, 1) MSTATE = SIGN(9, MSTATE) return end if if (MSTATE >= 0) THEN NSTATE = MSTATE NTASK = 1 ELSE NSTATE = - MSTATE NTASK = 3 end if EWTCOM(1) = EWT if (EWT /= 0.E0) THEN IERROR = 3 ELSE IERROR = 2 end if if (MINT == 1) THEN MITER = 0 MXORD = 12 ELSE if (MINT == 2) THEN MITER = 2 MXORD = 5 ELSE if (MINT == 3) THEN MITER = 2 MXORD = 12 end if HMAX = 2.E0*ABS(TOUT - T) call CDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, & IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, & LENW, IWORK, LENIW, F, F, NDE, MXSTEP, G, F, IERFLG) if (NSTATE <= 7) THEN MSTATE = SIGN(NSTATE, MSTATE) ELSE if (NSTATE == 11) THEN MSTATE = SIGN(8, MSTATE) ELSE if (NSTATE > 11) THEN MSTATE = SIGN(9, MSTATE) end if return end subroutine CDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, & EWT, IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, & LENW, IWORK, LENIW, JACOBN, FA, NDE, MXSTEP, G, USERS, IERFLG) ! !! CDRIV3 solves N ordinary differential equations of the form ... ! dY(I)/dT = F(Y(I),T), given the initial conditions Y(I) = YI. The ... ! program has options to allow the solution of both stiff and non-stiff ... ! differential equations. Other important options are available. CDRIV3 ! allows complex-valued differential equations. ! !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE COMPLEX (SDRIV3-S, DDRIV3-D, CDRIV3-C) !***KEYWORDS COMPLEX VALUED, GEAR'S METHOD, INITIAL VALUE PROBLEMS, ! ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! I. ABSTRACT ....................................................... ! ! The primary function of CDRIV3 is to solve N ordinary differential ! equations of the form dY(I)/dT = F(Y(I),T), given the initial ! conditions Y(I) = YI. The program has options to allow the ! solution of both stiff and non-stiff differential equations. In ! addition, CDRIV3 may be used to solve: ! 1. The initial value problem, A*dY(I)/dT = F(Y(I),T), where A is ! a non-singular matrix depending on Y and T. ! 2. The hybrid differential/algebraic initial value problem, ! A*dY(I)/dT = F(Y(I),T), where A is a vector (whose values may ! depend upon Y and T) some of whose components will be zero ! corresponding to those equations which are algebraic rather ! than differential. ! CDRIV3 is to be called once for each output point of T. ! ! II. PARAMETERS .................................................... ! ! The user should use parameter names in the call sequence of CDRIV3 ! for those quantities whose value may be altered by CDRIV3. The ! parameters in the call sequence are: ! ! N = (Input) The number of dependent functions whose solution ! is desired. N must not be altered during a problem. ! ! T = (Real) The independent variable. On input for the first ! call, T is the initial point. On output, T is the point ! at which the solution is given. ! ! Y = (Complex) The vector of dependent variables. Y is used as ! input on the first call, to set the initial values. On ! output, Y is the computed solution vector. This array Y ! is passed in the call sequence of the user-provided ! routines F, JACOBN, FA, USERS, and G. Thus parameters ! required by those routines can be stored in this array in ! components N+1 and above. (Note: Changes by the user to ! the first N components of this array will take effect only ! after a restart, i.e., after setting NSTATE to 1 .) ! ! F = A subroutine supplied by the user. The name must be ! declared EXTERNAL in the user's calling program. This ! subroutine is of the form: ! SUBROUTINE F (N, T, Y, YDOT) ! COMPLEX Y(*), YDOT(*) ! . ! . ! YDOT(1) = ... ! . ! . ! YDOT(N) = ... ! END (Sample) ! This computes YDOT = F(Y,T), the right hand side of the ! differential equations. Here Y is a vector of length at ! least N. The actual length of Y is determined by the ! user's declaration in the program which calls CDRIV3. ! Thus the dimensioning of Y in F, while required by FORTRAN ! convention, does not actually allocate any storage. When ! this subroutine is called, the first N components of Y are ! intermediate approximations to the solution components. ! The user should not alter these values. Here YDOT is a ! vector of length N. The user should only compute YDOT(I) ! for I from 1 to N. Normally a return from F passes ! control back to CDRIV3. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls CDRIV3, he should set N to zero. ! CDRIV3 will signal this by returning a value of NSTATE ! equal to 6 . Altering the value of N in F has no effect ! on the value of N in the call sequence of CDRIV3. ! ! NSTATE = An integer describing the status of integration. The ! meaning of NSTATE is as follows: ! 1 (Input) Means the first call to the routine. This ! value must be set by the user. On all subsequent ! calls the value of NSTATE should be tested by the ! user, but must not be altered. (As a convenience to ! the user who may wish to put out the initial ! conditions, CDRIV3 can be called with NSTATE=1, and ! TOUT=T. In this case the program will return with ! NSTATE unchanged, i.e., NSTATE=1.) ! 2 (Output) Means a successful integration. If a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance TOUT and call ! again. All other parameters are automatically set. ! 3 (Output)(Unsuccessful) Means the integrator has taken ! MXSTEP steps without reaching TOUT. The user can ! continue the integration by simply calling CDRIV3 ! again. ! 4 (Output)(Unsuccessful) Means too much accuracy has ! been requested. EPS has been increased to a value ! the program estimates is appropriate. The user can ! continue the integration by simply calling CDRIV3 ! again. ! 5 (Output) A root was found at a point less than TOUT. ! The user can continue the integration toward TOUT by ! simply calling CDRIV3 again. ! 6 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE F. ! 7 (Output)(Unsuccessful) N has been set to zero in ! FUNCTION G. See description of G below. ! 8 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE JACOBN. See description of JACOBN below. ! 9 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE FA. See description of FA below. ! 10 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE USERS. See description of USERS below. ! 11 (Output)(Successful) For NTASK = 2 or 3, T is beyond ! TOUT. The solution was obtained by interpolation. ! The user can continue the integration by simply ! advancing TOUT and calling CDRIV3 again. ! 12 (Output)(Unsuccessful) The solution could not be ! obtained. The value of IERFLG (see description ! below) for a "Recoverable" situation indicates the ! type of difficulty encountered: either an illegal ! value for a parameter or an inability to continue the ! solution. For this condition the user should take ! corrective action and reset NSTATE to 1 before ! calling CDRIV3 again. Otherwise the program will ! terminate the run. ! ! TOUT = (Input, Real) The point at which the solution is desired. ! The position of TOUT relative to T on the first call ! determines the direction of integration. ! ! NTASK = (Input) An index specifying the manner of returning the ! solution, according to the following: ! NTASK = 1 Means CDRIV3 will integrate past TOUT and ! interpolate the solution. This is the most ! efficient mode. ! NTASK = 2 Means CDRIV3 will return the solution after ! each internal integration step, or at TOUT, ! whichever comes first. In the latter case, ! the program integrates exactly to TOUT. ! NTASK = 3 Means CDRIV3 will adjust its internal step to ! reach TOUT exactly (useful if a singularity ! exists beyond TOUT.) ! ! NROOT = (Input) The number of equations whose roots are desired. ! If NROOT is zero, the root search is not active. This ! option is useful for obtaining output at points which are ! not known in advance, but depend upon the solution, e.g., ! when some solution component takes on a specified value. ! The root search is carried out using the user-written ! function G (see description of G below.) CDRIV3 attempts ! to find the value of T at which one of the equations ! changes sign. CDRIV3 can find at most one root per ! equation per internal integration step, and will then ! return the solution either at TOUT or at a root, whichever ! occurs first in the direction of integration. The initial ! point is never reported as a root. The index of the ! equation whose root is being reported is stored in the ! sixth element of IWORK. ! NOTE: NROOT is never altered by this program. ! ! EPS = (Real) On input, the requested relative accuracy in all ! solution components. EPS = 0 is allowed. On output, the ! adjusted relative accuracy if the input value was too ! small. The value of EPS should be set as large as is ! reasonable, because the amount of work done by CDRIV3 ! increases as EPS decreases. ! ! EWT = (Input, Real) Problem zero, i.e., the smallest, nonzero, ! physically meaningful value for the solution. (Array, ! possibly of length one. See following description of ! IERROR.) Setting EWT smaller than necessary can adversely ! affect the running time. ! ! IERROR = (Input) Error control indicator. A value of 3 is ! suggested for most problems. Other choices and detailed ! explanations of EWT and IERROR are given below for those ! who may need extra flexibility. ! ! These last three input quantities EPS, EWT and IERROR ! control the accuracy of the computed solution. EWT and ! IERROR are used internally to compute an array YWT. One ! step error estimates divided by YWT(I) are kept less than ! EPS in root mean square norm. ! IERROR (Set by the user) = ! 1 Means YWT(I) = 1. (Absolute error control) ! EWT is ignored. ! 2 Means YWT(I) = ABS(Y(I)), (Relative error control) ! EWT is ignored. ! 3 Means YWT(I) = MAX(ABS(Y(I)), EWT(1)). ! 4 Means YWT(I) = MAX(ABS(Y(I)), EWT(I)). ! This choice is useful when the solution components ! have differing scales. ! 5 Means YWT(I) = EWT(I). ! If IERROR is 3, EWT need only be dimensioned one. ! If IERROR is 4 or 5, the user must dimension EWT at least ! N, and set its values. ! ! MINT = (Input) The integration method indicator. ! MINT = 1 Means the Adams methods, and is used for ! non-stiff problems. ! MINT = 2 Means the stiff methods of Gear (i.e., the ! backward differentiation formulas), and is ! used for stiff problems. ! MINT = 3 Means the program dynamically selects the ! Adams methods when the problem is non-stiff ! and the Gear methods when the problem is ! stiff. When using the Adams methods, the ! program uses a value of MITER=0; when using ! the Gear methods, the program uses the value ! of MITER provided by the user. Only a value ! of IMPL = 0 and a value of MITER = 1, 2, 4, or ! 5 is allowed for this option. The user may ! not alter the value of MINT or MITER without ! restarting, i.e., setting NSTATE to 1. ! ! MITER = (Input) The iteration method indicator. ! MITER = 0 Means functional iteration. This value is ! suggested for non-stiff problems. ! MITER = 1 Means chord method with analytic Jacobian. ! In this case, the user supplies subroutine ! JACOBN (see description below). ! MITER = 2 Means chord method with Jacobian calculated ! internally by finite differences. ! MITER = 3 Means chord method with corrections computed ! by the user-written routine USERS (see ! description of USERS below.) This option ! allows all matrix algebra and storage ! decisions to be made by the user. When using ! a value of MITER = 3, the subroutine FA is ! not required, even if IMPL is not 0. For ! further information on using this option, see ! Section IV-E below. ! MITER = 4 Means the same as MITER = 1 but the A and ! Jacobian matrices are assumed to be banded. ! MITER = 5 Means the same as MITER = 2 but the A and ! Jacobian matrices are assumed to be banded. ! ! IMPL = (Input) The implicit method indicator. ! IMPL = 0 Means solving dY(I)/dT = F(Y(I),T). ! IMPL = 1 Means solving A*dY(I)/dT = F(Y(I),T), non- ! singular A (see description of FA below.) ! Only MINT = 1 or 2, and MITER = 1, 2, 3, 4, ! or 5 are allowed for this option. ! IMPL = 2,3 Means solving certain systems of hybrid ! differential/algebraic equations (see ! description of FA below.) Only MINT = 2 and ! MITER = 1, 2, 3, 4, or 5, are allowed for ! this option. ! The value of IMPL must not be changed during a problem. ! ! ML = (Input) The lower half-bandwidth in the case of a banded ! A or Jacobian matrix. (I.e., maximum(R-C) for nonzero ! A(R,C).) ! ! MU = (Input) The upper half-bandwidth in the case of a banded ! A or Jacobian matrix. (I.e., maximum(C-R).) ! ! MXORD = (Input) The maximum order desired. This is <= 12 for ! the Adams methods and <= 5 for the Gear methods. Normal ! value is 12 and 5, respectively. If MINT is 3, the ! maximum order used will be MIN(MXORD, 12) when using the ! Adams methods, and MIN(MXORD, 5) when using the Gear ! methods. MXORD must not be altered during a problem. ! ! HMAX = (Input, Real) The maximum magnitude of the step size that ! will be used for the problem. This is useful for ensuring ! that important details are not missed. If this is not the ! case, a large value, such as the interval length, is ! suggested. ! ! WORK ! LENW = (Input) ! WORK is an array of LENW complex words used ! internally for temporary storage. The user must allocate ! space for this array in the calling program by a statement ! such as ! COMPLEX WORK(...) ! The following table gives the required minimum value for ! the length of WORK, depending on the value of IMPL and ! MITER. LENW should be set to the value used. The ! contents of WORK should not be disturbed between calls to ! CDRIV3. ! ! IMPL = 0 1 2 3 ! --------------------------------------------------------- ! MITER = 0 (MXORD+4)*N Not allowed Not allowed Not allowed ! + 2*NROOT ! + 250 ! ! 1,2 N*N + 2*N*N + N*N + N*(N + NDE) ! (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N ! + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT ! + 250 + 250 + 250 + 250 ! ! 3 (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N ! + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT ! + 250 + 250 + 250 + 250 ! ! 4,5 (2*ML+MU+1) 2*(2*ML+MU+1) (2*ML+MU+1) (2*ML+MU+1)* ! *N + *N + *N + (N+NDE) + ! (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N ! + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT ! + 250 + 250 + 250 + 250 ! --------------------------------------------------------- ! ! IWORK ! LENIW = (Input) ! IWORK is an integer array of length LENIW used internally ! for temporary storage. The user must allocate space for ! this array in the calling program by a statement such as ! INTEGER IWORK(...) ! The length of IWORK should be at least ! 50 if MITER is 0 or 3, or ! N+50 if MITER is 1, 2, 4, or 5, or MINT is 3, ! and LENIW should be set to the value used. The contents ! of IWORK should not be disturbed between calls to CDRIV3. ! ! JACOBN = A subroutine supplied by the user, if MITER is 1 or 4. ! If this is the case, the name must be declared EXTERNAL in ! the user's calling program. Given a system of N ! differential equations, it is meaningful to speak about ! the partial derivative of the I-th right hand side with ! respect to the J-th dependent variable. In general there ! are N*N such quantities. Often however the equations can ! be ordered so that the I-th differential equation only ! involves dependent variables with index near I, e.g., I+1, ! I-2. Such a system is called banded. If, for all I, the ! I-th equation depends on at most the variables ! Y(I-ML), Y(I-ML+1), ... , Y(I), Y(I+1), ... , Y(I+MU) ! then we call ML+MU+1 the bandwidth of the system. In a ! banded system many of the partial derivatives above are ! automatically zero. For the cases MITER = 1, 2, 4, and 5, ! some of these partials are needed. For the cases ! MITER = 2 and 5 the necessary derivatives are ! approximated numerically by CDRIV3, and we only ask the ! user to tell CDRIV3 the value of ML and MU if the system ! is banded. For the cases MITER = 1 and 4 the user must ! derive these partials algebraically and encode them in ! subroutine JACOBN. By computing these derivatives the ! user can often save 20-30 per cent of the computing time. ! Usually, however, the accuracy is not much affected and ! most users will probably forego this option. The optional ! user-written subroutine JACOBN has the form: ! SUBROUTINE JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) ! COMPLEX Y(*), DFDY(MATDIM,*) ! . ! . ! Calculate values of DFDY ! . ! . ! END (Sample) ! Here Y is a vector of length at least N. The actual ! length of Y is determined by the user's declaration in the ! program which calls CDRIV3. Thus the dimensioning of Y in ! JACOBN, while required by FORTRAN convention, does not ! actually allocate any storage. When this subroutine is ! called, the first N components of Y are intermediate ! approximations to the solution components. The user ! should not alter these values. If the system is not ! banded (MITER=1), the partials of the I-th equation with ! respect to the J-th dependent function are to be stored in ! DFDY(I,J). Thus partials of the I-th equation are stored ! in the I-th row of DFDY. If the system is banded ! (MITER=4), then the partials of the I-th equation with ! respect to Y(J) are to be stored in DFDY(K,J), where ! K=I-J+MU+1 . Normally a return from JACOBN passes control ! back to CDRIV3. However, if the user would like to abort ! the calculation, i.e., return control to the program which ! calls CDRIV3, he should set N to zero. CDRIV3 will signal ! this by returning a value of NSTATE equal to +8(-8). ! Altering the value of N in JACOBN has no effect on the ! value of N in the call sequence of CDRIV3. ! ! FA = A subroutine supplied by the user if IMPL is not zero, and ! MITER is not 3. If so, the name must be declared EXTERNAL ! in the user's calling program. This subroutine computes ! the array A, where A*dY(I)/dT = F(Y(I),T). ! There are three cases: ! ! IMPL=1. ! Subroutine FA is of the form: ! SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) ! COMPLEX Y(*), A(MATDIM,*) ! . ! . ! Calculate ALL values of A ! . ! . ! END (Sample) ! In this case A is assumed to be a nonsingular matrix, ! with the same structure as DFDY (see JACOBN description ! above). Programming considerations prevent complete ! generality. If MITER is 1 or 2, A is assumed to be full ! and the user must compute and store all values of ! A(I,J), I,J=1, ... ,N. If MITER is 4 or 5, A is assumed ! to be banded with lower and upper half bandwidth ML and ! MU. The left hand side of the I-th equation is a linear ! combination of dY(I-ML)/dT, dY(I-ML+1)/dT, ... , ! dY(I)/dT, ... , dY(I+MU-1)/dT, dY(I+MU)/dT. Thus in the ! I-th equation, the coefficient of dY(J)/dT is to be ! stored in A(K,J), where K=I-J+MU+1. ! NOTE: The array A will be altered between calls to FA. ! ! IMPL=2. ! Subroutine FA is of the form: ! SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) ! COMPLEX Y(*), A(*) ! . ! . ! Calculate non-zero values of A(1),...,A(NDE) ! . ! . ! END (Sample) ! In this case it is assumed that the system is ordered by ! the user so that the differential equations appear ! first, and the algebraic equations appear last. The ! algebraic equations must be written in the form: ! 0 = F(Y(I),T). When using this option it is up to the ! user to provide initial values for the Y(I) that satisfy ! the algebraic equations as well as possible. It is ! further assumed that A is a vector of length NDE. All ! of the components of A, which may depend on T, Y(I), ! etc., must be set by the user to non-zero values. ! ! IMPL=3. ! Subroutine FA is of the form: ! SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) ! COMPLEX Y(*), A(MATDIM,*) ! . ! . ! Calculate ALL values of A ! . ! . ! END (Sample) ! In this case A is assumed to be a nonsingular NDE by NDE ! matrix with the same structure as DFDY (see JACOBN ! description above). Programming considerations prevent ! complete generality. If MITER is 1 or 2, A is assumed ! to be full and the user must compute and store all ! values of A(I,J), I,J=1, ... ,NDE. If MITER is 4 or 5, ! A is assumed to be banded with lower and upper half ! bandwidths ML and MU. The left hand side of the I-th ! equation is a linear combination of dY(I-ML)/dT, ! dY(I-ML+1)/dT, ... , dY(I)/dT, ... , dY(I+MU-1)/dT, ! dY(I+MU)/dT. Thus in the I-th equation, the coefficient ! of dY(J)/dT is to be stored in A(K,J), where K=I-J+MU+1. ! It is assumed that the system is ordered by the user so ! that the differential equations appear first, and the ! algebraic equations appear last. The algebraic ! equations must be written in the form 0 = F(Y(I),T). ! When using this option it is up to the user to provide ! initial values for the Y(I) that satisfy the algebraic ! equations as well as possible. ! NOTE: For IMPL = 3, the array A will be altered between ! calls to FA. ! Here Y is a vector of length at least N. The actual ! length of Y is determined by the user's declaration in the ! program which calls CDRIV3. Thus the dimensioning of Y in ! FA, while required by FORTRAN convention, does not ! actually allocate any storage. When this subroutine is ! called, the first N components of Y are intermediate ! approximations to the solution components. The user ! should not alter these values. FA is always called ! immediately after calling F, with the same values of T ! and Y. Normally a return from FA passes control back to ! CDRIV3. However, if the user would like to abort the ! calculation, i.e., return control to the program which ! calls CDRIV3, he should set N to zero. CDRIV3 will signal ! this by returning a value of NSTATE equal to +9(-9). ! Altering the value of N in FA has no effect on the value ! of N in the call sequence of CDRIV3. ! ! NDE = (Input) The number of differential equations. This is ! required only for IMPL = 2 or 3, with NDE < N. ! ! MXSTEP = (Input) The maximum number of internal steps allowed on ! one call to CDRIV3. ! ! G = A real FORTRAN function supplied by the user ! if NROOT is not 0. In this case, the name must be ! declared EXTERNAL in the user's calling program. G is ! repeatedly called with different values of IROOT to obtain ! the value of each of the NROOT equations for which a root ! is desired. G is of the form: ! REAL FUNCTION G (N, T, Y, IROOT) ! COMPLEX Y(*) ! go to (10, ...), IROOT ! 10 G = ... ! . ! . ! END (Sample) ! Here, Y is a vector of length at least N, whose first N ! components are the solution components at the point T. ! The user should not alter these values. The actual length ! of Y is determined by the user's declaration in the ! program which calls CDRIV3. Thus the dimensioning of Y in ! G, while required by FORTRAN convention, does not actually ! allocate any storage. Normally a return from G passes ! control back to CDRIV3. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls CDRIV3, he should set N to zero. ! CDRIV3 will signal this by returning a value of NSTATE ! equal to +7(-7). In this case, the index of the equation ! being evaluated is stored in the sixth element of IWORK. ! Altering the value of N in G has no effect on the value of ! N in the call sequence of CDRIV3. ! ! USERS = A subroutine supplied by the user, if MITER is 3. ! If this is the case, the name must be declared EXTERNAL in ! the user's calling program. The routine USERS is called ! by CDRIV3 when certain linear systems must be solved. The ! user may choose any method to form, store and solve these ! systems in order to obtain the solution result that is ! returned to CDRIV3. In particular, this allows sparse ! matrix methods to be used. The call sequence for this ! routine is: ! ! SUBROUTINE USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, ! 8 IMPL, N, NDE, IFLAG) ! COMPLEX Y(*), YH(*), YWT(*), SAVE1(*), SAVE2(*) ! REAL T, H, EL ! ! The input variable IFLAG indicates what action is to be ! taken. Subroutine USERS should perform the following ! operations, depending on the value of IFLAG and IMPL. ! ! IFLAG = 0 ! IMPL = 0. USERS is not called. ! IMPL = 1, 2 or 3. Solve the system A*X = SAVE2, ! returning the result in SAVE2. The array SAVE1 can ! be used as a work array. For IMPL = 1, there are N ! components to the system, and for IMPL = 2 or 3, ! there are NDE components to the system. ! ! IFLAG = 1 ! IMPL = 0. Compute, decompose and store the matrix ! (I - H*EL*J), where I is the identity matrix and J ! is the Jacobian matrix of the right hand side. The ! array SAVE1 can be used as a work array. ! IMPL = 1, 2 or 3. Compute, decompose and store the ! matrix (A - H*EL*J). The array SAVE1 can be used as ! a work array. ! ! IFLAG = 2 ! IMPL = 0. Solve the system ! (I - H*EL*J)*X = H*SAVE2 - YH - SAVE1, ! returning the result in SAVE2. ! IMPL = 1, 2 or 3. Solve the system ! (A - H*EL*J)*X = H*SAVE2 - A*(YH + SAVE1) ! returning the result in SAVE2. ! The array SAVE1 should not be altered. ! If IFLAG is 0 and IMPL is 1 or 2 and the matrix A is ! singular, or if IFLAG is 1 and one of the matrices ! (I - H*EL*J), (A - H*EL*J) is singular, the INTEGER ! variable IFLAG is to be set to -1 before RETURNing. ! Normally a return from USERS passes control back to ! CDRIV3. However, if the user would like to abort the ! calculation, i.e., return control to the program which ! calls CDRIV3, he should set N to zero. CDRIV3 will signal ! this by returning a value of NSTATE equal to +10(-10). ! Altering the value of N in USERS has no effect on the ! value of N in the call sequence of CDRIV3. ! ! IERFLG = An error flag. The error number associated with a ! diagnostic message (see Section III-A below) is the same ! as the corresponding value of IERFLG. The meaning of ! IERFLG: ! 0 The routine completed successfully. (No message is ! issued.) ! 3 (Warning) The number of steps required to reach TOUT ! exceeds MXSTEP. ! 4 (Warning) The value of EPS is too small. ! 11 (Warning) For NTASK = 2 or 3, T is beyond TOUT. ! The solution was obtained by interpolation. ! 15 (Warning) The integration step size is below the ! roundoff level of T. (The program issues this ! message as a warning but does not return control to ! the user.) ! 22 (Recoverable) N is not positive. ! 23 (Recoverable) MINT is less than 1 or greater than 3 . ! 24 (Recoverable) MITER is less than 0 or greater than ! 5 . ! 25 (Recoverable) IMPL is less than 0 or greater than 3 . ! 26 (Recoverable) The value of NSTATE is less than 1 or ! greater than 12 . ! 27 (Recoverable) EPS is less than zero. ! 28 (Recoverable) MXORD is not positive. ! 29 (Recoverable) For MINT = 3, either MITER = 0 or 3, or ! IMPL = 0 . ! 30 (Recoverable) For MITER = 0, IMPL is not 0 . ! 31 (Recoverable) For MINT = 1, IMPL is 2 or 3 . ! 32 (Recoverable) Insufficient storage has been allocated ! for the WORK array. ! 33 (Recoverable) Insufficient storage has been allocated ! for the IWORK array. ! 41 (Recoverable) The integration step size has gone ! to zero. ! 42 (Recoverable) The integration step size has been ! reduced about 50 times without advancing the ! solution. The problem setup may not be correct. ! 43 (Recoverable) For IMPL greater than 0, the matrix A ! is singular. ! 999 (Fatal) The value of NSTATE is 12 . ! ! III. OTHER COMMUNICATION TO THE USER .............................. ! ! A. The solver communicates to the user through the parameters ! above. In addition it writes diagnostic messages through the ! standard error handling program XERMSG. A complete description ! of XERMSG is given in "Guide to the SLATEC Common Mathematical ! Library" by Kirby W. Fong et al.. At installations which do not ! have this error handling package the short but serviceable ! routine, XERMSG, available with this package, can be used. That ! program uses the file named OUTPUT to transmit messages. ! ! B. The first three elements of WORK and the first five elements of ! IWORK will contain the following statistical data: ! AVGH The average step size used. ! HUSED The step size last used (successfully). ! AVGORD The average order used. ! IMXERR The index of the element of the solution vector that ! contributed most to the last error test. ! NQUSED The order last used (successfully). ! NSTEP The number of steps taken since last initialization. ! NFE The number of evaluations of the right hand side. ! NJE The number of evaluations of the Jacobian matrix. ! ! IV. REMARKS ....................................................... ! ! A. Other routines used: ! CDNTP, CDZRO, CDSTP, CDNTL, CDPST, CDCOR, CDCST, ! CDPSC, and CDSCL; ! CGEFA, CGESL, CGBFA, CGBSL, and SCNRM2 (from LINPACK) ! R1MACH (from the Bell Laboratories Machine Constants Package) ! XERMSG (from the SLATEC Common Math Library) ! The last seven routines above, not having been written by the ! present authors, are not explicitly part of this package. ! ! B. On any return from CDRIV3 all information necessary to continue ! the calculation is contained in the call sequence parameters, ! including the work arrays. Thus it is possible to suspend one ! problem, integrate another, and then return to the first. ! ! C. If this package is to be used in an overlay situation, the user ! must declare in the primary overlay the variables in the call ! sequence to CDRIV3. ! ! D. Changing parameters during an integration. ! The value of NROOT, EPS, EWT, IERROR, MINT, MITER, or HMAX may ! be altered by the user between calls to CDRIV3. For example, if ! too much accuracy has been requested (the program returns with ! NSTATE = 4 and an increased value of EPS) the user may wish to ! increase EPS further. In general, prudence is necessary when ! making changes in parameters since such changes are not ! implemented until the next integration step, which is not ! necessarily the next call to CDRIV3. This can happen if the ! program has already integrated to a point which is beyond the ! new point TOUT. ! ! E. As the price for complete control of matrix algebra, the CDRIV3 ! USERS option puts all responsibility for Jacobian matrix ! evaluation on the user. It is often useful to approximate ! numerically all or part of the Jacobian matrix. However this ! must be done carefully. The FORTRAN sequence below illustrates ! the method we recommend. It can be inserted directly into ! subroutine USERS to approximate Jacobian elements in rows I1 ! to I2 and columns J1 to J2. ! COMPLEX DFDY(N,N), R, SAVE1(N), SAVE2(N), Y(N), YJ, YWT(N) ! REAL EPSJ, H, R1MACH, T, UROUND ! UROUND = R1MACH(4) ! EPSJ = SQRT(UROUND) ! DO 30 J = J1,J2 ! if (ABS(Y(J)) > ABS(YWT(J))) THEN ! R = EPSJ*Y(J) ! ELSE ! R = EPSJ*YWT(J) ! end if ! if (R == 0.E0) R = YWT(J) ! YJ = Y(J) ! Y(J) = Y(J) + R ! call F (N, T, Y, SAVE1) ! if (N == 0) RETURN ! Y(J) = YJ ! DO 20 I = I1,I2 ! 20 DFDY(I,J) = (SAVE1(I) - SAVE2(I))/R ! 30 CONTINUE ! Many problems give rise to structured sparse Jacobians, e.g., ! block banded. It is possible to approximate them with fewer ! function evaluations than the above procedure uses; see Curtis, ! Powell and Reid, J. Inst. Maths Applics, (1974), Vol. 13, ! pp. 117-119. ! ! F. When any of the routines JACOBN, FA, G, or USERS, is not ! required, difficulties associated with unsatisfied externals can ! be avoided by using the name of the routine which calculates the ! right hand side of the differential equations in place of the ! corresponding name in the call sequence of CDRIV3. ! !***REFERENCES C. W. Gear, Numerical Initial Value Problems in ! Ordinary Differential Equations, Prentice-Hall, 1971. !***ROUTINES CALLED CDNTP, CDSTP, CDZRO, CGBFA, CGBSL, CGEFA, CGESL, ! R1MACH, SCNRM2, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDRIV3 EXTERNAL F, JACOBN, FA, G, USERS COMPLEX WORK(*), Y(*) REAL AE, AVGH, AVGORD, BIG, EL(13,12), EPS, EWT(*), & G, GLAST, GNOW, H, HMAX, HOLD, HSIGN, HUSED, NROUND, RC, RE, & RMAX, R1MACH, SCNRM2, SIZE, SUM, T, TLAST, TOUT, TQ(3,12), & TREND, TROOT, UROUND INTEGER I, IA, IAVGH, IAVGRD, ICNVRG, IDFDY, IEL, IERFLG, IERROR, & IFAC, IFLAG, IGNOW, IH, IHMAX, IHOLD, IHSIGN, IHUSED, & IJROOT, IJSTPL, IJTASK, IMNT, IMNTLD, IMPL, IMTR, IMTRLD, & IMTRSV, IMXERR, IMXORD, IMXRDS, INDMXR, INDPRT, INDPVT, & INDTRT, INFE, INFO, INJE, INQ, INQUSE, INROOT, INRTLD, & INSTEP, INWAIT, IRC, IRMAX, IROOT, IMACH1, IMACH4, ISAVE1, & ISAVE2, IT, ITOUT, ITQ, ITREND, ITROOT, IWORK(*), IYH, & IYWT, J, JSTATE, JTROOT, LENCHK, LENIW, LENW, LIWCHK, & MATDIM, MAXORD, MINT, MITER, ML, MU, MXORD, MXSTEP, N, & NDE, NDECOM, NPAR, NROOT, NSTATE, NSTEPL, NTASK LOGICAL CONVRG CHARACTER INTGR1*8, INTGR2*8, RL1*16, RL2*16 PARAMETER(NROUND = 20.E0) PARAMETER(IAVGH = 1, IHUSED = 2, IAVGRD = 3, & IEL = 4, IH = 160, IHMAX = 161, IHOLD = 162, & IHSIGN = 163, IRC = 164, IRMAX = 165, IT = 166, & ITOUT = 167, ITQ = 168, ITREND = 204, IMACH1 = 205, & IMACH4 = 206, IYH = 251, & INDMXR = 1, INQUSE = 2, INSTEP = 3, INFE = 4, INJE = 5, & INROOT = 6, ICNVRG = 7, IJROOT = 8, IJTASK = 9, & IMNTLD = 10, IMTRLD = 11, INQ = 12, INRTLD = 13, & INDTRT = 14, INWAIT = 15, IMNT = 16, IMTRSV = 17, & IMTR = 18, IMXRDS = 19, IMXORD = 20, INDPRT = 21, & IJSTPL = 22, INDPVT = 51) !***FIRST EXECUTABLE STATEMENT CDRIV3 if (NSTATE == 12) THEN IERFLG = 999 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. The value of NSTATE is 12 .', IERFLG, 2) return ELSE if (NSTATE < 1 .OR. NSTATE > 12) THEN WRITE(INTGR1, '(I8)') NSTATE IERFLG = 26 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. Improper value for NSTATE(= '//INTGR1//').', & IERFLG, 1) NSTATE = 12 return end if NPAR = N if (EPS < 0.E0) THEN WRITE(RL1, '(E16.8)') EPS IERFLG = 27 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. EPS, '//RL1//', is negative.', IERFLG, 1) NSTATE = 12 return end if if (N <= 0) THEN WRITE(INTGR1, '(I8)') N IERFLG = 22 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. Number of equations, '//INTGR1// & ', is not positive.', IERFLG, 1) NSTATE = 12 return end if if (MXORD <= 0) THEN WRITE(INTGR1, '(I8)') MXORD IERFLG = 28 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. Maximum order, '//INTGR1// & ', is not positive.', IERFLG, 1) NSTATE = 12 return end if if (MINT < 1 .OR. MINT > 3) THEN WRITE(INTGR1, '(I8)') MINT IERFLG = 23 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. Improper value for the integration method '// & 'flag, '//INTGR1//' .', IERFLG, 1) NSTATE = 12 return ELSE if (MITER < 0 .OR. MITER > 5) THEN WRITE(INTGR1, '(I8)') MITER IERFLG = 24 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. Improper value for MITER(= '//INTGR1//').', & IERFLG, 1) NSTATE = 12 return ELSE if (IMPL < 0 .OR. IMPL > 3) THEN WRITE(INTGR1, '(I8)') IMPL IERFLG = 25 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. Improper value for IMPL(= '//INTGR1//').', & IERFLG, 1) NSTATE = 12 return ELSE if (MINT == 3 .AND. & (MITER == 0 .OR. MITER == 3 .OR. IMPL /= 0)) THEN WRITE(INTGR1, '(I8)') MITER WRITE(INTGR2, '(I8)') IMPL IERFLG = 29 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. For MINT = 3, the value of MITER, '//INTGR1// & ', and/or IMPL, '//INTGR2//', is not allowed.', IERFLG, 1) NSTATE = 12 return ELSE if ((IMPL >= 1 .AND. IMPL <= 3) .AND. MITER == 0) THEN WRITE(INTGR1, '(I8)') IMPL IERFLG = 30 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. For MITER = 0, the value of IMPL, '//INTGR1// & ', is not allowed.', IERFLG, 1) NSTATE = 12 return ELSE if ((IMPL == 2 .OR. IMPL == 3) .AND. MINT == 1) THEN WRITE(INTGR1, '(I8)') IMPL IERFLG = 31 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. For MINT = 1, the value of IMPL, '//INTGR1// & ', is not allowed.', IERFLG, 1) NSTATE = 12 return end if if (MITER == 0 .OR. MITER == 3) THEN LIWCHK = INDPVT - 1 ELSE if (MITER == 1 .OR. MITER == 2 .OR. MITER == 4 .OR. & MITER == 5) THEN LIWCHK = INDPVT + N - 1 end if if (LENIW < LIWCHK) THEN WRITE(INTGR1, '(I8)') LIWCHK IERFLG = 33 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. Insufficient storage allocated for the '// & 'IWORK array. Based on the value of the input parameters '// & 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) NSTATE = 12 return end if ! Allocate the WORK array ! IYH is the index of YH in WORK if (MINT == 1 .OR. MINT == 3) THEN MAXORD = MIN(MXORD, 12) ELSE if (MINT == 2) THEN MAXORD = MIN(MXORD, 5) end if IDFDY = IYH + (MAXORD + 1)*N ! IDFDY is the index of DFDY ! if (MITER == 0 .OR. MITER == 3) THEN IYWT = IDFDY ELSE if (MITER == 1 .OR. MITER == 2) THEN IYWT = IDFDY + N*N ELSE if (MITER == 4 .OR. MITER == 5) THEN IYWT = IDFDY + (2*ML + MU + 1)*N end if ! IYWT is the index of YWT ISAVE1 = IYWT + N ! ISAVE1 is the index of SAVE1 ISAVE2 = ISAVE1 + N ! ISAVE2 is the index of SAVE2 IGNOW = ISAVE2 + N ! IGNOW is the index of GNOW ITROOT = IGNOW + NROOT ! ITROOT is the index of TROOT IFAC = ITROOT + NROOT ! IFAC is the index of FAC if (MITER == 2 .OR. MITER == 5 .OR. MINT == 3) THEN IA = IFAC + N ELSE IA = IFAC end if ! IA is the index of A if (IMPL == 0 .OR. MITER == 3) THEN LENCHK = IA - 1 ELSE if (IMPL == 1 .AND. (MITER == 1 .OR. MITER == 2)) THEN LENCHK = IA - 1 + N*N ELSE if (IMPL == 1 .AND. (MITER == 4 .OR. MITER == 5)) THEN LENCHK = IA - 1 + (2*ML + MU + 1)*N ELSE if (IMPL == 2 .AND. MITER /= 3) THEN LENCHK = IA - 1 + N ELSE if (IMPL == 3 .AND. (MITER == 1 .OR. MITER == 2)) THEN LENCHK = IA - 1 + N*NDE ELSE if (IMPL == 3 .AND. (MITER == 4 .OR. MITER == 5)) THEN LENCHK = IA - 1 + (2*ML + MU + 1)*NDE end if if (LENW < LENCHK) THEN WRITE(INTGR1, '(I8)') LENCHK IERFLG = 32 call XERMSG('SLATEC', 'CDRIV3', & 'Illegal input. Insufficient storage allocated for the '// & 'WORK array. Based on the value of the input parameters '// & 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) NSTATE = 12 return end if if (MITER == 0 .OR. MITER == 3) THEN MATDIM = 1 ELSE if (MITER == 1 .OR. MITER == 2) THEN MATDIM = N ELSE if (MITER == 4 .OR. MITER == 5) THEN MATDIM = 2*ML + MU + 1 end if if (IMPL == 0 .OR. IMPL == 1) THEN NDECOM = N ELSE if (IMPL == 2 .OR. IMPL == 3) THEN NDECOM = NDE end if if (NSTATE == 1) THEN ! Initialize parameters if (MINT == 1 .OR. MINT == 3) THEN IWORK(IMXORD) = MIN(MXORD, 12) ELSE if (MINT == 2) THEN IWORK(IMXORD) = MIN(MXORD, 5) end if IWORK(IMXRDS) = MXORD if (MINT == 1 .OR. MINT == 2) THEN IWORK(IMNT) = MINT IWORK(IMTR) = MITER IWORK(IMNTLD) = MINT IWORK(IMTRLD) = MITER ELSE if (MINT == 3) THEN IWORK(IMNT) = 1 IWORK(IMTR) = 0 IWORK(IMNTLD) = IWORK(IMNT) IWORK(IMTRLD) = IWORK(IMTR) IWORK(IMTRSV) = MITER end if WORK(IHMAX) = HMAX UROUND = R1MACH (4) WORK(IMACH4) = UROUND WORK(IMACH1) = R1MACH (1) if (NROOT /= 0) THEN RE = UROUND AE = WORK(IMACH1) end if H = (TOUT - T)*(1.E0 - 4.E0*UROUND) H = SIGN(MIN(ABS(H), HMAX), H) WORK(IH) = H HSIGN = SIGN(1.E0, H) WORK(IHSIGN) = HSIGN IWORK(IJTASK) = 0 AVGH = 0.E0 AVGORD = 0.E0 WORK(IAVGH) = 0.E0 WORK(IHUSED) = 0.E0 WORK(IAVGRD) = 0.E0 IWORK(INDMXR) = 0 IWORK(INQUSE) = 0 IWORK(INSTEP) = 0 IWORK(IJSTPL) = 0 IWORK(INFE) = 0 IWORK(INJE) = 0 IWORK(INROOT) = 0 WORK(IT) = T IWORK(ICNVRG) = 0 IWORK(INDPRT) = 0 ! Set initial conditions DO 30 I = 1,N 30 WORK(I+IYH-1) = Y(I) if (T == TOUT) RETURN go to 180 ELSE UROUND = WORK(IMACH4) if (NROOT /= 0) THEN RE = UROUND AE = WORK(IMACH1) end if end if ! On a continuation, check ! that output points have ! been or will be overtaken. if (IWORK(ICNVRG) == 1) THEN CONVRG = .TRUE. ELSE CONVRG = .FALSE. end if AVGH = WORK(IAVGH) AVGORD = WORK(IAVGRD) HOLD = WORK(IHOLD) RC = WORK(IRC) RMAX = WORK(IRMAX) TREND = WORK(ITREND) DO 35 J = 1,12 DO 35 I = 1,13 35 EL(I,J) = WORK(I+IEL+(J-1)*13-1) DO 40 J = 1,12 DO 40 I = 1,3 40 TQ(I,J) = WORK(I+ITQ+(J-1)*3-1) T = WORK(IT) H = WORK(IH) HSIGN = WORK(IHSIGN) if (IWORK(IJTASK) == 0) go to 180 ! ! IWORK(IJROOT) flags unreported ! roots, and is set to the value of ! NTASK when a root was last selected. ! It is set to zero when all roots ! have been reported. IWORK(INROOT) ! contains the index and WORK(ITOUT) ! contains the value of the root last ! selected to be reported. ! IWORK(INRTLD) contains the value of ! NROOT and IWORK(INDTRT) contains ! the value of ITROOT when the array ! of roots was last calculated. if (NROOT /= 0) THEN if (IWORK(IJROOT) > 0) THEN ! TOUT has just been reported. ! If TROOT <= TOUT, report TROOT. if (NSTATE /= 5) THEN if (TOUT*HSIGN >= REAL(WORK(ITOUT))*HSIGN) THEN TROOT = WORK(ITOUT) call CDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) T = TROOT NSTATE = 5 IERFLG = 0 go to 580 end if ! A root has just been reported. ! Select the next root. ELSE TROOT = T IROOT = 0 DO 50 I = 1,IWORK(INRTLD) JTROOT = I + IWORK(INDTRT) - 1 if (REAL(WORK(JTROOT))*HSIGN <= TROOT*HSIGN) THEN ! ! Check for multiple roots. ! if (WORK(JTROOT) == WORK(ITOUT) .AND. & I > IWORK(INROOT)) THEN IROOT = I TROOT = WORK(JTROOT) go to 60 end if if (REAL(WORK(JTROOT))*HSIGN > & REAL(WORK(ITOUT))*HSIGN) THEN IROOT = I TROOT = WORK(JTROOT) end if end if 50 CONTINUE 60 IWORK(INROOT) = IROOT WORK(ITOUT) = TROOT IWORK(IJROOT) = NTASK if (NTASK == 1) THEN if (IROOT == 0) THEN IWORK(IJROOT) = 0 ELSE if (TOUT*HSIGN >= TROOT*HSIGN) THEN call CDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), & Y) NSTATE = 5 T = TROOT IERFLG = 0 go to 580 end if end if ELSE if (NTASK == 2 .OR. NTASK == 3) THEN ! ! If there are no more roots, or the ! user has altered TOUT to be less ! than a root, set IJROOT to zero. ! if (IROOT == 0 .OR. (TOUT*HSIGN < TROOT*HSIGN)) THEN IWORK(IJROOT) = 0 ELSE call CDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), & Y) NSTATE = 5 T = TROOT IERFLG = 0 go to 580 end if end if end if end if end if ! if (NTASK == 1) THEN NSTATE = 2 if (T*HSIGN >= TOUT*HSIGN) THEN call CDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT IERFLG = 0 go to 580 end if ELSE if (NTASK == 2) THEN ! Check if TOUT has ! been reset < T if (T*HSIGN > TOUT*HSIGN) THEN WRITE(RL1, '(E16.8)') T WRITE(RL2, '(E16.8)') TOUT IERFLG = 11 call XERMSG('SLATEC', 'CDRIV3', & 'While integrating exactly to TOUT, T, '//RL1// & ', was beyond TOUT, '//RL2//' . Solution obtained by '// & 'interpolation.', IERFLG, 0) NSTATE = 11 call CDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT go to 580 end if ! Determine if TOUT has been overtaken ! if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT NSTATE = 2 IERFLG = 0 go to 560 end if ! If there are no more roots ! to report, report T. if (NSTATE == 5) THEN NSTATE = 2 IERFLG = 0 go to 560 end if NSTATE = 2 ! See if TOUT will ! be overtaken. if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) WORK(IH) = H if (H == 0.E0) go to 670 IWORK(IJTASK) = -1 end if ELSE if (NTASK == 3) THEN NSTATE = 2 if (T*HSIGN > TOUT*HSIGN) THEN WRITE(RL1, '(E16.8)') T WRITE(RL2, '(E16.8)') TOUT IERFLG = 11 call XERMSG('SLATEC', 'CDRIV3', & 'While integrating exactly to TOUT, T, '//RL1// & ', was beyond TOUT, '//RL2//' . Solution obtained by '// & 'interpolation.', IERFLG, 0) NSTATE = 11 call CDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT go to 580 end if if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT IERFLG = 0 go to 560 end if if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) WORK(IH) = H if (H == 0.E0) go to 670 IWORK(IJTASK) = -1 end if end if ! Implement changes in MINT, MITER, and/or HMAX. ! if ((MINT /= IWORK(IMNTLD) .OR. MITER /= IWORK(IMTRLD)) .AND. & MINT /= 3 .AND. IWORK(IMNTLD) /= 3) IWORK(IJTASK) = -1 if (HMAX /= WORK(IHMAX)) THEN H = SIGN(MIN(ABS(H), HMAX), H) if (H /= WORK(IH)) THEN IWORK(IJTASK) = -1 WORK(IH) = H end if WORK(IHMAX) = HMAX end if ! 180 NSTEPL = IWORK(INSTEP) DO 190 I = 1,N 190 Y(I) = WORK(I+IYH-1) if (NROOT /= 0) THEN DO 200 I = 1,NROOT WORK(I+IGNOW-1) = G (NPAR, T, Y, I) if (NPAR == 0) THEN IWORK(INROOT) = I NSTATE = 7 return end if 200 CONTINUE end if if (IERROR == 1) THEN DO 230 I = 1,N 230 WORK(I+IYWT-1) = 1.E0 go to 410 ELSE if (IERROR == 5) THEN DO 250 I = 1,N 250 WORK(I+IYWT-1) = EWT(I) go to 410 end if ! Reset YWT array. Looping point. 260 if (IERROR == 2) THEN DO 280 I = 1,N if (Y(I) == 0.E0) go to 290 280 WORK(I+IYWT-1) = Y(I) go to 410 290 if (IWORK(IJTASK) == 0) THEN call F (NPAR, T, Y, WORK(ISAVE2)) if (NPAR == 0) THEN NSTATE = 6 return end if IWORK(INFE) = IWORK(INFE) + 1 if (MITER == 3 .AND. IMPL /= 0) THEN IFLAG = 0 call USERS (Y, WORK(IYH), WORK(IYWT), WORK(ISAVE1), & WORK(ISAVE2), T, H, REAL(WORK(IEL)), IMPL, NPAR, & NDECOM, IFLAG) if (IFLAG == -1) go to 690 if (NPAR == 0) THEN NSTATE = 10 return end if ELSE if (IMPL == 1) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call CGEFA (WORK(IA), MATDIM, N, IWORK(INDPVT), INFO) if (INFO /= 0) go to 690 call CGESL (WORK(IA), MATDIM, N, IWORK(INDPVT), & WORK(ISAVE2), 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call CGBFA (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), & INFO) if (INFO /= 0) go to 690 call CGBSL (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), & WORK(ISAVE2), 0) end if ELSE if (IMPL == 2) THEN call FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if DO 340 I = 1,NDECOM if (WORK(I+IA-1) == 0.E0) go to 690 340 WORK(I+ISAVE2-1) = WORK(I+ISAVE2-1)/WORK(I+IA-1) ELSE if (IMPL == 3) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call CGEFA (WORK(IA), MATDIM, NDE, IWORK(INDPVT), INFO) if (INFO /= 0) go to 690 call CGESL (WORK(IA), MATDIM, NDE, IWORK(INDPVT), & WORK(ISAVE2), 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call CGBFA (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), & INFO) if (INFO /= 0) go to 690 call CGBSL (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), & WORK(ISAVE2), 0) end if end if end if DO 360 J = I,N if (Y(J) /= 0.E0) THEN WORK(J+IYWT-1) = Y(J) ELSE if (IWORK(IJTASK) == 0) THEN WORK(J+IYWT-1) = H*WORK(J+ISAVE2-1) ELSE WORK(J+IYWT-1) = WORK(J+IYH+N-1) end if end if if (WORK(J+IYWT-1) == 0.E0) WORK(J+IYWT-1) = UROUND 360 CONTINUE ELSE if (IERROR == 3) THEN DO 380 I = 1,N 380 WORK(I+IYWT-1) = MAX(EWT(1), ABS(Y(I))) ELSE if (IERROR == 4) THEN DO 400 I = 1,N 400 WORK(I+IYWT-1) = MAX(EWT(I), ABS(Y(I))) end if ! 410 DO 420 I = 1,N 420 WORK(I+ISAVE2-1) = Y(I)/WORK(I+IYWT-1) SUM = SCNRM2(N, WORK(ISAVE2), 1)/SQRT(REAL(N)) SUM = MAX(1.E0, SUM) if (EPS < SUM*UROUND) THEN EPS = SUM*UROUND*(1.E0 + 10.E0*UROUND) WRITE(RL1, '(E16.8)') T WRITE(RL2, '(E16.8)') EPS IERFLG = 4 call XERMSG('SLATEC', 'CDRIV3', & 'At T, '//RL1//', the requested accuracy, EPS, was not '// & 'obtainable with the machine precision. EPS has been '// & 'increased to '//RL2//' .', IERFLG, 0) NSTATE = 4 go to 560 end if if (ABS(H) >= UROUND*ABS(T)) THEN IWORK(INDPRT) = 0 ELSE if (IWORK(INDPRT) == 0) THEN WRITE(RL1, '(E16.8)') T WRITE(RL2, '(E16.8)') H IERFLG = 15 call XERMSG('SLATEC', 'CDRIV3', & 'At T, '//RL1//', the step size, '//RL2//', is smaller '// & 'than the roundoff level of T. This may occur if there is '// & 'an abrupt change in the right hand side of the '// & 'differential equations.', IERFLG, 0) IWORK(INDPRT) = 1 end if if (NTASK /= 2) THEN if ((IWORK(INSTEP)-NSTEPL) == MXSTEP) THEN WRITE(RL1, '(E16.8)') T WRITE(INTGR1, '(I8)') MXSTEP WRITE(RL2, '(E16.8)') TOUT IERFLG = 3 call XERMSG('SLATEC', 'CDRIV3', & 'At T, '//RL1//', '//INTGR1//' steps have been taken '// & 'without reaching TOUT, '//RL2//' .', IERFLG, 0) NSTATE = 3 go to 560 end if end if ! ! call CDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, ! 8 MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, ! 8 USERS, AVGH, AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, ! 8 NFE, NJE, NQUSED, NSTEP, T, Y, YH, A, CONVRG, ! 8 DFDY, EL, FAC, HOLD, IPVT, JSTATE, JSTEPL, NQ, NWAIT, ! 8 RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, MTRSV, ! 8 MXRDSV) ! call CDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, & IWORK(IMXORD), IWORK(IMNT), IWORK(IMTR), ML, MU, NPAR, & NDECOM, WORK(IYWT), UROUND, USERS, AVGH, AVGORD, H, & HUSED, IWORK(IJTASK), IWORK(IMNTLD), IWORK(IMTRLD), & IWORK(INFE), IWORK(INJE), IWORK(INQUSE), IWORK(INSTEP), & T, Y, WORK(IYH), WORK(IA), CONVRG, WORK(IDFDY), EL, & WORK(IFAC), HOLD, IWORK(INDPVT), JSTATE, IWORK(IJSTPL), & IWORK(INQ), IWORK(INWAIT), RC, RMAX, WORK(ISAVE1), & WORK(ISAVE2), TQ, TREND, MINT, IWORK(IMTRSV), & IWORK(IMXRDS)) ! WORK(IH) = H WORK(IT) = T go to (470, 670, 680, 690, 690, 660, 660, 660, 660, 660), JSTATE 470 IWORK(IJTASK) = 1 ! Determine if a root has been overtaken if (NROOT /= 0) THEN IROOT = 0 DO 500 I = 1,NROOT GLAST = WORK(I+IGNOW-1) GNOW = G (NPAR, T, Y, I) if (NPAR == 0) THEN IWORK(INROOT) = I NSTATE = 7 return end if WORK(I+IGNOW-1) = GNOW if (GLAST*GNOW > 0.E0) THEN WORK(I+ITROOT-1) = T + H ELSE if (GNOW == 0.E0) THEN WORK(I+ITROOT-1) = T IROOT = I ELSE if (GLAST == 0.E0) THEN WORK(I+ITROOT-1) = T + H ELSE if (ABS(HUSED) >= UROUND*ABS(T)) THEN TLAST = T - HUSED IROOT = I TROOT = T call CDZRO (AE, G, H, NPAR, IWORK(INQ), IROOT, RE, T, & WORK(IYH), UROUND, TROOT, TLAST, & GNOW, GLAST, Y) DO 480 J = 1,N 480 Y(J) = WORK(IYH+J-1) if (NPAR == 0) THEN IWORK(INROOT) = I NSTATE = 7 return end if WORK(I+ITROOT-1) = TROOT ELSE WORK(I+ITROOT-1) = T IROOT = I end if end if end if end if 500 CONTINUE if (IROOT == 0) THEN IWORK(IJROOT) = 0 ! Select the first root ELSE IWORK(IJROOT) = NTASK IWORK(INRTLD) = NROOT IWORK(INDTRT) = ITROOT TROOT = T + H DO 510 I = 1,NROOT if (REAL(WORK(I+ITROOT-1))*HSIGN < TROOT*HSIGN) THEN TROOT = WORK(I+ITROOT-1) IROOT = I end if 510 CONTINUE IWORK(INROOT) = IROOT WORK(ITOUT) = TROOT if (TROOT*HSIGN <= TOUT*HSIGN) THEN call CDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) NSTATE = 5 T = TROOT IERFLG = 0 go to 580 end if end if end if ! Test for NTASK condition to be satisfied NSTATE = 2 if (NTASK == 1) THEN if (T*HSIGN < TOUT*HSIGN) go to 260 call CDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT IERFLG = 0 go to 580 ! TOUT is assumed to have been attained ! exactly if T is within twenty roundoff ! units of TOUT, relative to MAX(TOUT, T). ! ELSE if (NTASK == 2) THEN if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT ELSE if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) WORK(IH) = H if (H == 0.E0) go to 670 IWORK(IJTASK) = -1 end if end if ELSE if (NTASK == 3) THEN if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT ELSE if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) WORK(IH) = H if (H == 0.E0) go to 670 IWORK(IJTASK) = -1 end if go to 260 end if end if IERFLG = 0 ! All returns are made through this ! section. IMXERR is determined. 560 DO 570 I = 1,N 570 Y(I) = WORK(I+IYH-1) 580 if (CONVRG) THEN IWORK(ICNVRG) = 1 ELSE IWORK(ICNVRG) = 0 end if WORK(IAVGH) = AVGH WORK(IAVGRD) = AVGORD WORK(IHUSED) = HUSED WORK(IHOLD) = HOLD WORK(IRC) = RC WORK(IRMAX) = RMAX WORK(ITREND) = TREND DO 582 J = 1,12 DO 582 I = 1,13 582 WORK(I+IEL+(J-1)*13-1) = EL(I,J) DO 584 J = 1,12 DO 584 I = 1,3 584 WORK(I+ITQ+(J-1)*3-1) = TQ(I,J) if (IWORK(IJTASK) == 0) RETURN BIG = 0.E0 IMXERR = 1 DO 590 I = 1,N ! SIZE = ABS(ERROR(I)/YWT(I)) SIZE = ABS(WORK(I+ISAVE1-1)/WORK(I+IYWT-1)) if (BIG < SIZE) THEN BIG = SIZE IMXERR = I end if 590 CONTINUE IWORK(INDMXR) = IMXERR return ! 660 NSTATE = JSTATE DO 662 I = 1,N 662 Y(I) = WORK(I + IYH - 1) if (CONVRG) THEN IWORK(ICNVRG) = 1 ELSE IWORK(ICNVRG) = 0 end if WORK(IAVGH) = AVGH WORK(IAVGRD) = AVGORD WORK(IHUSED) = HUSED WORK(IHOLD) = HOLD WORK(IRC) = RC WORK(IRMAX) = RMAX WORK(ITREND) = TREND DO 664 J = 1,12 DO 664 I = 1,13 664 WORK(I+IEL+(J-1)*13-1) = EL(I,J) DO 666 J = 1,12 DO 666 I = 1,3 666 WORK(I+ITQ+(J-1)*3-1) = TQ(I,J) return ! Fatal errors are processed here ! 670 WRITE(RL1, '(E16.8)') T IERFLG = 41 call XERMSG('SLATEC', 'CDRIV3', & 'At T, '//RL1//', the attempted step size has gone to '// & 'zero. Often this occurs if the problem setup is incorrect.', & IERFLG, 1) NSTATE = 12 return ! 680 WRITE(RL1, '(E16.8)') T IERFLG = 42 call XERMSG('SLATEC', 'CDRIV3', & 'At T, '//RL1//', the step size has been reduced about 50 '// & 'times without advancing the solution. Often this occurs '// & 'if the problem setup is incorrect.', IERFLG, 1) NSTATE = 12 return ! 690 WRITE(RL1, '(E16.8)') T IERFLG = 43 call XERMSG('SLATEC', 'CDRIV3', & 'At T, '//RL1//', while solving A*YDOT = F, A is singular.', & IERFLG, 1) NSTATE = 12 return end subroutine CDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) ! !! CDSCL rescales the YH array whenever the step size is changed. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE COMPLEX (SDSCL-S, DDSCL-D, CDSCL-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDSCL INTEGER I, J, N, NQ COMPLEX YH(N,*) REAL H, HMAX, RC, RH, RMAX, R1 !***FIRST EXECUTABLE STATEMENT CDSCL if (H < 1.E0) THEN RH = MIN(ABS(H)*RH, ABS(H)*RMAX, HMAX)/ABS(H) ELSE RH = MIN(RH, RMAX, HMAX/ABS(H)) end if R1 = 1.E0 DO 10 J = 1,NQ R1 = R1*RH DO 10 I = 1,N 10 YH(I,J+1) = YH(I,J+1)*R1 H = H*RH RC = RC*RH return end subroutine CDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, USERS, AVGH, & AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, NFE, NJE, NQUSED, & NSTEP, T, Y, YH, A, CONVRG, DFDY, EL, FAC, HOLD, IPVT, JSTATE, & JSTEPL, NQ, NWAIT, RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, & MTRSV, MXRDSV) ! !! CDSTP performs one step of the integration of an initial value problem ... ! for a system of ordinary differential equations. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE COMPLEX (SDSTP-S, DDSTP-D, CDSTP-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! Communication with CDSTP is done with the following variables: ! ! YH An N by MAXORD+1 array containing the dependent variables ! and their scaled derivatives. MAXORD, the maximum order ! used, is currently 12 for the Adams methods and 5 for the ! Gear methods. YH(I,J+1) contains the J-th derivative of ! Y(I), scaled by H**J/factorial(J). Only Y(I), ! 1 <= I <= N, need be set by the calling program on ! the first entry. The YH array should not be altered by ! the calling program. When referencing YH as a ! 2-dimensional array, use a column length of N, as this is ! the value used in CDSTP. ! DFDY A block of locations used for partial derivatives if MITER ! is not 0. If MITER is 1 or 2 its length must be at least ! N*N. If MITER is 4 or 5 its length must be at least ! (2*ML+MU+1)*N. ! YWT An array of N locations used in convergence and error tests ! SAVE1 ! SAVE2 Arrays of length N used for temporary storage. ! IPVT An integer array of length N used by the linear system ! solvers for the storage of row interchange information. ! A A block of locations used to store the matrix A, when using ! the implicit method. If IMPL is 1, A is a MATDIM by N ! array. If MITER is 1 or 2 MATDIM is N, and if MITER is 4 ! or 5 MATDIM is 2*ML+MU+1. If IMPL is 2 its length is N. ! If IMPL is 3, A is a MATDIM by NDE array. ! JTASK An integer used on input. ! It has the following values and meanings: ! == 0 Perform the first step. This value enables ! the subroutine to initialize itself. ! > 0 Take a new step continuing from the last. ! Assumes the last step was successful and ! user has not changed any parameters. ! < 0 Take a new step with a new value of H and/or ! MINT and/or MITER. ! JSTATE A completion code with the following meanings: ! 1 The step was successful. ! 2 A solution could not be obtained with H /= 0. ! 3 A solution was not obtained in MXTRY attempts. ! 4 For IMPL /= 0, the matrix A is singular. ! On a return with JSTATE > 1, the values of T and ! the YH array are as of the beginning of the last ! step, and H is the last step size attempted. ! !***ROUTINES CALLED CDCOR, CDCST, CDNTL, CDPSC, CDPST, CDSCL, SCNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDSTP EXTERNAL F, JACOBN, FA, USERS INTEGER I, IERROR, IMPL, IPVT(*), ISWFLG, ITER, J, JSTATE, JSTEPL, & JTASK, MATDIM, MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, & MTRSV, MU, MXFAIL, MXITER, MXRDSV, MXTRY, N, NDE, NDJSTP, & NFAIL, NFE, NJE, NQ, NQUSED, NSTEP, NSV, NTRY, NWAIT COMPLEX A(MATDIM,*), DFDY(MATDIM,*), FAC(*), SAVE1(*), SAVE2(*), & Y(*), YH(N,*), YWT(*) REAL AVGH, AVGORD, BIAS1, BIAS2, BIAS3, BND, CTEST, D, DENOM, D1, & EL(13,12), EPS, ERDN, ERUP, ETEST, H, HMAX, HN, HOLD, HS, & HUSED, NUMER, RC, RCTEST, RH, RH1, RH2, RH3, RMAX, RMFAIL, & RMNORM, SCNRM2, T, TOLD, TQ(3,12), TREND, TRSHLD, UROUND, & Y0NRM LOGICAL CONVRG, EVALFA, EVALJC, IER, SWITCH PARAMETER(BIAS1 = 1.3E0, BIAS2 = 1.2E0, BIAS3 = 1.4E0, MXFAIL = 3, & MXITER = 3, MXTRY = 50, RCTEST = .3E0, RMFAIL = 2.E0, & RMNORM = 10.E0, TRSHLD = 1.E0) PARAMETER (NDJSTP = 10) DATA IER /.FALSE./ !***FIRST EXECUTABLE STATEMENT CDSTP NSV = N BND = 0.E0 SWITCH = .FALSE. NTRY = 0 TOLD = T NFAIL = 0 if (JTASK <= 0) THEN call CDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, & UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, & YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, & RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) if (N == 0) go to 440 if (H == 0.E0) go to 400 if (IER) go to 420 end if 100 NTRY = NTRY + 1 if (NTRY > MXTRY) go to 410 T = T + H call CDPSC (1, N, NQ, YH) EVALJC = (((ABS(RC - 1.E0) > RCTEST) .OR. & (NSTEP >= JSTEPL + NDJSTP)) .AND. (MITER /= 0)) EVALFA = .NOT. EVALJC ! 110 ITER = 0 DO 115 I = 1,N 115 Y(I) = YH(I,1) call F (N, T, Y, SAVE2) if (N == 0) THEN JSTATE = 6 go to 430 end if NFE = NFE + 1 if (EVALJC .OR. IER) THEN call CDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, & MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, & NFE, NJE, A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, & BND, JSTATE) if (N == 0) go to 430 if (IER) go to 160 CONVRG = .FALSE. RC = 1.E0 JSTEPL = NSTEP end if DO 125 I = 1,N 125 SAVE1(I) = 0.E0 ! Up to MXITER corrector iterations are taken. ! Convergence is tested by requiring the r.m.s. ! norm of changes to be less than EPS. The sum of ! the corrections is accumulated in the vector ! SAVE1(I). It is approximately equal to the L-th ! derivative of Y multiplied by ! H**L/(factorial(L-1)*EL(L,NQ)), and is thus ! proportional to the actual errors to the lowest ! power of H present (H**L). The YH array is not ! altered in the correction loop. The norm of the ! iterate difference is stored in D. If ! ITER > 0, an estimate of the convergence rate ! constant is stored in TREND, and this is used in ! the convergence test. ! 130 call CDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, MITER, & ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, & SAVE1, SAVE2, A, D, JSTATE) if (N == 0) go to 430 if (ISWFLG == 3 .AND. MINT == 1) THEN if (ITER == 0) THEN NUMER = SCNRM2(N, SAVE1, 1) DO 132 I = 1,N 132 DFDY(1,I) = SAVE1(I) Y0NRM = SCNRM2(N, YH, 1) ELSE DENOM = NUMER DO 134 I = 1,N 134 DFDY(1,I) = SAVE1(I) - DFDY(1,I) NUMER = SCNRM2(N, DFDY, MATDIM) if (EL(1,NQ)*NUMER <= 100.E0*UROUND*Y0NRM) THEN if (RMAX == RMFAIL) THEN SWITCH = .TRUE. go to 170 end if end if DO 136 I = 1,N 136 DFDY(1,I) = SAVE1(I) if (DENOM /= 0.E0) & BND = MAX(BND, NUMER/(DENOM*ABS(H)*EL(1,NQ))) end if end if if (ITER > 0) TREND = MAX(.9E0*TREND, D/D1) D1 = D CTEST = MIN(2.E0*TREND, 1.E0)*D if (CTEST <= EPS) go to 170 ITER = ITER + 1 if (ITER < MXITER) THEN DO 140 I = 1,N 140 Y(I) = YH(I,1) + EL(1,NQ)*SAVE1(I) call F (N, T, Y, SAVE2) if (N == 0) THEN JSTATE = 6 go to 430 end if NFE = NFE + 1 go to 130 end if ! The corrector iteration failed to converge in ! MXITER tries. If partials are involved but are ! not up to date, they are reevaluated for the next ! try. Otherwise the YH array is retracted to its ! values before prediction, and H is reduced, if ! possible. If not, a no-convergence exit is taken. if (CONVRG) THEN EVALJC = .TRUE. EVALFA = .FALSE. go to 110 end if 160 T = TOLD call CDPSC (-1, N, NQ, YH) NWAIT = NQ + 2 if (JTASK /= 0 .AND. JTASK /= 2) RMAX = RMFAIL if (ITER == 0) THEN RH = .3E0 ELSE RH = .9E0*(EPS/CTEST)**(.2E0) end if if (RH*H == 0.E0) go to 400 call CDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) go to 100 ! The corrector has converged. CONVRG is set ! to .TRUE. if partial derivatives were used, ! to indicate that they may need updating on ! subsequent steps. The error test is made. 170 CONVRG = (MITER /= 0) if (IERROR == 1 .OR. IERROR == 5) THEN DO 180 I = 1,NDE 180 SAVE2(I) = SAVE1(I)/YWT(I) ELSE DO 185 I = 1,NDE 185 SAVE2(I) = SAVE1(I)/MAX(ABS(Y(I)), ABS(YWT(I))) end if ETEST = SCNRM2(NDE, SAVE2, 1)/(TQ(2,NQ)*SQRT(REAL(NDE))) ! ! The error test failed. NFAIL keeps track of ! multiple failures. Restore T and the YH ! array to their previous values, and prepare ! to try the step again. Compute the optimum ! step size for this or one lower order. if (ETEST > EPS) THEN T = TOLD call CDPSC (-1, N, NQ, YH) NFAIL = NFAIL + 1 if (NFAIL < MXFAIL .OR. NQ == 1) THEN if (JTASK /= 0 .AND. JTASK /= 2) RMAX = RMFAIL RH2 = 1.E0/(BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) if (NQ > 1) THEN if (IERROR == 1 .OR. IERROR == 5) THEN DO 190 I = 1,NDE 190 SAVE2(I) = YH(I,NQ+1)/YWT(I) ELSE DO 195 I = 1,NDE 195 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), ABS(YWT(I))) end if ERDN = SCNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(REAL(NDE))) RH1 = 1.E0/MAX(1.E0, BIAS1*(ERDN/EPS)**(1.E0/NQ)) if (RH2 < RH1) THEN NQ = NQ - 1 RC = RC*EL(1,NQ)/EL(1,NQ+1) RH = RH1 ELSE RH = RH2 end if ELSE RH = RH2 end if NWAIT = NQ + 2 if (RH*H == 0.E0) go to 400 call CDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) go to 100 end if ! Control reaches this section if the error test has ! failed MXFAIL or more times. It is assumed that the ! derivatives that have accumulated in the YH array have ! errors of the wrong order. Hence the first derivative ! is recomputed, the order is set to 1, and the step is ! retried. NFAIL = 0 JTASK = 2 DO 215 I = 1,N 215 Y(I) = YH(I,1) call CDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, & UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, & YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, & RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) RMAX = RMNORM if (N == 0) go to 440 if (H == 0.E0) go to 400 if (IER) go to 420 go to 100 end if ! After a successful step, update the YH array. NSTEP = NSTEP + 1 HUSED = H NQUSED = NQ AVGH = ((NSTEP-1)*AVGH + H)/NSTEP AVGORD = ((NSTEP-1)*AVGORD + NQ)/NSTEP DO 230 J = 1,NQ+1 DO 230 I = 1,N 230 YH(I,J) = YH(I,J) + EL(J,NQ)*SAVE1(I) DO 235 I = 1,N 235 Y(I) = YH(I,1) ! If ISWFLG is 3, consider ! changing integration methods. if (ISWFLG == 3) THEN if (BND /= 0.E0) THEN if (MINT == 1 .AND. NQ <= 5) THEN HN = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.E0/(NQ+1))) HN = MIN(HN, 1.E0/(2.E0*EL(1,NQ)*BND)) HS = ABS(H)/MAX(UROUND, & (ETEST/(EPS*EL(NQ+1,1)))**(1.E0/(NQ+1))) if (HS > 1.2E0*HN) THEN MINT = 2 MNTOLD = MINT MITER = MTRSV MTROLD = MITER MAXORD = MIN(MXRDSV, 5) RC = 0.E0 RMAX = RMNORM TREND = 1.E0 call CDCST (MAXORD, MINT, ISWFLG, EL, TQ) NWAIT = NQ + 2 end if ELSE if (MINT == 2) THEN HS = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.E0/(NQ+1))) HN = ABS(H)/MAX(UROUND, & (ETEST*EL(NQ+1,1)/EPS)**(1.E0/(NQ+1))) HN = MIN(HN, 1.E0/(2.E0*EL(1,NQ)*BND)) if (HN >= HS) THEN MINT = 1 MNTOLD = MINT MITER = 0 MTROLD = MITER MAXORD = MIN(MXRDSV, 12) RMAX = RMNORM TREND = 1.E0 CONVRG = .FALSE. call CDCST (MAXORD, MINT, ISWFLG, EL, TQ) NWAIT = NQ + 2 end if end if end if end if if (SWITCH) THEN MINT = 2 MNTOLD = MINT MITER = MTRSV MTROLD = MITER MAXORD = MIN(MXRDSV, 5) NQ = MIN(NQ, MAXORD) RC = 0.E0 RMAX = RMNORM TREND = 1.E0 call CDCST (MAXORD, MINT, ISWFLG, EL, TQ) NWAIT = NQ + 2 end if ! Consider changing H if NWAIT = 1. Otherwise ! decrease NWAIT by 1. If NWAIT is then 1 and ! NQ < MAXORD, then SAVE1 is saved for use in ! a possible order increase on the next step. ! if (JTASK == 0 .OR. JTASK == 2) THEN RH = 1.E0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) if (RH > TRSHLD) call CDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) ELSE if (NWAIT > 1) THEN NWAIT = NWAIT - 1 if (NWAIT == 1 .AND. NQ < MAXORD) THEN DO 250 I = 1,NDE 250 YH(I,MAXORD+1) = SAVE1(I) end if ! If a change in H is considered, an increase or decrease in ! order by one is considered also. A change in H is made ! only if it is by a factor of at least TRSHLD. Factors ! RH1, RH2, and RH3 are computed, by which H could be ! multiplied at order NQ - 1, order NQ, or order NQ + 1, ! respectively. The largest of these is determined and the ! new order chosen accordingly. If the order is to be ! increased, we compute one additional scaled derivative. ! If there is a change of order, reset NQ and the ! coefficients. In any case H is reset according to RH and ! the YH array is rescaled. ELSE if (NQ == 1) THEN RH1 = 0.E0 ELSE if (IERROR == 1 .OR. IERROR == 5) THEN DO 270 I = 1,NDE 270 SAVE2(I) = YH(I,NQ+1)/YWT(I) ELSE DO 275 I = 1,NDE 275 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), ABS(YWT(I))) end if ERDN = SCNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(REAL(NDE))) RH1 = 1.E0/MAX(UROUND, BIAS1*(ERDN/EPS)**(1.E0/NQ)) end if RH2 = 1.E0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) if (NQ == MAXORD) THEN RH3 = 0.E0 ELSE if (IERROR == 1 .OR. IERROR == 5) THEN DO 290 I = 1,NDE 290 SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/YWT(I) ELSE DO 295 I = 1,NDE SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/ & MAX(ABS(Y(I)), ABS(YWT(I))) 295 CONTINUE end if ERUP = SCNRM2(NDE, SAVE2, 1)/(TQ(3,NQ)*SQRT(REAL(NDE))) RH3 = 1.E0/MAX(UROUND, BIAS3*(ERUP/EPS)**(1.E0/(NQ+2))) end if if (RH1 > RH2 .AND. RH1 >= RH3) THEN RH = RH1 if (RH <= TRSHLD) go to 380 NQ = NQ - 1 RC = RC*EL(1,NQ)/EL(1,NQ+1) ELSE if (RH2 >= RH1 .AND. RH2 >= RH3) THEN RH = RH2 if (RH <= TRSHLD) go to 380 ELSE RH = RH3 if (RH <= TRSHLD) go to 380 DO 360 I = 1,N 360 YH(I,NQ+2) = SAVE1(I)*EL(NQ+1,NQ)/(NQ+1) NQ = NQ + 1 RC = RC*EL(1,NQ)/EL(1,NQ-1) end if if (ISWFLG == 3 .AND. MINT == 1) THEN if (BND /= 0.E0) RH = MIN(RH, 1.E0/(2.E0*EL(1,NQ)*BND*ABS(H))) end if call CDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) RMAX = RMNORM 380 NWAIT = NQ + 2 end if ! All returns are made through this section. H is saved ! in HOLD to allow the caller to change H on the next step JSTATE = 1 HOLD = H return ! 400 JSTATE = 2 HOLD = H DO 405 I = 1,N 405 Y(I) = YH(I,1) return ! 410 JSTATE = 3 HOLD = H return ! 420 JSTATE = 4 HOLD = H return ! 430 T = TOLD call CDPSC (-1, NSV, NQ, YH) DO 435 I = 1,NSV 435 Y(I) = YH(I,1) 440 HOLD = H return end subroutine CDZRO (AE, F, H, N, NQ, IROOT, RE, T, YH, UROUND, B, C, & FB, FC, Y) ! !! CDZRO searches for a zero of a function F(N, T, Y, IROOT) ... ! between the given values B and C until the width of the ... ! interval (B, C) has collapsed to within a tolerance ... ! specified by the stopping criterion, ... ! ABS(B - C) <= 2.*(RW*ABS(B) + AE). ! !***LIBRARY SLATEC (SDRIVE) !***TYPE COMPLEX (SDZRO-S, DDZRO-D, CDZRO-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! This is a special purpose version of ZEROIN, modified for use with ! the CDRIV package. ! ! Sandia Mathematical Program Library ! Mathematical Computing Services Division 5422 ! Sandia Laboratories ! P. O. Box 5800 ! Albuquerque, New Mexico 87115 ! Control Data 6600 Version 4.5, 1 November 1971 ! ! PARAMETERS ! F - Name of the external function, which returns a ! real result. This name must be in an ! EXTERNAL statement in the calling program. ! B - One end of the interval (B, C). The value returned for ! B usually is the better approximation to a zero of F. ! C - The other end of the interval (B, C). ! RE - Relative error used for RW in the stopping criterion. ! If the requested RE is less than machine precision, ! then RW is set to approximately machine precision. ! AE - Absolute error used in the stopping criterion. If the ! given interval (B, C) contains the origin, then a ! nonzero value should be chosen for AE. ! !***REFERENCES L. F. Shampine and H. A. Watts, ZEROIN, a root-solving ! routine, SC-TM-70-631, Sept 1970. ! T. J. Dekker, Finding a zero by means of successive ! linear interpolation, Constructive Aspects of the ! Fundamental Theorem of Algebra, edited by B. Dejon ! and P. Henrici, 1969. !***ROUTINES CALLED CDNTP !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE CDZRO INTEGER IC, IROOT, KOUNT, N, NQ COMPLEX Y(*), YH(N,*) REAL A, ACBS, ACMB, AE, B, C, CMB, ER, F, FA, FB, FC, & H, P, Q, RE, RW, T, TOL, UROUND !***FIRST EXECUTABLE STATEMENT CDZRO ER = 4.E0*UROUND RW = MAX(RE, ER) IC = 0 ACBS = ABS(B - C) A = C FA = FC KOUNT = 0 ! Perform interchange 10 if (ABS(FC) < ABS(FB)) THEN A = B FA = FB B = C FB = FC C = A FC = FA end if CMB = 0.5E0*(C - B) ACMB = ABS(CMB) TOL = RW*ABS(B) + AE ! Test stopping criterion if (ACMB <= TOL) RETURN if (KOUNT > 50) RETURN ! Calculate new iterate implicitly as ! B + P/Q, where we arrange P >= 0. ! The implicit form is used to prevent overflow. P = (B - A)*FB Q = FA - FB if (P < 0.E0) THEN P = -P Q = -Q end if ! Update A and check for satisfactory reduction ! in the size of our bounding interval. A = B FA = FB IC = IC + 1 if (IC >= 4) THEN if (8.E0*ACMB >= ACBS) THEN ! Bisect B = 0.5E0*(C + B) go to 20 end if IC = 0 end if ACBS = ACMB ! Test for too small a change if (P <= ABS(Q)*TOL) THEN ! Increment by tolerance B = B + SIGN(TOL, CMB) ! Root ought to be between ! B and (C + B)/2. ELSE if (P < CMB*Q) THEN ! Interpolate B = B + P/Q ELSE ! Bisect B = 0.5E0*(C + B) end if ! Have completed computation ! for new iterate B. 20 call CDNTP (H, 0, N, NQ, T, B, YH, Y) FB = F(N, B, Y, IROOT) if (N == 0) RETURN if (FB == 0.E0) RETURN KOUNT = KOUNT + 1 ! ! Decide whether next step is interpolation or extrapolation ! if (SIGN(1.0E0, FB) == SIGN(1.0E0, FC)) THEN C = A FC = FA end if go to 10 end FUNCTION CEXPRL (Z) ! !! CEXPRL calculates the relative error exponential (EXP(X)-1)/X. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4B !***TYPE COMPLEX (EXPREL-S, DEXPRL-D, CEXPRL-C) !***KEYWORDS ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate (EXP(Z)-1)/Z . For small ABS(Z), we use the Taylor ! series. We could instead use the expression ! CEXPRL(Z) = (EXP(X)*EXP(I*Y)-1)/Z ! = (X*EXPREL(X) * (1 - 2*SIN(Y/2)**2) - 2*SIN(Y/2)**2 ! + I*SIN(Y)*(1+X*EXPREL(X))) / Z ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CEXPRL COMPLEX CEXPRL COMPLEX Z LOGICAL FIRST SAVE NTERMS, RBND, FIRST DATA FIRST / .TRUE. / !***FIRST EXECUTABLE STATEMENT CEXPRL if (FIRST) THEN ALNEPS = LOG(R1MACH(3)) XN = 3.72 - 0.3*ALNEPS XLN = LOG((XN+1.0)/1.36) NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36) + 1.5 RBND = R1MACH(3) end if FIRST = .FALSE. ! R = ABS(Z) if (R > 0.5) CEXPRL = (EXP(Z) - 1.0) / Z if (R > 0.5) RETURN ! CEXPRL = (1.0, 0.0) if (R < RBND) RETURN ! CEXPRL = (0.0, 0.0) DO 20 I=1,NTERMS CEXPRL = 1.0 + CEXPRL*Z/(NTERMS+2-I) 20 CONTINUE ! return end subroutine CFFTB1 (N, C, CH, WA, IFAC) ! !! CFFTB1 computes the unnormalized inverse of CFFTF1. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A2 !***TYPE COMPLEX (RFFTB1-S, CFFTB1-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine CFFTB1 computes the backward complex discrete Fourier ! transform (the Fourier synthesis). Equivalently, CFFTB1 computes ! a complex periodic sequence from its Fourier coefficients. ! The transform is defined below at output parameter C. ! ! A call of CFFTF1 followed by a call of CFFTB1 will multiply the ! sequence by N. ! ! The arrays WA and IFAC which are used by subroutine CFFTB1 must be ! initialized by calling subroutine CFFTI1 (N, WA, IFAC). ! ! Input Parameters ! ! N the length of the complex sequence C. The method is ! more efficient when N is the product of small primes. ! ! C a complex array of length N which contains the sequence ! ! CH a real work array of length at least 2*N ! ! WA a real work array which must be dimensioned at least 2*N. ! ! IFAC an integer work array which must be dimensioned at least 15. ! ! The WA and IFAC arrays must be initialized by calling ! subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC ! arrays must be used for each different value of N. This ! initialization does not have to be repeated so long as N ! remains unchanged. Thus subsequent transforms can be ! obtained faster than the first. The same WA and IFAC arrays ! can be used by CFFTF1 and CFFTB1. ! ! Output Parameters ! ! C For J=1,...,N ! ! C(J)=the sum from K=1,...,N of ! ! C(K)*EXP(I*(J-1)*(K-1)*2*PI/N) ! ! where I=SQRT(-1) ! ! NOTE: WA and IFAC contain initialization calculations which must ! not be destroyed between calls of subroutine CFFTF1 or CFFTB1 ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED PASSB, PASSB2, PASSB3, PASSB4, PASSB5 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from subsidiary to user-callable. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CFFTB1 DIMENSION CH(*), C(*), WA(*), IFAC(*) !***FIRST EXECUTABLE STATEMENT CFFTB1 NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDOT = IDO+IDO IDL1 = IDOT*L1 if (IP /= 4) go to 103 IX2 = IW+IDOT IX3 = IX2+IDOT if (NA /= 0) go to 101 call PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) go to 102 101 call PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA go to 115 103 if (IP /= 2) go to 106 if (NA /= 0) go to 104 call PASSB2 (IDOT,L1,C,CH,WA(IW)) go to 105 104 call PASSB2 (IDOT,L1,CH,C,WA(IW)) 105 NA = 1-NA go to 115 106 if (IP /= 3) go to 109 IX2 = IW+IDOT if (NA /= 0) go to 107 call PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) go to 108 107 call PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA go to 115 109 if (IP /= 5) go to 112 IX2 = IW+IDOT IX3 = IX2+IDOT IX4 = IX3+IDOT if (NA /= 0) go to 110 call PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) go to 111 110 call PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA go to 115 112 if (NA /= 0) go to 113 call PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) go to 114 113 call PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 if (NAC /= 0) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDOT 116 CONTINUE if (NA == 0) RETURN N2 = N+N DO 117 I=1,N2 C(I) = CH(I) 117 CONTINUE return end subroutine CFFTB (N, C, WSAVE) ! !! CFFTB computes the unnormalized inverse of CFFTF. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A2 !***TYPE COMPLEX (RFFTB-S, CFFTB-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! ******************************************************************** ! * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * ! ******************************************************************** ! * * ! * This routine uses non-standard Fortran 77 constructs and will * ! * be removed from the library at a future date. You are * ! * requested to use CFFTB1. * ! * * ! ******************************************************************** ! ! Subroutine CFFTB computes the backward complex discrete Fourier ! transform (the Fourier synthesis). Equivalently, CFFTB computes ! a complex periodic sequence from its Fourier coefficients. ! The transform is defined below at output parameter C. ! ! A call of CFFTF followed by a call of CFFTB will multiply the ! sequence by N. ! ! The array WSAVE which is used by subroutine CFFTB must be ! initialized by calling subroutine CFFTI(N,WSAVE). ! ! Input Parameters ! ! N the length of the complex sequence C. The method is ! more efficient when N is the product of small primes. ! ! C a complex array of length N which contains the sequence ! ! WSAVE a real work array which must be dimensioned at least 4*N+15 ! in the program that calls CFFTB. The WSAVE array must be ! initialized by calling subroutine CFFTI(N,WSAVE), and a ! different WSAVE array must be used for each different ! value of N. This initialization does not have to be ! repeated so long as N remains unchanged. Thus subsequent ! transforms can be obtained faster than the first. ! The same WSAVE array can be used by CFFTF and CFFTB. ! ! Output Parameters ! ! C For J=1,...,N ! ! C(J)=the sum from K=1,...,N of ! ! C(K)*EXP(I*(J-1)*(K-1)*2*PI/N) ! ! where I=SQRT(-1) ! ! WSAVE contains initialization calculations which must not be ! destroyed between calls of subroutine CFFTF or CFFTB ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED CFFTB1 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from user-callable to subsidiary ! because of non-standard Fortran 77 arguments in the ! call to CFFTB1. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CFFTB COMPLEX C DIMENSION C(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT CFFTB if (N == 1) RETURN IW1 = N+N+1 IW2 = IW1+N+N call CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) return end subroutine CFFTF1 (N, C, CH, WA, IFAC) ! !! CFFTF1 computes the forward transform of a complex, periodic sequence. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A2 !***TYPE COMPLEX (RFFTF1-S, CFFTF1-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine CFFTF1 computes the forward complex discrete Fourier ! transform (the Fourier analysis). Equivalently, CFFTF1 computes ! the Fourier coefficients of a complex periodic sequence. ! The transform is defined below at output parameter C. ! ! The transform is not normalized. To obtain a normalized transform ! the output must be divided by N. Otherwise a call of CFFTF1 ! followed by a call of CFFTB1 will multiply the sequence by N. ! ! The arrays WA and IFAC which are used by subroutine CFFTB1 must be ! initialized by calling subroutine CFFTI1 (N, WA, IFAC). ! ! Input Parameters ! ! N the length of the complex sequence C. The method is ! more efficient when N is the product of small primes. ! ! C a complex array of length N which contains the sequence ! ! CH a real work array of length at least 2*N ! ! WA a real work array which must be dimensioned at least 2*N. ! ! IFAC an integer work array which must be dimensioned at least 15. ! ! The WA and IFAC arrays must be initialized by calling ! subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC ! arrays must be used for each different value of N. This ! initialization does not have to be repeated so long as N ! remains unchanged. Thus subsequent transforms can be ! obtained faster than the first. The same WA and IFAC arrays ! can be used by CFFTF1 and CFFTB1. ! ! Output Parameters ! ! C For J=1,...,N ! ! C(J)=the sum from K=1,...,N of ! ! C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N) ! ! where I=SQRT(-1) ! ! NOTE: WA and IFAC contain initialization calculations which must ! not be destroyed between calls of subroutine CFFTF1 or CFFTB1 ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED PASSF, PASSF2, PASSF3, PASSF4, PASSF5 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from subsidiary to user-callable. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CFFTF1 DIMENSION CH(*), C(*), WA(*), IFAC(*) !***FIRST EXECUTABLE STATEMENT CFFTF1 NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDOT = IDO+IDO IDL1 = IDOT*L1 if (IP /= 4) go to 103 IX2 = IW+IDOT IX3 = IX2+IDOT if (NA /= 0) go to 101 call PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) go to 102 101 call PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA go to 115 103 if (IP /= 2) go to 106 if (NA /= 0) go to 104 call PASSF2 (IDOT,L1,C,CH,WA(IW)) go to 105 104 call PASSF2 (IDOT,L1,CH,C,WA(IW)) 105 NA = 1-NA go to 115 106 if (IP /= 3) go to 109 IX2 = IW+IDOT if (NA /= 0) go to 107 call PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) go to 108 107 call PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA go to 115 109 if (IP /= 5) go to 112 IX2 = IW+IDOT IX3 = IX2+IDOT IX4 = IX3+IDOT if (NA /= 0) go to 110 call PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) go to 111 110 call PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA go to 115 112 if (NA /= 0) go to 113 call PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) go to 114 113 call PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 if (NAC /= 0) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDOT 116 CONTINUE if (NA == 0) RETURN N2 = N+N DO 117 I=1,N2 C(I) = CH(I) 117 CONTINUE return end subroutine CFFTF (N, C, WSAVE) ! !! CFFTF computes the forward transform of a complex, periodic sequence. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A2 !***TYPE COMPLEX (RFFTF-S, CFFTF-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! ******************************************************************** ! * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * ! ******************************************************************** ! * * ! * This routine uses non-standard Fortran 77 constructs and will * ! * be removed from the library at a future date. You are * ! * requested to use CFFTF1. * ! * * ! ******************************************************************** ! ! Subroutine CFFTF computes the forward complex discrete Fourier ! transform (the Fourier analysis). Equivalently, CFFTF computes ! the Fourier coefficients of a complex periodic sequence. ! The transform is defined below at output parameter C. ! ! The transform is not normalized. To obtain a normalized transform ! the output must be divided by N. Otherwise a call of CFFTF ! followed by a call of CFFTB will multiply the sequence by N. ! ! The array WSAVE which is used by subroutine CFFTF must be ! initialized by calling subroutine CFFTI(N,WSAVE). ! ! Input Parameters ! ! N the length of the complex sequence C. The method is ! more efficient when N is the product of small primes. ! ! C a complex array of length N which contains the sequence ! ! WSAVE a real work array which must be dimensioned at least 4*N+15 ! in the program that calls CFFTF. The WSAVE array must be ! initialized by calling subroutine CFFTI(N,WSAVE), and a ! different WSAVE array must be used for each different ! value of N. This initialization does not have to be ! repeated so long as N remains unchanged. Thus subsequent ! transforms can be obtained faster than the first. ! The same WSAVE array can be used by CFFTF and CFFTB. ! ! Output Parameters ! ! C For J=1,...,N ! ! C(J)=the sum from K=1,...,N of ! ! C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N) ! ! where I=SQRT(-1) ! ! WSAVE contains initialization calculations which must not be ! destroyed between calls of subroutine CFFTF or CFFTB ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED CFFTF1 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from user-callable to subsidiary ! because of non-standard Fortran 77 arguments in the ! call to CFFTB1. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CFFTF COMPLEX C DIMENSION C(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT CFFTF if (N == 1) RETURN IW1 = N+N+1 IW2 = IW1+N+N call CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) return end subroutine CFFTI1 (N, WA, IFAC) ! !! CFFTI1 initializes a real and an integer work array for CFFTF1 and CFFTB1. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A2 !***TYPE COMPLEX (RFFTI1-S, CFFTI1-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine CFFTI1 initializes the work arrays WA and IFAC which are ! used in both CFFTF1 and CFFTB1. The prime factorization of N and a ! tabulation of the trigonometric functions are computed and stored in ! IFAC and WA, respectively. ! ! Input Parameter ! ! N the length of the sequence to be transformed ! ! Output Parameters ! ! WA a real work array which must be dimensioned at least 2*N. ! ! IFAC an integer work array which must be dimensioned at least 15. ! ! The same work arrays can be used for both CFFTF1 and CFFTB1 ! as long as N remains unchanged. Different WA and IFAC arrays ! are required for different values of N. The contents of ! WA and IFAC must not be changed between calls of CFFTF1 or ! CFFTB1. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing references to intrinsic function FLOAT ! to REAL, and ! (c) changing definition of variable TPI by using ! FORTRAN intrinsic function ATAN instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from subsidiary to user-callable. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CFFTI1 DIMENSION WA(*), IFAC(*), NTRYH(4) SAVE NTRYH DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/ !***FIRST EXECUTABLE STATEMENT CFFTI1 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 /= 2) go to 107 if (NF == 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 /= 1) go to 104 IFAC(1) = N IFAC(2) = NF TPI = 8.*ATAN(1.) ARGH = TPI/N I = 2 L1 = 1 DO 110 K1=1,NF IP = IFAC(K1+2) LD = 0 L2 = L1*IP IDO = N/L2 IDOT = IDO+IDO+2 IPM = IP-1 DO 109 J=1,IPM I1 = I WA(I-1) = 1. WA(I) = 0. LD = LD+L1 FI = 0. ARGLD = LD*ARGH DO 108 II=4,IDOT,2 I = I+2 FI = FI+1. ARG = FI*ARGLD WA(I-1) = COS(ARG) WA(I) = SIN(ARG) 108 CONTINUE if (IP <= 5) go to 109 WA(I1-1) = WA(I-1) WA(I1) = WA(I) 109 CONTINUE L1 = L2 110 CONTINUE return end subroutine CFFTI (N, WSAVE) ! !! CFFTI initializes a work array for CFFTF and CFFTB. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A2 !***TYPE COMPLEX (RFFTI-S, CFFTI-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! ******************************************************************** ! * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * ! ******************************************************************** ! * * ! * This routine uses non-standard Fortran 77 constructs and will * ! * be removed from the library at a future date. You are * ! * requested to use CFFTI1. * ! * * ! ******************************************************************** ! ! Subroutine CFFTI initializes the array WSAVE which is used in ! both CFFTF and CFFTB. The prime factorization of N together with ! a tabulation of the trigonometric functions are computed and ! stored in WSAVE. ! ! Input Parameter ! ! N the length of the sequence to be transformed ! ! Output Parameter ! ! WSAVE a work array which must be dimensioned at least 4*N+15. ! The same work array can be used for both CFFTF and CFFTB ! as long as N remains unchanged. Different WSAVE arrays ! are required for different values of N. The contents of ! WSAVE must not be changed between calls of CFFTF or CFFTB. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED CFFTI1 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from user-callable to subsidiary ! because of non-standard Fortran 77 arguments in the ! call to CFFTB1. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CFFTI DIMENSION WSAVE(*) !***FIRST EXECUTABLE STATEMENT CFFTI if (N == 1) RETURN IW1 = N+N+1 IW2 = IW1+N+N call CFFTI1 (N,WSAVE(IW1),WSAVE(IW2)) return end subroutine CFOD (METH, ELCO, TESCO) ! !! CFOD is subsidiary to DEBDF. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CFOD-S, DCFOD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! CFOD defines coefficients needed in the integrator package DEBDF ! !***SEE ALSO DEBDF !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE CFOD ! ! !LLL. OPTIMIZE INTEGER METH, I, IB, NQ, NQM1, NQP1 REAL ELCO, TESCO, AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, & RQFAC, RQ1FAC, TSIGN, XPIN DIMENSION ELCO(13,12), TESCO(3,12) !----------------------------------------------------------------------- ! CFOD IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS ! NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS ! GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. ! THE MAXIMUM ORDER ASSUMED HERE IS 12 if METH = 1 AND 5 IF METH = 2. ! (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) ! CFOD IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, ! AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. ! ! THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. ! THE COEFFICIENTS EL(I), 1 <= I <= NQ+1, FOR THE METHOD OF ! ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A GENERATING ! POLYNOMIAL, I.E., ! L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. ! FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY ! DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = 0. ! FOR THE BDF METHODS, L(X) IS GIVEN BY ! L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, ! WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). ! ! THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE ! LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. ! AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP ! SIZE AT ORDER NQ - 1 if K = 1, AT ORDER NQ IF K = 2, AND AT ORDER ! NQ + 1 if K = 3. !----------------------------------------------------------------------- DIMENSION PC(12) ! !***FIRST EXECUTABLE STATEMENT CFOD go to (100, 200), METH ! 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 !----------------------------------------------------------------------- ! THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL ! P(X) = (X+1)*(X+2)*...*(X+NQ-1). ! INITIALLY, P(X) = 1. !----------------------------------------------------------------------- RQ1FAC = RQFAC RQFAC = RQFAC/NQ NQM1 = NQ - 1 FNQM1 = NQM1 NQP1 = NQ + 1 ! 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) ! 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)/I 120 XPIN = XPIN + TSIGN*PC(I)/(I+1) ! 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)/I AGAMQ = RQFAC*XPIN RAGQ = 1.0E0/AGAMQ TESCO(2,NQ) = RAGQ if ( NQ < 12)TESCO(1,NQP1)=RAGQ*RQFAC/NQP1 TESCO(3,NQM1) = RAGQ 140 CONTINUE return ! 200 PC(1) = 1.0E0 RQ1FAC = 1.0E0 DO 230 NQ = 1,5 !----------------------------------------------------------------------- ! THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL ! P(X) = (X+1)*(X+2)*...*(X+NQ). ! INITIALLY, P(X) = 1. !----------------------------------------------------------------------- FNQ = NQ NQP1 = NQ + 1 ! 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) ! 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) = NQP1/ELCO(1,NQ) TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) RQ1FAC = RQ1FAC/FNQ 230 CONTINUE return !----------------------- END OF SUBROUTINE CFOD ----------------------- end FUNCTION CGAMMA (Z) ! !! CGAMMA computes the complete Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE COMPLEX (GAMMA-S, DGAMMA-D, CGAMMA-C) !***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CGAMMA(Z) calculates the complete gamma function for COMPLEX ! argument Z. This is a preliminary version that is portable ! but not accurate. ! !***REFERENCES (NONE) !***ROUTINES CALLED CLNGAM !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CGAMMA COMPLEX CGAMMA COMPLEX Z, CLNGAM !***FIRST EXECUTABLE STATEMENT CGAMMA CGAMMA = EXP (CLNGAM(Z)) ! return end FUNCTION CGAMR (Z) ! !! CGAMR computes the reciprocal of the Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE COMPLEX (GAMR-S, DGAMR-D, CGAMR-C) !***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CGAMR(Z) calculates the reciprocal gamma function for COMPLEX ! argument Z. This is a preliminary version that is not accurate. ! !***REFERENCES (NONE) !***ROUTINES CALLED CLNGAM, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CGAMR COMPLEX CGAMR COMPLEX Z, CLNGAM !***FIRST EXECUTABLE STATEMENT CGAMR CGAMR = (0.0, 0.0) X = REAL (Z) if (X <= 0.0 .AND. AINT(X) == X .AND. AIMAG(Z) == 0.0) RETURN ! call XGETF (IROLD) call XSETF (1) CGAMR = CLNGAM(Z) call XERCLR call XSETF (IROLD) CGAMR = EXP (-CGAMR) ! return end subroutine CGBCO (ABD, LDA, N, ML, MU, IPVT, RCOND, Z) ! !! CGBCO factors a band matrix by Gaussian elimination and ... ! estimate the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C2 !***TYPE COMPLEX (SGBCO-S, DGBCO-D, CGBCO-C) !***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CGBCO factors a complex band matrix by Gaussian ! elimination and estimates the condition of the matrix. ! ! If RCOND is not needed, CGBFA is slightly faster. ! To solve A*X = B , follow CGBCO by CGBSL. ! To compute INVERSE(A)*C , follow CGBCO by CGBSL. ! To compute DETERMINANT(A) , follow CGBCO by CGBDI. ! ! On Entry ! ! ABD COMPLEX(LDA, N) ! contains the matrix in band storage. The columns ! of the matrix are stored in the columns of ABD and ! the diagonals of the matrix are stored in rows ! ML+1 through 2*ML+MU+1 of ABD . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= 2*ML + MU + 1 . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! ! On Return ! ! ABD an upper triangular matrix in band storage and ! the multipliers which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A And B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! ! Band Storage ! ! if A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! M = ML + MU + 1 ! DO 20 J = 1, N ! I1 = MAX(1, J-MU) ! I2 = MIN(N, J+Ml) ! DO 10 I = I1, I2 ! K = I - J + M ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses rows ML+1 through 2*ML+MU+1 of ABD . ! In addition, the first ML rows in ABD are used for ! elements generated during the triangularization. ! The total number of rows needed in ABD is 2*ML+MU+1 . ! The ML+MU by ML+MU upper left triangle and the ! ML by ML lower right triangle are not referenced. ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABD should contain ! ! * * * + + + , * = not used ! * * 13243546 , + = used for pivoting ! * 1223344556 ! 112233445566 ! 2132435465 * ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC, CGBFA, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGBCO INTEGER LDA,N,ML,MU,IPVT(*) COMPLEX ABD(LDA,*),Z(*) REAL RCOND ! COMPLEX CDOTC,EK,T,WK,WKM REAL ANORM,S,SCASUM,SM,YNORM INTEGER IS,INFO,J,JU,K,KB,KP1,L,LA,LM,LZ,M,MM COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2)) ! ! COMPUTE 1-NORM OF A ! !***FIRST EXECUTABLE STATEMENT CGBCO ANORM = 0.0E0 L = ML + 1 IS = L + MU DO 10 J = 1, N ANORM = MAX(ANORM,SCASUM(L,ABD(IS,J),1)) if (IS > ML + 1) IS = IS - 1 if (J <= MU) L = L + 1 if (J >= N - ML) L = L - 1 10 CONTINUE ! ! FACTOR ! call CGBFA(ABD,LDA,N,ML,MU,IPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND CTRANS(A)*Y = E . ! CTRANS(A) IS THE CONJUGATE TRANSPOSE OF A . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE CTRANS(U)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE CTRANS(U)*W = E ! EK = (1.0E0,0.0E0) DO 20 J = 1, N Z(J) = (0.0E0,0.0E0) 20 CONTINUE M = ML + MU + 1 JU = 0 DO 100 K = 1, N if (CABS1(Z(K)) /= 0.0E0) EK = CSIGN1(EK,-Z(K)) if (CABS1(EK-Z(K)) <= CABS1(ABD(M,K))) go to 30 S = CABS1(ABD(M,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(ABD(M,K)) == 0.0E0) go to 40 WK = WK/CONJG(ABD(M,K)) WKM = WKM/CONJG(ABD(M,K)) go to 50 40 CONTINUE WK = (1.0E0,0.0E0) WKM = (1.0E0,0.0E0) 50 CONTINUE KP1 = K + 1 JU = MIN(MAX(JU,MU+IPVT(K)),N) MM = M if (KP1 > JU) go to 90 DO 60 J = KP1, JU MM = MM - 1 SM = SM + CABS1(Z(J)+WKM*CONJG(ABD(MM,J))) Z(J) = Z(J) + WK*CONJG(ABD(MM,J)) S = S + CABS1(Z(J)) 60 CONTINUE if (S >= SM) go to 80 T = WKM - WK WK = WKM MM = M DO 70 J = KP1, JU MM = MM - 1 Z(J) = Z(J) + T*CONJG(ABD(MM,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) ! ! SOLVE CTRANS(L)*Y = W ! DO 120 KB = 1, N K = N + 1 - KB LM = MIN(ML,N-K) if (K < N) Z(K) = Z(K) + CDOTC(LM,ABD(M+1,K),1,Z(K+1),1) if (CABS1(Z(K)) <= 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) ! YNORM = 1.0E0 ! ! SOLVE L*V = Y ! DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T LM = MIN(ML,N-K) if (K < N) call CAXPY(LM,T,ABD(M+1,K),1,Z(K+1),1) if (CABS1(Z(K)) <= 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 ! ! SOLVE U*Z = W ! DO 160 KB = 1, N K = N + 1 - KB if (CABS1(Z(K)) <= CABS1(ABD(M,K))) go to 150 S = CABS1(ABD(M,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE if (CABS1(ABD(M,K)) /= 0.0E0) Z(K) = Z(K)/ABD(M,K) if (CABS1(ABD(M,K)) == 0.0E0) Z(K) = (1.0E0,0.0E0) LM = MIN(K,M) - 1 LA = M - LM LZ = K - LM T = -Z(K) call CAXPY(LM,T,ABD(LA,K),1,Z(LZ),1) 160 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine CGBDI (ABD, LDA, N, ML, MU, IPVT, DET) ! !! CGBDI computes the determinant of a complex band matrix using the ... ! factors from CGBCO or CGBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D3C2 !***TYPE COMPLEX (SGBDI-S, DGBDI-D, CGBDI-C) !***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, ! MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CGBDI computes the determinant of a band matrix ! using the factors computed by CGBCO or CGBFA. ! If the inverse is needed, use CGBSL N times. ! ! On Entry ! ! ABD COMPLEX(LDA, N) ! the output from CGBCO or CGBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from CGBCO or CGBFA. ! ! On Return ! ! DET COMPLEX(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= CABS1(DET(1)) < 10.0 ! or DET(1) = 0.0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGBDI INTEGER LDA,N,ML,MU,IPVT(*) COMPLEX ABD(LDA,*),DET(2) ! REAL TEN INTEGER I,M COMPLEX ZDUM REAL CABS1 ! CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT CGBDI M = ML + MU + 1 DET(1) = (1.0E0,0.0E0) DET(2) = (0.0E0,0.0E0) TEN = 10.0E0 DO 50 I = 1, N if (IPVT(I) /= I) DET(1) = -DET(1) DET(1) = ABD(M,I)*DET(1) if (CABS1(DET(1)) == 0.0E0) go to 60 10 if (CABS1(DET(1)) >= 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)) < 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 return end subroutine CGBFA (ABD, LDA, N, ML, MU, IPVT, INFO) ! !! CGBFA factors a band matrix using Gaussian elimination. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C2 !***TYPE COMPLEX (SGBFA-S, DGBFA-D, CGBFA-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CGBFA factors a complex band matrix by elimination. ! ! CGBFA is usually called by CGBCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! ! On Entry ! ! ABD COMPLEX(LDA, N) ! contains the matrix in band storage. The columns ! of the matrix are stored in the columns of ABD and ! the diagonals of the matrix are stored in rows ! ML+1 through 2*ML+MU+1 of ABD . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= 2*ML + MU + 1 . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! On Return ! ! ABD an upper triangular matrix in band storage and ! the multipliers which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if U(K,K) == 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that CGBSL will divide by zero if ! called. Use RCOND in CGBCO for a reliable ! indication of singularity. ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! M = ML + MU + 1 ! DO 20 J = 1, N ! I1 = MAX(1, J-MU) ! I2 = MIN(N, J+ML) ! DO 10 I = I1, I2 ! K = I - J + M ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses rows ML+1 through 2*ML+MU+1 of ABD . ! In addition, the first ML rows in ABD are used for ! elements generated during the triangularization. ! The total number of rows needed in ABD is 2*ML+MU+1 . ! The ML+MU by ML+MU upper left triangle and the ! ML by ML lower right triangle are not referenced. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSCAL, ICAMAX !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGBFA INTEGER LDA,N,ML,MU,IPVT(*),INFO COMPLEX ABD(LDA,*) ! COMPLEX T INTEGER I,ICAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) ! !***FIRST EXECUTABLE STATEMENT CGBFA M = ML + MU + 1 INFO = 0 ! ! ZERO INITIAL FILL-IN COLUMNS ! J0 = MU + 2 J1 = MIN(N,M) - 1 if (J1 < J0) go to 30 DO 20 JZ = J0, J1 I0 = M + 1 - JZ DO 10 I = I0, ML ABD(I,JZ) = (0.0E0,0.0E0) 10 CONTINUE 20 CONTINUE 30 CONTINUE JZ = J1 JU = 0 ! ! GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING ! NM1 = N - 1 if (NM1 < 1) go to 130 DO 120 K = 1, NM1 KP1 = K + 1 ! ! ZERO NEXT FILL-IN COLUMN ! JZ = JZ + 1 if (JZ > N) go to 50 if (ML < 1) go to 50 DO 40 I = 1, ML ABD(I,JZ) = (0.0E0,0.0E0) 40 CONTINUE 50 CONTINUE ! ! FIND L = PIVOT INDEX ! LM = MIN(ML,N-K) L = ICAMAX(LM+1,ABD(M,K),1) + M - 1 IPVT(K) = L + K - M ! ! ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED ! if (CABS1(ABD(L,K)) == 0.0E0) go to 100 ! ! INTERCHANGE if NECESSARY ! if (L == M) go to 60 T = ABD(L,K) ABD(L,K) = ABD(M,K) ABD(M,K) = T 60 CONTINUE ! ! COMPUTE MULTIPLIERS ! T = -(1.0E0,0.0E0)/ABD(M,K) call CSCAL(LM,T,ABD(M+1,K),1) ! ! ROW ELIMINATION WITH COLUMN INDEXING ! JU = MIN(MAX(JU,MU+IPVT(K)),N) MM = M if (JU < KP1) go to 90 DO 80 J = KP1, JU L = L - 1 MM = MM - 1 T = ABD(L,J) if (L == MM) go to 70 ABD(L,J) = ABD(MM,J) ABD(MM,J) = T 70 CONTINUE call CAXPY(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 (CABS1(ABD(M,N)) == 0.0E0) INFO = N return end subroutine CGBMV (TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, & BETA, Y, INCY) ! !! CGBMV multiplies a complex vector by a complex general band matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (SGBMV-S, DGBMV-D, CGBMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CGBMV performs one of the matrix-vector operations ! ! y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or ! ! y := alpha*conjg( A' )*x + beta*y, ! ! where alpha and beta are scalars, x and y are vectors and A is an ! m by n band matrix, with kl sub-diagonals and ku super-diagonals. ! ! Parameters ! ========== ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' y := alpha*A*x + beta*y. ! ! TRANS = 'T' or 't' y := alpha*A'*x + beta*y. ! ! TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix A. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! KL - INTEGER. ! On entry, KL specifies the number of sub-diagonals of the ! matrix A. KL must satisfy 0 .le. KL. ! Unchanged on exit. ! ! KU - INTEGER. ! On entry, KU specifies the number of super-diagonals of the ! matrix A. KU must satisfy 0 .le. KU. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry, the leading ( kl + ku + 1 ) by n part of the ! array A must contain the matrix of coefficients, supplied ! column by column, with the leading diagonal of the matrix in ! row ( ku + 1 ) of the array, the first super-diagonal ! starting at position 2 in row ku, the first sub-diagonal ! starting at position 1 in row ( ku + 2 ), and so on. ! Elements in the array A that do not correspond to elements ! in the band matrix (such as the top left ku by ku triangle) ! are not referenced. ! The following program segment will transfer a band matrix ! from conventional full matrix storage to band storage: ! ! DO 20, J = 1, N ! K = KU + 1 - J ! DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) ! A( K + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( kl + ku + 1 ). ! Unchanged on exit. ! ! X - COMPLEX array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. ! Before entry, the incremented array X must contain the ! vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - COMPLEX . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - COMPLEX array of DIMENSION at least ! ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. ! Before entry, the incremented array Y must contain the ! vector y. On exit, Y is overwritten by the updated vector y. ! ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CGBMV ! .. Scalar Arguments .. COMPLEX ALPHA, BETA INTEGER INCX, INCY, KL, KU, LDA, M, N CHARACTER*1 TRANS ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, & LENX, LENY LOGICAL NOCONJ ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN !***FIRST EXECUTABLE STATEMENT CGBMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE if ( M < 0 )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( KL < 0 )THEN INFO = 4 ELSE if ( KU < 0 )THEN INFO = 5 ELSE if ( LDA < ( KL + KU + 1 ) )THEN INFO = 8 ELSE if ( INCX == 0 )THEN INFO = 10 ELSE if ( INCY == 0 )THEN INFO = 13 end if if ( INFO /= 0 )THEN call XERBLA( 'CGBMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! NOCONJ = LSAME( TRANS, 'T' ) ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if ( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N end if if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the band part of A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return KUP1 = KU + 1 if ( LSAME( TRANS, 'N' ) )THEN ! ! Form y := alpha*A*x + y. ! JX = KX if ( INCY == 1 )THEN DO 60, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) K = KUP1 - J DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) Y( I ) = Y( I ) + TEMP*A( K + I, J ) 50 CONTINUE end if JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY K = KUP1 - J DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) IY = IY + INCY 70 CONTINUE end if JX = JX + INCX if ( J > KU ) & KY = KY + INCY 80 CONTINUE end if ELSE ! ! Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. ! JY = KY if ( INCX == 1 )THEN DO 110, J = 1, N TEMP = ZERO K = KUP1 - J if ( NOCONJ )THEN DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + A( K + I, J )*X( I ) 90 CONTINUE ELSE DO 100, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + CONJG( A( K + I, J ) )*X( I ) 100 CONTINUE end if Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 110 CONTINUE ELSE DO 140, J = 1, N TEMP = ZERO IX = KX K = KUP1 - J if ( NOCONJ )THEN DO 120, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + A( K + I, J )*X( IX ) IX = IX + INCX 120 CONTINUE ELSE DO 130, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + CONJG( A( K + I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE end if Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY if ( J > KU ) & KX = KX + INCX 140 CONTINUE end if end if ! return ! ! End of CGBMV . ! end subroutine CGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB) ! !! CGBSL solves the complex band system A*X=B or CTRANS(A)*X=B using ... ! the factors computed by CGBCO or CGBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C2 !***TYPE COMPLEX (SGBSL-S, DGBSL-D, CGBSL-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CGBSL solves the complex band system ! A * X = B or CTRANS(A) * X = B ! using the factors computed by CGBCO or CGBFA. ! ! On Entry ! ! ABD COMPLEX(LDA, N) ! the output from CGBCO or CGBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from CGBCO or CGBFA. ! ! B COMPLEX(N) ! the right hand side vector. ! ! JOB INTEGER ! = 0 to solve A*X = B , ! = nonzero to solve CTRANS(A)*X = B , where ! CTRANS(A) is the conjugate transpose. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically this indicates singularity ! but it is often caused by improper arguments or improper ! setting of LDA . It will not occur if the subroutines are ! called correctly and if CGBCO has set RCOND > 0.0 ! or CGBFA has set INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call CGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) ! if (RCOND is too small) go to ... ! DO 10 J = 1, P ! call CGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGBSL INTEGER LDA,N,ML,MU,IPVT(*),JOB COMPLEX ABD(LDA,*),B(*) ! COMPLEX CDOTC,T INTEGER K,KB,L,LA,LB,LM,M,NM1 !***FIRST EXECUTABLE STATEMENT CGBSL M = MU + ML + 1 NM1 = N - 1 if (JOB /= 0) go to 50 ! ! JOB = 0 , SOLVE A * X = B ! FIRST SOLVE L*Y = B ! if (ML == 0) go to 30 if (NM1 < 1) go to 30 DO 20 K = 1, NM1 LM = MIN(ML,N-K) L = IPVT(K) T = B(L) if (L == K) go to 10 B(L) = B(K) B(K) = T 10 CONTINUE call CAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE ! ! NOW SOLVE U*X = Y ! DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/ABD(M,K) LM = MIN(K,M) - 1 LA = M - LM LB = K - LM T = -B(K) call CAXPY(LM,T,ABD(LA,K),1,B(LB),1) 40 CONTINUE go to 100 50 CONTINUE ! ! JOB = NONZERO, SOLVE CTRANS(A) * X = B ! FIRST SOLVE CTRANS(U)*Y = B ! DO 60 K = 1, N LM = MIN(K,M) - 1 LA = M - LM LB = K - LM T = CDOTC(LM,ABD(LA,K),1,B(LB),1) B(K) = (B(K) - T)/CONJG(ABD(M,K)) 60 CONTINUE ! ! NOW SOLVE CTRANS(L)*X = Y ! if (ML == 0) go to 90 if (NM1 < 1) go to 90 DO 80 KB = 1, NM1 K = N - KB LM = MIN(ML,N-K) B(K) = B(K) + CDOTC(LM,ABD(M+1,K),1,B(K+1),1) L = IPVT(K) if (L == 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 CGECO (A, LDA, N, IPVT, RCOND, Z) ! !! CGECO factors a matrix using Gaussian elimination and estimates ... ! the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1 !***TYPE COMPLEX (SGECO-S, DGECO-D, CGECO-C) !***KEYWORDS CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CGECO factors a complex matrix by Gaussian elimination ! and estimates the condition of the matrix. ! ! If RCOND is not needed, CGEFA is slightly faster. ! To solve A*X = B , follow CGECO By CGESL. ! To Compute INVERSE(A)*C , follow CGECO by CGESL. ! To compute DETERMINANT(A) , follow CGECO by CGEDI. ! To compute INVERSE(A) , follow CGECO by CGEDI. ! ! On Entry ! ! A COMPLEX(LDA, N) ! the matrix to be factored. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix and the multipliers ! which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC, CGEFA, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGECO INTEGER LDA,N,IPVT(*) COMPLEX A(LDA,*),Z(*) REAL RCOND ! COMPLEX CDOTC,EK,T,WK,WKM REAL ANORM,S,SCASUM,SM,YNORM INTEGER INFO,J,K,KB,KP1,L COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2)) ! ! COMPUTE 1-NORM OF A ! !***FIRST EXECUTABLE STATEMENT CGECO ANORM = 0.0E0 DO 10 J = 1, N ANORM = MAX(ANORM,SCASUM(N,A(1,J),1)) 10 CONTINUE ! ! FACTOR ! call CGEFA(A,LDA,N,IPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND CTRANS(A)*Y = E . ! CTRANS(A) IS THE CONJUGATE TRANSPOSE OF A . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE CTRANS(U)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE CTRANS(U)*W = E ! 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)) /= 0.0E0) EK = CSIGN1(EK,-Z(K)) if (CABS1(EK-Z(K)) <= 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)) == 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 > 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 >= 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) ! ! SOLVE CTRANS(L)*Y = W ! DO 120 KB = 1, N K = N + 1 - KB if (K < N) Z(K) = Z(K) + CDOTC(N-K,A(K+1,K),1,Z(K+1),1) if (CABS1(Z(K)) <= 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) ! YNORM = 1.0E0 ! ! SOLVE L*V = Y ! DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T if (K < N) call CAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) if (CABS1(Z(K)) <= 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 ! ! SOLVE U*Z = V ! DO 160 KB = 1, N K = N + 1 - KB if (CABS1(Z(K)) <= 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)) /= 0.0E0) Z(K) = Z(K)/A(K,K) if (CABS1(A(K,K)) == 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 ! MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine CGEDI (A, LDA, N, IPVT, DET, WORK, JOB) ! !! CGEDI computes the determinant and inverse of a matrix using the ... ! factors computed by CGECO or CGEFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1, D3C1 !***TYPE COMPLEX (SGEDI-S, DGEDI-D, CGEDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CGEDI computes the determinant and inverse of a matrix ! using the factors computed by CGECO or CGEFA. ! ! On Entry ! ! A COMPLEX(LDA, N) ! the output from CGECO or CGEFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! IPVT INTEGER(N) ! the pivot vector from CGECO or CGEFA. ! ! WORK COMPLEX(N) ! work vector. Contents destroyed. ! ! JOB INTEGER ! = 11 both determinant and inverse. ! = 01 inverse only. ! = 10 determinant only. ! ! On Return ! ! A inverse of original matrix if requested. ! Otherwise unchanged. ! ! DET COMPLEX(2) ! determinant of original matrix if requested. ! Otherwise not referenced. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= CABS1(DET(1)) < 10.0 ! or DET(1) == 0.0 . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal and the inverse is requested. ! It will not occur if the subroutines are called correctly ! and if CGECO has set RCOND > 0.0 or CGEFA has set ! INFO == 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSCAL, CSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGEDI INTEGER LDA,N,IPVT(*),JOB COMPLEX A(LDA,*),DET(2),WORK(*) ! COMPLEX T REAL TEN INTEGER I,J,K,KB,KP1,L,NM1 COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT CGEDI ! ! COMPUTE DETERMINANT ! if (JOB/10 == 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) /= I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) if (CABS1(DET(1)) == 0.0E0) go to 60 10 if (CABS1(DET(1)) >= 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)) < 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 ! ! COMPUTE INVERSE(U) ! if (MOD(JOB,10) == 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 < 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 ! ! FORM INVERSE(U)*INVERSE(L) ! NM1 = N - 1 if (NM1 < 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 /= K) call CSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE return end subroutine CGEEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO) ! !! CGEEV computes the eigenvalues and, optionally, the eigenvectors ... ! of a complex general matrix. ! !***LIBRARY SLATEC !***CATEGORY D4A4 !***TYPE COMPLEX (SGEEV-S, CGEEV-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, GENERAL MATRIX !***AUTHOR Kahaner, D. K., (NBS) ! Moler, C. B., (U. of New Mexico) ! Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! Abstract ! CGEEV computes the eigenvalues and, optionally, ! the eigenvectors of a general complex matrix. ! ! Call Sequence Parameters- ! (The values of parameters marked with * (star) will be changed ! by CGEEV.) ! ! A* COMPLEX(LDA,N) ! complex nonsymmetric input matrix. ! ! LDA INTEGER ! set by the user to ! the leading dimension of the complex array A. ! ! N INTEGER ! set by the user to ! the order of the matrices A and V, and ! the number of elements in E. ! ! E* COMPLEX(N) ! on return from CGEEV E contains the eigenvalues of A. ! See also INFO below. ! ! V* COMPLEX(LDV,N) ! on return from CGEEV if the user has set JOB ! = 0 V is not referenced. ! = nonzero the N eigenvectors of A are stored in the ! first N columns of V. See also INFO below. ! (If the input matrix A is nearly degenerate, V ! will be badly conditioned, i.e. have nearly ! dependent columns.) ! ! LDV INTEGER ! set by the user to ! the leading dimension of the array V if JOB is also ! set nonzero. In that case N must be <= LDV. ! If JOB is set to zero LDV is not referenced. ! ! WORK* REAL(3N) ! temporary storage vector. Contents changed by CGEEV. ! ! JOB INTEGER ! set by the user to ! = 0 eigenvalues only to be calculated by CGEEV. ! neither V nor LDV are referenced. ! = nonzero eigenvalues and vectors to be calculated. ! In this case A & V must be distinct arrays. ! Also, if LDA > LDV, CGEEV changes all the ! elements of A thru column N. If LDA < LDV, ! CGEEV changes all the elements of V through ! column N. If LDA = LDV only A(I,J) and V(I, ! J) for I,J = 1,...,N are changed by CGEEV. ! ! INFO* INTEGER ! on return from CGEEV the value of INFO is ! = 0 normal return, calculation successful. ! = K if the eigenvalue iteration fails to converge, ! eigenvalues K+1 through N are correct, but ! no eigenvectors were computed even if they were ! requested (JOB nonzero). ! ! Error Messages ! No. 1 recoverable N is greater than LDA ! No. 2 recoverable N is less than one. ! No. 3 recoverable JOB is nonzero and N is greater than LDV ! No. 4 warning LDA > LDV, elements of A other than the ! N by N input elements have been changed ! No. 5 warning LDA < LDV, elements of V other than the ! N by N output elements have been changed ! !***REFERENCES (NONE) !***ROUTINES CALLED CBABK2, CBAL, COMQR, COMQR2, CORTH, SCOPY, XERMSG !***REVISION HISTORY (YYMMDD) ! 800808 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE CGEEV INTEGER I,IHI,ILO,INFO,J,K,L,LDA,LDV,MDIM,N REAL A(*),E(*),WORK(*),V(*) !***FIRST EXECUTABLE STATEMENT CGEEV if (N > LDA) call XERMSG ('SLATEC', 'CGEEV', 'N > LDA.', 1, & 1) if ( N > LDA) RETURN if (N < 1) call XERMSG ('SLATEC', 'CGEEV', 'N < 1', 2, 1) if ( N < 1) RETURN if ( N == 1 .AND. JOB == 0) go to 35 MDIM = 2 * LDA if ( JOB == 0) go to 5 if (N > LDV) call XERMSG ('SLATEC', 'CGEEV', & 'JOB /= 0 AND N > LDV.', 3, 1) if ( N > LDV) RETURN if ( N == 1) go to 35 ! ! REARRANGE A if NECESSARY WHEN LDA > LDV AND JOB /= 0 ! MDIM = MIN(MDIM,2 * LDV) if (LDA < LDV) call XERMSG ('SLATEC', 'CGEEV', & 'LDA < LDV, ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' // & 'ELEMENTS HAVE BEEN CHANGED.', 5, 0) if ( LDA <= LDV) go to 5 call XERMSG ('SLATEC', 'CGEEV', & 'LDA > LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' // & 'ELEMENTS HAVE BEEN CHANGED.', 4, 0) L = N - 1 DO 4 J=1,L I = 2 * N M = 1+J*2*LDV K = 1+J*2*LDA call SCOPY(I,A(K),1,A(M),1) 4 CONTINUE 5 CONTINUE ! ! SEPARATE REAL AND IMAGINARY PARTS ! DO 6 J = 1, N K = (J-1) * MDIM +1 L = K + N call SCOPY(N,A(K+1),2,WORK(1),1) call SCOPY(N,A(K),2,A(K),1) call SCOPY(N,WORK(1),1,A(L),1) 6 CONTINUE ! ! SCALE AND ORTHOGONAL REDUCTION TO HESSENBERG. ! call CBAL(MDIM,N,A(1),A(N+1),ILO,IHI,WORK(1)) call CORTH(MDIM,N,ILO,IHI,A(1),A(N+1),WORK(N+1),WORK(2*N+1)) if ( JOB /= 0) go to 10 ! ! EIGENVALUES ONLY ! call COMQR(MDIM,N,ILO,IHI,A(1),A(N+1),E(1),E(N+1),INFO) go to 30 ! ! EIGENVALUES AND EIGENVECTORS. ! 10 call COMQR2(MDIM,N,ILO,IHI,WORK(N+1),WORK(2*N+1),A(1),A(N+1), & E(1),E(N+1),V(1),V(N+1),INFO) if (INFO /= 0) go to 30 call CBABK2(MDIM,N,ILO,IHI,WORK(1),N,V(1),V(N+1)) ! ! CONVERT EIGENVECTORS TO COMPLEX STORAGE. ! DO 20 J = 1,N K = (J-1) * MDIM + 1 I = (J-1) * 2 * LDV + 1 L = K + N call SCOPY(N,V(K),1,WORK(1),1) call SCOPY(N,V(L),1,V(I+1),2) call SCOPY(N,WORK(1),1,V(I),2) 20 CONTINUE ! ! CONVERT EIGENVALUES TO COMPLEX STORAGE. ! 30 call SCOPY(N,E(1),1,WORK(1),1) call SCOPY(N,E(N+1),1,E(2),2) call SCOPY(N,WORK(1),1,E(1),2) return ! ! TAKE CARE OF N=1 CASE ! 35 E(1) = A(1) E(2) = A(2) INFO = 0 if ( JOB == 0) RETURN V(1) = A(1) V(2) = A(2) return end subroutine CGEFA (A, LDA, N, IPVT, INFO) ! !! CGEFA factors a matrix using Gaussian elimination. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1 !***TYPE COMPLEX (SGEFA-S, DGEFA-D, CGEFA-C) !***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CGEFA factors a complex matrix by Gaussian elimination. ! ! CGEFA is usually called by CGECO, but it can be called ! directly with a saving in time if RCOND is not needed. ! (Time for CGECO) = (1 + 9/N)*(Time for CGEFA) . ! ! On Entry ! ! A COMPLEX(LDA, N) ! the matrix to be factored. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix and the multipliers ! which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if U(K,K) == 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that CGESL or CGEDI will divide by zero ! if called. Use RCOND in CGECO for a reliable ! indication of singularity. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSCAL, ICAMAX !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGEFA INTEGER LDA,N,IPVT(*),INFO COMPLEX A(LDA,*) ! COMPLEX T INTEGER ICAMAX,J,K,KP1,L,NM1 COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) ! ! GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING ! !***FIRST EXECUTABLE STATEMENT CGEFA INFO = 0 NM1 = N - 1 if (NM1 < 1) go to 70 DO 60 K = 1, NM1 KP1 = K + 1 ! ! FIND L = PIVOT INDEX ! L = ICAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L ! ! ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED ! if (CABS1(A(L,K)) == 0.0E0) go to 40 ! ! INTERCHANGE if NECESSARY ! if (L == K) go to 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE ! ! COMPUTE MULTIPLIERS ! T = -(1.0E0,0.0E0)/A(K,K) call CSCAL(N-K,T,A(K+1,K),1) ! ! ROW ELIMINATION WITH COLUMN INDEXING ! DO 30 J = KP1, N T = A(L,J) if (L == 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)) == 0.0E0) INFO = N return end subroutine CGEFS (A, LDA, N, V, ITASK, IND, WORK, IWORK) ! !! CGEFS solves a general system of linear equations. ! !***LIBRARY SLATEC !***CATEGORY D2C1 !***TYPE COMPLEX (SGEFS-S, DGEFS-D, CGEFS-C) !***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, ! GENERAL SYSTEM OF LINEAR EQUATIONS !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine CGEFS solves A general NxN system of complex ! linear equations using LINPACK subroutines CGECO ! and CGESL. That is, if A is an NxN complex matrix ! and if X and B are complex N-vectors, then CGEFS ! solves the equation ! ! A*X=B. ! ! The matrix A is first factored into upper and lower tri- ! angular matrices U and L using partial pivoting. These ! factors and the pivoting information are used to find the ! solution vector X. An approximate condition number is ! calculated to provide a rough estimate of the number of ! digits of accuracy in the computed solution. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N and IWORK must not have been altered by the user follow- ! ing factorization (ITASK=1). IND will not be changed by CGEFS ! in this case. ! ! Argument Description *** ! ! A COMPLEX(LDA,N) ! on entry, the doubly subscripted array with dimension ! (LDA,N) which contains the coefficient matrix. ! on return, an upper triangular matrix U and the ! multipliers necessary to construct a matrix L ! so that A=L*U. ! LDA INTEGER ! the leading dimension of the array A. LDA must be great- ! er than or equal to N. (Terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. The first N elements of ! the array A are the elements of the first column of ! the matrix A. N must be greater than or equal to 1. ! (Terminal error message IND=-2) ! V COMPLEX(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! if ITASK=1, the matrix A is factored and then the ! linear equation is solved. ! if ITASK > 1, the equation is solved using the existing ! factored matrix A and IWORK. ! if ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT.0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. ! LT.0 see error message corresponding to IND below. ! WORK COMPLEX(N) ! a singly subscripted array of dimension at least N. ! IWORK INTEGER(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than 1. ! IND=-3 terminal ITASK is less than 1. ! IND=-4 terminal The matrix A is computationally singular. ! A solution has not been computed. ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! NOTE- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CGECO, CGESL, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800328 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to ! IF-THEN-ELSE. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGEFS ! INTEGER LDA,N,ITASK,IND,IWORK(*) COMPLEX A(LDA,*),V(*),WORK(*) REAL R1MACH REAL RCOND CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT CGEFS if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'CGEFS', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'CGEFS', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'CGEFS', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! ! FACTOR MATRIX A INTO LU ! if (ITASK == 1) THEN call CGECO(A,LDA,N,IWORK,RCOND,WORK) ! ! CHECK FOR COMPUTATIONALLY SINGULAR MATRIX ! if (RCOND == 0.0) THEN IND = -4 call XERMSG ('SLATEC', 'CGEFS', & 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) return ENDIF ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! IND = -LOG10(R1MACH(4)/RCOND) ! ! CHECK FOR IND GREATER THAN ZERO ! if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'CGEFS', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) ENDIF end if ! ! SOLVE AFTER FACTORING ! call CGESL(A,LDA,N,IWORK,V,0) return end subroutine CGEIR (A, LDA, N, V, ITASK, IND, WORK, IWORK) ! !! CGEIR solves a general system of linear equations. Iterative ... ! refinement is used to obtain an error estimate. ! !***LIBRARY SLATEC !***CATEGORY D2C1 !***TYPE COMPLEX (SGEIR-S, CGEIR-C) !***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, ! GENERAL SYSTEM OF LINEAR EQUATIONS !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine CGEIR solves a general NxN system of complex ! linear equations using LINPACK subroutines CGEFA and CGESL. ! One pass of iterative refinement is used only to obtain an ! estimate of the accuracy. That is, if A is an NxN complex ! matrix and if X and B are complex N-vectors, then CGEIR solves ! the equation ! ! A*X=B. ! ! The matrix A is first factored into upper and lower tri- ! angular matrices U and L using partial pivoting. These ! factors and the pivoting information are used to calculate ! the solution, X. Then the residual vector is found and ! used to calculate an estimate of the relative error, IND. ! IND estimates the accuracy of the solution only when the ! input matrix and the right hand side are represented ! exactly in the computer and does not take into ! account any errors in the input data. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N, WORK, and IWORK must not have been altered by the ! user following factorization (ITASK=1). IND will not be ! changed by CGEIR in this case. ! ! Argument Description *** ! ! A COMPLEX(LDA,N) ! the doubly subscripted array with dimension (LDA,N) ! which contains the coefficient matrix. A is not ! altered by the routine. ! LDA INTEGER ! the leading dimension of the array A. LDA must be great- ! er than or equal to N. (Terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. The first N elements of ! the array A are the elements of the first column of ! matrix A. N must be greater than or equal to 1. ! (Terminal error message IND=-2) ! V COMPLEX(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! if ITASK=1, the matrix A is factored and then the ! linear equation is solved. ! if ITASK > 1, the equation is solved using the existing ! factored matrix A (stored in work). ! if ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT.0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. IND=75 means ! that the solution vector X is zero. ! LT.0 see error message corresponding to IND below. ! WORK COMPLEX(N*(N+1)) ! a singly subscripted array of dimension at least N*(N+1). ! IWORK INTEGER(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than one. ! IND=-3 terminal ITASK is less than one. ! IND=-4 terminal The matrix A is computationally singular. ! A solution has not been computed. ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! NOTE- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CCOPY, CDCDOT, CGEFA, CGESL, R1MACH, SCASUM, XERMSG !***REVISION HISTORY (YYMMDD) ! 800502 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to ! IF-THEN-ELSE. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGEIR ! INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J COMPLEX A(LDA,*),V(*),WORK(N,*),CDCDOT REAL SCASUM,XNORM,DNORM,R1MACH CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT CGEIR if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'CGEIR', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'CGEIR', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'CGEIR', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ITASK == 1) THEN ! MOVE MATRIX A TO WORK DO 10 J=1,N call CCOPY(N,A(1,J),1,WORK(1,J),1) 10 CONTINUE ! ! FACTOR MATRIX A INTO LU ! call CGEFA(WORK,N,N,IWORK,INFO) ! ! CHECK FOR COMPUTATIONALLY SINGULAR MATRIX ! if (INFO /= 0) THEN IND = -4 call XERMSG ('SLATEC', 'CGEIR', & 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) return ENDIF end if ! ! SOLVE WHEN FACTORING COMPLETE ! MOVE VECTOR B TO WORK ! call CCOPY(N,V(1),1,WORK(1,N+1),1) call CGESL(WORK,N,N,IWORK,V,0) ! ! FORM NORM OF X0 ! XNORM = SCASUM(N,V(1),1) if (XNORM == 0.0) THEN IND = 75 return end if ! ! COMPUTE RESIDUAL ! DO 40 J=1,N WORK(J,N+1) = CDCDOT(N,-WORK(J,N+1),A(J,1),LDA,V,1) 40 CONTINUE ! ! SOLVE A*DELTA=R ! call CGESL(WORK,N,N,IWORK,WORK(1,N+1),0) ! ! FORM NORM OF DELTA ! DNORM = SCASUM(N,WORK(1,N+1),1) ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'CGEIR', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) end if return end subroutine CGEMM (TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, & BETA, C, LDC) ! !! CGEMM multiplies a complex general matrix by a complex general matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE COMPLEX (SGEMM-S, DGEMM-D, CGEMM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! CGEMM performs one of the matrix-matrix operations ! ! C := alpha*op( A )*op( B ) + beta*C, ! ! where op( X ) is one of ! ! op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), ! ! alpha and beta are scalars, and A, B and C are matrices, with op( A ) ! an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. ! ! Parameters ! ========== ! ! TRANSA - CHARACTER*1. ! On entry, TRANSA specifies the form of op( A ) to be used in ! the matrix multiplication as follows: ! ! TRANSA = 'N' or 'n', op( A ) = A. ! ! TRANSA = 'T' or 't', op( A ) = A'. ! ! TRANSA = 'C' or 'c', op( A ) = conjg( A' ). ! ! Unchanged on exit. ! ! TRANSB - CHARACTER*1. ! On entry, TRANSB specifies the form of op( B ) to be used in ! the matrix multiplication as follows: ! ! TRANSB = 'N' or 'n', op( B ) = B. ! ! TRANSB = 'T' or 't', op( B ) = B'. ! ! TRANSB = 'C' or 'c', op( B ) = conjg( B' ). ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix ! op( A ) and of the matrix C. M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix ! op( B ) and the number of columns of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry, K specifies the number of columns of the matrix ! op( A ) and the number of rows of the matrix op( B ). K must ! be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is ! k when TRANSA = 'N' or 'n', and is m otherwise. ! Before entry with TRANSA = 'N' or 'n', the leading m by k ! part of the array A must contain the matrix A, otherwise ! the leading k by m part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANSA = 'N' or 'n' then ! LDA must be at least max( 1, m ), otherwise LDA must be at ! least max( 1, k ). ! Unchanged on exit. ! ! B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is ! n when TRANSB = 'N' or 'n', and is k otherwise. ! Before entry with TRANSB = 'N' or 'n', the leading k by n ! part of the array B must contain the matrix B, otherwise ! the leading n by k part of the array B must contain the ! matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. When TRANSB = 'N' or 'n' then ! LDB must be at least max( 1, k ), otherwise LDB must be at ! least max( 1, n ). ! Unchanged on exit. ! ! BETA - COMPLEX . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then C need not be set on input. ! Unchanged on exit. ! ! C - COMPLEX array of DIMENSION ( LDC, n ). ! Before entry, the leading m by n part of the array C must ! contain the matrix C, except when beta is zero, in which ! case C need not be set on entry. ! On exit, the array C is overwritten by the m by n matrix ! ( alpha*op( A )*op( B ) + beta*C ). ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CGEMM ! .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC COMPLEX ALPHA, BETA ! .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX ! .. Local Scalars .. LOGICAL CONJA, CONJB, NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB COMPLEX TEMP ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) !***FIRST EXECUTABLE STATEMENT CGEMM ! ! Set NOTA and NOTB as true if A and B respectively are not ! conjugated or transposed, set CONJA and CONJB as true if A and ! B respectively are to be transposed but not conjugated and set ! NROWA, NCOLA and NROWB as the number of rows and columns of A ! and the number of rows of B respectively. ! NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) CONJA = LSAME( TRANSA, 'C' ) CONJB = LSAME( TRANSB, 'C' ) if ( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M end if if ( NOTB )THEN NROWB = K ELSE NROWB = N end if ! ! Test the input parameters. ! INFO = 0 if ( ( .NOT.NOTA ).AND. & ( .NOT.CONJA ).AND. & ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.NOTB ).AND. & ( .NOT.CONJB ).AND. & ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE if ( M < 0 )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( K < 0 )THEN INFO = 5 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 8 ELSE if ( LDB < MAX( 1, NROWB ) )THEN INFO = 10 ELSE if ( LDC < MAX( 1, M ) )THEN INFO = 13 end if if ( INFO /= 0 )THEN call XERBLA( 'CGEMM ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if return end if ! ! Start the operations. ! if ( NOTB )THEN if ( NOTA )THEN ! ! Form C := alpha*A*B + beta*C. ! DO 90, J = 1, N if ( BETA == ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE if ( BETA /= ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE end if DO 80, L = 1, K if ( B( L, J ) /= ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE end if 80 CONTINUE 90 CONTINUE ELSE if ( CONJA )THEN ! ! Form C := alpha*conjg( A' )*B + beta*C. ! DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + CONJG( A( L, I ) )*B( L, J ) 100 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 110 CONTINUE 120 CONTINUE ELSE ! ! Form C := alpha*A'*B + beta*C ! DO 150, J = 1, N DO 140, I = 1, M TEMP = ZERO DO 130, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 130 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 140 CONTINUE 150 CONTINUE end if ELSE if ( NOTA )THEN if ( CONJB )THEN ! ! Form C := alpha*A*conjg( B' ) + beta*C. ! DO 200, J = 1, N if ( BETA == ZERO )THEN DO 160, I = 1, M C( I, J ) = ZERO 160 CONTINUE ELSE if ( BETA /= ONE )THEN DO 170, I = 1, M C( I, J ) = BETA*C( I, J ) 170 CONTINUE end if DO 190, L = 1, K if ( B( J, L ) /= ZERO )THEN TEMP = ALPHA*CONJG( B( J, L ) ) DO 180, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 180 CONTINUE end if 190 CONTINUE 200 CONTINUE ELSE ! ! Form C := alpha*A*B' + beta*C ! DO 250, J = 1, N if ( BETA == ZERO )THEN DO 210, I = 1, M C( I, J ) = ZERO 210 CONTINUE ELSE if ( BETA /= ONE )THEN DO 220, I = 1, M C( I, J ) = BETA*C( I, J ) 220 CONTINUE end if DO 240, L = 1, K if ( B( J, L ) /= ZERO )THEN TEMP = ALPHA*B( J, L ) DO 230, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 230 CONTINUE end if 240 CONTINUE 250 CONTINUE end if ELSE if ( CONJA )THEN if ( CONJB )THEN ! ! Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. ! DO 280, J = 1, N DO 270, I = 1, M TEMP = ZERO DO 260, L = 1, K TEMP = TEMP + CONJG( A( L, I ) )*CONJG( B( J, L ) ) 260 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 270 CONTINUE 280 CONTINUE ELSE ! ! Form C := alpha*conjg( A' )*B' + beta*C ! DO 310, J = 1, N DO 300, I = 1, M TEMP = ZERO DO 290, L = 1, K TEMP = TEMP + CONJG( A( L, I ) )*B( J, L ) 290 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 300 CONTINUE 310 CONTINUE end if ELSE if ( CONJB )THEN ! ! Form C := alpha*A'*conjg( B' ) + beta*C ! DO 340, J = 1, N DO 330, I = 1, M TEMP = ZERO DO 320, L = 1, K TEMP = TEMP + A( L, I )*CONJG( B( J, L ) ) 320 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 330 CONTINUE 340 CONTINUE ELSE ! ! Form C := alpha*A'*B' + beta*C ! DO 370, J = 1, N DO 360, I = 1, M TEMP = ZERO DO 350, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 350 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 360 CONTINUE 370 CONTINUE end if end if ! return ! ! End of CGEMM . ! end subroutine CGEMV (TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, & INCY) ! !! CGEMV multiplies a complex vector by a complex general matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (SGEMV-S, DGEMV-D, CGEMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CGEMV performs one of the matrix-vector operations ! ! y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or ! ! y := alpha*conjg( A' )*x + beta*y, ! ! where alpha and beta are scalars, x and y are vectors and A is an ! m by n matrix. ! ! Parameters ! ========== ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' y := alpha*A*x + beta*y. ! ! TRANS = 'T' or 't' y := alpha*A'*x + beta*y. ! ! TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix A. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry, the leading m by n part of the array A must ! contain the matrix of coefficients. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, m ). ! Unchanged on exit. ! ! X - COMPLEX array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. ! Before entry, the incremented array X must contain the ! vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - COMPLEX . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - COMPLEX array of DIMENSION at least ! ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. ! Before entry with BETA non-zero, the incremented array Y ! must contain the vector y. On exit, Y is overwritten by the ! updated vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CGEMV ! .. Scalar Arguments .. COMPLEX ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY LOGICAL NOCONJ ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX !***FIRST EXECUTABLE STATEMENT CGEMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE if ( M < 0 )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( LDA < MAX( 1, M ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 ELSE if ( INCY == 0 )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'CGEMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! NOCONJ = LSAME( TRANS, 'T' ) ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if ( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N end if if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return if ( LSAME( TRANS, 'N' ) )THEN ! ! Form y := alpha*A*x + y. ! JX = KX if ( INCY == 1 )THEN DO 60, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE end if JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if ELSE ! ! Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. ! JY = KY if ( INCX == 1 )THEN DO 110, J = 1, N TEMP = ZERO if ( NOCONJ )THEN DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE ELSE DO 100, I = 1, M TEMP = TEMP + CONJG( A( I, J ) )*X( I ) 100 CONTINUE end if Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 110 CONTINUE ELSE DO 140, J = 1, N TEMP = ZERO IX = KX if ( NOCONJ )THEN DO 120, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE ELSE DO 130, I = 1, M TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE end if Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 140 CONTINUE end if end if ! return ! ! End of CGEMV . ! end subroutine CGERC (M, N, ALPHA, X, INCX, Y, INCY, A, LDA) ! !! CGERC performs conjugated rank 1 update of a complex general matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (SGERC-S, DGERC-D, CGERC-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CGERC performs the rank 1 operation ! ! A := alpha*x*conjg( y') + A, ! ! where alpha is a scalar, x is an m element vector, y is an n element ! vector and A is an m by n matrix. ! ! Parameters ! ========== ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix A. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( m - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the m ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! Y - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. ! Unchanged on exit. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry, the leading m by n part of the array A must ! contain the matrix of coefficients. On exit, A is ! overwritten by the updated matrix. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CGERC ! .. Scalar Arguments .. COMPLEX ALPHA INTEGER INCX, INCY, LDA, M, N ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JY, KX ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX !***FIRST EXECUTABLE STATEMENT CGERC ! ! Test the input parameters. ! INFO = 0 if ( M < 0 )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( INCY == 0 )THEN INFO = 7 ELSE if ( LDA < MAX( 1, M ) )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'CGERC ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( INCY > 0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY end if if ( INCX == 1 )THEN DO 20, J = 1, N if ( Y( JY ) /= ZERO )THEN TEMP = ALPHA*CONJG( Y( JY ) ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE end if JY = JY + INCY 20 CONTINUE ELSE if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX end if DO 40, J = 1, N if ( Y( JY ) /= ZERO )THEN TEMP = ALPHA*CONJG( Y( JY ) ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE end if JY = JY + INCY 40 CONTINUE end if ! return ! ! End of CGERC . ! end subroutine CGERU (M, N, ALPHA, X, INCX, Y, INCY, A, LDA) ! !! CGERU performs unconjugated rank 1 update of a complex general matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (SGERU-S, DGERU-D, CGERU-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CGERU performs the rank 1 operation ! ! A := alpha*x*y' + A, ! ! where alpha is a scalar, x is an m element vector, y is an n element ! vector and A is an m by n matrix. ! ! Parameters ! ========== ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix A. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( m - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the m ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! Y - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. ! Unchanged on exit. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry, the leading m by n part of the array A must ! contain the matrix of coefficients. On exit, A is ! overwritten by the updated matrix. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CGERU ! .. Scalar Arguments .. COMPLEX ALPHA INTEGER INCX, INCY, LDA, M, N ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JY, KX ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT CGERU ! ! Test the input parameters. ! INFO = 0 if ( M < 0 )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( INCY == 0 )THEN INFO = 7 ELSE if ( LDA < MAX( 1, M ) )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'CGERU ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( INCY > 0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY end if if ( INCX == 1 )THEN DO 20, J = 1, N if ( Y( JY ) /= ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE end if JY = JY + INCY 20 CONTINUE ELSE if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX end if DO 40, J = 1, N if ( Y( JY ) /= ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE end if JY = JY + INCY 40 CONTINUE end if ! return ! ! End of CGERU . ! end subroutine CGESL (A, LDA, N, IPVT, B, JOB) ! !! CGESL solves the complex system A*X=B or CTRANS(A)*X=B using the ... ! factors computed by CGECO or CGEFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1 !***TYPE COMPLEX (SGESL-S, DGESL-D, CGESL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CGESL solves the complex system ! A * X = B or CTRANS(A) * X = B ! using the factors computed by CGECO or CGEFA. ! ! On Entry ! ! A COMPLEX(LDA, N) ! the output from CGECO or CGEFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! IPVT INTEGER(N) ! the pivot vector from CGECO or CGEFA. ! ! B COMPLEX(N) ! the right hand side vector. ! ! JOB INTEGER ! = 0 to solve A*X = B , ! = nonzero to solve CTRANS(A)*X = B where ! CTRANS(A) is the conjugate transpose. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically this indicates singularity ! but it is often caused by improper arguments or improper ! setting of LDA . It will not occur if the subroutines are ! called correctly and if CGECO has set RCOND > 0.0 ! or CGEFA has set INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call CGECO(A,LDA,N,IPVT,RCOND,Z) ! if (RCOND is too small) go to ... ! DO 10 J = 1, P ! call CGESL(A,LDA,N,IPVT,C(1,J),0) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGESL INTEGER LDA,N,IPVT(*),JOB COMPLEX A(LDA,*),B(*) ! COMPLEX CDOTC,T INTEGER K,KB,L,NM1 !***FIRST EXECUTABLE STATEMENT CGESL NM1 = N - 1 if (JOB /= 0) go to 50 ! ! JOB = 0 , SOLVE A * X = B ! FIRST SOLVE L*Y = B ! if (NM1 < 1) go to 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) if (L == 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 ! ! NOW SOLVE U*X = Y ! 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 ! ! JOB = NONZERO, SOLVE CTRANS(A) * X = B ! FIRST SOLVE CTRANS(U)*Y = B ! 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 ! ! NOW SOLVE CTRANS(L)*X = Y ! if (NM1 < 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 == 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 CG (NM, N, AR, AI, WR, WI, MATZ, ZR, ZI, FV1, FV2, FV3, & IERR) ! !! CG computes the eigenvalues and, optionally, the eigenvectors ... ! of a complex general matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A4 !***TYPE COMPLEX (RG-S, CG-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! to find the eigenvalues and eigenvectors (if desired) ! of a COMPLEX GENERAL matrix. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, AR, AI, ZR and ZI, as declared in the ! calling program dimension statement. NM is an INTEGER ! variable. ! ! N is the order of the matrix A=(AR,AI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! AR and AI contain the real and imaginary parts, respectively, ! of the complex general matrix. AR and AI are two-dimensional ! REAL arrays, dimensioned AR(NM,N) and AI(NM,N). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On OUTPUT ! ! WR and WI contain the real and imaginary parts, respectively, ! of the eigenvalues. WR and WI are one-dimensional REAL ! arrays, dimensioned WR(N) and WI(N). ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the eigenvectors if MATZ is not zero. ZR and ZI are ! two-dimensional REAL arrays, dimensioned ZR(NM,N) and ! ZI(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! J if the J-th eigenvalue has not been ! determined after a total of 30 iterations. ! The eigenvalues should be correct for indices ! IERR+1, IERR+2, ..., N, but no eigenvectors are ! computed. ! ! FV1, FV2, and FV3 are one-dimensional REAL arrays used for ! temporary storage, dimensioned FV1(N), FV2(N), and FV3(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED CBABK2, CBAL, COMQR, COMQR2, CORTH !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CG ! INTEGER N,NM,IS1,IS2,IERR,MATZ REAL AR(NM,*),AI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*) REAL FV1(*),FV2(*),FV3(*) ! !***FIRST EXECUTABLE STATEMENT CG if (N <= NM) go to 10 IERR = 10 * N go to 50 ! 10 call CBAL(NM,N,AR,AI,IS1,IS2,FV1) call CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3) if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 call COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR) if (IERR /= 0) go to 50 call CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI) 50 RETURN end subroutine CGTSL (N, C, D, E, B, INFO) ! !! CGTSL solves a tridiagonal linear system. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C2A !***TYPE COMPLEX (SGTSL-S, DGTSL-D, CGTSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, TRIDIAGONAL !***AUTHOR Dongarra, J., (ANL) !***DESCRIPTION ! ! CGTSL given a general tridiagonal matrix and a right hand ! side will find the solution. ! ! On Entry ! ! N INTEGER ! is the order of the tridiagonal matrix. ! ! C COMPLEX(N) ! is the subdiagonal of the tridiagonal matrix. ! C(2) through C(N) should contain the subdiagonal. ! On output C is destroyed. ! ! D COMPLEX(N) ! is the diagonal of the tridiagonal matrix. ! On output D is destroyed. ! ! E COMPLEX(N) ! is the superdiagonal of the tridiagonal matrix. ! E(1) through E(N-1) should contain the superdiagonal. ! On output E is destroyed. ! ! B COMPLEX(N) ! is the right hand side vector. ! ! On Return ! ! B is the solution vector. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th element of the diagonal becomes ! exactly zero. The subroutine returns when ! this is detected. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CGTSL INTEGER N,INFO COMPLEX C(*),D(*),E(*),B(*) ! INTEGER K,KB,KP1,NM1,NM2 COMPLEX T COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT CGTSL INFO = 0 C(1) = D(1) NM1 = N - 1 if (NM1 < 1) go to 40 D(1) = E(1) E(1) = (0.0E0,0.0E0) E(N) = (0.0E0,0.0E0) ! DO 30 K = 1, NM1 KP1 = K + 1 ! ! FIND THE LARGEST OF THE TWO ROWS ! if (CABS1(C(KP1)) < CABS1(C(K))) go to 10 ! ! INTERCHANGE ROW ! T = C(KP1) C(KP1) = C(K) C(K) = T T = D(KP1) D(KP1) = D(K) D(K) = T T = E(KP1) E(KP1) = E(K) E(K) = T T = B(KP1) B(KP1) = B(K) B(K) = T 10 CONTINUE ! ! ZERO ELEMENTS ! if (CABS1(C(K)) /= 0.0E0) go to 20 INFO = K go to 100 20 CONTINUE T = -C(KP1)/C(K) C(KP1) = D(KP1) + T*D(K) D(KP1) = E(KP1) + T*E(K) E(KP1) = (0.0E0,0.0E0) B(KP1) = B(KP1) + T*B(K) 30 CONTINUE 40 CONTINUE if (CABS1(C(N)) /= 0.0E0) go to 50 INFO = N go to 90 50 CONTINUE ! ! BACK SOLVE ! NM2 = N - 2 B(N) = B(N)/C(N) if (N == 1) go to 80 B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1) if (NM2 < 1) go to 70 DO 60 KB = 1, NM2 K = NM2 - KB + 1 B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K) 60 CONTINUE 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE ! return end subroutine CHBMV (UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, & INCY) ! !! CHBMV multiplies a complex vector by a complex Hermitian band matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (SHBMV-S, DHBMV-D, CHBMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CHBMV performs the matrix-vector operation ! ! y := alpha*A*x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! A is an n by n hermitian band matrix, with k super-diagonals. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the band matrix A is being supplied as ! follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! being supplied. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! being supplied. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry, K specifies the number of super-diagonals of the ! matrix A. K must satisfy 0 .le. K. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) ! by n part of the array A must contain the upper triangular ! band part of the hermitian matrix, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. The top left k by k triangle ! of the array A is not referenced. ! The following program segment will transfer the upper ! triangular part of a hermitian band matrix from conventional ! full matrix storage to band storage: ! ! DO 20, J = 1, N ! M = K + 1 - J ! DO 10, I = MAX( 1, J - K ), J ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) ! by n part of the array A must contain the lower triangular ! band part of the hermitian matrix, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. The bottom right k by k triangle of the ! array A is not referenced. ! The following program segment will transfer the lower ! triangular part of a hermitian band matrix from conventional ! full matrix storage to band storage: ! ! DO 20, J = 1, N ! M = 1 - J ! DO 10, I = J, MIN( N, J + K ) ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Note that the imaginary parts of the diagonal elements need ! not be set and are assumed to be zero. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( k + 1 ). ! Unchanged on exit. ! ! X - COMPLEX array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the ! vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - COMPLEX . ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! Y - COMPLEX array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the ! vector y. On exit, Y is overwritten by the updated vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CHBMV ! .. Scalar Arguments .. COMPLEX ALPHA, BETA INTEGER INCX, INCY, K, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN, REAL !***FIRST EXECUTABLE STATEMENT CHBMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( K < 0 )THEN INFO = 3 ELSE if ( LDA < ( K + 1 ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 ELSE if ( INCY == 0 )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'CHBMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set up the start points in X and Y. ! if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if ! ! Start the operations. In this version the elements of the array A ! are accessed sequentially with one pass through A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return if ( LSAME( UPLO, 'U' ) )THEN ! ! Form y when upper triangle of A is stored. ! KPLUS1 = K + 1 if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO L = KPLUS1 - J DO 50, I = MAX( 1, J - K ), J - 1 Y( I ) = Y( I ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + CONJG( A( L + I, J ) )*X( I ) 50 CONTINUE Y( J ) = Y( J ) + TEMP1*REAL( A( KPLUS1, J ) ) & + ALPHA*TEMP2 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY L = KPLUS1 - J DO 70, I = MAX( 1, J - K ), J - 1 Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + CONJG( A( L + I, J ) )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*REAL( A( KPLUS1, J ) ) & + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY if ( J > K )THEN KX = KX + INCX KY = KY + INCY end if 80 CONTINUE end if ELSE ! ! Form y when lower triangle of A is stored. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*REAL( A( 1, J ) ) L = 1 - J DO 90, I = J + 1, MIN( N, J + K ) Y( I ) = Y( I ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + CONJG( A( L + I, J ) )*X( I ) 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*REAL( A( 1, J ) ) L = 1 - J IX = JX IY = JY DO 110, I = J + 1, MIN( N, J + K ) IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + CONJG( A( L + I, J ) )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE end if end if ! return ! ! End of CHBMV . ! end subroutine CHEMM (SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, & C, LDC) ! !! CHEMM multiplies a complex general matrix by a complex Hermitian matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE COMPLEX (SHEMM-S, DHEMM-D, CHEMM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! CHEMM performs one of the matrix-matrix operations ! ! C := alpha*A*B + beta*C, ! ! or ! ! C := alpha*B*A + beta*C, ! ! where alpha and beta are scalars, A is an hermitian matrix and B and ! C are m by n matrices. ! ! Parameters ! ========== ! ! SIDE - CHARACTER*1. ! On entry, SIDE specifies whether the hermitian matrix A ! appears on the left or right in the operation as follows: ! ! SIDE = 'L' or 'l' C := alpha*A*B + beta*C, ! ! SIDE = 'R' or 'r' C := alpha*B*A + beta*C, ! ! Unchanged on exit. ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the hermitian matrix A is to be ! referenced as follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of the ! hermitian matrix is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of the ! hermitian matrix is to be referenced. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix C. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix C. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is ! m when SIDE = 'L' or 'l' and is n otherwise. ! Before entry with SIDE = 'L' or 'l', the m by m part of ! the array A must contain the hermitian matrix, such that ! when UPLO = 'U' or 'u', the leading m by m upper triangular ! part of the array A must contain the upper triangular part ! of the hermitian matrix and the strictly lower triangular ! part of A is not referenced, and when UPLO = 'L' or 'l', ! the leading m by m lower triangular part of the array A ! must contain the lower triangular part of the hermitian ! matrix and the strictly upper triangular part of A is not ! referenced. ! Before entry with SIDE = 'R' or 'r', the n by n part of ! the array A must contain the hermitian matrix, such that ! when UPLO = 'U' or 'u', the leading n by n upper triangular ! part of the array A must contain the upper triangular part ! of the hermitian matrix and the strictly lower triangular ! part of A is not referenced, and when UPLO = 'L' or 'l', ! the leading n by n lower triangular part of the array A ! must contain the lower triangular part of the hermitian ! matrix and the strictly upper triangular part of A is not ! referenced. ! Note that the imaginary parts of the diagonal elements need ! not be set, they are assumed to be zero. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When SIDE = 'L' or 'l' then ! LDA must be at least max( 1, m ), otherwise LDA must be at ! least max( 1, n ). ! Unchanged on exit. ! ! B - COMPLEX array of DIMENSION ( LDB, n ). ! Before entry, the leading m by n part of the array B must ! contain the matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. LDB must be at least ! max( 1, m ). ! Unchanged on exit. ! ! BETA - COMPLEX . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then C need not be set on input. ! Unchanged on exit. ! ! C - COMPLEX array of DIMENSION ( LDC, n ). ! Before entry, the leading m by n part of the array C must ! contain the matrix C, except when beta is zero, in which ! case C need not be set on entry. ! On exit, the array C is overwritten by the m by n updated ! matrix. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CHEMM ! .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC COMPLEX ALPHA, BETA ! .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX, REAL ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, K, NROWA COMPLEX TEMP1, TEMP2 ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) !***FIRST EXECUTABLE STATEMENT CHEMM ! ! Set NROWA as the number of rows of A. ! if ( LSAME( SIDE, 'L' ) )THEN NROWA = M ELSE NROWA = N end if UPPER = LSAME( UPLO, 'U' ) ! ! Test the input parameters. ! INFO = 0 if ( ( .NOT.LSAME( SIDE, 'L' ) ).AND. & ( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE if ( M < 0 )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDB < MAX( 1, M ) )THEN INFO = 9 ELSE if ( LDC < MAX( 1, M ) )THEN INFO = 12 end if if ( INFO /= 0 )THEN call XERBLA( 'CHEMM ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if return end if ! ! Start the operations. ! if ( LSAME( SIDE, 'L' ) )THEN ! ! Form C := alpha*A*B + beta*C. ! if ( UPPER )THEN DO 70, J = 1, N DO 60, I = 1, M TEMP1 = ALPHA*B( I, J ) TEMP2 = ZERO DO 50, K = 1, I - 1 C( K, J ) = C( K, J ) + TEMP1*A( K, I ) TEMP2 = TEMP2 + & B( K, J )*CONJG( A( K, I ) ) 50 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = TEMP1*REAL( A( I, I ) ) + & ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & TEMP1*REAL( A( I, I ) ) + & ALPHA*TEMP2 end if 60 CONTINUE 70 CONTINUE ELSE DO 100, J = 1, N DO 90, I = M, 1, -1 TEMP1 = ALPHA*B( I, J ) TEMP2 = ZERO DO 80, K = I + 1, M C( K, J ) = C( K, J ) + TEMP1*A( K, I ) TEMP2 = TEMP2 + & B( K, J )*CONJG( A( K, I ) ) 80 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = TEMP1*REAL( A( I, I ) ) + & ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & TEMP1*REAL( A( I, I ) ) + & ALPHA*TEMP2 end if 90 CONTINUE 100 CONTINUE end if ELSE ! ! Form C := alpha*B*A + beta*C. ! DO 170, J = 1, N TEMP1 = ALPHA*REAL( A( J, J ) ) if ( BETA == ZERO )THEN DO 110, I = 1, M C( I, J ) = TEMP1*B( I, J ) 110 CONTINUE ELSE DO 120, I = 1, M C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) 120 CONTINUE end if DO 140, K = 1, J - 1 if ( UPPER )THEN TEMP1 = ALPHA*A( K, J ) ELSE TEMP1 = ALPHA*CONJG( A( J, K ) ) end if DO 130, I = 1, M C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 130 CONTINUE 140 CONTINUE DO 160, K = J + 1, N if ( UPPER )THEN TEMP1 = ALPHA*CONJG( A( J, K ) ) ELSE TEMP1 = ALPHA*A( K, J ) end if DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 150 CONTINUE 160 CONTINUE 170 CONTINUE end if ! return ! ! End of CHEMM . ! end subroutine CHEMV (UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) ! !! CHEMV multiplies a complex vector by a complex Hermitian matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (SHEMV-S, DHEMV-D, CHEMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CHEMV performs the matrix-vector operation ! ! y := alpha*A*x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! A is an n by n hermitian matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array A is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of A ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of A ! is to be referenced. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular part of the hermitian matrix and the strictly ! lower triangular part of A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular part of the hermitian matrix and the strictly ! upper triangular part of A is not referenced. ! Note that the imaginary parts of the diagonal elements need ! not be set and are assumed to be zero. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - COMPLEX . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. On exit, Y is overwritten by the updated ! vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CHEMV ! .. Scalar Arguments .. COMPLEX ALPHA, BETA INTEGER INCX, INCY, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX, REAL !***FIRST EXECUTABLE STATEMENT CHEMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 5 ELSE if ( INCX == 0 )THEN INFO = 7 ELSE if ( INCY == 0 )THEN INFO = 10 end if if ( INFO /= 0 )THEN call XERBLA( 'CHEMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set up the start points in X and Y. ! if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return if ( LSAME( UPLO, 'U' ) )THEN ! ! Form y when A is stored in upper triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO DO 50, I = 1, J - 1 Y( I ) = Y( I ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + CONJG( A( I, J ) )*X( I ) 50 CONTINUE Y( J ) = Y( J ) + TEMP1*REAL( A( J, J ) ) + ALPHA*TEMP2 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY DO 70, I = 1, J - 1 Y( IY ) = Y( IY ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + CONJG( A( I, J ) )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*REAL( A( J, J ) ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 80 CONTINUE end if ELSE ! ! Form y when A is stored in lower triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*REAL( A( J, J ) ) DO 90, I = J + 1, N Y( I ) = Y( I ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + CONJG( A( I, J ) )*X( I ) 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*REAL( A( J, J ) ) IX = JX IY = JY DO 110, I = J + 1, N IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + CONJG( A( I, J ) )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE end if end if ! return ! ! End of CHEMV . ! end subroutine CHER2 (UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) ! !! CHER2 performs Hermitian rank 2 update of a complex Hermitian matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (SHER2-S, DHER2-D, CHER2-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CHER2 performs the hermitian rank 2 operation ! ! A := alpha*x*conjg( y') + conjg( alpha)*y*conjg( x') + A, ! ! where alpha is a scalar, x and y are n element vectors and A is an n ! by n hermitian matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array A is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of A ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of A ! is to be referenced. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! Y - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. ! Unchanged on exit. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular part of the hermitian matrix and the strictly ! lower triangular part of A is not referenced. On exit, the ! upper triangular part of the array A is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular part of the hermitian matrix and the strictly ! upper triangular part of A is not referenced. On exit, the ! lower triangular part of the array A is overwritten by the ! lower triangular part of the updated matrix. ! Note that the imaginary parts of the diagonal elements need ! not be set, they are assumed to be zero, and on exit they ! are set to zero. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CHER2 ! .. Scalar Arguments .. COMPLEX ALPHA INTEGER INCX, INCY, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX, REAL !***FIRST EXECUTABLE STATEMENT CHER2 ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( INCY == 0 )THEN INFO = 7 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'CHER2 ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ( ( INCX /= 1 ).OR.( INCY /= 1 ) )THEN if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if JX = KX JY = KY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when A is stored in the upper triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 20, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*CONJG( Y( J ) ) TEMP2 = CONJG( ALPHA*X( J ) ) DO 10, I = 1, J - 1 A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 10 CONTINUE A( J, J ) = REAL( A( J, J ) ) + & REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) ELSE A( J, J ) = REAL( A( J, J ) ) end if 20 CONTINUE ELSE DO 40, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*CONJG( Y( JY ) ) TEMP2 = CONJG( ALPHA*X( JX ) ) IX = KX IY = KY DO 30, I = 1, J - 1 A( I, J ) = A( I, J ) + X( IX )*TEMP1 & + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE A( J, J ) = REAL( A( J, J ) ) + & REAL( X( JX )*TEMP1 + Y( JY )*TEMP2 ) ELSE A( J, J ) = REAL( A( J, J ) ) end if JX = JX + INCX JY = JY + INCY 40 CONTINUE end if ELSE ! ! Form A when A is stored in the lower triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*CONJG( Y( J ) ) TEMP2 = CONJG( ALPHA*X( J ) ) A( J, J ) = REAL( A( J, J ) ) + & REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) DO 50, I = J + 1, N A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 50 CONTINUE ELSE A( J, J ) = REAL( A( J, J ) ) end if 60 CONTINUE ELSE DO 80, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*CONJG( Y( JY ) ) TEMP2 = CONJG( ALPHA*X( JX ) ) A( J, J ) = REAL( A( J, J ) ) + & REAL( X( JX )*TEMP1 + Y( JY )*TEMP2 ) IX = JX IY = JY DO 70, I = J + 1, N IX = IX + INCX IY = IY + INCY A( I, J ) = A( I, J ) + X( IX )*TEMP1 & + Y( IY )*TEMP2 70 CONTINUE ELSE A( J, J ) = REAL( A( J, J ) ) end if JX = JX + INCX JY = JY + INCY 80 CONTINUE end if end if ! return ! ! End of CHER2 . ! end subroutine CHER2K (UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, & C, LDC) ! !! CHER2K performs Hermitian rank 2k update of a complex Hermitian matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE COMPLEX (SHER2-S, DHER2-D, CHER2-C, CHER2K-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! CHER2K performs one of the hermitian rank 2k operations ! ! C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, ! ! or ! ! C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, ! ! where alpha and beta are scalars with beta real, C is an n by n ! hermitian matrix and A and B are n by k matrices in the first case ! and k by n matrices in the second case. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array C is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of C ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of C ! is to be referenced. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + ! conjg( alpha )*B*conjg( A' ) + ! beta*C. ! ! TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + ! conjg( alpha )*conjg( B' )*A + ! beta*C. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with TRANS = 'N' or 'n', K specifies the number ! of columns of the matrices A and B, and on entry with ! TRANS = 'C' or 'c', K specifies the number of rows of the ! matrices A and B. K must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array A must contain the matrix A, otherwise ! the leading k by n part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDA must be at least max( 1, n ), otherwise LDA must ! be at least max( 1, k ). ! Unchanged on exit. ! ! B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array B must contain the matrix B, otherwise ! the leading k by n part of the array B must contain the ! matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDB must be at least max( 1, n ), otherwise LDB must ! be at least max( 1, k ). ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! C - COMPLEX array of DIMENSION ( LDC, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array C must contain the upper ! triangular part of the hermitian matrix and the strictly ! lower triangular part of C is not referenced. On exit, the ! upper triangular part of the array C is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array C must contain the lower ! triangular part of the hermitian matrix and the strictly ! upper triangular part of C is not referenced. On exit, the ! lower triangular part of the array C is overwritten by the ! lower triangular part of the updated matrix. ! Note that the imaginary parts of the diagonal elements need ! not be set, they are assumed to be zero, and on exit they ! are set to zero. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CHER2K ! .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC REAL BETA COMPLEX ALPHA ! .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX, REAL ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, L, NROWA COMPLEX TEMP1, TEMP2 ! .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) !***FIRST EXECUTABLE STATEMENT CHER2K ! ! Test the input parameters. ! if ( LSAME( TRANS, 'N' ) )THEN NROWA = N ELSE NROWA = K end if UPPER = LSAME( UPLO, 'U' ) ! INFO = 0 if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.LSAME( TRANS, 'N' ) ).AND. & ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( K < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDB < MAX( 1, NROWA ) )THEN INFO = 9 ELSE if ( LDC < MAX( 1, N ) )THEN INFO = 12 end if if ( INFO /= 0 )THEN call XERBLA( 'CHER2K', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( UPPER )THEN if ( BETA == REAL( ZERO ) )THEN DO 20, J = 1, N DO 10, I = 1, J C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, J - 1 C( I, J ) = BETA*C( I, J ) 30 CONTINUE C( J, J ) = BETA*REAL( C( J, J ) ) 40 CONTINUE end if ELSE if ( BETA == REAL( ZERO ) )THEN DO 60, J = 1, N DO 50, I = J, N C( I, J ) = ZERO 50 CONTINUE 60 CONTINUE ELSE DO 80, J = 1, N C( J, J ) = BETA*REAL( C( J, J ) ) DO 70, I = J + 1, N C( I, J ) = BETA*C( I, J ) 70 CONTINUE 80 CONTINUE end if end if return end if ! ! Start the operations. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + ! C. ! if ( UPPER )THEN DO 130, J = 1, N if ( BETA == REAL( ZERO ) )THEN DO 90, I = 1, J C( I, J ) = ZERO 90 CONTINUE ELSE if ( BETA /= ONE )THEN DO 100, I = 1, J - 1 C( I, J ) = BETA*C( I, J ) 100 CONTINUE C( J, J ) = BETA*REAL( C( J, J ) ) end if DO 120, L = 1, K if ( ( A( J, L ) /= ZERO ).OR. & ( B( J, L ) /= ZERO ) )THEN TEMP1 = ALPHA*CONJG( B( J, L ) ) TEMP2 = CONJG( ALPHA*A( J, L ) ) DO 110, I = 1, J - 1 C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + & B( I, L )*TEMP2 110 CONTINUE C( J, J ) = REAL( C( J, J ) ) + & REAL( A( J, L )*TEMP1 + & B( J, L )*TEMP2 ) end if 120 CONTINUE 130 CONTINUE ELSE DO 180, J = 1, N if ( BETA == REAL( ZERO ) )THEN DO 140, I = J, N C( I, J ) = ZERO 140 CONTINUE ELSE if ( BETA /= ONE )THEN DO 150, I = J + 1, N C( I, J ) = BETA*C( I, J ) 150 CONTINUE C( J, J ) = BETA*REAL( C( J, J ) ) end if DO 170, L = 1, K if ( ( A( J, L ) /= ZERO ).OR. & ( B( J, L ) /= ZERO ) )THEN TEMP1 = ALPHA*CONJG( B( J, L ) ) TEMP2 = CONJG( ALPHA*A( J, L ) ) DO 160, I = J + 1, N C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + & B( I, L )*TEMP2 160 CONTINUE C( J, J ) = REAL( C( J, J ) ) + & REAL( A( J, L )*TEMP1 + & B( J, L )*TEMP2 ) end if 170 CONTINUE 180 CONTINUE end if ELSE ! ! Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + ! C. ! if ( UPPER )THEN DO 210, J = 1, N DO 200, I = 1, J TEMP1 = ZERO TEMP2 = ZERO DO 190, L = 1, K TEMP1 = TEMP1 + CONJG( A( L, I ) )*B( L, J ) TEMP2 = TEMP2 + CONJG( B( L, I ) )*A( L, J ) 190 CONTINUE if ( I == J )THEN if ( BETA == REAL( ZERO ) )THEN C( J, J ) = REAL( ALPHA *TEMP1 + & CONJG( ALPHA )*TEMP2 ) ELSE C( J, J ) = BETA*REAL( C( J, J ) ) + & REAL( ALPHA *TEMP1 + & CONJG( ALPHA )*TEMP2 ) end if ELSE if ( BETA == REAL( ZERO ) )THEN C( I, J ) = ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 end if end if 200 CONTINUE 210 CONTINUE ELSE DO 240, J = 1, N DO 230, I = J, N TEMP1 = ZERO TEMP2 = ZERO DO 220, L = 1, K TEMP1 = TEMP1 + CONJG( A( L, I ) )*B( L, J ) TEMP2 = TEMP2 + CONJG( B( L, I ) )*A( L, J ) 220 CONTINUE if ( I == J )THEN if ( BETA == REAL( ZERO ) )THEN C( J, J ) = REAL( ALPHA *TEMP1 + & CONJG( ALPHA )*TEMP2 ) ELSE C( J, J ) = BETA*REAL( C( J, J ) ) + & REAL( ALPHA *TEMP1 + & CONJG( ALPHA )*TEMP2 ) end if ELSE if ( BETA == REAL( ZERO ) )THEN C( I, J ) = ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 end if end if 230 CONTINUE 240 CONTINUE end if end if ! return ! ! End of CHER2K. ! end subroutine CHER (UPLO, N, ALPHA, X, INCX, A, LDA) ! !! CHER performs Hermitian rank 1 update of a complex Hermitian matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (SHER-S, DHER-D, CHER-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CHER performs the hermitian rank 1 operation ! ! A := alpha*x*conjg( x') + A, ! ! where alpha is a real scalar, x is an n element vector and A is an ! n by n hermitian matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array A is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of A ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of A ! is to be referenced. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular part of the hermitian matrix and the strictly ! lower triangular part of A is not referenced. On exit, the ! upper triangular part of the array A is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular part of the hermitian matrix and the strictly ! upper triangular part of A is not referenced. On exit, the ! lower triangular part of the array A is overwritten by the ! lower triangular part of the updated matrix. ! Note that the imaginary parts of the diagonal elements need ! not be set, they are assumed to be zero, and on exit they ! are set to zero. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CHER ! .. Scalar Arguments .. REAL ALPHA INTEGER INCX, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, KX ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX, REAL !***FIRST EXECUTABLE STATEMENT CHER ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'CHER ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == REAL( ZERO ) ) ) & return ! ! Set the start point in X if the increment is not unity. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when A is stored in upper triangle. ! if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*CONJG( X( J ) ) DO 10, I = 1, J - 1 A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE A( J, J ) = REAL( A( J, J ) ) + REAL( X( J )*TEMP ) ELSE A( J, J ) = REAL( A( J, J ) ) end if 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*CONJG( X( JX ) ) IX = KX DO 30, I = 1, J - 1 A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE A( J, J ) = REAL( A( J, J ) ) + REAL( X( JX )*TEMP ) ELSE A( J, J ) = REAL( A( J, J ) ) end if JX = JX + INCX 40 CONTINUE end if ELSE ! ! Form A when A is stored in lower triangle. ! if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*CONJG( X( J ) ) A( J, J ) = REAL( A( J, J ) ) + REAL( TEMP*X( J ) ) DO 50, I = J + 1, N A( I, J ) = A( I, J ) + X( I )*TEMP 50 CONTINUE ELSE A( J, J ) = REAL( A( J, J ) ) end if 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*CONJG( X( JX ) ) A( J, J ) = REAL( A( J, J ) ) + REAL( TEMP*X( JX ) ) IX = JX DO 70, I = J + 1, N IX = IX + INCX A( I, J ) = A( I, J ) + X( IX )*TEMP 70 CONTINUE ELSE A( J, J ) = REAL( A( J, J ) ) end if JX = JX + INCX 80 CONTINUE end if end if ! return ! ! End of CHER . ! end subroutine CHERK (UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) ! !! CHERK performs Hermitian rank k update of a complex Hermitian matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE COMPLEX (SHERK-S, DHERK-D, CHERK-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! CHERK performs one of the hermitian rank k operations ! ! C := alpha*A*conjg( A' ) + beta*C, ! ! or ! ! C := alpha*conjg( A' )*A + beta*C, ! ! where alpha and beta are real scalars, C is an n by n hermitian ! matrix and A is an n by k matrix in the first case and a k by n ! matrix in the second case. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array C is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of C ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of C ! is to be referenced. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. ! ! TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with TRANS = 'N' or 'n', K specifies the number ! of columns of the matrix A, and on entry with ! TRANS = 'C' or 'c', K specifies the number of rows of the ! matrix A. K must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array A must contain the matrix A, otherwise ! the leading k by n part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDA must be at least max( 1, n ), otherwise LDA must ! be at least max( 1, k ). ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! C - COMPLEX array of DIMENSION ( LDC, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array C must contain the upper ! triangular part of the hermitian matrix and the strictly ! lower triangular part of C is not referenced. On exit, the ! upper triangular part of the array C is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array C must contain the lower ! triangular part of the hermitian matrix and the strictly ! upper triangular part of C is not referenced. On exit, the ! lower triangular part of the array C is overwritten by the ! lower triangular part of the updated matrix. ! Note that the imaginary parts of the diagonal elements need ! not be set, they are assumed to be zero, and on exit they ! are set to zero. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CHERK ! .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC REAL ALPHA, BETA ! .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CMPLX, CONJG, MAX, REAL ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, L, NROWA REAL RTEMP COMPLEX TEMP ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) !***FIRST EXECUTABLE STATEMENT CHERK ! ! Test the input parameters. ! if ( LSAME( TRANS, 'N' ) )THEN NROWA = N ELSE NROWA = K end if UPPER = LSAME( UPLO, 'U' ) ! INFO = 0 if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.LSAME( TRANS, 'N' ) ).AND. & ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( K < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDC < MAX( 1, N ) )THEN INFO = 10 end if if ( INFO /= 0 )THEN call XERBLA( 'CHERK ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( UPPER )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, J C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, J - 1 C( I, J ) = BETA*C( I, J ) 30 CONTINUE C( J, J ) = BETA*REAL( C( J, J ) ) 40 CONTINUE end if ELSE if ( BETA == ZERO )THEN DO 60, J = 1, N DO 50, I = J, N C( I, J ) = ZERO 50 CONTINUE 60 CONTINUE ELSE DO 80, J = 1, N C( J, J ) = BETA*REAL( C( J, J ) ) DO 70, I = J + 1, N C( I, J ) = BETA*C( I, J ) 70 CONTINUE 80 CONTINUE end if end if return end if ! ! Start the operations. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form C := alpha*A*conjg( A' ) + beta*C. ! if ( UPPER )THEN DO 130, J = 1, N if ( BETA == ZERO )THEN DO 90, I = 1, J C( I, J ) = ZERO 90 CONTINUE ELSE if ( BETA /= ONE )THEN DO 100, I = 1, J - 1 C( I, J ) = BETA*C( I, J ) 100 CONTINUE C( J, J ) = BETA*REAL( C( J, J ) ) end if DO 120, L = 1, K if ( A( J, L ) /= CMPLX( ZERO ) )THEN TEMP = ALPHA*CONJG( A( J, L ) ) DO 110, I = 1, J - 1 C( I, J ) = C( I, J ) + TEMP*A( I, L ) 110 CONTINUE C( J, J ) = REAL( C( J, J ) ) + & REAL( TEMP*A( I, L ) ) end if 120 CONTINUE 130 CONTINUE ELSE DO 180, J = 1, N if ( BETA == ZERO )THEN DO 140, I = J, N C( I, J ) = ZERO 140 CONTINUE ELSE if ( BETA /= ONE )THEN C( J, J ) = BETA*REAL( C( J, J ) ) DO 150, I = J + 1, N C( I, J ) = BETA*C( I, J ) 150 CONTINUE end if DO 170, L = 1, K if ( A( J, L ) /= CMPLX( ZERO ) )THEN TEMP = ALPHA*CONJG( A( J, L ) ) C( J, J ) = REAL( C( J, J ) ) + & REAL( TEMP*A( J, L ) ) DO 160, I = J + 1, N C( I, J ) = C( I, J ) + TEMP*A( I, L ) 160 CONTINUE end if 170 CONTINUE 180 CONTINUE end if ELSE ! ! Form C := alpha*conjg( A' )*A + beta*C. ! if ( UPPER )THEN DO 220, J = 1, N DO 200, I = 1, J - 1 TEMP = ZERO DO 190, L = 1, K TEMP = TEMP + CONJG( A( L, I ) )*A( L, J ) 190 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 200 CONTINUE RTEMP = ZERO DO 210, L = 1, K RTEMP = RTEMP + CONJG( A( L, J ) )*A( L, J ) 210 CONTINUE if ( BETA == ZERO )THEN C( J, J ) = ALPHA*RTEMP ELSE C( J, J ) = ALPHA*RTEMP + BETA*REAL( C( J, J ) ) end if 220 CONTINUE ELSE DO 260, J = 1, N RTEMP = ZERO DO 230, L = 1, K RTEMP = RTEMP + CONJG( A( L, J ) )*A( L, J ) 230 CONTINUE if ( BETA == ZERO )THEN C( J, J ) = ALPHA*RTEMP ELSE C( J, J ) = ALPHA*RTEMP + BETA*REAL( C( J, J ) ) end if DO 250, I = J + 1, N TEMP = ZERO DO 240, L = 1, K TEMP = TEMP + CONJG( A( L, I ) )*A( L, J ) 240 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 250 CONTINUE 260 CONTINUE end if end if ! return ! ! End of CHERK . ! end subroutine CH (NM, N, AR, AI, W, MATZ, ZR, ZI, FV1, FV2, FM1, & IERR) ! !! CH computes the eigenvalues and, optionally, the eigenvectors ... ! of a complex Hermitian matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A3 !***TYPE COMPLEX (RS-S, CH-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! to find the eigenvalues and eigenvectors (if desired) ! of a COMPLEX HERMITIAN matrix. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, AR, AI, ZR and ZI, as declared in the ! calling program dimension statement. NM is an INTEGER ! variable. ! ! N is the order of the matrix A=(AR,AI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! AR and AI contain the real and imaginary parts, respectively, ! of the complex Hermitian matrix. AR and AI are ! two-dimensional REAL arrays, dimensioned AR(NM,N) ! and AI(NM,N). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On OUTPUT ! ! W contains the eigenvalues in ascending order. ! W is a one-dimensional REAL array, dimensioned W(N). ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the eigenvectors if MATZ is not zero. ZR and ZI are ! two-dimensional REAL arrays, dimensioned ZR(NM,N) and ! ZI(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! J if the J-th eigenvalue has not been ! determined after a total of 30 iterations. ! The eigenvalues should be correct for indices ! 1, 2, ..., IERR-1, but no eigenvectors are ! computed. ! ! FV1 and FV2 are one-dimensional REAL arrays used for ! temporary storage, dimensioned FV1(N) and FV2(N). ! ! FM1 is a two-dimensional REAL array used for temporary ! storage, dimensioned FM1(2,N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED HTRIBK, HTRIDI, TQL2, TQLRAT !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CH ! INTEGER I,J,N,NM,IERR,MATZ REAL AR(NM,*),AI(NM,*),W(*),ZR(NM,*),ZI(NM,*) REAL FV1(*),FV2(*),FM1(2,*) ! !***FIRST EXECUTABLE STATEMENT CH if (N <= NM) go to 10 IERR = 10 * N go to 50 ! 10 call HTRIDI(NM,N,AR,AI,W,FV1,FV2,FM1) if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call TQLRAT(N,W,FV2,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 DO 40 I = 1, N ! DO 30 J = 1, N ZR(J,I) = 0.0E0 30 CONTINUE ! ZR(I,I) = 1.0E0 40 CONTINUE ! call TQL2(NM,N,W,FV1,ZR,IERR) if (IERR /= 0) go to 50 call HTRIBK(NM,N,AR,AI,FM1,N,ZR,ZI) 50 RETURN end INTEGER FUNCTION CHFCM (D1, D2, DELTA) ! !! CHFCM checks a single cubic for monotonicity. ! !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (CHFCM-S, DCHFCM-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! *Usage: ! ! REAL D1, D2, DELTA ! INTEGER ISMON, CHFCM ! ! ISMON = CHFCM (D1, D2, DELTA) ! ! *Arguments: ! ! D1,D2:IN are the derivative values at the ends of an interval. ! ! DELTA:IN is the data slope over that interval. ! ! *Function Return Values: ! ISMON : indicates the monotonicity of the cubic segment: ! ISMON = -3 if function is probably decreasing; ! ISMON = -1 if function is strictly decreasing; ! ISMON = 0 if function is constant; ! ISMON = 1 if function is strictly increasing; ! ISMON = 2 if function is non-monotonic; ! ISMON = 3 if function is probably increasing. ! If ABS(ISMON)=3, the derivative values are too close to the ! boundary of the monotonicity region to declare monotonicity ! in the presence of roundoff error. ! ! *Description: ! ! CHFCM: Cubic Hermite Function -- Check Monotonicity. ! ! Called by PCHCM to determine the monotonicity properties of the ! cubic with boundary derivative values D1,D2 and chord slope DELTA. ! ! *Cautions: ! This is essentially the same as old CHFMC, except that a ! new output value, -3, was added February 1989. (Formerly, -3 ! and +3 were lumped together in the single value 3.) Codes that ! flag nonmonotonicity by "IF (ISMON == 2)" need not be changed. ! Codes that check via "IF (ISMON >= 3)" should change the test to ! "IF (IABS(ISMON) >= 3)". Codes that declare monotonicity via ! "IF (ISMON <= 1)" should change to "IF (IABS(ISMON) <= 1)". ! ! REFER TO PCHCM ! !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 820518 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 831201 Changed from ISIGN to SIGN to correct bug that ! produced wrong sign when -1 < DELTA < 0 . ! 890206 Added SAVE statements. ! 890207 Added sign to returned value ISMON=3 and corrected ! argument description accordingly. ! 890306 Added caution about changed output. ! 890407 Changed name from CHFMC to CHFCM, as requested at the ! March 1989 SLATEC CML meeting, and made a few other ! minor modifications necessitated by this change. ! 890407 Converted to new SLATEC format. ! 890407 Modified DESCRIPTION to LDOC format. ! 891214 Moved SAVE statements. (WRB) !***END PROLOGUE CHFCM ! ! Fortran intrinsics used: SIGN. ! Other routines used: R1MACH. ! ! ---------------------------------------------------------------------- ! ! Programming notes: ! ! TEN is actually a tuning parameter, which determines the width of ! the fuzz around the elliptical boundary. ! ! To produce a double precision version, simply: ! a. Change CHFCM to DCHFCM wherever it occurs, ! b. Change the real declarations to double precision, and ! c. Change the constants ZERO, ONE, ... to double precision. ! ! DECLARE ARGUMENTS. ! REAL D1, D2, DELTA ! ! DECLARE LOCAL VARIABLES. ! INTEGER ISMON, ITRUE REAL A, B, EPS, FOUR, ONE, PHI, TEN, THREE, TWO, ZERO SAVE ZERO, ONE, TWO, THREE, FOUR SAVE TEN ! ! INITIALIZE. ! DATA ZERO /0./, ONE /1.0/, TWO /2./, THREE /3./, FOUR /4./, & TEN /10./ ! ! MACHINE-DEPENDENT PARAMETER -- SHOULD BE ABOUT 10*UROUND. !***FIRST EXECUTABLE STATEMENT CHFCM EPS = TEN*R1MACH(4) ! ! MAKE THE CHECK. ! if (DELTA == ZERO) THEN ! CASE OF CONSTANT DATA. if ((D1 == ZERO) .AND. (D2 == ZERO)) THEN ISMON = 0 ELSE ISMON = 2 ENDIF ELSE ! DATA IS NOT CONSTANT -- PICK UP SIGN. ITRUE = SIGN (ONE, DELTA) A = D1/DELTA B = D2/DELTA if ((A < ZERO) .OR. (B < ZERO)) THEN ISMON = 2 ELSE if ((A <= THREE-EPS) .AND. (B <= THREE-EPS)) THEN ! INSIDE SQUARE (0,3)X(0,3) IMPLIES OK. ISMON = ITRUE ELSE if ((A > FOUR+EPS) .AND. (B > FOUR+EPS)) THEN ! OUTSIDE SQUARE (0,4)X(0,4) IMPLIES NONMONOTONIC. ISMON = 2 ELSE ! MUST CHECK AGAINST BOUNDARY OF ELLIPSE. A = A - TWO B = B - TWO PHI = ((A*A + B*B) + A*B) - THREE if (PHI < -EPS) THEN ISMON = ITRUE ELSE if (PHI > EPS) THEN ISMON = 2 ELSE ! TO CLOSE TO BOUNDARY TO TELL, ! IN THE PRESENCE OF ROUND-OFF ERRORS. ISMON = 3*ITRUE ENDIF ENDIF end if ! ! return VALUE. ! CHFCM = ISMON return !------------- LAST LINE OF CHFCM FOLLOWS ------------------------------ end subroutine CHFDV (X1, X2, F1, F2, D1, D2, NE, XE, FE, DE, NEXT, & IERR) ! !! CHFDV evaluates a cubic polynomial given in Hermite form and its ... ! first derivative at an array of points. While designed for ... ! use by PCHFD, it may be useful directly as an evaluator ... ! for a piecewise cubic Hermite function in applications, ... ! such as graphing, where the interval is known in advance. ... ! If only function values are required, use CHFEV instead. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3, H1 !***TYPE SINGLE PRECISION (CHFDV-S, DCHFDV-D) !***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, ! CUBIC POLYNOMIAL EVALUATION, PCHIP !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! CHFDV: Cubic Hermite Function and Derivative Evaluator ! ! Evaluates the cubic polynomial determined by function values ! F1,F2 and derivatives D1,D2 on interval (X1,X2), together with ! its first derivative, at the points XE(J), J=1(1)NE. ! ! If only function values are required, use CHFEV, instead. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! INTEGER NE, NEXT(2), IERR ! REAL X1, X2, F1, F2, D1, D2, XE(NE), FE(NE), DE(NE) ! ! call CHFDV (X1,X2, F1,F2, D1,D2, NE, XE, FE, DE, NEXT, IERR) ! ! Parameters: ! ! X1,X2 -- (input) endpoints of interval of definition of cubic. ! (Error return if X1 == X2 .) ! ! F1,F2 -- (input) values of function at X1 and X2, respectively. ! ! D1,D2 -- (input) values of derivative at X1 and X2, respectively. ! ! NE -- (input) number of evaluation points. (Error return if ! NE < 1 .) ! ! XE -- (input) real array of points at which the functions are to ! be evaluated. If any of the XE are outside the interval ! [X1,X2], a warning error is returned in NEXT. ! ! FE -- (output) real array of values of the cubic function defined ! by X1,X2, F1,F2, D1,D2 at the points XE. ! ! DE -- (output) real array of values of the first derivative of ! the same function at the points XE. ! ! NEXT -- (output) integer array indicating number of extrapolation ! points: ! NEXT(1) = number of evaluation points to left of interval. ! NEXT(2) = number of evaluation points to right of interval. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -1 if NE < 1 . ! IERR = -2 if X1 == X2 . ! (Output arrays have not been changed in either case.) ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811019 DATE WRITTEN ! 820803 Minor cosmetic changes for release 1. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE CHFDV ! Programming notes: ! ! To produce a double precision version, simply: ! a. Change CHFDV to DCHFDV wherever it occurs, ! b. Change the real declaration to double precision, and ! c. Change the constant ZERO to double precision. ! ! DECLARE ARGUMENTS. ! INTEGER NE, NEXT(2), IERR REAL X1, X2, F1, F2, D1, D2, XE(*), FE(*), DE(*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I REAL C2, C2T2, C3, C3T3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO SAVE ZERO DATA ZERO /0./ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT CHFDV if (NE < 1) go to 5001 H = X2 - X1 if (H == ZERO) go to 5002 ! ! INITIALIZE. ! IERR = 0 NEXT(1) = 0 NEXT(2) = 0 XMI = MIN(ZERO, H) XMA = MAX(ZERO, H) ! ! COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). ! DELTA = (F2 - F1)/H DEL1 = (D1 - DELTA)/H DEL2 = (D2 - DELTA)/H ! (DELTA IS NO LONGER NEEDED.) C2 = -(DEL1+DEL1 + DEL2) C2T2 = C2 + C2 C3 = (DEL1 + DEL2)/H ! (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) C3T3 = C3+C3+C3 ! ! EVALUATION LOOP. ! DO 500 I = 1, NE X = XE(I) - X1 FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) DE(I) = D1 + X*(C2T2 + X*C3T3) ! COUNT EXTRAPOLATION POINTS. if ( X < XMI ) NEXT(1) = NEXT(1) + 1 if ( X > XMA ) NEXT(2) = NEXT(2) + 1 ! (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) 500 CONTINUE ! ! NORMAL RETURN. ! return ! ! ERROR RETURNS. ! 5001 CONTINUE ! NE < 1 RETURN. IERR = -1 call XERMSG ('SLATEC', 'CHFDV', & 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) return ! 5002 CONTINUE ! X1 == X2 RETURN. IERR = -2 call XERMSG ('SLATEC', 'CHFDV', 'INTERVAL ENDPOINTS EQUAL', IERR, & 1) return !------------- LAST LINE OF CHFDV FOLLOWS ------------------------------ end subroutine CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR) ! !! CHFEV evaluates a cubic polynomial given in Hermite form at an ... ! array of points. While designed for use by PCHFE, it may ... ! be useful directly as an evaluator for a piecewise cubic ... ! Hermite function in applications, such as graphing, where ... ! the interval is known in advance. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3 !***TYPE SINGLE PRECISION (CHFEV-S, DCHFEV-D) !***KEYWORDS CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION, ! PCHIP !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! CHFEV: Cubic Hermite Function EValuator ! ! Evaluates the cubic polynomial determined by function values ! F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points ! XE(J), J=1(1)NE. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! INTEGER NE, NEXT(2), IERR ! REAL X1, X2, F1, F2, D1, D2, XE(NE), FE(NE) ! ! call CHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR) ! ! Parameters: ! ! X1,X2 -- (input) endpoints of interval of definition of cubic. ! (Error return if X1 == X2 .) ! ! F1,F2 -- (input) values of function at X1 and X2, respectively. ! ! D1,D2 -- (input) values of derivative at X1 and X2, respectively. ! ! NE -- (input) number of evaluation points. (Error return if ! NE < 1 .) ! ! XE -- (input) real array of points at which the function is to be ! evaluated. If any of the XE are outside the interval ! [X1,X2], a warning error is returned in NEXT. ! ! FE -- (output) real array of values of the cubic function defined ! by X1,X2, F1,F2, D1,D2 at the points XE. ! ! NEXT -- (output) integer array indicating number of extrapolation ! points: ! NEXT(1) = number of evaluation points to left of interval. ! NEXT(2) = number of evaluation points to right of interval. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -1 if NE < 1 . ! IERR = -2 if X1 == X2 . ! (The FE-array has not been changed in either case.) ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811019 DATE WRITTEN ! 820803 Minor cosmetic changes for release 1. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890703 Corrected category record. (WRB) ! 890703 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE CHFEV ! Programming notes: ! ! To produce a double precision version, simply: ! a. Change CHFEV to DCHFEV wherever it occurs, ! b. Change the real declaration to double precision, and ! c. Change the constant ZERO to double precision. ! ! DECLARE ARGUMENTS. ! INTEGER NE, NEXT(2), IERR REAL X1, X2, F1, F2, D1, D2, XE(*), FE(*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I REAL C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO SAVE ZERO DATA ZERO /0./ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT CHFEV if (NE < 1) go to 5001 H = X2 - X1 if (H == ZERO) go to 5002 ! ! INITIALIZE. ! IERR = 0 NEXT(1) = 0 NEXT(2) = 0 XMI = MIN(ZERO, H) XMA = MAX(ZERO, H) ! ! COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). ! DELTA = (F2 - F1)/H DEL1 = (D1 - DELTA)/H DEL2 = (D2 - DELTA)/H ! (DELTA IS NO LONGER NEEDED.) C2 = -(DEL1+DEL1 + DEL2) C3 = (DEL1 + DEL2)/H ! (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) ! ! EVALUATION LOOP. ! DO 500 I = 1, NE X = XE(I) - X1 FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) ! COUNT EXTRAPOLATION POINTS. if ( X < XMI ) NEXT(1) = NEXT(1) + 1 if ( X > XMA ) NEXT(2) = NEXT(2) + 1 ! (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) 500 CONTINUE ! ! NORMAL RETURN. ! return ! ! ERROR RETURNS. ! 5001 CONTINUE ! NE < 1 RETURN. IERR = -1 call XERMSG ('SLATEC', 'CHFEV', & 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) return ! 5002 CONTINUE ! X1 == X2 RETURN. IERR = -2 call XERMSG ('SLATEC', 'CHFEV', 'INTERVAL ENDPOINTS EQUAL', IERR, & 1) return end FUNCTION CHFIE (X1, X2, F1, F2, D1, D2, A, B) ! !! CHFIE evaluates the integral of a single cubic for PCHIA. ! !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (CHFIE-S, DCHFIE-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! CHFIE: Cubic Hermite Function Integral Evaluator. ! ! Called by PCHIA to evaluate the integral of a single cubic (in ! Hermite form) over an arbitrary interval (A,B). ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! REAL X1, X2, F1, F2, D1, D2, A, B ! REAL VALUE, CHFIE ! ! VALUE = CHFIE (X1, X2, F1, F2, D1, D2, A, B) ! ! Parameters: ! ! VALUE -- (output) value of the requested integral. ! ! X1,X2 -- (input) endpoints if interval of definition of cubic. ! ! F1,F2 -- (input) function values at the ends of the interval. ! ! D1,D2 -- (input) derivative values at the ends of the interval. ! ! A,B -- (input) endpoints of interval of integration. ! !***SEE ALSO PCHIA !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820730 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 870813 Minor cosmetic changes. ! 890411 1. Added SAVE statements (Vers. 3.2). ! 2. Added SIX to REAL declaration. ! 890411 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR section in prologue. (WRB) ! 930503 Corrected to set VALUE=0 when IERR.ne.0. (FNF) ! 930504 Eliminated IERR and changed name from CHFIV to CHFIE. (FNF) !***END PROLOGUE CHFIE ! ! Programming notes: ! 1. There is no error return from this routine because zero is ! indeed the mathematically correct answer when X1 == X2 . !**End ! ! DECLARE ARGUMENTS. ! REAL CHFIE REAL X1, X2, F1, F2, D1, D2, A, B ! ! DECLARE LOCAL VARIABLES. ! REAL DTERM, FOUR, FTERM, H, HALF, PHIA1, PHIA2, PHIB1, PHIB2, & PSIA1, PSIA2, PSIB1, PSIB2, SIX, TA1, TA2, TB1, TB2, THREE, & TWO, UA1, UA2, UB1, UB2 SAVE HALF, TWO, THREE, FOUR, SIX ! ! INITIALIZE. ! DATA HALF /0.5/, TWO /2./, THREE /3./, FOUR /4./, SIX /6./ ! ! VALIDITY CHECK INPUT. ! !***FIRST EXECUTABLE STATEMENT CHFIE if (X1 == X2) THEN CHFIE = 0 ELSE H = X2 - X1 TA1 = (A - X1) / H TA2 = (X2 - A) / H TB1 = (B - X1) / H TB2 = (X2 - B) / H ! UA1 = TA1**3 PHIA1 = UA1 * (TWO - TA1) PSIA1 = UA1 * (THREE*TA1 - FOUR) UA2 = TA2**3 PHIA2 = UA2 * (TWO - TA2) PSIA2 = -UA2 * (THREE*TA2 - FOUR) ! UB1 = TB1**3 PHIB1 = UB1 * (TWO - TB1) PSIB1 = UB1 * (THREE*TB1 - FOUR) UB2 = TB2**3 PHIB2 = UB2 * (TWO - TB2) PSIB2 = -UB2 * (THREE*TB2 - FOUR) FTERM = F1*(PHIA2 - PHIB2) + F2*(PHIB1 - PHIA1) DTERM = ( D1*(PSIA2 - PSIB2) + D2*(PSIB1 - PSIA1) )*(H/SIX) CHFIE = (HALF*H) * (FTERM + DTERM) end if return end subroutine CHICO (A, LDA, N, KPVT, RCOND, Z) ! !! CHICO factors a complex Hermitian matrix by elimination with symmetric ... ! pivoting and estimate the condition of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1A !***TYPE COMPLEX (SSICO-S, DSICO-D, CHICO-C, CSICO-C) !***KEYWORDS CONDITION NUMBER, HERMITIAN, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CHICO factors a complex Hermitian matrix by elimination with ! symmetric pivoting and estimates the condition of the matrix. ! ! If RCOND is not needed, CHIFA is slightly faster. ! To solve A*X = B , follow CHICO by CHISL. ! To compute INVERSE(A)*C , follow CHICO by CHISL. ! To compute INVERSE(A) , follow CHICO by CHIDI. ! To compute DETERMINANT(A) , follow CHICO by CHIDI. ! To compute INERTIA(A), follow CHICO by CHIDI. ! ! On Entry ! ! A COMPLEX(LDA, N) ! the Hermitian matrix to be factored. ! Only the diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! Output ! ! A a block diagonal matrix and the multipliers which ! were used to obtain it. ! The factorization can be written A = U*D*CTRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , CTRANS(U) is the ! conjugate transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KVPT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC, CHIFA, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CHICO INTEGER LDA,N,KPVT(*) COMPLEX A(LDA,*),Z(*) REAL RCOND ! COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,EK,T REAL ANORM,S,SCASUM,YNORM INTEGER I,INFO,J,JM1,K,KP,KPS,KS COMPLEX ZDUM,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT CHICO DO 30 J = 1, N Z(J) = CMPLX(SCASUM(J,A(1,J),1),0.0E0) JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 Z(I) = CMPLX(REAL(Z(I))+CABS1(A(I,J)),0.0E0) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,REAL(Z(J))) 40 CONTINUE ! ! FACTOR ! call CHIFA(A,LDA,N,KPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE U*D*W = E ! EK = (1.0E0,0.0E0) DO 50 J = 1, N Z(J) = (0.0E0,0.0E0) 50 CONTINUE K = N 60 if (K == 0) go to 120 KS = 1 if (KPVT(K) < 0) KS = 2 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE if (CABS1(Z(K)) /= 0.0E0) EK = CSIGN1(EK,Z(K)) Z(K) = Z(K) + EK call CAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) if (KS == 1) go to 80 if (CABS1(Z(K-1)) /= 0.0E0) EK = CSIGN1(EK,Z(K-1)) Z(K-1) = Z(K-1) + EK call CAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) 80 CONTINUE if (KS == 2) go to 100 if (CABS1(Z(K)) <= CABS1(A(K,K))) go to 90 S = CABS1(A(K,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) EK = CMPLX(S,0.0E0)*EK 90 CONTINUE if (CABS1(A(K,K)) /= 0.0E0) Z(K) = Z(K)/A(K,K) if (CABS1(A(K,K)) == 0.0E0) Z(K) = (1.0E0,0.0E0) go to 110 100 CONTINUE AK = A(K,K)/CONJG(A(K-1,K)) AKM1 = A(K-1,K-1)/A(K-1,K) BK = Z(K)/CONJG(A(K-1,K)) BKM1 = Z(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0E0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 110 CONTINUE K = K - KS go to 60 120 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! ! SOLVE CTRANS(U)*Y = W ! K = 1 130 if (K > N) go to 160 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 150 Z(K) = Z(K) + CDOTC(K-1,A(1,K),1,Z(1),1) if (KS == 2) & Z(K+1) = Z(K+1) + CDOTC(K-1,A(1,K+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE K = K + KS go to 130 160 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE U*D*V = Y ! K = N 170 if (K == 0) go to 230 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == KS) go to 190 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 180 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 180 CONTINUE call CAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) if (KS == 2) call CAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) 190 CONTINUE if (KS == 2) go to 210 if (CABS1(Z(K)) <= CABS1(A(K,K))) go to 200 S = CABS1(A(K,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 200 CONTINUE if (CABS1(A(K,K)) /= 0.0E0) Z(K) = Z(K)/A(K,K) if (CABS1(A(K,K)) == 0.0E0) Z(K) = (1.0E0,0.0E0) go to 220 210 CONTINUE AK = A(K,K)/CONJG(A(K-1,K)) AKM1 = A(K-1,K-1)/A(K-1,K) BK = Z(K)/CONJG(A(K-1,K)) BKM1 = Z(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0E0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 220 CONTINUE K = K - KS go to 170 230 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE CTRANS(U)*Z = V ! K = 1 240 if (K > N) go to 270 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 260 Z(K) = Z(K) + CDOTC(K-1,A(1,K),1,Z(1),1) if (KS == 2) & Z(K+1) = Z(K+1) + CDOTC(K-1,A(1,K+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE K = K + KS go to 240 270 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine CHIDI (A, LDA, N, KPVT, DET, INERT, WORK, JOB) ! !! CHIDI computes the determinant, inertia and inverse of a complex ... ! Hermitian matrix using the factors obtained from CHIFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1A, D3D1A !***TYPE COMPLEX (SSIDI-S, DSISI-D, CHIDI-C, CSIDI-C) !***KEYWORDS DETERMINANT, HERMITIAN, INVERSE, LINEAR ALGEBRA, LINPACK, ! MATRIX !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CHIDI computes the determinant, inertia and inverse ! of a complex Hermitian matrix using the factors from CHIFA. ! ! On Entry ! ! A COMPLEX(LDA,N) ! the output from CHIFA. ! ! LDA INTEGER ! the leading dimension of the array A. ! ! N INTEGER ! the order of the matrix A. ! ! KVPT INTEGER(N) ! the pivot vector from CHIFA. ! ! WORK COMPLEX(N) ! work vector. Contents destroyed. ! ! JOB INTEGER ! JOB has the decimal expansion ABC where ! if C /= 0, the inverse is computed, ! if B /= 0, the determinant is computed, ! if A /= 0, the inertia is computed. ! ! For example, JOB = 111 gives all three. ! ! On Return ! ! Variables not requested by JOB are not used. ! ! A contains the upper triangle of the inverse of ! the original matrix. The strict lower triangle ! is never referenced. ! ! DET REAL(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0. ! ! INERT INTEGER(3) ! the inertia of the original matrix. ! INERT(1) = number of positive eigenvalues. ! INERT(2) = number of negative eigenvalues. ! INERT(3) = number of zero eigenvalues. ! ! Error Condition ! ! A division by zero may occur if the inverse is requested ! and CHICO has set RCOND == 0.0 ! or CHIFA has set INFO /= 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CCOPY, CDOTC, CSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CHIDI INTEGER LDA,N,JOB COMPLEX A(LDA,*),WORK(*) REAL DET(2) INTEGER KPVT(*),INERT(3) ! COMPLEX AKKP1,CDOTC,TEMP REAL TEN,D,T,AK,AKP1 INTEGER J,JB,K,KM1,KS,KSTEP LOGICAL NOINV,NODET,NOERT !***FIRST EXECUTABLE STATEMENT CHIDI NOINV = MOD(JOB,10) == 0 NODET = MOD(JOB,100)/10 == 0 NOERT = MOD(JOB,1000)/100 == 0 ! 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 DO 130 K = 1, N D = REAL(A(K,K)) ! ! CHECK if 1 BY 1 ! if (KPVT(K) > 0) go to 50 ! ! 2 BY 2 BLOCK ! USE DET (D S) = (D/T * C - T) * T , T = ABS(S) ! (S C) ! TO AVOID UNDERFLOW/OVERFLOW TROUBLES. ! TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. ! if (T /= 0.0E0) go to 30 T = ABS(A(K,K+1)) D = (D/T)*REAL(A(K+1,K+1)) - T go to 40 30 CONTINUE D = T T = 0.0E0 40 CONTINUE 50 CONTINUE ! if (NOERT) go to 60 if (D > 0.0E0) INERT(1) = INERT(1) + 1 if (D < 0.0E0) INERT(2) = INERT(2) + 1 if (D == 0.0E0) INERT(3) = INERT(3) + 1 60 CONTINUE ! if (NODET) go to 120 DET(1) = D*DET(1) if (DET(1) == 0.0E0) go to 110 70 if (ABS(DET(1)) >= 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)) < TEN) go to 100 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 go to 90 100 CONTINUE 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE ! ! COMPUTE INVERSE(A) ! if (NOINV) go to 270 K = 1 150 if (K > N) go to 260 KM1 = K - 1 if (KPVT(K) < 0) go to 180 ! ! 1 BY 1 ! A(K,K) = CMPLX(1.0E0/REAL(A(K,K)),0.0E0) if (KM1 < 1) go to 170 call CCOPY(KM1,A(1,K),1,WORK,1) DO 160 J = 1, KM1 A(J,K) = CDOTC(J,A(1,J),1,WORK,1) call CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 160 CONTINUE A(K,K) = A(K,K) & + CMPLX(REAL(CDOTC(KM1,WORK,1,A(1,K),1)), & 0.0E0) 170 CONTINUE KSTEP = 1 go to 220 180 CONTINUE ! ! 2 BY 2 ! T = ABS(A(K,K+1)) AK = REAL(A(K,K))/T AKP1 = REAL(A(K+1,K+1))/T AKKP1 = A(K,K+1)/T D = T*(AK*AKP1 - 1.0E0) A(K,K) = CMPLX(AKP1/D,0.0E0) A(K+1,K+1) = CMPLX(AK/D,0.0E0) A(K,K+1) = -AKKP1/D if (KM1 < 1) go to 210 call CCOPY(KM1,A(1,K+1),1,WORK,1) DO 190 J = 1, KM1 A(J,K+1) = CDOTC(J,A(1,J),1,WORK,1) call CAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1) 190 CONTINUE A(K+1,K+1) = A(K+1,K+1) & + CMPLX(REAL(CDOTC(KM1,WORK,1,A(1,K+1), & 1)),0.0E0) A(K,K+1) = A(K,K+1) + CDOTC(KM1,A(1,K),1,A(1,K+1),1) call CCOPY(KM1,A(1,K),1,WORK,1) DO 200 J = 1, KM1 A(J,K) = CDOTC(J,A(1,J),1,WORK,1) call CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 200 CONTINUE A(K,K) = A(K,K) & + CMPLX(REAL(CDOTC(KM1,WORK,1,A(1,K),1)), & 0.0E0) 210 CONTINUE KSTEP = 2 220 CONTINUE ! ! SWAP ! KS = ABS(KPVT(K)) if (KS == K) go to 250 call CSWAP(KS,A(1,KS),1,A(1,K),1) DO 230 JB = KS, K J = K + KS - JB TEMP = CONJG(A(J,K)) A(J,K) = CONJG(A(KS,J)) A(KS,J) = TEMP 230 CONTINUE if (KSTEP == 1) go to 240 TEMP = A(KS,K+1) A(KS,K+1) = A(K,K+1) A(K,K+1) = TEMP 240 CONTINUE 250 CONTINUE K = K + KSTEP go to 150 260 CONTINUE 270 CONTINUE return end subroutine CHIEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO) ! !! CHIEV computes the eigenvalues and, optionally, the eigenvectors ... ! of a complex Hermitian matrix. ! !***LIBRARY SLATEC !***CATEGORY D4A3 !***TYPE COMPLEX (SSIEV-S, CHIEV-C) !***KEYWORDS COMPLEX HERMITIAN, EIGENVALUES, EIGENVECTORS, MATRIX, ! SYMMETRIC !***AUTHOR Kahaner, D. K., (NBS) ! Moler, C. B., (U. of New Mexico) ! Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! David Kahaner, Cleve Moler, G. W. Stewart, ! N.B.S. U.N.M. N.B.S./U.MD. ! ! Abstract ! CHIEV computes the eigenvalues and, optionally, ! the eigenvectors of a complex Hermitian matrix. ! ! Call Sequence Parameters- ! (the values of parameters marked with * (star) will be changed ! by CHIEV.) ! ! A* COMPLEX(LDA,N) ! complex Hermitian input matrix. ! Only the upper triangle of A need be ! filled in. Elements on diagonal must be real. ! ! LDA INTEGER ! set by the user to ! the leading dimension of the complex array A. ! ! N INTEGER ! set by the user to ! the order of the matrices A and V, and ! the number of elements in E. ! ! E* REAL(N) ! on return from CHIEV E contains the eigenvalues of A. ! See also INFO below. ! ! V* COMPLEX(LDV,N) ! on return from CHIEV if the user has set JOB ! = 0 V is not referenced. ! = nonzero the N eigenvectors of A are stored in the ! first N columns of V. See also INFO below. ! ! LDV INTEGER ! set by the user to ! the leading dimension of the array V if JOB is also ! set nonzero. In that case N must be <= LDV. ! If JOB is set to zero LDV is not referenced. ! ! WORK* REAL(4N) ! temporary storage vector. Contents changed by CHIEV. ! ! JOB INTEGER ! set by the user to ! = 0 eigenvalues only to be calculated by CHIEV. ! Neither V nor LDV are referenced. ! = nonzero eigenvalues and vectors to be calculated. ! In this case A and V must be distinct arrays ! also if LDA > LDV CHIEV changes all the ! elements of A thru column N. If LDA < LDV ! CHIEV changes all the elements of V through ! column N. If LDA = LDV only A(I,J) and V(I, ! J) for I,J = 1,...,N are changed by CHIEV. ! ! INFO* INTEGER ! on return from CHIEV the value of INFO is ! = 0 normal return, calculation successful. ! = K if the eigenvalue iteration fails to converge, ! eigenvalues (and eigenvectors if requested) ! 1 through K-1 are correct. ! ! Error Messages ! No. 1 recoverable N is greater than LDA ! No. 2 recoverable N is less than one. ! No. 3 recoverable JOB is nonzero and N is greater than LDV ! No. 4 warning LDA > LDV, elements of A other than the ! N by N input elements have been changed ! No. 5 warning LDA < LDV, elements of V other than the ! N by N output elements have been changed ! No. 6 recoverable nonreal element on diagonal of A. ! !***REFERENCES (NONE) !***ROUTINES CALLED HTRIBK, HTRIDI, IMTQL2, SCOPY, SCOPYM, TQLRAT, ! XERMSG !***REVISION HISTORY (YYMMDD) ! 800808 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE CHIEV INTEGER I,INFO,J,JOB,K,L,LDA,LDV,M,MDIM,N REAL A(*),E(*),WORK(*),V(*) !***FIRST EXECUTABLE STATEMENT CHIEV if (N > LDA) call XERMSG ('SLATEC', 'CHIEV', 'N > LDA.', 1, & 1) if ( N > LDA) RETURN if (N < 1) call XERMSG ('SLATEC', 'CHIEV', 'N < 1', 2, 1) if ( N < 1) RETURN if ( N == 1 .AND. JOB == 0) go to 35 MDIM = 2 * LDA if ( JOB == 0) go to 5 if (N > LDV) call XERMSG ('SLATEC', 'CHIEV', & 'JOB /= 0 AND N > LDV.', 3, 1) if ( N > LDV) RETURN if ( N == 1) go to 35 ! ! REARRANGE A if NECESSARY WHEN LDA > LDV AND JOB /= 0 ! MDIM = MIN(MDIM,2 * LDV) if (LDA < LDV) call XERMSG ('SLATEC', 'CHIEV', & 'LDA < LDV, ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' // & 'ELEMENTS HAVE BEEN CHANGED.', 5, 0) if ( LDA <= LDV) go to 5 call XERMSG ('SLATEC', 'CHIEV', & 'LDA > LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' // & 'ELEMENTS HAVE BEEN CHANGED.', 4, 0) L = N - 1 DO 4 J=1,L M = 1+J*2*LDV K = 1+J*2*LDA call SCOPY(2*N,A(K),1,A(M),1) 4 CONTINUE 5 CONTINUE ! ! FILL IN LOWER TRIANGLE OF A, COLUMN BY COLUMN. ! DO 6 J = 1,N K = (J-1)*(MDIM+2)+1 if (A(K+1) /= 0.0) call XERMSG ('SLATEC', 'CHIEV', & 'NONREAL ELEMENT ON DIAGONAL OF A', 6, 1) if ( A(K+1) /= 0.0) RETURN call SCOPY(N-J+1,A(K),MDIM,A(K),2) call SCOPYM(N-J+1,A(K+1),MDIM,A(K+1),2) 6 CONTINUE ! ! SEPARATE REAL AND IMAGINARY PARTS ! DO 10 J = 1, N K = (J-1) * MDIM +1 L = K + N call SCOPY(N,A(K+1),2,WORK(1),1) call SCOPY(N,A(K),2,A(K),1) call SCOPY(N,WORK(1),1,A(L),1) 10 CONTINUE ! ! REDUCE A TO TRIDIAGONAL MATRIX. ! call HTRIDI(MDIM,N,A(1),A(N+1),E,WORK(1),WORK(N+1), & WORK(2*N+1)) if ( JOB /= 0) GOTO 15 ! ! EIGENVALUES ONLY. ! call TQLRAT(N,E,WORK(N+1),INFO) return ! ! EIGENVALUES AND EIGENVECTORS. ! 15 DO 17 J = 1,N K = (J-1) * MDIM + 1 M = K + N - 1 DO 16 I = K,M 16 V(I) = 0. I = K + J - 1 V(I) = 1. 17 CONTINUE call IMTQL2(MDIM,N,E,WORK(1),V,INFO) if ( INFO /= 0) RETURN call HTRIBK(MDIM,N,A(1),A(N+1),WORK(2*N+1),N,V(1),V(N+1)) ! ! CONVERT EIGENVECTORS TO COMPLEX STORAGE. ! DO 20 J = 1,N K = (J-1) * MDIM + 1 I = (J-1) * 2 * LDV + 1 L = K + N call SCOPY(N,V(K),1,WORK(1),1) call SCOPY(N,V(L),1,V(I+1),2) call SCOPY(N,WORK(1),1,V(I),2) 20 CONTINUE return ! ! TAKE CARE OF N=1 CASE. ! 35 if (A(2) /= 0.) call XERMSG ('SLATEC', 'CHIEV', & 'NONREAL ELEMENT ON DIAGONAL OF A', 6, 1) if ( A(2) /= 0.) RETURN E(1) = A(1) INFO = 0 if ( JOB == 0) RETURN V(1) = A(1) V(2) = 0. return end subroutine CHIFA (A, LDA, N, KPVT, INFO) ! !! CHIFA factors a complex Hermitian matrix by elimination (symmetric pivoting). ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1A !***TYPE COMPLEX (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C) !***KEYWORDS HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CHIFA factors a complex Hermitian matrix by elimination ! with symmetric pivoting. ! ! To solve A*X = B , follow CHIFA by CHISL. ! To compute INVERSE(A)*C , follow CHIFA by CHISL. ! To compute DETERMINANT(A) , follow CHIFA by CHIDI. ! To compute INERTIA(A) , follow CHIFA by CHIDI. ! To compute INVERSE(A) , follow CHIFA by CHIDI. ! ! On Entry ! ! A COMPLEX(LDA,N) ! the Hermitian matrix to be factored. ! Only the diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A a block diagonal matrix and the multipliers which ! were used to obtain it. ! The factorization can be written A = U*D*CTRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , CTRANS(U) is the ! conjugate transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KVPT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th pivot block is singular. This is ! not an error condition for this subroutine, ! but it does indicate that CHISL or CHIDI may ! divide by zero if called. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSWAP, ICAMAX !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CHIFA INTEGER LDA,N,KPVT(*),INFO COMPLEX A(LDA,*) ! COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T REAL ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,ICAMAX LOGICAL SWAP COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT CHIFA ! ! INITIALIZE ! ! ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ! ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 ! INFO = 0 ! ! MAIN LOOP ON K, WHICH GOES FROM N TO 1. ! K = N 10 CONTINUE ! ! LEAVE THE LOOP if K=0 OR K=1. ! if (K == 0) go to 200 if (K > 1) go to 20 KPVT(1) = 1 if (CABS1(A(1,1)) == 0.0E0) INFO = 1 go to 200 20 CONTINUE ! ! THIS SECTION OF CODE DETERMINES THE KIND OF ! ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, ! KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND ! SWAP WILL BE SET TO .TRUE. if AN INTERCHANGE IS ! REQUIRED. ! KM1 = K - 1 ABSAKK = CABS1(A(K,K)) ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! COLUMN K. ! IMAX = ICAMAX(K-1,A(1,K),1) COLMAX = CABS1(A(IMAX,K)) if (ABSAKK < ALPHA*COLMAX) go to 30 KSTEP = 1 SWAP = .FALSE. go to 90 30 CONTINUE ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! ROW IMAX. ! ROWMAX = 0.0E0 IMAXP1 = IMAX + 1 DO 40 J = IMAXP1, K ROWMAX = MAX(ROWMAX,CABS1(A(IMAX,J))) 40 CONTINUE if (IMAX == 1) go to 50 JMAX = ICAMAX(IMAX-1,A(1,IMAX),1) ROWMAX = MAX(ROWMAX,CABS1(A(JMAX,IMAX))) 50 CONTINUE if (CABS1(A(IMAX,IMAX)) < ALPHA*ROWMAX) go to 60 KSTEP = 1 SWAP = .TRUE. go to 80 60 CONTINUE if (ABSAKK < ALPHA*COLMAX*(COLMAX/ROWMAX)) go to 70 KSTEP = 1 SWAP = .FALSE. go to 80 70 CONTINUE KSTEP = 2 SWAP = IMAX /= KM1 80 CONTINUE 90 CONTINUE if (MAX(ABSAKK,COLMAX) /= 0.0E0) go to 100 ! ! COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. ! KPVT(K) = K INFO = K go to 190 100 CONTINUE if (KSTEP == 2) go to 140 ! ! 1 X 1 PIVOT BLOCK. ! if (.NOT.SWAP) go to 120 ! ! PERFORM AN INTERCHANGE. ! call CSWAP(IMAX,A(1,IMAX),1,A(1,K),1) DO 110 JJ = IMAX, K J = K + IMAX - JJ T = CONJG(A(J,K)) A(J,K) = CONJG(A(IMAX,J)) A(IMAX,J) = T 110 CONTINUE 120 CONTINUE ! ! PERFORM THE ELIMINATION. ! DO 130 JJ = 1, KM1 J = K - JJ MULK = -A(J,K)/A(K,K) T = CONJG(MULK) call CAXPY(J,T,A(1,K),1,A(1,J),1) A(J,J) = CMPLX(REAL(A(J,J)),0.0E0) A(J,K) = MULK 130 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = K if (SWAP) KPVT(K) = IMAX go to 190 140 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (.NOT.SWAP) go to 160 ! ! PERFORM AN INTERCHANGE. ! call CSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) DO 150 JJ = IMAX, KM1 J = KM1 + IMAX - JJ T = CONJG(A(J,K-1)) A(J,K-1) = CONJG(A(IMAX,J)) A(IMAX,J) = T 150 CONTINUE T = A(K-1,K) A(K-1,K) = A(IMAX,K) A(IMAX,K) = T 160 CONTINUE ! ! PERFORM THE ELIMINATION. ! KM2 = K - 2 if (KM2 == 0) go to 180 AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/CONJG(A(K-1,K)) DENOM = 1.0E0 - AK*AKM1 DO 170 JJ = 1, KM2 J = KM1 - JJ BK = A(J,K)/A(K-1,K) BKM1 = A(J,K-1)/CONJG(A(K-1,K)) MULK = (AKM1*BK - BKM1)/DENOM MULKM1 = (AK*BKM1 - BK)/DENOM T = CONJG(MULK) call CAXPY(J,T,A(1,K),1,A(1,J),1) T = CONJG(MULKM1) call CAXPY(J,T,A(1,K-1),1,A(1,J),1) A(J,K) = MULK A(J,K-1) = MULKM1 A(J,J) = CMPLX(REAL(A(J,J)),0.0E0) 170 CONTINUE 180 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = 1 - K if (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE K = K - KSTEP go to 10 200 CONTINUE return end subroutine CHISL (A, LDA, N, KPVT, B) ! !! CHISL solves the complex Hermitian system using factors obtained from CHIFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1A !***TYPE COMPLEX (SSISL-S, DSISL-D, CHISL-C, CSISL-C) !***KEYWORDS HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CHISL solves the complex Hermitian system ! A * X = B ! using the factors computed by CHIFA. ! ! On Entry ! ! A COMPLEX(LDA,N) ! the output from CHIFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! KVPT INTEGER(N) ! the pivot vector from CHIFA. ! ! B COMPLEX(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero may occur if CHICO has set RCOND == 0.0 ! or CHIFA has set INFO /= 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call CHIFA(A,LDA,N,KVPT,INFO) ! if (INFO /= 0) go to ... ! DO 10 J = 1, p ! call CHISL(A,LDA,N,KVPT,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CHISL INTEGER LDA,N,KPVT(*) COMPLEX A(LDA,*),B(*) ! COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,TEMP INTEGER K,KP ! ! LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND ! D INVERSE TO B. ! !***FIRST EXECUTABLE STATEMENT CHISL K = N 10 if (K == 0) go to 80 if (KPVT(K) < 0) go to 40 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 30 KP = KPVT(K) if (KP == K) go to 20 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call CAXPY(K-1,B(K),A(1,K),1,B(1),1) 30 CONTINUE ! ! APPLY D INVERSE. ! B(K) = B(K)/A(K,K) K = K - 1 go to 70 40 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (K == 2) go to 60 KP = ABS(KPVT(K)) if (KP == K - 1) go to 50 ! ! INTERCHANGE. ! TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call CAXPY(K-2,B(K),A(1,K),1,B(1),1) call CAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) 60 CONTINUE ! ! APPLY D INVERSE. ! AK = A(K,K)/CONJG(A(K-1,K)) AKM1 = A(K-1,K-1)/A(K-1,K) BK = B(K)/CONJG(A(K-1,K)) BKM1 = B(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0E0 B(K) = (AKM1*BK - BKM1)/DENOM B(K-1) = (AK*BKM1 - BK)/DENOM K = K - 2 70 CONTINUE go to 10 80 CONTINUE ! ! LOOP FORWARD APPLYING THE TRANSFORMATIONS. ! K = 1 90 if (K > N) go to 160 if (KPVT(K) < 0) go to 120 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 110 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + CDOTC(K-1,A(1,K),1,B(1),1) KP = KPVT(K) if (KP == K) go to 100 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 100 CONTINUE 110 CONTINUE K = K + 1 go to 150 120 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (K == 1) go to 140 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + CDOTC(K-1,A(1,K),1,B(1),1) B(K+1) = B(K+1) + CDOTC(K-1,A(1,K+1),1,B(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 130 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 130 CONTINUE 140 CONTINUE K = K + 2 150 CONTINUE go to 90 160 CONTINUE return end subroutine CHKDER (M, N, X, FVEC, FJAC, LDFJAC, XP, FVECP, MODE, ERR) ! !! CHKDER checks the gradients of M nonlinear functions in N variables, ... ! evaluated at a point X, for consistency with the functions themselves. ! !***LIBRARY SLATEC !***CATEGORY F3, G4C !***TYPE SINGLE PRECISION (CHKDER-S, DCKDER-D) !***KEYWORDS GRADIENTS, JACOBIAN, MINPACK, NONLINEAR !***AUTHOR Hiebert, K. L. (SNLA) !***DESCRIPTION ! ! This subroutine is a companion routine to SNLS1,SNLS1E,SNSQ,and ! SNSQE which may be used to check the calculation of the Jacobian. ! ! SUBROUTINE CHKDER ! ! This subroutine checks the gradients of M nonlinear functions ! in N variables, evaluated at a point X, for consistency with ! the functions themselves. The user must call CKDER twice, ! first with MODE = 1 and then with MODE = 2. ! ! MODE = 1. On input, X must contain the point of evaluation. ! On output, XP is set to a neighboring point. ! ! MODE = 2. On input, FVEC must contain the functions and the ! rows of FJAC must contain the gradients ! of the respective functions each evaluated ! at X, and FVECP must contain the functions ! evaluated at XP. ! On output, ERR contains measures of correctness of ! the respective gradients. ! ! The subroutine does not perform reliably if cancellation or ! rounding errors cause a severe loss of significance in the ! evaluation of a function. Therefore, none of the components ! of X should be unusually small (in particular, zero) or any ! other value which may cause loss of significance. ! ! The SUBROUTINE statement is ! ! SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) ! ! where ! ! M is a positive integer input variable set to the number ! of functions. ! ! N is a positive integer input variable set to the number ! of variables. ! ! X is an input array of length N. ! ! FVEC is an array of length M. On input when MODE = 2, ! FVEC must contain the functions evaluated at X. ! ! FJAC is an M by N array. On input when MODE = 2, ! the rows of FJAC must contain the gradients of ! the respective functions evaluated at X. ! ! LDFJAC is a positive integer input parameter not less than M ! which specifies the leading dimension of the array FJAC. ! ! XP is an array of length N. On output when MODE = 1, ! XP is set to a neighboring point of X. ! ! FVECP is an array of length M. On input when MODE = 2, ! FVECP must contain the functions evaluated at XP. ! ! MODE is an integer input variable set to 1 on the first call ! and 2 on the second. Other values of MODE are equivalent ! to MODE = 1. ! ! ERR is an array of length M. On output when MODE = 2, ! ERR contains measures of correctness of the respective ! gradients. If there is no severe loss of significance, ! then if ERR(I) is 1.0 the I-th gradient is correct, ! while if ERR(I) is 0.0 the I-th gradient is incorrect. ! For values of ERR between 0.0 and 1.0, the categorization ! is less certain. In general, a value of ERR(I) greater ! than 0.5 indicates that the I-th gradient is probably ! correct, while a value of ERR(I) less than 0.5 indicates ! that the I-th gradient is probably incorrect. ! !***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- ! tions. In Numerical Methods for Nonlinear Algebraic ! Equations, P. Rabinowitz, Editor. Gordon and Breach, ! 1988. !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CHKDER INTEGER M,N,LDFJAC,MODE REAL X(*),FVEC(*),FJAC(LDFJAC,*),XP(*),FVECP(*),ERR(*) INTEGER I,J REAL EPS,EPSF,EPSLOG,EPSMCH,FACTOR,ONE,TEMP,ZERO REAL R1MACH SAVE FACTOR, ONE, ZERO ! DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ !***FIRST EXECUTABLE STATEMENT CHKDER EPSMCH = R1MACH(4) ! EPS = SQRT(EPSMCH) ! if (MODE == 2) go to 20 ! ! MODE = 1. ! DO 10 J = 1, N TEMP = EPS*ABS(X(J)) if (TEMP == ZERO) TEMP = EPS XP(J) = X(J) + TEMP 10 CONTINUE go to 70 20 CONTINUE ! ! MODE = 2. ! EPSF = FACTOR*EPSMCH EPSLOG = LOG10(EPS) DO 30 I = 1, M ERR(I) = ZERO 30 CONTINUE DO 50 J = 1, N TEMP = ABS(X(J)) if (TEMP == ZERO) TEMP = ONE DO 40 I = 1, M ERR(I) = ERR(I) + TEMP*FJAC(I,J) 40 CONTINUE 50 CONTINUE DO 60 I = 1, M TEMP = ONE if (FVEC(I) /= ZERO .AND. FVECP(I) /= ZERO & .AND. ABS(FVECP(I)-FVEC(I)) >= EPSF*ABS(FVEC(I))) & TEMP = EPS*ABS((FVECP(I)-FVEC(I))/EPS-ERR(I)) & /(ABS(FVEC(I)) + ABS(FVECP(I))) ERR(I) = ONE if (TEMP > EPSMCH .AND. TEMP < EPS) & ERR(I) = (LOG10(TEMP) - EPSLOG)/EPSLOG if (TEMP >= EPS) ERR(I) = ZERO 60 CONTINUE 70 CONTINUE ! return ! ! LAST CARD OF SUBROUTINE CHKDER. ! end subroutine CHKPR4 (IORDER, A, B, M, MBDCND, C, D, N, NBDCND, COFX, & IDMN, IERROR) ! !! CHKPR4 subsidiary to SEPX4. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CHKPR4-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This program checks the input parameters for errors. ! !***SEE ALSO SEPX4 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CHKPR4 EXTERNAL COFX !***FIRST EXECUTABLE STATEMENT CHKPR4 IERROR = 1 if (A >= B .OR. C >= D) RETURN ! ! CHECK BOUNDARY SWITCHES ! IERROR = 2 if (MBDCND < 0 .OR. MBDCND > 4) RETURN IERROR = 3 if (NBDCND < 0 .OR. NBDCND > 4) RETURN ! ! CHECK FIRST DIMENSION IN CALLING ROUTINE ! IERROR = 5 if (IDMN < 7) RETURN ! ! CHECK M ! IERROR = 6 if (M > (IDMN-1) .OR. M < 6) RETURN ! ! CHECK N ! IERROR = 7 if (N < 5) RETURN ! ! CHECK IORDER ! IERROR = 8 if (IORDER /= 2 .AND. IORDER /= 4) RETURN ! ! CHECK THAT EQUATION IS ELLIPTIC ! DLX = (B-A)/M DO 30 I=2,M XI = A+(I-1)*DLX call COFX (XI,AI,BI,CI) if (AI > 0.0) go to 10 IERROR=10 return 10 CONTINUE 30 CONTINUE ! ! NO ERROR FOUND ! IERROR = 0 return end subroutine CHKPRM (INTL, IORDER, A, B, M, MBDCND, C, D, N, NBDCND, & COFX, COFY, IDMN, IERROR) ! !! CHKPRM is subsidiary to SEPELI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CHKPRM-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This program checks the input parameters for errors. ! !***SEE ALSO SEPELI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CHKPRM ! EXTERNAL COFX ,COFY !***FIRST EXECUTABLE STATEMENT CHKPRM IERROR = 1 if (A >= B .OR. C >= D) RETURN ! ! CHECK BOUNDARY SWITCHES ! IERROR = 2 if (MBDCND < 0 .OR. MBDCND > 4) RETURN IERROR = 3 if (NBDCND < 0 .OR. NBDCND > 4) RETURN ! ! CHECK FIRST DIMENSION IN CALLING ROUTINE ! IERROR = 5 if (IDMN < 7) RETURN ! ! CHECK M ! IERROR = 6 if (M > (IDMN-1) .OR. M < 6) RETURN ! ! CHECK N ! IERROR = 7 if (N < 5) RETURN ! ! CHECK IORDER ! IERROR = 8 if (IORDER /= 2 .AND. IORDER /= 4) RETURN ! ! CHECK INTL ! IERROR = 9 if (INTL /= 0 .AND. INTL /= 1) RETURN ! ! CHECK THAT EQUATION IS ELLIPTIC ! DLX = (B-A)/M DLY = (D-C)/N DO 30 I=2,M XI = A+(I-1)*DLX call COFX (XI,AI,BI,CI) DO 20 J=2,N YJ = C+(J-1)*DLY call COFY (YJ,DJ,EJ,FJ) if (AI*DJ > 0.0) go to 10 IERROR = 10 return 10 CONTINUE 20 CONTINUE 30 CONTINUE ! ! NO ERROR FOUND ! IERROR = 0 return end subroutine CHKSN4 (MBDCND, NBDCND, ALPHA, BETA, COFX, SINGLR) ! !! CHKSN4 is subsidiary to SEPX4. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CHKSN4-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine checks if the PDE SEPX4 ! must solve is a singular operator. ! !***SEE ALSO SEPX4 !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SPL4 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CHKSN4 ! COMMON /SPL4/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 LOGICAL SINGLR EXTERNAL COFX !***FIRST EXECUTABLE STATEMENT CHKSN4 SINGLR = .FALSE. ! ! CHECK if THE BOUNDARY CONDITIONS ARE ! ENTIRELY PERIODIC AND/OR MIXED ! if ((MBDCND /= 0 .AND. MBDCND /= 3) .OR. & (NBDCND /= 0 .AND. NBDCND /= 3)) RETURN ! ! CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN ! if (MBDCND /= 3) go to 10 if (ALPHA /= 0.0 .OR. BETA /= 0.0) RETURN 10 CONTINUE ! ! CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS ! ARE ZERO ! DO 30 I=IS,MS XI = AIT+(I-1)*DLX call COFX (XI,AI,BI,CI) if (CI /= 0.0) RETURN 30 CONTINUE ! ! THE OPERATOR MUST BE SINGULAR if THIS POINT IS REACHED ! SINGLR = .TRUE. return end subroutine CHKSNG (MBDCND, NBDCND, ALPHA, BETA, GAMA, XNU, COFX, & COFY, SINGLR) ! !! CHKSNG is subsidiary to SEPELI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CHKSNG-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine checks if the PDE SEPELI ! must solve is a singular operator. ! !***SEE ALSO SEPELI !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SPLPCM !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CHKSNG ! COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 LOGICAL SINGLR !***FIRST EXECUTABLE STATEMENT CHKSNG SINGLR = .FALSE. ! ! CHECK if THE BOUNDARY CONDITIONS ARE ! ENTIRELY PERIODIC AND/OR MIXED ! if ((MBDCND /= 0 .AND. MBDCND /= 3) .OR. & (NBDCND /= 0 .AND. NBDCND /= 3)) RETURN ! ! CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN ! if (MBDCND /= 3) go to 10 if (ALPHA /= 0.0 .OR. BETA /= 0.0) RETURN 10 if (NBDCND /= 3) go to 20 if (GAMA /= 0.0 .OR. XNU /= 0.0) RETURN 20 CONTINUE ! ! CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS ! ARE ZERO ! DO 30 I=IS,MS XI = AIT+(I-1)*DLX call COFX (XI,AI,BI,CI) if (CI /= 0.0) RETURN 30 CONTINUE DO 40 J=JS,NS YJ = CIT+(J-1)*DLY call COFY (YJ,DJ,EJ,FJ) if (FJ /= 0.0) RETURN 40 CONTINUE ! ! THE OPERATOR MUST BE SINGULAR if THIS POINT IS REACHED ! SINGLR = .TRUE. return end subroutine CHPCO (AP, N, KPVT, RCOND, Z) ! !! CHPCO factors a complex Hermitian matrix stored in packed form by ... ! elimination with symmetric pivoting and estimate the ... ! condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1A !***TYPE COMPLEX (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) !***KEYWORDS CONDITION NUMBER, HERMITIAN, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, PACKED !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CHPCO factors a complex Hermitian matrix stored in packed ! form by elimination with symmetric pivoting and estimates ! the condition of the matrix. ! ! if RCOND is not needed, CHPFA is slightly faster. ! To solve A*X = B , follow CHPCO by CHPSL. ! To compute INVERSE(A)*C , follow CHPCO by CHPSL. ! To compute INVERSE(A) , follow CHPCO by CHPDI. ! To compute DETERMINANT(A) , follow CHPCO by CHPDI. ! To compute INERTIA(A), follow CHPCO by CHPDI. ! ! On Entry ! ! AP COMPLEX (N*(N+1)/2) ! the packed form of a Hermitian matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! Output ! ! AP a block diagonal matrix and the multipliers which ! were used to obtain it stored in packed form. ! The factorization can be written A = U*D*CTRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , CTRANS(U) is the ! conjugate transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KVPT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a Hermitian matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC, CHPFA, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CHPCO INTEGER N,KPVT(*) COMPLEX AP(*),Z(*) REAL RCOND ! COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,EK,T REAL ANORM,S,SCASUM,YNORM INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1 INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS COMPLEX ZDUM,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT CHPCO J1 = 1 DO 30 J = 1, N Z(J) = CMPLX(SCASUM(J,AP(J1),1),0.0E0) IJ = J1 J1 = J1 + J JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 Z(I) = CMPLX(REAL(Z(I))+CABS1(AP(IJ)),0.0E0) IJ = IJ + 1 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,REAL(Z(J))) 40 CONTINUE ! ! FACTOR ! call CHPFA(AP,N,KPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE U*D*W = E ! EK = (1.0E0,0.0E0) DO 50 J = 1, N Z(J) = (0.0E0,0.0E0) 50 CONTINUE K = N IK = (N*(N - 1))/2 60 if (K == 0) go to 120 KK = IK + K IKM1 = IK - (K - 1) KS = 1 if (KPVT(K) < 0) KS = 2 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE if (CABS1(Z(K)) /= 0.0E0) EK = CSIGN1(EK,Z(K)) Z(K) = Z(K) + EK call CAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) if (KS == 1) go to 80 if (CABS1(Z(K-1)) /= 0.0E0) EK = CSIGN1(EK,Z(K-1)) Z(K-1) = Z(K-1) + EK call CAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) 80 CONTINUE if (KS == 2) go to 100 if (CABS1(Z(K)) <= CABS1(AP(KK))) go to 90 S = CABS1(AP(KK))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) EK = CMPLX(S,0.0E0)*EK 90 CONTINUE if (CABS1(AP(KK)) /= 0.0E0) Z(K) = Z(K)/AP(KK) if (CABS1(AP(KK)) == 0.0E0) Z(K) = (1.0E0,0.0E0) go to 110 100 CONTINUE KM1K = IK + K - 1 KM1KM1 = IKM1 + K - 1 AK = AP(KK)/CONJG(AP(KM1K)) AKM1 = AP(KM1KM1)/AP(KM1K) BK = Z(K)/CONJG(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 == 2) IK = IK - (K + 1) go to 60 120 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! ! SOLVE CTRANS(U)*Y = W ! K = 1 IK = 0 130 if (K > N) go to 160 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 150 Z(K) = Z(K) + CDOTC(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K if (KS == 2) & Z(K+1) = Z(K+1) + CDOTC(K-1,AP(IKP1+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE IK = IK + K if (KS == 2) IK = IK + (K + 1) K = K + KS go to 130 160 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE U*D*V = Y ! K = N IK = N*(N - 1)/2 170 if (K == 0) go to 230 KK = IK + K IKM1 = IK - (K - 1) KS = 1 if (KPVT(K) < 0) KS = 2 if (K == KS) go to 190 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 180 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 180 CONTINUE call CAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) if (KS == 2) call CAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) 190 CONTINUE if (KS == 2) go to 210 if (CABS1(Z(K)) <= CABS1(AP(KK))) go to 200 S = CABS1(AP(KK))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 200 CONTINUE if (CABS1(AP(KK)) /= 0.0E0) Z(K) = Z(K)/AP(KK) if (CABS1(AP(KK)) == 0.0E0) Z(K) = (1.0E0,0.0E0) go to 220 210 CONTINUE KM1K = IK + K - 1 KM1KM1 = IKM1 + K - 1 AK = AP(KK)/CONJG(AP(KM1K)) AKM1 = AP(KM1KM1)/AP(KM1K) BK = Z(K)/CONJG(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 == 2) IK = IK - (K + 1) go to 170 230 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE CTRANS(U)*Z = V ! K = 1 IK = 0 240 if (K > N) go to 270 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 260 Z(K) = Z(K) + CDOTC(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K if (KS == 2) & Z(K+1) = Z(K+1) + CDOTC(K-1,AP(IKP1+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE IK = IK + K if (KS == 2) IK = IK + (K + 1) K = K + KS go to 240 270 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine CHPDI (AP, N, KPVT, DET, INERT, WORK, JOB) ! !! CHPDI computes the determinant, inertia and inverse of a complex ... ! Hermitian matrix stored in packed form using the factors ! obtained from CHPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1A, D3D1A !***TYPE COMPLEX (SSPDI-S, DSPDI-D, CHPDI-C, DSPDI-C) !***KEYWORDS DETERMINANT, HERMITIAN, INVERSE, LINEAR ALGEBRA, LINPACK, ! MATRIX, PACKED !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CHPDI computes the determinant, inertia and inverse ! of a complex Hermitian matrix using the factors from CHPFA, ! where the matrix is stored in packed form. ! ! On Entry ! ! AP COMPLEX (N*(N+1)/2) ! the output from CHPFA. ! ! N INTEGER ! the order of the matrix A. ! ! KVPT INTEGER(N) ! the pivot vector from CHPFA. ! ! WORK COMPLEX(N) ! work vector. Contents ignored. ! ! JOB INTEGER ! JOB has the decimal expansion ABC where ! if C /= 0, the inverse is computed, ! if B /= 0, the determinant is computed, ! if A /= 0, the inertia is computed. ! ! For example, JOB = 111 gives all three. ! ! On Return ! ! Variables not requested by JOB are not used. ! ! AP contains the upper triangle of the inverse of ! the original matrix, stored in packed form. ! The columns of the upper triangle are stored ! sequentially in a one-dimensional array. ! ! DET REAL(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0. ! ! INERT INTEGER(3) ! the inertia of the original matrix. ! INERT(1) = number of positive eigenvalues. ! INERT(2) = number of negative eigenvalues. ! INERT(3) = number of zero eigenvalues. ! ! Error Condition ! ! A division by zero will occur if the inverse is requested ! and CHPCO has set RCOND == 0.0 ! or CHPFA has set INFO /= 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CCOPY, CDOTC, CSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CHPDI INTEGER N,JOB COMPLEX AP(*),WORK(*) REAL DET(2) INTEGER KPVT(*),INERT(3) ! COMPLEX AKKP1,CDOTC,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 !***FIRST EXECUTABLE STATEMENT CHPDI NOINV = MOD(JOB,10) == 0 NODET = MOD(JOB,100)/10 == 0 NOERT = MOD(JOB,1000)/100 == 0 ! 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 = REAL(AP(KK)) ! ! CHECK if 1 BY 1 ! if (KPVT(K) > 0) go to 50 ! ! 2 BY 2 BLOCK ! USE DET (D S) = (D/T * C - T) * T , T = ABS(S) ! (S C) ! TO AVOID UNDERFLOW/OVERFLOW TROUBLES. ! TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. ! if (T /= 0.0E0) go to 30 IKP1 = IK + K KKP1 = IKP1 + K T = ABS(AP(KKP1)) D = (D/T)*REAL(AP(KKP1+1)) - T go to 40 30 CONTINUE D = T T = 0.0E0 40 CONTINUE 50 CONTINUE ! if (NOERT) go to 60 if (D > 0.0E0) INERT(1) = INERT(1) + 1 if (D < 0.0E0) INERT(2) = INERT(2) + 1 if (D == 0.0E0) INERT(3) = INERT(3) + 1 60 CONTINUE ! if (NODET) go to 120 DET(1) = D*DET(1) if (DET(1) == 0.0E0) go to 110 70 if (ABS(DET(1)) >= 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)) < 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 ! ! COMPUTE INVERSE(A) ! if (NOINV) go to 270 K = 1 IK = 0 150 if (K > N) go to 260 KM1 = K - 1 KK = IK + K IKP1 = IK + K KKP1 = IKP1 + K if (KPVT(K) < 0) go to 180 ! ! 1 BY 1 ! AP(KK) = CMPLX(1.0E0/REAL(AP(KK)),0.0E0) if (KM1 < 1) go to 170 call CCOPY(KM1,AP(IK+1),1,WORK,1) IJ = 0 DO 160 J = 1, KM1 JK = IK + J AP(JK) = CDOTC(J,AP(IJ+1),1,WORK,1) call CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) IJ = IJ + J 160 CONTINUE AP(KK) = AP(KK) & + CMPLX(REAL(CDOTC(KM1,WORK,1,AP(IK+1),1)), & 0.0E0) 170 CONTINUE KSTEP = 1 go to 220 180 CONTINUE ! ! 2 BY 2 ! T = ABS(AP(KKP1)) AK = REAL(AP(KK))/T AKP1 = REAL(AP(KKP1+1))/T AKKP1 = AP(KKP1)/T D = T*(AK*AKP1 - 1.0E0) AP(KK) = CMPLX(AKP1/D,0.0E0) AP(KKP1+1) = CMPLX(AK/D,0.0E0) AP(KKP1) = -AKKP1/D if (KM1 < 1) go to 210 call CCOPY(KM1,AP(IKP1+1),1,WORK,1) IJ = 0 DO 190 J = 1, KM1 JKP1 = IKP1 + J AP(JKP1) = CDOTC(J,AP(IJ+1),1,WORK,1) call CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1) IJ = IJ + J 190 CONTINUE AP(KKP1+1) = AP(KKP1+1) & + CMPLX(REAL(CDOTC(KM1,WORK,1, & AP(IKP1+1),1)),0.0E0) AP(KKP1) = AP(KKP1) & + CDOTC(KM1,AP(IK+1),1,AP(IKP1+1),1) call CCOPY(KM1,AP(IK+1),1,WORK,1) IJ = 0 DO 200 J = 1, KM1 JK = IK + J AP(JK) = CDOTC(J,AP(IJ+1),1,WORK,1) call CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) IJ = IJ + J 200 CONTINUE AP(KK) = AP(KK) & + CMPLX(REAL(CDOTC(KM1,WORK,1,AP(IK+1),1)), & 0.0E0) 210 CONTINUE KSTEP = 2 220 CONTINUE ! ! SWAP ! KS = ABS(KPVT(K)) if (KS == K) go to 250 IKS = (KS*(KS - 1))/2 call CSWAP(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 = CONJG(AP(JK)) AP(JK) = CONJG(AP(KSJ)) AP(KSJ) = TEMP KSJ = KSJ - (J - 1) 230 CONTINUE if (KSTEP == 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 == 2) IK = IK + K + 1 K = K + KSTEP go to 150 260 CONTINUE 270 CONTINUE return end subroutine CHPFA (AP, N, KPVT, INFO) ! !! CHPFA factors a complex Hermitian matrix stored in packed form by ... ! elimination with symmetric pivoting. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1A !***TYPE COMPLEX (SSPFA-S, DSPFA-D, CHPFA-C, DSPFA-C) !***KEYWORDS HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, ! PACKED !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CHPFA factors a complex Hermitian matrix stored in ! packed form by elimination with symmetric pivoting. ! ! To solve A*X = B , follow CHPFA by CHPSL. ! To compute INVERSE(A)*C , follow CHPFA by CHPSL. ! To compute DETERMINANT(A) , follow CHPFA by CHPDI. ! To compute INERTIA(A) , follow CHPFA by CHPDI. ! To compute INVERSE(A) , follow CHPFA by CHPDI. ! ! On Entry ! ! AP COMPLEX (N*(N+1)/2) ! the packed form of a Hermitian matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! Output ! ! AP A block diagonal matrix and the multipliers which ! were used to obtain it stored in packed form. ! The factorization can be written A = U*D*CTRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , CTRANS(U) is the ! conjugate transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KVPT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th pivot block is singular. This is ! not an error condition for this subroutine, ! but it does indicate that CHPSL or CHPDI may ! divide by zero if called. ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a Hermitian matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSWAP, ICAMAX !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CHPFA INTEGER N,KPVT(*),INFO COMPLEX AP(*) ! COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T REAL ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER ICAMAX,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 COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT CHPFA ! ! INITIALIZE ! ! ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ! ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 ! INFO = 0 ! ! MAIN LOOP ON K, WHICH GOES FROM N TO 1. ! K = N IK = (N*(N - 1))/2 10 CONTINUE ! ! LEAVE THE LOOP if K=0 OR K=1. ! if (K == 0) go to 200 if (K > 1) go to 20 KPVT(1) = 1 if (CABS1(AP(1)) == 0.0E0) INFO = 1 go to 200 20 CONTINUE ! ! THIS SECTION OF CODE DETERMINES THE KIND OF ! ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, ! KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND ! SWAP WILL BE SET TO .TRUE. if AN INTERCHANGE IS ! REQUIRED. ! KM1 = K - 1 KK = IK + K ABSAKK = CABS1(AP(KK)) ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! COLUMN K. ! IMAX = ICAMAX(K-1,AP(IK+1),1) IMK = IK + IMAX COLMAX = CABS1(AP(IMK)) if (ABSAKK < ALPHA*COLMAX) go to 30 KSTEP = 1 SWAP = .FALSE. go to 90 30 CONTINUE ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! ROW IMAX. ! ROWMAX = 0.0E0 IMAXP1 = IMAX + 1 IM = IMAX*(IMAX - 1)/2 IMJ = IM + 2*IMAX DO 40 J = IMAXP1, K ROWMAX = MAX(ROWMAX,CABS1(AP(IMJ))) IMJ = IMJ + J 40 CONTINUE if (IMAX == 1) go to 50 JMAX = ICAMAX(IMAX-1,AP(IM+1),1) JMIM = JMAX + IM ROWMAX = MAX(ROWMAX,CABS1(AP(JMIM))) 50 CONTINUE IMIM = IMAX + IM if (CABS1(AP(IMIM)) < ALPHA*ROWMAX) go to 60 KSTEP = 1 SWAP = .TRUE. go to 80 60 CONTINUE if (ABSAKK < ALPHA*COLMAX*(COLMAX/ROWMAX)) go to 70 KSTEP = 1 SWAP = .FALSE. go to 80 70 CONTINUE KSTEP = 2 SWAP = IMAX /= KM1 80 CONTINUE 90 CONTINUE if (MAX(ABSAKK,COLMAX) /= 0.0E0) go to 100 ! ! COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. ! KPVT(K) = K INFO = K go to 190 100 CONTINUE if (KSTEP == 2) go to 140 ! ! 1 X 1 PIVOT BLOCK. ! if (.NOT.SWAP) go to 120 ! ! PERFORM AN INTERCHANGE. ! call CSWAP(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 = CONJG(AP(JK)) AP(JK) = CONJG(AP(IMJ)) AP(IMJ) = T IMJ = IMJ - (J - 1) 110 CONTINUE 120 CONTINUE ! ! PERFORM THE ELIMINATION. ! IJ = IK - (K - 1) DO 130 JJ = 1, KM1 J = K - JJ JK = IK + J MULK = -AP(JK)/AP(KK) T = CONJG(MULK) call CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) IJJ = IJ + J AP(IJJ) = CMPLX(REAL(AP(IJJ)),0.0E0) AP(JK) = MULK IJ = IJ - (J - 1) 130 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = K if (SWAP) KPVT(K) = IMAX go to 190 140 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! KM1K = IK + K - 1 IKM1 = IK - (K - 1) if (.NOT.SWAP) go to 160 ! ! PERFORM AN INTERCHANGE. ! call CSWAP(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 = CONJG(AP(JKM1)) AP(JKM1) = CONJG(AP(IMJ)) AP(IMJ) = T IMJ = IMJ - (J - 1) 150 CONTINUE T = AP(KM1K) AP(KM1K) = AP(IMK) AP(IMK) = T 160 CONTINUE ! ! PERFORM THE ELIMINATION. ! KM2 = K - 2 if (KM2 == 0) go to 180 AK = AP(KK)/AP(KM1K) KM1KM1 = IKM1 + K - 1 AKM1 = AP(KM1KM1)/CONJG(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)/CONJG(AP(KM1K)) MULK = (AKM1*BK - BKM1)/DENOM MULKM1 = (AK*BKM1 - BK)/DENOM T = CONJG(MULK) call CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) T = CONJG(MULKM1) call CAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1) AP(JK) = MULK AP(JKM1) = MULKM1 IJJ = IJ + J AP(IJJ) = CMPLX(REAL(AP(IJJ)),0.0E0) IJ = IJ - (J - 1) 170 CONTINUE 180 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = 1 - K if (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE IK = IK - (K - 1) if (KSTEP == 2) IK = IK - (K - 2) K = K - KSTEP go to 10 200 CONTINUE return end subroutine CHPMV (UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) ! !! CHPMV performs the matrix-vector operation y := alpha*A*x + beta*y. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (SHPMV-S, DHPMV-D, CHPMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CHPMV performs the matrix-vector operation ! ! y := alpha*A*x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! A is an n by n hermitian matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the matrix A is supplied in the packed ! array AP as follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! supplied in AP. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! supplied in AP. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! AP - COMPLEX array of DIMENSION at least ! ( ( n*( n + 1))/2). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular part of the hermitian matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular part of the hermitian matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. ! Note that the imaginary parts of the diagonal elements need ! not be set and are assumed to be zero. ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - COMPLEX . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. On exit, Y is overwritten by the updated ! vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CHPMV ! .. Scalar Arguments .. COMPLEX ALPHA, BETA INTEGER INCX, INCY, N CHARACTER*1 UPLO ! .. Array Arguments .. COMPLEX AP( * ), X( * ), Y( * ) ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, REAL !***FIRST EXECUTABLE STATEMENT CHPMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 6 ELSE if ( INCY == 0 )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'CHPMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set up the start points in X and Y. ! if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return KK = 1 if ( LSAME( UPLO, 'U' ) )THEN ! ! Form y when AP contains the upper triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO K = KK DO 50, I = 1, J - 1 Y( I ) = Y( I ) + TEMP1*AP( K ) TEMP2 = TEMP2 + CONJG( AP( K ) )*X( I ) K = K + 1 50 CONTINUE Y( J ) = Y( J ) + TEMP1*REAL( AP( KK + J - 1 ) ) & + ALPHA*TEMP2 KK = KK + J 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY DO 70, K = KK, KK + J - 2 Y( IY ) = Y( IY ) + TEMP1*AP( K ) TEMP2 = TEMP2 + CONJG( AP( K ) )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*REAL( AP( KK + J - 1 ) ) & + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY KK = KK + J 80 CONTINUE end if ELSE ! ! Form y when AP contains the lower triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*REAL( AP( KK ) ) K = KK + 1 DO 90, I = J + 1, N Y( I ) = Y( I ) + TEMP1*AP( K ) TEMP2 = TEMP2 + CONJG( AP( K ) )*X( I ) K = K + 1 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 KK = KK + ( N - J + 1 ) 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*REAL( AP( KK ) ) IX = JX IY = JY DO 110, K = KK + 1, KK + N - J IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*AP( K ) TEMP2 = TEMP2 + CONJG( AP( K ) )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY KK = KK + ( N - J + 1 ) 120 CONTINUE end if end if ! return ! ! End of CHPMV . ! end subroutine CHPR2 (UPLO, N, ALPHA, X, INCX, Y, INCY, AP) ! !! CHPR2 performs a hermitian rank 2 operation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (SHPR2-S, DHPR2-D, CHPR2-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CHPR2 performs the hermitian rank 2 operation ! ! A := alpha*x*conjg( y') + conjg( alpha)*y*conjg( x') + A, ! ! where alpha is a scalar, x and y are n element vectors and A is an ! n by n hermitian matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the matrix A is supplied in the packed ! array AP as follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! supplied in AP. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! supplied in AP. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! Y - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. ! Unchanged on exit. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! ! AP - COMPLEX array of DIMENSION at least ! ( ( n*( n + 1 ) )/2 ). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular part of the hermitian matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. On exit, the array ! AP is overwritten by the upper triangular part of the ! updated matrix. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular part of the hermitian matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. On exit, the array ! AP is overwritten by the lower triangular part of the ! updated matrix. ! Note that the imaginary parts of the diagonal elements need ! not be set, they are assumed to be zero, and on exit they ! are set to zero. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CHPR2 ! .. Scalar Arguments .. COMPLEX ALPHA INTEGER INCX, INCY, N CHARACTER*1 UPLO ! .. Array Arguments .. COMPLEX AP( * ), X( * ), Y( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, REAL !***FIRST EXECUTABLE STATEMENT CHPR2 ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( INCY == 0 )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'CHPR2 ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ( ( INCX /= 1 ).OR.( INCY /= 1 ) )THEN if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if JX = KX JY = KY end if ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! KK = 1 if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when upper triangle is stored in AP. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 20, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*CONJG( Y( J ) ) TEMP2 = CONJG( ALPHA*X( J ) ) K = KK DO 10, I = 1, J - 1 AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 K = K + 1 10 CONTINUE AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) + & REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) ELSE AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) end if KK = KK + J 20 CONTINUE ELSE DO 40, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*CONJG( Y( JY ) ) TEMP2 = CONJG( ALPHA*X( JX ) ) IX = KX IY = KY DO 30, K = KK, KK + J - 2 AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) + & REAL( X( JX )*TEMP1 + & Y( JY )*TEMP2 ) ELSE AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) end if JX = JX + INCX JY = JY + INCY KK = KK + J 40 CONTINUE end if ELSE ! ! Form A when lower triangle is stored in AP. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*CONJG( Y( J ) ) TEMP2 = CONJG( ALPHA*X( J ) ) AP( KK ) = REAL( AP( KK ) ) + & REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) K = KK + 1 DO 50, I = J + 1, N AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 K = K + 1 50 CONTINUE ELSE AP( KK ) = REAL( AP( KK ) ) end if KK = KK + N - J + 1 60 CONTINUE ELSE DO 80, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*CONJG( Y( JY ) ) TEMP2 = CONJG( ALPHA*X( JX ) ) AP( KK ) = REAL( AP( KK ) ) + & REAL( X( JX )*TEMP1 + Y( JY )*TEMP2 ) IX = JX IY = JY DO 70, K = KK + 1, KK + N - J IX = IX + INCX IY = IY + INCY AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 70 CONTINUE ELSE AP( KK ) = REAL( AP( KK ) ) end if JX = JX + INCX JY = JY + INCY KK = KK + N - J + 1 80 CONTINUE end if end if ! return ! ! End of CHPR2 . ! end subroutine CHPR (UPLO, N, ALPHA, X, INCX, AP) ! !! CHPR performs a hermitian rank 1 operation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (CHPR-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CHPR performs the hermitian rank 1 operation ! ! A := alpha*x*conjg( x') + A, ! ! where alpha is a real scalar, x is an n element vector and A is an ! n by n hermitian matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the matrix A is supplied in the packed ! array AP as follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! supplied in AP. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! supplied in AP. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! AP - COMPLEX array of DIMENSION at least ! ( ( n*( n + 1 ) )/2 ). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular part of the hermitian matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. On exit, the array ! AP is overwritten by the upper triangular part of the ! updated matrix. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular part of the hermitian matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. On exit, the array ! AP is overwritten by the lower triangular part of the ! updated matrix. ! Note that the imaginary parts of the diagonal elements need ! not be set, they are assumed to be zero, and on exit they ! are set to zero. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CHPR ! .. Scalar Arguments .. REAL ALPHA INTEGER INCX, N CHARACTER*1 UPLO ! .. Array Arguments .. COMPLEX AP( * ), X( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, REAL !***FIRST EXECUTABLE STATEMENT CHPR ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 end if if ( INFO /= 0 )THEN call XERBLA( 'CHPR ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == REAL( ZERO ) ) ) & return ! ! Set the start point in X if the increment is not unity. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! KK = 1 if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when upper triangle is stored in AP. ! if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*CONJG( X( J ) ) K = KK DO 10, I = 1, J - 1 AP( K ) = AP( K ) + X( I )*TEMP K = K + 1 10 CONTINUE AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) & + REAL( X( J )*TEMP ) ELSE AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) end if KK = KK + J 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*CONJG( X( JX ) ) IX = KX DO 30, K = KK, KK + J - 2 AP( K ) = AP( K ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) & + REAL( X( JX )*TEMP ) ELSE AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) end if JX = JX + INCX KK = KK + J 40 CONTINUE end if ELSE ! ! Form A when lower triangle is stored in AP. ! if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*CONJG( X( J ) ) AP( KK ) = REAL( AP( KK ) ) + REAL( TEMP*X( J ) ) K = KK + 1 DO 50, I = J + 1, N AP( K ) = AP( K ) + X( I )*TEMP K = K + 1 50 CONTINUE ELSE AP( KK ) = REAL( AP( KK ) ) end if KK = KK + N - J + 1 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*CONJG( X( JX ) ) AP( KK ) = REAL( AP( KK ) ) + REAL( TEMP*X( JX ) ) IX = JX DO 70, K = KK + 1, KK + N - J IX = IX + INCX AP( K ) = AP( K ) + X( IX )*TEMP 70 CONTINUE ELSE AP( KK ) = REAL( AP( KK ) ) end if JX = JX + INCX KK = KK + N - J + 1 80 CONTINUE end if end if ! return ! ! End of CHPR . ! end subroutine CHPSL (AP, N, KPVT, B) ! !! CHPSL solves a complex Hermitian system using factors from CHPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1A !***TYPE COMPLEX (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C) !***KEYWORDS HERMITIAN, LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CHISL solves the complex Hermitian system ! A * X = B ! using the factors computed by CHPFA. ! ! On Entry ! ! AP COMPLEX(N*(N+1)/2) ! the output from CHPFA. ! ! N INTEGER ! the order of the matrix A . ! ! KVPT INTEGER(N) ! the pivot vector from CHPFA. ! ! B COMPLEX(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero may occur if CHPCO has set RCOND == 0.0 ! or CHPFA has set INFO /= 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call CHPFA(AP,N,KVPT,INFO) ! if (INFO /= 0) go to ... ! DO 10 J = 1, P ! call CHPSL(AP,N,KVPT,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CHPSL INTEGER N,KPVT(*) COMPLEX AP(*),B(*) ! COMPLEX AK,AKM1,BK,BKM1,CDOTC,DENOM,TEMP INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP ! ! LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND ! D INVERSE TO B. ! !***FIRST EXECUTABLE STATEMENT CHPSL K = N IK = (N*(N - 1))/2 10 if (K == 0) go to 80 KK = IK + K if (KPVT(K) < 0) go to 40 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 30 KP = KPVT(K) if (KP == K) go to 20 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call CAXPY(K-1,B(K),AP(IK+1),1,B(1),1) 30 CONTINUE ! ! APPLY D INVERSE. ! B(K) = B(K)/AP(KK) K = K - 1 IK = IK - K go to 70 40 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! IKM1 = IK - (K - 1) if (K == 2) go to 60 KP = ABS(KPVT(K)) if (KP == K - 1) go to 50 ! ! INTERCHANGE. ! TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call CAXPY(K-2,B(K),AP(IK+1),1,B(1),1) call CAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1) 60 CONTINUE ! ! APPLY D INVERSE. ! KM1K = IK + K - 1 KK = IK + K AK = AP(KK)/CONJG(AP(KM1K)) KM1KM1 = IKM1 + K - 1 AKM1 = AP(KM1KM1)/AP(KM1K) BK = B(K)/CONJG(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 ! ! LOOP FORWARD APPLYING THE TRANSFORMATIONS. ! K = 1 IK = 0 90 if (K > N) go to 160 if (KPVT(K) < 0) go to 120 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 110 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + CDOTC(K-1,AP(IK+1),1,B(1),1) KP = KPVT(K) if (KP == K) go to 100 ! ! INTERCHANGE. ! 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 ! ! 2 X 2 PIVOT BLOCK. ! if (K == 1) go to 140 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + CDOTC(K-1,AP(IK+1),1,B(1),1) IKP1 = IK + K B(K+1) = B(K+1) + CDOTC(K-1,AP(IKP1+1),1,B(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 130 ! ! INTERCHANGE. ! 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 function CHU (A, B, X) ! !! CHU computes the logarithmic confluent hypergeometric function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C11 !***TYPE SINGLE PRECISION (CHU-S, DCHU-D) !***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CHU computes the logarithmic confluent hypergeometric function, ! U(A,B,X). ! ! Input Parameters: ! A real ! B real ! X real and positive ! ! This routine is not valid when 1+A-B is close to zero if X is small. ! !***REFERENCES (NONE) !***ROUTINES CALLED EXPREL, GAMMA, GAMR, POCH, POCH1, R1MACH, R9CHU, ! XERMSG !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE CHU EXTERNAL GAMMA SAVE PI, EPS DATA PI / 3.14159265358979324E0 / DATA EPS / 0.0 / !***FIRST EXECUTABLE STATEMENT CHU if (EPS == 0.0) EPS = R1MACH(3) ! if (X == 0.0) call XERMSG ('SLATEC', 'CHU', & 'X IS ZERO SO CHU IS INFINITE', 1, 2) if (X < 0.0) call XERMSG ('SLATEC', 'CHU', & 'X IS NEGATIVE, USE CCHU', 2, 2) ! if (MAX(ABS(A),1.0)*MAX(ABS(1.0+A-B),1.0) < 0.99*ABS(X)) & go to 120 ! ! THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL ! APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. ! if (ABS(1.0+A-B) < SQRT(EPS)) call XERMSG ('SLATEC', 'CHU', & 'ALGORITHM IS BAD WHEN 1+A-B IS NEAR ZERO FOR SMALL X', 10, 2) ! AINTB = AINT(B+0.5) if (B < 0.0) AINTB = AINT(B-0.5) BEPS = B - AINTB N = AINTB ! ALNX = LOG(X) XTOEPS = EXP(-BEPS*ALNX) ! ! EVALUATE THE FINITE SUM. ----------------------------------------- ! if (N >= 1) go to 40 ! ! CONSIDER THE CASE B < 1.0 FIRST. ! SUM = 1.0 if (N == 0) go to 30 ! T = 1.0 M = -N DO 20 I=1,M XI1 = I - 1 T = T*(A+XI1)*X/((B+XI1)*(XI1+1.0)) SUM = SUM + T 20 CONTINUE ! 30 SUM = POCH(1.0+A-B, -A) * SUM go to 70 ! ! NOW CONSIDER THE CASE B >= 1.0. ! 40 SUM = 0.0 M = N - 2 if (M < 0) go to 70 T = 1.0 SUM = 1.0 if (M == 0) go to 60 ! DO 50 I=1,M XI = I T = T * (A-B+XI)*X/((1.0-B+XI)*XI) SUM = SUM + T 50 CONTINUE ! 60 SUM = GAMMA(B-1.0) * GAMR(A) * X**(1-N) * XTOEPS * SUM ! ! NOW EVALUATE THE INFINITE SUM. ----------------------------------- ! 70 ISTRT = 0 if (N < 1) ISTRT = 1 - N XI = ISTRT ! FACTOR = (-1.0)**N * GAMR(1.0+A-B) * X**ISTRT if (BEPS /= 0.0) FACTOR = FACTOR * BEPS*PI/SIN(BEPS*PI) ! POCHAI = POCH (A, XI) GAMRI1 = GAMR (XI+1.0) GAMRNI = GAMR (AINTB+XI) B0 = FACTOR * POCH(A,XI-BEPS) * GAMRNI * GAMR(XI+1.0-BEPS) ! if (ABS(XTOEPS-1.0) > 0.5) go to 90 ! ! X**(-BEPS) IS CLOSE TO 1.0, SO WE MUST BE CAREFUL IN EVALUATING ! THE DIFFERENCES ! PCH1AI = POCH1 (A+XI, -BEPS) PCH1I = POCH1 (XI+1.0-BEPS, BEPS) C0 = FACTOR * POCHAI * GAMRNI * GAMRI1 * ( & -POCH1(B+XI, -BEPS) + PCH1AI - PCH1I + BEPS*PCH1AI*PCH1I ) ! ! XEPS1 = (1.0 - X**(-BEPS)) / BEPS XEPS1 = ALNX * EXPREL(-BEPS*ALNX) ! CHU = SUM + C0 + XEPS1*B0 XN = N DO 80 I=1,1000 XI = ISTRT + I XI1 = ISTRT + I - 1 B0 = (A+XI1-BEPS)*B0*X/((XN+XI1)*(XI-BEPS)) C0 = (A+XI1)*C0*X/((B+XI1)*XI) - ((A-1.0)*(XN+2.*XI-1.0) & + XI*(XI-BEPS)) * B0/(XI*(B+XI1)*(A+XI1-BEPS)) T = C0 + XEPS1*B0 CHU = CHU + T if (ABS(T) < EPS*ABS(CHU)) go to 130 80 CONTINUE call XERMSG ('SLATEC', 'CHU', & 'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2) ! ! X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD ! FORMULATION IS STABLE. ! 90 A0 = FACTOR * POCHAI * GAMR(B+XI) * GAMRI1 / BEPS B0 = XTOEPS*B0/BEPS ! CHU = SUM + A0 - B0 DO 100 I=1,1000 XI = ISTRT + I XI1 = ISTRT + I - 1 A0 = (A+XI1)*A0*X/((B+XI1)*XI) B0 = (A+XI1-BEPS)*B0*X/((AINTB+XI1)*(XI-BEPS)) T = A0 - B0 CHU = CHU + T if (ABS(T) < EPS*ABS(CHU)) go to 130 100 CONTINUE call XERMSG ('SLATEC', 'CHU', & 'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2) ! ! USE LUKE-S RATIONAL APPROX IN THE ASYMPTOTIC REGION. ! 120 CHU = X**(-A) * R9CHU(A, B, X) ! 130 return end subroutine CINVIT (NM, N, AR, AI, WR, WI, SELECT, MM, M, ZR, ZI, & IERR, RM1, RM2, RV1, RV2) ! !! CINVIT computes the eigenvectors of a complex upper Hessenberg matrix ... ! associated with specified eigenvalues using inverse iteration. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C2B !***TYPE COMPLEX (INVIT-S, CINVIT-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure CXINVIT ! by Peters and Wilkinson. ! HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971). ! ! This subroutine finds those eigenvectors of A COMPLEX UPPER ! Hessenberg matrix corresponding to specified eigenvalues, ! using inverse iteration. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, AR, AI, ZR and ZI, as declared in the ! calling program dimension statement. NM is an INTEGER ! variable. ! ! N is the order of the matrix A=(AR,AI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! AR and AI contain the real and imaginary parts, respectively, ! of the complex upper Hessenberg matrix. AR and AI are ! two-dimensional REAL arrays, dimensioned AR(NM,N) ! and AI(NM,N). ! ! WR and WI contain the real and imaginary parts, respectively, ! of the eigenvalues of the matrix. The eigenvalues must be ! stored in a manner identical to that of subroutine COMLR, ! which recognizes possible splitting of the matrix. WR and ! WI are one-dimensional REAL arrays, dimensioned WR(N) and ! WI(N). ! ! SELECT specifies the eigenvectors to be found. The ! eigenvector corresponding to the J-th eigenvalue is ! specified by setting SELECT(J) to .TRUE. SELECT is a ! one-dimensional LOGICAL array, dimensioned SELECT(N). ! ! MM should be set to an upper bound for the number of ! eigenvectors to be found. MM is an INTEGER variable. ! ! On OUTPUT ! ! AR, AI, WI, and SELECT are unaltered. ! ! WR may have been altered since close eigenvalues are perturbed ! slightly in searching for independent eigenvectors. ! ! M is the number of eigenvectors actually found. M is an ! INTEGER variable. ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the eigenvectors corresponding to the flagged eigenvalues. ! The eigenvectors are normalized so that the component of ! largest magnitude is 1. Any vector which fails the ! acceptance test is set to zero. ZR and ZI are ! two-dimensional REAL arrays, dimensioned ZR(NM,MM) and ! ZI(NM,MM). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! -(2*N+1) if more than MM eigenvectors have been requested ! (the MM eigenvectors calculated to this point are ! in ZR and ZI), ! -K if the iteration corresponding to the K-th ! value fails (if this occurs more than once, K ! is the index of the last occurrence); the ! corresponding columns of ZR and ZI are set to ! zero vectors, ! -(N+K) if both error situations occur. ! ! RV1 and RV2 are one-dimensional REAL arrays used for ! temporary storage, dimensioned RV1(N) and RV2(N). ! They hold the approximate eigenvectors during the inverse ! iteration process. ! ! RM1 and RM2 are two-dimensional REAL arrays used for ! temporary storage, dimensioned RM1(N,N) and RM2(N,N). ! These arrays hold the triangularized form of the upper ! Hessenberg matrix used in the inverse iteration process. ! ! The ALGOL procedure GUESSVEC appears in CINVIT in-line. ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! Calls CDIV for complex division. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED CDIV, PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CINVIT ! INTEGER I,J,K,M,N,S,II,MM,MP,NM,UK,IP1,ITS,KM1,IERR REAL AR(NM,*),AI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*) REAL RM1(N,*),RM2(N,*),RV1(*),RV2(*) REAL X,Y,EPS3,NORM,NORMV,GROWTO,ILAMBD,RLAMBD,UKROOT REAL PYTHAG LOGICAL SELECT(N) ! !***FIRST EXECUTABLE STATEMENT CINVIT IERR = 0 UK = 0 S = 1 ! DO 980 K = 1, N if (.NOT. SELECT(K)) go to 980 if (S > MM) go to 1000 if (UK >= K) go to 200 ! .......... CHECK FOR POSSIBLE SPLITTING .......... DO 120 UK = K, N if (UK == N) go to 140 if (AR(UK+1,UK) == 0.0E0 .AND. AI(UK+1,UK) == 0.0E0) & go to 140 120 CONTINUE ! .......... COMPUTE INFINITY NORM OF LEADING UK BY UK ! (HESSENBERG) MATRIX .......... 140 NORM = 0.0E0 MP = 1 ! DO 180 I = 1, UK X = 0.0E0 ! DO 160 J = MP, UK 160 X = X + PYTHAG(AR(I,J),AI(I,J)) ! if (X > NORM) NORM = X MP = I 180 CONTINUE ! .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION ! AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... if (NORM == 0.0E0) NORM = 1.0E0 EPS3 = NORM 190 EPS3 = 0.5E0*EPS3 if (NORM + EPS3 > NORM) go to 190 EPS3 = 2.0E0*EPS3 ! .......... GROWTO IS THE CRITERION FOR GROWTH .......... UKROOT = SQRT(REAL(UK)) GROWTO = 0.1E0 / UKROOT 200 RLAMBD = WR(K) ILAMBD = WI(K) if (K == 1) go to 280 KM1 = K - 1 go to 240 ! .......... PERTURB EIGENVALUE if IT IS CLOSE ! TO ANY PREVIOUS EIGENVALUE .......... 220 RLAMBD = RLAMBD + EPS3 ! .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... 240 DO 260 II = 1, KM1 I = K - II if (SELECT(I) .AND. ABS(WR(I)-RLAMBD) < EPS3 .AND. & ABS(WI(I)-ILAMBD) < EPS3) go to 220 260 CONTINUE ! WR(K) = RLAMBD ! .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)*I ! AND INITIAL COMPLEX VECTOR .......... 280 MP = 1 ! DO 320 I = 1, UK ! DO 300 J = MP, UK RM1(I,J) = AR(I,J) RM2(I,J) = AI(I,J) 300 CONTINUE ! RM1(I,I) = RM1(I,I) - RLAMBD RM2(I,I) = RM2(I,I) - ILAMBD MP = I RV1(I) = EPS3 320 CONTINUE ! .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES, ! REPLACING ZERO PIVOTS BY EPS3 .......... if (UK == 1) go to 420 ! DO 400 I = 2, UK MP = I - 1 if (PYTHAG(RM1(I,MP),RM2(I,MP)) <= & PYTHAG(RM1(MP,MP),RM2(MP,MP))) go to 360 ! DO 340 J = MP, UK Y = RM1(I,J) RM1(I,J) = RM1(MP,J) RM1(MP,J) = Y Y = RM2(I,J) RM2(I,J) = RM2(MP,J) RM2(MP,J) = Y 340 CONTINUE ! 360 if (RM1(MP,MP) == 0.0E0 .AND. RM2(MP,MP) == 0.0E0) & RM1(MP,MP) = EPS3 call CDIV(RM1(I,MP),RM2(I,MP),RM1(MP,MP),RM2(MP,MP),X,Y) if (X == 0.0E0 .AND. Y == 0.0E0) go to 400 ! DO 380 J = I, UK RM1(I,J) = RM1(I,J) - X * RM1(MP,J) + Y * RM2(MP,J) RM2(I,J) = RM2(I,J) - X * RM2(MP,J) - Y * RM1(MP,J) 380 CONTINUE ! 400 CONTINUE ! 420 if (RM1(UK,UK) == 0.0E0 .AND. RM2(UK,UK) == 0.0E0) & RM1(UK,UK) = EPS3 ITS = 0 ! .......... BACK SUBSTITUTION ! FOR I=UK STEP -1 UNTIL 1 DO -- .......... 660 DO 720 II = 1, UK I = UK + 1 - II X = RV1(I) Y = 0.0E0 if (I == UK) go to 700 IP1 = I + 1 ! DO 680 J = IP1, UK X = X - RM1(I,J) * RV1(J) + RM2(I,J) * RV2(J) Y = Y - RM1(I,J) * RV2(J) - RM2(I,J) * RV1(J) 680 CONTINUE ! 700 call CDIV(X,Y,RM1(I,I),RM2(I,I),RV1(I),RV2(I)) 720 CONTINUE ! .......... ACCEPTANCE TEST FOR EIGENVECTOR ! AND NORMALIZATION .......... ITS = ITS + 1 NORM = 0.0E0 NORMV = 0.0E0 ! DO 780 I = 1, UK X = PYTHAG(RV1(I),RV2(I)) if (NORMV >= X) go to 760 NORMV = X J = I 760 NORM = NORM + X 780 CONTINUE ! if (NORM < GROWTO) go to 840 ! .......... ACCEPT VECTOR .......... X = RV1(J) Y = RV2(J) ! DO 820 I = 1, UK call CDIV(RV1(I),RV2(I),X,Y,ZR(I,S),ZI(I,S)) 820 CONTINUE ! if (UK == N) go to 940 J = UK + 1 go to 900 ! .......... IN-LINE PROCEDURE FOR CHOOSING ! A NEW STARTING VECTOR .......... 840 if (ITS >= UK) go to 880 X = UKROOT Y = EPS3 / (X + 1.0E0) RV1(1) = EPS3 ! DO 860 I = 2, UK 860 RV1(I) = Y ! J = UK - ITS + 1 RV1(J) = RV1(J) - EPS3 * X go to 660 ! .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... 880 J = 1 IERR = -K ! .......... SET REMAINING VECTOR COMPONENTS TO ZERO .......... 900 DO 920 I = J, N ZR(I,S) = 0.0E0 ZI(I,S) = 0.0E0 920 CONTINUE ! 940 S = S + 1 980 CONTINUE ! go to 1001 ! .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR ! SPACE REQUIRED .......... 1000 if (IERR /= 0) IERR = IERR - N if (IERR == 0) IERR = -(2 * N + 1) 1001 M = S - 1 return end subroutine CKSCL (ZR, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM) ! !! CKSCL is subsidiary to CBKNU, CUNK1 and CUNK2. ! !***LIBRARY SLATEC !***TYPE ALL (CKSCL-A, ZKSCL-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE ! ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN ! return WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. ! !***SEE ALSO CBKNU, CUNK1, CUNK2 !***ROUTINES CALLED CUCHK !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CKSCL COMPLEX CK, CS, CY, CZERO, RZ, S1, S2, Y, ZR, ZD, CELM REAL AA, ASCLE, ACS, AS, CSI, CSR, ELIM, FN, FNU, TOL, XX, ZRI, & ELM, ALAS, HELIM INTEGER I, IC, K, KK, N, NN, NW, NZ DIMENSION Y(N), CY(2) DATA CZERO / (0.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CUCHK NZ = 0 IC = 0 XX = REAL(ZR) NN = MIN(2,N) DO 10 I=1,NN S1 = Y(I) CY(I) = S1 AS = ABS(S1) ACS = -XX + ALOG(AS) NZ = NZ + 1 Y(I) = CZERO if (ACS < (-ELIM)) go to 10 CS = -ZR + CLOG(S1) CSR = REAL(CS) CSI = AIMAG(CS) AA = EXP(CSR)/TOL CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) call CUCHK(CS, NW, ASCLE, TOL) if (NW /= 0) go to 10 Y(I) = CS NZ = NZ - 1 IC = I 10 CONTINUE if (N == 1) RETURN if (IC > 1) go to 20 Y(1) = CZERO NZ = 2 20 CONTINUE if (N == 2) RETURN if (NZ == 0) RETURN FN = FNU + 1.0E0 CK = CMPLX(FN,0.0E0)*RZ S1 = CY(1) S2 = CY(2) HELIM = 0.5E0*ELIM ELM = EXP(-ELIM) CELM = CMPLX(ELM,0.0E0) ZRI =AIMAG(ZR) ZD = ZR ! ! FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF ! S2 GETS LARGER THAN EXP(ELIM/2) ! DO 30 I=3,N KK = I CS = S2 S2 = CK*S2 + S1 S1 = CS CK = CK + RZ AS = ABS(S2) ALAS = ALOG(AS) ACS = -XX + ALAS NZ = NZ + 1 Y(I) = CZERO if (ACS < (-ELIM)) go to 25 CS = -ZD + CLOG(S2) CSR = REAL(CS) CSI = AIMAG(CS) AA = EXP(CSR)/TOL CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI)) call CUCHK(CS, NW, ASCLE, TOL) if (NW /= 0) go to 25 Y(I) = CS NZ = NZ - 1 if (IC == (KK-1)) go to 40 IC = KK go to 30 25 CONTINUE if ( ALAS < HELIM) go to 30 XX = XX-ELIM S1 = S1*CELM S2 = S2*CELM ZD = CMPLX(XX,ZRI) 30 CONTINUE NZ = N if ( IC == N) NZ=N-1 go to 45 40 CONTINUE NZ = KK - 2 45 CONTINUE DO 50 K=1,NZ Y(K) = CZERO 50 CONTINUE return end FUNCTION CLBETA (A, B) ! !! CLBETA computes the natural logarithm of the complete Beta function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7B !***TYPE COMPLEX (ALBETA-S, DLBETA-D, CLBETA-C) !***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CLBETA computes the natural log of the complex valued complete beta ! function of complex parameters A and B. This is a preliminary version ! which is not accurate. ! ! Input Parameters: ! A complex and the real part of A positive ! B complex and the real part of B positive ! !***REFERENCES (NONE) !***ROUTINES CALLED CLNGAM, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE CLBETA COMPLEX CLBETA COMPLEX A, B, CLNGAM !***FIRST EXECUTABLE STATEMENT CLBETA if (REAL(A) <= 0.0 .OR. REAL(B) <= 0.0) call XERMSG ('SLATEC', & 'CLBETA', 'REAL PART OF BOTH ARGUMENTS MUST BE GT 0', 1, 2) ! CLBETA = CLNGAM(A) + CLNGAM(B) - CLNGAM(A+B) ! return end FUNCTION CLNGAM (ZIN) ! !! CLNGAM computes the logarithm of the absolute value of the Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE COMPLEX (ALNGAM-S, DLNGAM-D, CLNGAM-C) !***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CLNGAM computes the natural log of the complex valued gamma function ! at ZIN, where ZIN is a complex number. This is a preliminary version, ! which is not accurate. ! !***REFERENCES (NONE) !***ROUTINES CALLED C9LGMC, CARG, CLNREL, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 780401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE CLNGAM COMPLEX CLNGAM COMPLEX ZIN, Z, CORR, CLNREL, C9LGMC LOGICAL FIRST SAVE PI, SQ2PIL, BOUND, DXREL, FIRST DATA PI / 3.14159265358979324E0 / DATA SQ2PIL / 0.91893853320467274E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT CLNGAM if (FIRST) THEN N = -0.30*LOG(R1MACH(3)) ! BOUND = N*(0.1*EPS)**(-1/(2*N-1))/(PI*EXP(1)) BOUND = 0.1171*N*(0.1*R1MACH(3))**(-1./(2*N-1)) DXREL = SQRT (R1MACH(4)) end if FIRST = .FALSE. ! Z = ZIN X = REAL(ZIN) Y = AIMAG(ZIN) ! CORR = (0.0, 0.0) CABSZ = ABS(Z) if (X >= 0.0 .AND. CABSZ > BOUND) go to 50 if (X < 0.0 .AND. ABS(Y) > BOUND) go to 50 ! if (CABSZ < BOUND) go to 20 ! ! USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND ! ABS(AIMAG(Y)) SMALL. ! if (Y > 0.0) Z = CONJG (Z) CORR = EXP (-CMPLX(0.0,2.0*PI)*Z) if (REAL(CORR) == 1.0 .AND. AIMAG(CORR) == 0.0) call XERMSG & ('SLATEC', 'CLNGAM', 'Z IS A NEGATIVE INTEGER', 3, 2) ! CLNGAM = SQ2PIL + 1.0 - CMPLX(0.0,PI)*(Z-0.5) - CLNREL(-CORR) & + (Z-0.5)*LOG(1.0-Z) - Z - C9LGMC(1.0-Z) if (Y > 0.0) CLNGAM = CONJG (CLNGAM) return ! ! USE THE RECURSION RELATION FOR ABS(Z) SMALL. ! 20 if (X >= (-0.5) .OR. ABS(Y) > DXREL) go to 30 if (ABS((Z-AINT(X-0.5))/X) < DXREL) call XERMSG ('SLATEC', & 'CLNGAM', & 'ANSWER LT HALF PRECISION BECAUSE Z TOO NEAR NEGATIVE INTEGER', & 1, 1) ! 30 N = SQRT (BOUND**2 - Y**2) - X + 1.0 ARGSUM = 0.0 CORR = (1.0, 0.0) DO 40 I=1,N ARGSUM = ARGSUM + CARG(Z) CORR = Z*CORR Z = 1.0 + Z 40 CONTINUE ! if (REAL(CORR) == 0.0 .AND. AIMAG(CORR) == 0.0) call XERMSG & ('SLATEC', 'CLNGAM', 'Z IS A NEGATIVE INTEGER', 3, 2) CORR = -CMPLX (LOG(ABS(CORR)), ARGSUM) ! ! USE STIRLING-S APPROXIMATION FOR LARGE Z. ! 50 CLNGAM = SQ2PIL + (Z-0.5)*LOG(Z) - Z + CORR + C9LGMC(Z) return ! end FUNCTION CLNREL (Z) ! !! CLNREL evaluates ln(1+X) accurate in the sense of relative error. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4B !***TYPE COMPLEX (ALNREL-S, DLNREL-D, CLNREL-C) !***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CLNREL(Z) = LOG(1+Z) with relative error accuracy near Z = 0. ! Let RHO = ABS(Z) and ! R**2 = ABS(1+Z)**2 = (1+X)**2 + Y**2 = 1 + 2*X + RHO**2 . ! Now if RHO is small we may evaluate CLNREL(Z) accurately by ! LOG(1+Z) = CMPLX (LOG(R), CARG(1+Z)) ! = CMPLX (0.5*LOG(R**2), CARG(1+Z)) ! = CMPLX (0.5*ALNREL(2*X+RHO**2), CARG(1+Z)) ! !***REFERENCES (NONE) !***ROUTINES CALLED ALNREL, CARG, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE CLNREL COMPLEX CLNREL COMPLEX Z SAVE SQEPS DATA SQEPS /0.0/ !***FIRST EXECUTABLE STATEMENT CLNREL if (SQEPS == 0.) SQEPS = SQRT (R1MACH(4)) ! if (ABS(1.+Z) < SQEPS) call XERMSG ('SLATEC', 'CLNREL', & 'ANSWER LT HALF PRECISION BECAUSE Z TOO NEAR -1', 1, 1) ! RHO = ABS(Z) if (RHO > 0.375) CLNREL = LOG (1.0+Z) if (RHO > 0.375) RETURN ! X = REAL(Z) CLNREL = CMPLX (0.5*ALNREL(2.*X+RHO**2), CARG(1.0+Z)) ! return end FUNCTION CLOG10 (Z) ! !! CLOG10 computes the principal value of the complex base 10 logarithm. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4B !***TYPE COMPLEX (CLOG10-C) !***KEYWORDS BASE TEN LOGARITHM, ELEMENTARY FUNCTIONS, FNLIB !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CLOG10(Z) calculates the principal value of the complex common ! or base 10 logarithm of Z for -PI < arg(Z) <= +PI. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CLOG10 COMPLEX CLOG10 COMPLEX Z SAVE ALOGE DATA ALOGE / 0.43429448190325182765E0 / !***FIRST EXECUTABLE STATEMENT CLOG10 CLOG10 = ALOGE * LOG(Z) ! return end subroutine CMGNBN (NPEROD, N, MPEROD, M, A, B, C, IDIMY, Y, & IERROR, W) ! !! CMGNBN solves a complex block tridiagonal linear system of ... ! equations by a cyclic reduction algorithm. ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B4B !***TYPE COMPLEX (GENBUN-S, CMGNBN-C) !***KEYWORDS CYCLIC REDUCTION, ELLIPTIC PDE, FISHPACK, ! TRIDIAGONAL LINEAR SYSTEM !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine CMGNBN solves the complex linear system of equations ! ! A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J) ! ! + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J) ! ! For I = 1,2,...,M and J = 1,2,...,N. ! ! The indices I+1 and I-1 are evaluated modulo M, i.e., ! X(0,J) = X(M,J) and X(M+1,J) = X(1,J), and X(I,0) may be equal to ! 0, X(I,2), or X(I,N) and X(I,N+1) may be equal to 0, X(I,N-1), or ! X(I,1) depending on an input parameter. ! ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! NPEROD ! Indicates the values that X(I,0) and X(I,N+1) are assumed to ! have. ! ! = 0 If X(I,0) = X(I,N) and X(I,N+1) = X(I,1). ! = 1 If X(I,0) = X(I,N+1) = 0 . ! = 2 If X(I,0) = 0 and X(I,N+1) = X(I,N-1). ! = 3 If X(I,0) = X(I,2) and X(I,N+1) = X(I,N-1). ! = 4 If X(I,0) = X(I,2) and X(I,N+1) = 0. ! ! N ! The number of unknowns in the J-direction. N must be greater ! than 2. ! ! MPEROD ! = 0 If A(1) and C(M) are not zero ! = 1 If A(1) = C(M) = 0 ! ! M ! The number of unknowns in the I-direction. N must be greater ! than 2. ! ! A,B,C ! One-dimensional complex arrays of length M that specify the ! coefficients in the linear equations given above. If MPEROD = 0 ! the array elements must not depend upon the index I, but must be ! constant. Specifically, the subroutine checks the following ! condition ! ! A(I) = C(1) ! C(I) = C(1) ! B(I) = B(1) ! ! For I=1,2,...,M. ! ! IDIMY ! The row (or first) dimension of the two-dimensional array Y as ! it appears in the program calling CMGNBN. This parameter is ! used to specify the variable dimension of Y. IDIMY must be at ! least M. ! ! Y ! A two-dimensional complex array that specifies the values of the ! right side of the linear system of equations given above. Y ! must be dimensioned at least M*N. ! ! W ! A one-dimensional complex array that must be provided by the ! user for work space. W may require up to 4*N + ! (10 + INT(log2(N)))*M LOCATIONS. The actual number of locations ! used is computed by CMGNBN and is returned in location W(1). ! ! ! * * * * * * On Output * * * * * * ! ! Y ! Contains the solution X. ! ! IERROR ! An error flag which indicates invalid input parameters. Except ! for number zero, a solution is not attempted. ! ! = 0 No error. ! = 1 M <= 2 ! = 2 N <= 2 ! = 3 IDIMY < M ! = 4 NPEROD < 0 or NPEROD > 4 ! = 5 MPEROD < 0 or MPEROD > 1 ! = 6 A(I) /= C(1) or C(I) /= C(1) or B(I) /= B(1) for ! some I=1,2,...,M. ! = 7 A(1) /= 0 or C(M) /= 0 and MPEROD = 1 ! ! W ! W(1) contains the required length of W. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of A(M),B(M),C(M),Y(IDIMY,N),W(see parameter list) ! Arguments ! ! Latest June 1979 ! Revision ! ! Subprograms CMGNBN,CMPOSD,CMPOSN,CMPOSP,CMPCSG,CMPMRG, ! Required CMPTRX,CMPTR3,PIMACH ! ! Special None ! Conditions ! ! Common None ! Blocks ! ! I/O None ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Written by Roland Sweet at NCAR in June, 1977 ! ! Algorithm The linear system is solved by a cyclic reduction ! algorithm described in the reference. ! ! Space 4944(DECIMAL) = 11520(octal) locations on the NCAR ! Required Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine CMGNBN is roughly proportional ! to M*N*log2(N), but also depends on the input ! parameter NPEROD. Some typical values are listed ! in the table below. ! To measure the accuracy of the algorithm a ! uniform random number generator was used to create ! a solution array X for the system given in the ! 'PURPOSE' with ! ! A(I) = C(I) = -0.5*B(I) = 1, I=1,2,...,M ! ! and, when MPEROD = 1 ! ! A(1) = C(M) = 0 ! A(M) = C(1) = 2. ! ! The solution X was substituted into the given sys- ! tem and a right side Y was computed. Using this ! array Y subroutine CMGNBN was called to produce an ! approximate solution Z. Then the relative error, ! defined as ! ! E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J))) ! ! where the two maxima are taken over all I=1,2,...,M ! and J=1,2,...,N, was computed. The value of E is ! given in the table below for some typical values of ! M and N. ! ! ! M (=N) MPEROD NPEROD T(MSECS) E ! ------ ------ ------ -------- ------ ! ! 31 0 0 77 1.E-12 ! 31 1 1 45 4.E-13 ! 31 1 3 91 2.E-12 ! 32 0 0 59 7.E-14 ! 32 1 1 65 5.E-13 ! 32 1 3 97 2.E-13 ! 33 0 0 80 6.E-13 ! 33 1 1 67 5.E-13 ! 33 1 3 76 3.E-12 ! 63 0 0 350 5.E-12 ! 63 1 1 215 6.E-13 ! 63 1 3 412 1.E-11 ! 64 0 0 264 1.E-13 ! 64 1 1 287 3.E-12 ! 64 1 3 421 3.E-13 ! 65 0 0 338 2.E-12 ! 65 1 1 292 5.E-13 ! 65 1 3 329 1.E-11 ! ! Portability American National Standards Institute Fortran. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS ! Resident ! Routines ! ! Reference Sweet, R., 'A Cyclic Reduction Algorithm for ! Solving Block Tridiagonal Systems Of Arbitrary ! Dimensions,' SIAM J. on Numer. Anal., ! 14(SEPT., 1977), PP. 706-720. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES R. Sweet, A cyclic reduction algorithm for solving ! block tridiagonal systems of arbitrary dimensions, ! SIAM Journal on Numerical Analysis 14, (September ! 1977), pp. 706-720. !***ROUTINES CALLED CMPOSD, CMPOSN, CMPOSP !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CMGNBN ! ! COMPLEX A ,B ,C ,Y , & W ,A1 DIMENSION Y(IDIMY,*) DIMENSION W(*) ,B(*) ,A(*) ,C(*) !***FIRST EXECUTABLE STATEMENT CMGNBN IERROR = 0 if (M <= 2) IERROR = 1 if (N <= 2) IERROR = 2 if (IDIMY < M) IERROR = 3 if (NPEROD < 0 .OR. NPEROD > 4) IERROR = 4 if (MPEROD < 0 .OR. MPEROD > 1) IERROR = 5 if (MPEROD == 1) go to 102 DO 101 I=2,M if (ABS(A(I)-C(1)) /= 0.) go to 103 if (ABS(C(I)-C(1)) /= 0.) go to 103 if (ABS(B(I)-B(1)) /= 0.) go to 103 101 CONTINUE go to 104 102 if (ABS(A(1)) /= 0. .AND. ABS(C(M)) /= 0.) IERROR = 7 go to 104 103 IERROR = 6 104 if (IERROR /= 0) RETURN IWBA = M+1 IWBB = IWBA+M IWBC = IWBB+M IWB2 = IWBC+M IWB3 = IWB2+M IWW1 = IWB3+M IWW2 = IWW1+M IWW3 = IWW2+M IWD = IWW3+M IWTCOS = IWD+M IWP = IWTCOS+4*N DO 106 I=1,M K = IWBA+I-1 W(K) = -A(I) K = IWBC+I-1 W(K) = -C(I) K = IWBB+I-1 W(K) = 2.-B(I) DO 105 J=1,N Y(I,J) = -Y(I,J) 105 CONTINUE 106 CONTINUE MP = MPEROD+1 NP = NPEROD+1 go to (114,107),MP 107 go to (108,109,110,111,123),NP 108 call CMPOSP (M,N,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), & W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), & W(IWP)) go to 112 109 call CMPOSD (M,N,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWW1), & W(IWD),W(IWTCOS),W(IWP)) go to 112 110 call CMPOSN (M,N,1,2,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), & W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), & W(IWP)) go to 112 111 call CMPOSN (M,N,1,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), & W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), & W(IWP)) 112 IPSTOR = REAL(W(IWW1)) IREV = 2 if (NPEROD == 4) go to 124 113 go to (127,133),MP 114 CONTINUE ! ! REORDER UNKNOWNS WHEN MP =0 ! MH = (M+1)/2 MHM1 = MH-1 MODD = 1 if (MH*2 == M) MODD = 2 DO 119 J=1,N DO 115 I=1,MHM1 MHPI = MH+I MHMI = MH-I W(I) = Y(MHMI,J)-Y(MHPI,J) W(MHPI) = Y(MHMI,J)+Y(MHPI,J) 115 CONTINUE W(MH) = 2.*Y(MH,J) go to (117,116),MODD 116 W(M) = 2.*Y(M,J) 117 CONTINUE DO 118 I=1,M Y(I,J) = W(I) 118 CONTINUE 119 CONTINUE K = IWBC+MHM1-1 I = IWBA+MHM1 W(K) = (0.,0.) W(I) = (0.,0.) W(K+1) = 2.*W(K+1) go to (120,121),MODD 120 CONTINUE K = IWBB+MHM1-1 W(K) = W(K)-W(I-1) W(IWBC-1) = W(IWBC-1)+W(IWBB-1) go to 122 121 W(IWBB-1) = W(K+1) 122 CONTINUE go to 107 ! ! REVERSE COLUMNS WHEN NPEROD = 4 ! 123 IREV = 1 NBY2 = N/2 124 DO 126 J=1,NBY2 MSKIP = N+1-J DO 125 I=1,M A1 = Y(I,J) Y(I,J) = Y(I,MSKIP) Y(I,MSKIP) = A1 125 CONTINUE 126 CONTINUE go to (110,113),IREV 127 CONTINUE DO 132 J=1,N DO 128 I=1,MHM1 MHMI = MH-I MHPI = MH+I W(MHMI) = .5*(Y(MHPI,J)+Y(I,J)) W(MHPI) = .5*(Y(MHPI,J)-Y(I,J)) 128 CONTINUE W(MH) = .5*Y(MH,J) go to (130,129),MODD 129 W(M) = .5*Y(M,J) 130 CONTINUE DO 131 I=1,M Y(I,J) = W(I) 131 CONTINUE 132 CONTINUE 133 CONTINUE ! ! return STORAGE REQUIREMENTS FOR W ARRAY. ! W(1) = CMPLX(REAL(IPSTOR+IWP-1),0.) return end subroutine CMLRI (Z, FNU, KODE, N, Y, NZ, TOL) ! !! CMLRI is subsidiary to CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CMLRI-A, ZMLRI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z) >= 0.0 BY THE ! MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. ! !***SEE ALSO CBESI, CBESK !***ROUTINES CALLED GAMLN, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CMLRI COMPLEX CK, CNORM, CONE, CTWO, CZERO, PT, P1, P2, RZ, SUM, Y, Z REAL ACK, AK, AP, AT, AZ, BK, FKAP, FKK, FLAM, FNF, FNU, RHO, & RHO2, SCLE, TFNF, TOL, TST, X, GAMLN, R1MACH INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ DIMENSION Y(N) DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/ SCLE = 1.0E+3*R1MACH(1)/TOL !***FIRST EXECUTABLE STATEMENT CMLRI NZ=0 AZ = ABS(Z) X = REAL(Z) IAZ = AZ IFNU = FNU INU = IFNU + N - 1 AT = IAZ + 1.0E0 CK = CMPLX(AT,0.0E0)/Z RZ = CTWO/Z P1 = CZERO P2 = CONE ACK = (AT+1.0E0)/AZ RHO = ACK + SQRT(ACK*ACK-1.0E0) RHO2 = RHO*RHO TST = (RHO2+RHO2)/((RHO2-1.0E0)*(RHO-1.0E0)) TST = TST/TOL !----------------------------------------------------------------------- ! COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES !----------------------------------------------------------------------- AK = AT DO 10 I=1,80 PT = P2 P2 = P1 - CK*P2 P1 = PT CK = CK + RZ AP = ABS(P2) if (AP > TST*AK*AK) go to 20 AK = AK + 1.0E0 10 CONTINUE go to 110 20 CONTINUE I = I + 1 K = 0 if (INU < IAZ) go to 40 !----------------------------------------------------------------------- ! COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS !----------------------------------------------------------------------- P1 = CZERO P2 = CONE AT = INU + 1.0E0 CK = CMPLX(AT,0.0E0)/Z ACK = AT/AZ TST = SQRT(ACK/TOL) ITIME = 1 DO 30 K=1,80 PT = P2 P2 = P1 - CK*P2 P1 = PT CK = CK + RZ AP = ABS(P2) if (AP < TST) go to 30 if (ITIME == 2) go to 40 ACK = ABS(CK) FLAM = ACK + SQRT(ACK*ACK-1.0E0) FKAP = AP/ABS(P1) RHO = MIN(FLAM,FKAP) TST = TST*SQRT(RHO/(RHO*RHO-1.0E0)) ITIME = 2 30 CONTINUE go to 110 40 CONTINUE !----------------------------------------------------------------------- ! BACKWARD RECURRENCE AND SUM NORMALIZING RELATION !----------------------------------------------------------------------- K = K + 1 KK = MAX(I+IAZ,K+INU) FKK = KK P1 = CZERO !----------------------------------------------------------------------- ! SCALE P2 AND SUM BY SCLE !----------------------------------------------------------------------- P2 = CMPLX(SCLE,0.0E0) FNF = FNU - IFNU TFNF = FNF + FNF BK = GAMLN(FKK+TFNF+1.0E0,IDUM) - GAMLN(FKK+1.0E0,IDUM) & -GAMLN(TFNF+1.0E0,IDUM) BK = EXP(BK) SUM = CZERO KM = KK - INU DO 50 I=1,KM PT = P2 P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 P1 = PT AK = 1.0E0 - TFNF/(FKK+TFNF) ACK = BK*AK SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 BK = ACK FKK = FKK - 1.0E0 50 CONTINUE Y(N) = P2 if (N == 1) go to 70 DO 60 I=2,N PT = P2 P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 P1 = PT AK = 1.0E0 - TFNF/(FKK+TFNF) ACK = BK*AK SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 BK = ACK FKK = FKK - 1.0E0 M = N - I + 1 Y(M) = P2 60 CONTINUE 70 CONTINUE if (IFNU <= 0) go to 90 DO 80 I=1,IFNU PT = P2 P2 = P1 + CMPLX(FKK+FNF,0.0E0)*RZ*P2 P1 = PT AK = 1.0E0 - TFNF/(FKK+TFNF) ACK = BK*AK SUM = SUM + CMPLX(ACK+BK,0.0E0)*P1 BK = ACK FKK = FKK - 1.0E0 80 CONTINUE 90 CONTINUE PT = Z if (KODE == 2) PT = PT - CMPLX(X,0.0E0) P1 = -CMPLX(FNF,0.0E0)*CLOG(RZ) + PT AP = GAMLN(1.0E0+FNF,IDUM) PT = P1 - CMPLX(AP,0.0E0) !----------------------------------------------------------------------- ! THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW ! IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES !----------------------------------------------------------------------- P2 = P2 + SUM AP = ABS(P2) P1 = CMPLX(1.0E0/AP,0.0E0) CK = CEXP(PT)*P1 PT = CONJG(P2)*P1 CNORM = CK*PT DO 100 I=1,N Y(I) = Y(I)*CNORM 100 CONTINUE return 110 CONTINUE NZ=-2 return end subroutine CMPCSG (N, IJUMP, FNUM, FDEN, A) ! !! CMPCSG is subsidiary to CMGNBN. ! !***LIBRARY SLATEC !***TYPE COMPLEX (COSGEN-S, CMPCSG-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine computes required cosine values in ascending ! order. When IJUMP > 1 the routine computes values ! ! 2*COS(J*PI/L) , J=1,2,...,L and J /= 0(MOD N/IJUMP+1) ! ! where L = IJUMP*(N/IJUMP+1). ! ! ! when IJUMP = 1 it computes ! ! 2*COS((J-FNUM)*PI/(N+FDEN)) , J=1, 2, ... ,N ! ! where ! FNUM = 0.5, FDEN = 0.0, for regular reduction values. ! FNUM = 0.0, FDEN = 1.0, for B-R and C-R when ISTAG = 1 ! FNUM = 0.0, FDEN = 0.5, for B-R and C-R when ISTAG = 2 ! FNUM = 0.5, FDEN = 0.5, for B-R and C-R when ISTAG = 2 ! in CMPOSN only. ! !***SEE ALSO CMGNBN !***ROUTINES CALLED PIMACH !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CMPCSG COMPLEX A DIMENSION A(*) ! ! !***FIRST EXECUTABLE STATEMENT CMPCSG PI = PIMACH(DUM) if (N == 0) go to 105 if (IJUMP == 1) go to 103 K3 = N/IJUMP+1 K4 = K3-1 PIBYN = PI/(N+IJUMP) DO 102 K=1,IJUMP K1 = (K-1)*K3 K5 = (K-1)*K4 DO 101 I=1,K4 X = K1+I K2 = K5+I A(K2) = CMPLX(-2.*COS(X*PIBYN),0.) 101 CONTINUE 102 CONTINUE go to 105 103 CONTINUE NP1 = N+1 Y = PI/(N+FDEN) DO 104 I=1,N X = NP1-I-FNUM A(I) = CMPLX(2.*COS(X*Y),0.) 104 CONTINUE 105 CONTINUE return end subroutine CMPOSD (MR, NR, ISTAG, BA, BB, BC, Q, IDIMQ, B, W, D, & TCOS, P) ! !! CMPOSD is subsidiary to CMGNBN. ! !***LIBRARY SLATEC !***TYPE COMPLEX (POISD2-S, CMPOSD-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve Poisson's equation for Dirichlet boundary ! conditions. ! ! ISTAG = 1 if the last diagonal block is the matrix A. ! ISTAG = 2 if the last diagonal block is the matrix A+I. ! !***SEE ALSO CMGNBN !***ROUTINES CALLED C1MERG, CMPCSG, CMPTRX !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 920130 Modified to use merge routine C1MERG rather than deleted ! routine CMPMRG. (WRB) !***END PROLOGUE CMPOSD ! COMPLEX BA ,BB ,BC ,Q , & B ,W ,D ,TCOS , & P ,T DIMENSION Q(IDIMQ,*) ,BA(*) ,BB(*) ,BC(*) , & TCOS(*) ,B(*) ,D(*) ,W(*) , & P(*) !***FIRST EXECUTABLE STATEMENT CMPOSD M = MR N = NR FI = 1./ISTAG IP = -M IPSTOR = 0 JSH = 0 go to (101,102),ISTAG 101 KR = 0 IRREG = 1 if (N > 1) go to 106 TCOS(1) = (0.,0.) go to 103 102 KR = 1 JSTSAV = 1 IRREG = 2 if (N > 1) go to 106 TCOS(1) = CMPLX(-1.,0.) 103 DO 104 I=1,M B(I) = Q(I,1) 104 CONTINUE call CMPTRX (1,0,M,BA,BB,BC,B,TCOS,D,W) DO 105 I=1,M Q(I,1) = B(I) 105 CONTINUE go to 183 106 LR = 0 DO 107 I=1,M P(I) = CMPLX(0.,0.) 107 CONTINUE NUN = N JST = 1 JSP = N ! ! IRREG = 1 WHEN NO IRREGULARITIES HAVE OCCURRED, OTHERWISE IT IS 2. ! 108 L = 2*JST NODD = 2-2*((NUN+1)/2)+NUN ! ! NODD = 1 WHEN NUN IS ODD, OTHERWISE IT IS 2. ! go to (110,109),NODD 109 JSP = JSP-L go to 111 110 JSP = JSP-JST if (IRREG /= 1) JSP = JSP-L 111 CONTINUE ! ! REGULAR REDUCTION ! call CMPCSG (JST,1,0.5,0.0,TCOS) if (L > JSP) go to 118 DO 117 J=L,JSP,L JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST JM3 = JM2-JSH JP3 = JP2+JSH if (JST /= 1) go to 113 DO 112 I=1,M B(I) = 2.*Q(I,J) Q(I,J) = Q(I,JM2)+Q(I,JP2) 112 CONTINUE go to 115 113 DO 114 I=1,M T = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) B(I) = T+Q(I,J)-Q(I,JM3)-Q(I,JP3) Q(I,J) = T 114 CONTINUE 115 CONTINUE call CMPTRX (JST,0,M,BA,BB,BC,B,TCOS,D,W) DO 116 I=1,M Q(I,J) = Q(I,J)+B(I) 116 CONTINUE 117 CONTINUE ! ! REDUCTION FOR LAST UNKNOWN ! 118 go to (119,136),NODD 119 go to (152,120),IRREG ! ! ODD NUMBER OF UNKNOWNS ! 120 JSP = JSP+L J = JSP JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST JM3 = JM2-JSH go to (123,121),ISTAG 121 CONTINUE if (JST /= 1) go to 123 DO 122 I=1,M B(I) = Q(I,J) Q(I,J) = CMPLX(0.,0.) 122 CONTINUE go to 130 123 go to (124,126),NODDPR 124 DO 125 I=1,M IP1 = IP+I B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+P(IP1)+Q(I,J) 125 CONTINUE go to 128 126 DO 127 I=1,M B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+Q(I,JP2)-Q(I,JP1)+Q(I,J) 127 CONTINUE 128 DO 129 I=1,M Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) 129 CONTINUE 130 call CMPTRX (JST,0,M,BA,BB,BC,B,TCOS,D,W) IP = IP+M IPSTOR = MAX(IPSTOR,IP+M) DO 131 I=1,M IP1 = IP+I P(IP1) = Q(I,J)+B(I) B(I) = Q(I,JP2)+P(IP1) 131 CONTINUE if (LR /= 0) go to 133 DO 132 I=1,JST KRPI = KR+I TCOS(KRPI) = TCOS(I) 132 CONTINUE go to 134 133 CONTINUE call CMPCSG (LR,JSTSAV,0.,FI,TCOS(JST+1)) call C1MERG (TCOS,0,JST,JST,LR,KR) 134 CONTINUE call CMPCSG (KR,JSTSAV,0.0,FI,TCOS) call CMPTRX (KR,KR,M,BA,BB,BC,B,TCOS,D,W) DO 135 I=1,M IP1 = IP+I Q(I,J) = Q(I,JM2)+B(I)+P(IP1) 135 CONTINUE LR = KR KR = KR+L go to 152 ! ! EVEN NUMBER OF UNKNOWNS ! 136 JSP = JSP+L J = JSP JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST JM3 = JM2-JSH go to (137,138),IRREG 137 CONTINUE JSTSAV = JST IDEG = JST KR = L go to 139 138 call CMPCSG (KR,JSTSAV,0.0,FI,TCOS) call CMPCSG (LR,JSTSAV,0.0,FI,TCOS(KR+1)) IDEG = KR KR = KR+JST 139 if (JST /= 1) go to 141 IRREG = 2 DO 140 I=1,M B(I) = Q(I,J) Q(I,J) = Q(I,JM2) 140 CONTINUE go to 150 141 DO 142 I=1,M B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 142 CONTINUE go to (143,145),IRREG 143 DO 144 I=1,M Q(I,J) = Q(I,JM2)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) 144 CONTINUE IRREG = 2 go to 150 145 CONTINUE go to (146,148),NODDPR 146 DO 147 I=1,M IP1 = IP+I Q(I,J) = Q(I,JM2)+P(IP1) 147 CONTINUE IP = IP-M go to 150 148 DO 149 I=1,M Q(I,J) = Q(I,JM2)+Q(I,J)-Q(I,JM1) 149 CONTINUE 150 call CMPTRX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W) DO 151 I=1,M Q(I,J) = Q(I,J)+B(I) 151 CONTINUE 152 NUN = NUN/2 NODDPR = NODD JSH = JST JST = 2*JST if (NUN >= 2) go to 108 ! ! START SOLUTION. ! J = JSP DO 153 I=1,M B(I) = Q(I,J) 153 CONTINUE go to (154,155),IRREG 154 CONTINUE call CMPCSG (JST,1,0.5,0.0,TCOS) IDEG = JST go to 156 155 KR = LR+JST call CMPCSG (KR,JSTSAV,0.0,FI,TCOS) call CMPCSG (LR,JSTSAV,0.0,FI,TCOS(KR+1)) IDEG = KR 156 CONTINUE call CMPTRX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W) JM1 = J-JSH JP1 = J+JSH go to (157,159),IRREG 157 DO 158 I=1,M Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) 158 CONTINUE go to 164 159 go to (160,162),NODDPR 160 DO 161 I=1,M IP1 = IP+I Q(I,J) = P(IP1)+B(I) 161 CONTINUE IP = IP-M go to 164 162 DO 163 I=1,M Q(I,J) = Q(I,J)-Q(I,JM1)+B(I) 163 CONTINUE 164 CONTINUE ! ! START BACK SUBSTITUTION. ! JST = JST/2 JSH = JST/2 NUN = 2*NUN if (NUN > N) go to 183 DO 182 J=JST,N,L JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST if (J > JST) go to 166 DO 165 I=1,M B(I) = Q(I,J)+Q(I,JP2) 165 CONTINUE go to 170 166 if (JP2 <= N) go to 168 DO 167 I=1,M B(I) = Q(I,J)+Q(I,JM2) 167 CONTINUE if (JST < JSTSAV) IRREG = 1 go to (170,171),IRREG 168 DO 169 I=1,M B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) 169 CONTINUE 170 CONTINUE call CMPCSG (JST,1,0.5,0.0,TCOS) IDEG = JST JDEG = 0 go to 172 171 if (J+L > N) LR = LR-JST KR = JST+LR call CMPCSG (KR,JSTSAV,0.0,FI,TCOS) call CMPCSG (LR,JSTSAV,0.0,FI,TCOS(KR+1)) IDEG = KR JDEG = LR 172 CONTINUE call CMPTRX (IDEG,JDEG,M,BA,BB,BC,B,TCOS,D,W) if (JST > 1) go to 174 DO 173 I=1,M Q(I,J) = B(I) 173 CONTINUE go to 182 174 if (JP2 > N) go to 177 175 DO 176 I=1,M Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) 176 CONTINUE go to 182 177 go to (175,178),IRREG 178 if (J+JSH > N) go to 180 DO 179 I=1,M IP1 = IP+I Q(I,J) = B(I)+P(IP1) 179 CONTINUE IP = IP-M go to 182 180 DO 181 I=1,M Q(I,J) = B(I)+Q(I,J)-Q(I,JM1) 181 CONTINUE 182 CONTINUE L = L/2 go to 164 183 CONTINUE ! ! return STORAGE REQUIREMENTS FOR P VECTORS. ! W(1) = CMPLX(REAL(IPSTOR),0.) return end subroutine CMPOSN (M, N, ISTAG, MIXBND, A, BB, C, Q, IDIMQ, B, B2, & B3, W, W2, W3, D, TCOS, P) ! !! CMPOSN is subsidiary to CMGNBN. ! !***LIBRARY SLATEC !***TYPE COMPLEX (POISN2-S, CMPOSN-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve Poisson's equation with Neumann boundary ! conditions. ! ! ISTAG = 1 if the last diagonal block is A. ! ISTAG = 2 if the last diagonal block is A-I. ! MIXBND = 1 if have Neumann boundary conditions at both boundaries. ! MIXBND = 2 if have Neumann boundary conditions at bottom and ! Dirichlet condition at top. (For this case, must have ISTAG = 1) ! !***SEE ALSO CMGNBN !***ROUTINES CALLED C1MERG, CMPCSG, CMPTR3, CMPTRX !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 920130 Modified to use merge routine C1MERG rather than deleted ! routine CMPMRG. (WRB) !***END PROLOGUE CMPOSN ! COMPLEX A ,BB ,C ,Q , & B ,B2 ,B3 ,W , & W2 ,W3 ,D ,TCOS , & P ,FI ,T DIMENSION A(*) ,BB(*) ,C(*) ,Q(IDIMQ,*) , & B(*) ,B2(*) ,B3(*) ,W(*) , & W2(*) ,W3(*) ,D(*) ,TCOS(*) , & K(4) ,P(*) EQUIVALENCE (K(1),K1) ,(K(2),K2) ,(K(3),K3) ,(K(4),K4) !***FIRST EXECUTABLE STATEMENT CMPOSN FISTAG = 3-ISTAG FNUM = 1./ISTAG FDEN = 0.5*(ISTAG-1) MR = M IP = -MR IPSTOR = 0 I2R = 1 JR = 2 NR = N NLAST = N KR = 1 LR = 0 go to (101,103),ISTAG 101 CONTINUE DO 102 I=1,MR Q(I,N) = .5*Q(I,N) 102 CONTINUE go to (103,104),MIXBND 103 if (N <= 3) go to 155 104 CONTINUE JR = 2*I2R NROD = 1 if ((NR/2)*2 == NR) NROD = 0 go to (105,106),MIXBND 105 JSTART = 1 go to 107 106 JSTART = JR NROD = 1-NROD 107 CONTINUE JSTOP = NLAST-JR if (NROD == 0) JSTOP = JSTOP-I2R call CMPCSG (I2R,1,0.5,0.0,TCOS) I2RBY2 = I2R/2 if (JSTOP >= JSTART) go to 108 J = JR go to 116 108 CONTINUE ! ! REGULAR REDUCTION. ! DO 115 J=JSTART,JSTOP,JR JP1 = J+I2RBY2 JP2 = J+I2R JP3 = JP2+I2RBY2 JM1 = J-I2RBY2 JM2 = J-I2R JM3 = JM2-I2RBY2 if (J /= 1) go to 109 JM1 = JP1 JM2 = JP2 JM3 = JP3 109 CONTINUE if (I2R /= 1) go to 111 if (J == 1) JM2 = JP2 DO 110 I=1,MR B(I) = 2.*Q(I,J) Q(I,J) = Q(I,JM2)+Q(I,JP2) 110 CONTINUE go to 113 111 CONTINUE DO 112 I=1,MR FI = Q(I,J) Q(I,J) = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) B(I) = FI+Q(I,J)-Q(I,JM3)-Q(I,JP3) 112 CONTINUE 113 CONTINUE call CMPTRX (I2R,0,MR,A,BB,C,B,TCOS,D,W) DO 114 I=1,MR Q(I,J) = Q(I,J)+B(I) 114 CONTINUE ! ! END OF REDUCTION FOR REGULAR UNKNOWNS. ! 115 CONTINUE ! ! BEGIN SPECIAL REDUCTION FOR LAST UNKNOWN. ! J = JSTOP+JR 116 NLAST = J JM1 = J-I2RBY2 JM2 = J-I2R JM3 = JM2-I2RBY2 if (NROD == 0) go to 128 ! ! ODD NUMBER OF UNKNOWNS ! if (I2R /= 1) go to 118 DO 117 I=1,MR B(I) = FISTAG*Q(I,J) Q(I,J) = Q(I,JM2) 117 CONTINUE go to 126 118 DO 119 I=1,MR B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 119 CONTINUE if (NRODPR /= 0) go to 121 DO 120 I=1,MR II = IP+I Q(I,J) = Q(I,JM2)+P(II) 120 CONTINUE IP = IP-MR go to 123 121 CONTINUE DO 122 I=1,MR Q(I,J) = Q(I,J)-Q(I,JM1)+Q(I,JM2) 122 CONTINUE 123 if (LR == 0) go to 124 call CMPCSG (LR,1,0.5,FDEN,TCOS(KR+1)) go to 126 124 CONTINUE DO 125 I=1,MR B(I) = FISTAG*B(I) 125 CONTINUE 126 CONTINUE call CMPCSG (KR,1,0.5,FDEN,TCOS) call CMPTRX (KR,LR,MR,A,BB,C,B,TCOS,D,W) DO 127 I=1,MR Q(I,J) = Q(I,J)+B(I) 127 CONTINUE KR = KR+I2R go to 151 128 CONTINUE ! ! EVEN NUMBER OF UNKNOWNS ! JP1 = J+I2RBY2 JP2 = J+I2R if (I2R /= 1) go to 135 DO 129 I=1,MR B(I) = Q(I,J) 129 CONTINUE call CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) IP = 0 IPSTOR = MR go to (133,130),ISTAG 130 DO 131 I=1,MR P(I) = B(I) B(I) = B(I)+Q(I,N) 131 CONTINUE TCOS(1) = CMPLX(1.,0.) TCOS(2) = CMPLX(0.,0.) call CMPTRX (1,1,MR,A,BB,C,B,TCOS,D,W) DO 132 I=1,MR Q(I,J) = Q(I,JM2)+P(I)+B(I) 132 CONTINUE go to 150 133 CONTINUE DO 134 I=1,MR P(I) = B(I) Q(I,J) = Q(I,JM2)+2.*Q(I,JP2)+3.*B(I) 134 CONTINUE go to 150 135 CONTINUE DO 136 I=1,MR B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 136 CONTINUE if (NRODPR /= 0) go to 138 DO 137 I=1,MR II = IP+I B(I) = B(I)+P(II) 137 CONTINUE go to 140 138 CONTINUE DO 139 I=1,MR B(I) = B(I)+Q(I,JP2)-Q(I,JP1) 139 CONTINUE 140 CONTINUE call CMPTRX (I2R,0,MR,A,BB,C,B,TCOS,D,W) IP = IP+MR IPSTOR = MAX(IPSTOR,IP+MR) DO 141 I=1,MR II = IP+I P(II) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) B(I) = P(II)+Q(I,JP2) 141 CONTINUE if (LR == 0) go to 142 call CMPCSG (LR,1,0.5,FDEN,TCOS(I2R+1)) call C1MERG (TCOS,0,I2R,I2R,LR,KR) go to 144 142 DO 143 I=1,I2R II = KR+I TCOS(II) = TCOS(I) 143 CONTINUE 144 call CMPCSG (KR,1,0.5,FDEN,TCOS) if (LR /= 0) go to 145 go to (146,145),ISTAG 145 CONTINUE call CMPTRX (KR,KR,MR,A,BB,C,B,TCOS,D,W) go to 148 146 CONTINUE DO 147 I=1,MR B(I) = FISTAG*B(I) 147 CONTINUE 148 CONTINUE DO 149 I=1,MR II = IP+I Q(I,J) = Q(I,JM2)+P(II)+B(I) 149 CONTINUE 150 CONTINUE LR = KR KR = KR+JR 151 CONTINUE go to (152,153),MIXBND 152 NR = (NLAST-1)/JR+1 if (NR <= 3) go to 155 go to 154 153 NR = NLAST/JR if (NR <= 1) go to 192 154 I2R = JR NRODPR = NROD go to 104 155 CONTINUE ! ! BEGIN SOLUTION ! J = 1+JR JM1 = J-I2R JP1 = J+I2R JM2 = NLAST-I2R if (NR == 2) go to 184 if (LR /= 0) go to 170 if (N /= 3) go to 161 ! ! CASE N = 3. ! go to (156,168),ISTAG 156 CONTINUE DO 157 I=1,MR B(I) = Q(I,2) 157 CONTINUE TCOS(1) = CMPLX(0.,0.) call CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 158 I=1,MR Q(I,2) = B(I) B(I) = 4.*B(I)+Q(I,1)+2.*Q(I,3) 158 CONTINUE TCOS(1) = CMPLX(-2.,0.) TCOS(2) = CMPLX(2.,0.) I1 = 2 I2 = 0 call CMPTRX (I1,I2,MR,A,BB,C,B,TCOS,D,W) DO 159 I=1,MR Q(I,2) = Q(I,2)+B(I) B(I) = Q(I,1)+2.*Q(I,2) 159 CONTINUE TCOS(1) = (0.,0.) call CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 160 I=1,MR Q(I,1) = B(I) 160 CONTINUE JR = 1 I2R = 0 go to 194 ! ! CASE N = 2**P+1 ! 161 CONTINUE go to (162,170),ISTAG 162 CONTINUE DO 163 I=1,MR B(I) = Q(I,J)+.5*Q(I,1)-Q(I,JM1)+Q(I,NLAST)-Q(I,JM2) 163 CONTINUE call CMPCSG (JR,1,0.5,0.0,TCOS) call CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 164 I=1,MR Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) B(I) = Q(I,1)+2.*Q(I,NLAST)+4.*Q(I,J) 164 CONTINUE JR2 = 2*JR call CMPCSG (JR,1,0.0,0.0,TCOS) DO 165 I=1,JR I1 = JR+I I2 = JR+1-I TCOS(I1) = -TCOS(I2) 165 CONTINUE call CMPTRX (JR2,0,MR,A,BB,C,B,TCOS,D,W) DO 166 I=1,MR Q(I,J) = Q(I,J)+B(I) B(I) = Q(I,1)+2.*Q(I,J) 166 CONTINUE call CMPCSG (JR,1,0.5,0.0,TCOS) call CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 167 I=1,MR Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I) 167 CONTINUE go to 194 ! ! CASE OF GENERAL N WITH NR = 3 . ! 168 DO 169 I=1,MR B(I) = Q(I,2) Q(I,2) = (0.,0.) B2(I) = Q(I,3) B3(I) = Q(I,1) 169 CONTINUE JR = 1 I2R = 0 J = 2 go to 177 170 CONTINUE DO 171 I=1,MR B(I) = .5*Q(I,1)-Q(I,JM1)+Q(I,J) 171 CONTINUE if (NROD /= 0) go to 173 DO 172 I=1,MR II = IP+I B(I) = B(I)+P(II) 172 CONTINUE go to 175 173 DO 174 I=1,MR B(I) = B(I)+Q(I,NLAST)-Q(I,JM2) 174 CONTINUE 175 CONTINUE DO 176 I=1,MR T = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) Q(I,J) = T B2(I) = Q(I,NLAST)+T B3(I) = Q(I,1)+2.*T 176 CONTINUE 177 CONTINUE K1 = KR+2*JR-1 K2 = KR+JR TCOS(K1+1) = (-2.,0.) K4 = K1+3-ISTAG call CMPCSG (K2+ISTAG-2,1,0.0,FNUM,TCOS(K4)) K4 = K1+K2+1 call CMPCSG (JR-1,1,0.0,1.0,TCOS(K4)) call C1MERG (TCOS,K1,K2,K1+K2,JR-1,0) K3 = K1+K2+LR call CMPCSG (JR,1,0.5,0.0,TCOS(K3+1)) K4 = K3+JR+1 call CMPCSG (KR,1,0.5,FDEN,TCOS(K4)) call C1MERG (TCOS,K3,JR,K3+JR,KR,K1) if (LR == 0) go to 178 call CMPCSG (LR,1,0.5,FDEN,TCOS(K4)) call C1MERG (TCOS,K3,JR,K3+JR,LR,K3-LR) call CMPCSG (KR,1,0.5,FDEN,TCOS(K4)) 178 K3 = KR K4 = KR call CMPTR3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) DO 179 I=1,MR B(I) = B(I)+B2(I)+B3(I) 179 CONTINUE TCOS(1) = (2.,0.) call CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 180 I=1,MR Q(I,J) = Q(I,J)+B(I) B(I) = Q(I,1)+2.*Q(I,J) 180 CONTINUE call CMPCSG (JR,1,0.5,0.0,TCOS) call CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W) if (JR /= 1) go to 182 DO 181 I=1,MR Q(I,1) = B(I) 181 CONTINUE go to 194 182 CONTINUE DO 183 I=1,MR Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I) 183 CONTINUE go to 194 184 CONTINUE if (N /= 2) go to 188 ! ! CASE N = 2 ! DO 185 I=1,MR B(I) = Q(I,1) 185 CONTINUE TCOS(1) = (0.,0.) call CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 186 I=1,MR Q(I,1) = B(I) B(I) = 2.*(Q(I,2)+B(I))*FISTAG 186 CONTINUE TCOS(1) = CMPLX(-FISTAG,0.) TCOS(2) = CMPLX(2.,0.) call CMPTRX (2,0,MR,A,BB,C,B,TCOS,D,W) DO 187 I=1,MR Q(I,1) = Q(I,1)+B(I) 187 CONTINUE JR = 1 I2R = 0 go to 194 188 CONTINUE ! ! CASE OF GENERAL N AND NR = 2 . ! DO 189 I=1,MR II = IP+I B3(I) = (0.,0.) B(I) = Q(I,1)+2.*P(II) Q(I,1) = .5*Q(I,1)-Q(I,JM1) B2(I) = 2.*(Q(I,1)+Q(I,NLAST)) 189 CONTINUE K1 = KR+JR-1 TCOS(K1+1) = (-2.,0.) K4 = K1+3-ISTAG call CMPCSG (KR+ISTAG-2,1,0.0,FNUM,TCOS(K4)) K4 = K1+KR+1 call CMPCSG (JR-1,1,0.0,1.0,TCOS(K4)) call C1MERG (TCOS,K1,KR,K1+KR,JR-1,0) call CMPCSG (KR,1,0.5,FDEN,TCOS(K1+1)) K2 = KR K4 = K1+K2+1 call CMPCSG (LR,1,0.5,FDEN,TCOS(K4)) K3 = LR K4 = 0 call CMPTR3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) DO 190 I=1,MR B(I) = B(I)+B2(I) 190 CONTINUE TCOS(1) = (2.,0.) call CMPTRX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 191 I=1,MR Q(I,1) = Q(I,1)+B(I) 191 CONTINUE go to 194 192 DO 193 I=1,MR B(I) = Q(I,NLAST) 193 CONTINUE go to 196 194 CONTINUE ! ! START BACK SUBSTITUTION. ! J = NLAST-JR DO 195 I=1,MR B(I) = Q(I,NLAST)+Q(I,J) 195 CONTINUE 196 JM2 = NLAST-I2R if (JR /= 1) go to 198 DO 197 I=1,MR Q(I,NLAST) = (0.,0.) 197 CONTINUE go to 202 198 CONTINUE if (NROD /= 0) go to 200 DO 199 I=1,MR II = IP+I Q(I,NLAST) = P(II) 199 CONTINUE IP = IP-MR go to 202 200 DO 201 I=1,MR Q(I,NLAST) = Q(I,NLAST)-Q(I,JM2) 201 CONTINUE 202 CONTINUE call CMPCSG (KR,1,0.5,FDEN,TCOS) call CMPCSG (LR,1,0.5,FDEN,TCOS(KR+1)) if (LR /= 0) go to 204 DO 203 I=1,MR B(I) = FISTAG*B(I) 203 CONTINUE 204 CONTINUE call CMPTRX (KR,LR,MR,A,BB,C,B,TCOS,D,W) DO 205 I=1,MR Q(I,NLAST) = Q(I,NLAST)+B(I) 205 CONTINUE NLASTP = NLAST 206 CONTINUE JSTEP = JR JR = I2R I2R = I2R/2 if (JR == 0) go to 222 go to (207,208),MIXBND 207 JSTART = 1+JR go to 209 208 JSTART = JR 209 CONTINUE KR = KR-JR if (NLAST+JR > N) go to 210 KR = KR-JR NLAST = NLAST+JR JSTOP = NLAST-JSTEP go to 211 210 CONTINUE JSTOP = NLAST-JR 211 CONTINUE LR = KR-JR call CMPCSG (JR,1,0.5,0.0,TCOS) DO 221 J=JSTART,JSTOP,JSTEP JM2 = J-JR JP2 = J+JR if (J /= JR) go to 213 DO 212 I=1,MR B(I) = Q(I,J)+Q(I,JP2) 212 CONTINUE go to 215 213 CONTINUE DO 214 I=1,MR B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) 214 CONTINUE 215 CONTINUE if (JR /= 1) go to 217 DO 216 I=1,MR Q(I,J) = (0.,0.) 216 CONTINUE go to 219 217 CONTINUE JM1 = J-I2R JP1 = J+I2R DO 218 I=1,MR Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) 218 CONTINUE 219 CONTINUE call CMPTRX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 220 I=1,MR Q(I,J) = Q(I,J)+B(I) 220 CONTINUE 221 CONTINUE NROD = 1 if (NLAST+I2R <= N) NROD = 0 if (NLASTP /= NLAST) go to 194 go to 206 222 CONTINUE ! ! return STORAGE REQUIREMENTS FOR P VECTORS. ! W(1) = CMPLX(REAL(IPSTOR),0.) return end subroutine CMPOSP (M, N, A, BB, C, Q, IDIMQ, B, B2, B3, W, W2, W3, & D, TCOS, P) ! !! CMPOSP is subsidiary to CMGNBN. ! !***LIBRARY SLATEC !***TYPE COMPLEX (POISP2-S, CMPOSP-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve Poisson's equation with periodic boundary ! conditions. ! !***SEE ALSO CMGNBN !***ROUTINES CALLED CMPOSD, CMPOSN !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CMPOSP ! COMPLEX A ,BB ,C ,Q , & B ,B2 ,B3 ,W , & W2 ,W3 ,D ,TCOS , & P ,S ,T DIMENSION A(*) ,BB(*) ,C(*) ,Q(IDIMQ,*) , & B(*) ,B2(*) ,B3(*) ,W(*) , & W2(*) ,W3(*) ,D(*) ,TCOS(*) , & P(*) !***FIRST EXECUTABLE STATEMENT CMPOSP MR = M NR = (N+1)/2 NRM1 = NR-1 if (2*NR /= N) go to 107 ! ! EVEN NUMBER OF UNKNOWNS ! DO 102 J=1,NRM1 NRMJ = NR-J NRPJ = NR+J DO 101 I=1,MR S = Q(I,NRMJ)-Q(I,NRPJ) T = Q(I,NRMJ)+Q(I,NRPJ) Q(I,NRMJ) = S Q(I,NRPJ) = T 101 CONTINUE 102 CONTINUE DO 103 I=1,MR Q(I,NR) = 2.*Q(I,NR) Q(I,N) = 2.*Q(I,N) 103 CONTINUE call CMPOSD (MR,NRM1,1,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P) IPSTOR = REAL(W(1)) call CMPOSN (MR,NR+1,1,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D, & TCOS,P) IPSTOR = MAX(IPSTOR,INT(REAL(W(1)))) DO 105 J=1,NRM1 NRMJ = NR-J NRPJ = NR+J DO 104 I=1,MR S = .5*(Q(I,NRPJ)+Q(I,NRMJ)) T = .5*(Q(I,NRPJ)-Q(I,NRMJ)) Q(I,NRMJ) = S Q(I,NRPJ) = T 104 CONTINUE 105 CONTINUE DO 106 I=1,MR Q(I,NR) = .5*Q(I,NR) Q(I,N) = .5*Q(I,N) 106 CONTINUE go to 118 107 CONTINUE ! ! ODD NUMBER OF UNKNOWNS ! DO 109 J=1,NRM1 NRPJ = N+1-J DO 108 I=1,MR S = Q(I,J)-Q(I,NRPJ) T = Q(I,J)+Q(I,NRPJ) Q(I,J) = S Q(I,NRPJ) = T 108 CONTINUE 109 CONTINUE DO 110 I=1,MR Q(I,NR) = 2.*Q(I,NR) 110 CONTINUE LH = NRM1/2 DO 112 J=1,LH NRMJ = NR-J DO 111 I=1,MR S = Q(I,J) Q(I,J) = Q(I,NRMJ) Q(I,NRMJ) = S 111 CONTINUE 112 CONTINUE call CMPOSD (MR,NRM1,2,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P) IPSTOR = REAL(W(1)) call CMPOSN (MR,NR,2,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D, & TCOS,P) IPSTOR = MAX(IPSTOR,INT(REAL(W(1)))) DO 114 J=1,NRM1 NRPJ = NR+J DO 113 I=1,MR S = .5*(Q(I,NRPJ)+Q(I,J)) T = .5*(Q(I,NRPJ)-Q(I,J)) Q(I,NRPJ) = T Q(I,J) = S 113 CONTINUE 114 CONTINUE DO 115 I=1,MR Q(I,NR) = .5*Q(I,NR) 115 CONTINUE DO 117 J=1,LH NRMJ = NR-J DO 116 I=1,MR S = Q(I,J) Q(I,J) = Q(I,NRMJ) Q(I,NRMJ) = S 116 CONTINUE 117 CONTINUE 118 CONTINUE ! ! return STORAGE REQUIREMENTS FOR P VECTORS. ! W(1) = CMPLX(REAL(IPSTOR),0.) return end subroutine CMPTR3 (M, A, B, C, K, Y1, Y2, Y3, TCOS, D, W1, W2, W3) ! !! CMPTR3 is subsidiary to CMGNBN. ! !***LIBRARY SLATEC !***TYPE COMPLEX (TRI3-S, CMPTR3-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve tridiagonal systems. ! !***SEE ALSO CMGNBN !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CMPTR3 COMPLEX A ,B ,C ,Y1 , & Y2 ,Y3 ,TCOS ,D , & W1 ,W2 ,W3 ,X , & XX ,Z DIMENSION A(*) ,B(*) ,C(*) ,K(4) , & TCOS(*) ,Y1(*) ,Y2(*) ,Y3(*) , & D(*) ,W1(*) ,W2(*) ,W3(*) INTEGER K1P1, K2P1, K3P1, K4P1 ! !***FIRST EXECUTABLE STATEMENT CMPTR3 MM1 = M-1 K1 = K(1) K2 = K(2) K3 = K(3) K4 = K(4) K1P1 = K1+1 K2P1 = K2+1 K3P1 = K3+1 K4P1 = K4+1 K2K3K4 = K2+K3+K4 if (K2K3K4 == 0) go to 101 L1 = K1P1/K2P1 L2 = K1P1/K3P1 L3 = K1P1/K4P1 LINT1 = 1 LINT2 = 1 LINT3 = 1 KINT1 = K1 KINT2 = KINT1+K2 KINT3 = KINT2+K3 101 CONTINUE DO 115 N=1,K1 X = TCOS(N) if (K2K3K4 == 0) go to 107 if (N /= L1) go to 103 DO 102 I=1,M W1(I) = Y1(I) 102 CONTINUE 103 if (N /= L2) go to 105 DO 104 I=1,M W2(I) = Y2(I) 104 CONTINUE 105 if (N /= L3) go to 107 DO 106 I=1,M W3(I) = Y3(I) 106 CONTINUE 107 CONTINUE Z = 1./(B(1)-X) D(1) = C(1)*Z Y1(1) = Y1(1)*Z Y2(1) = Y2(1)*Z Y3(1) = Y3(1)*Z DO 108 I=2,M Z = 1./(B(I)-X-A(I)*D(I-1)) D(I) = C(I)*Z Y1(I) = (Y1(I)-A(I)*Y1(I-1))*Z Y2(I) = (Y2(I)-A(I)*Y2(I-1))*Z Y3(I) = (Y3(I)-A(I)*Y3(I-1))*Z 108 CONTINUE DO 109 IP=1,MM1 I = M-IP Y1(I) = Y1(I)-D(I)*Y1(I+1) Y2(I) = Y2(I)-D(I)*Y2(I+1) Y3(I) = Y3(I)-D(I)*Y3(I+1) 109 CONTINUE if (K2K3K4 == 0) go to 115 if (N /= L1) go to 111 I = LINT1+KINT1 XX = X-TCOS(I) DO 110 I=1,M Y1(I) = XX*Y1(I)+W1(I) 110 CONTINUE LINT1 = LINT1+1 L1 = (LINT1*K1P1)/K2P1 111 if (N /= L2) go to 113 I = LINT2+KINT2 XX = X-TCOS(I) DO 112 I=1,M Y2(I) = XX*Y2(I)+W2(I) 112 CONTINUE LINT2 = LINT2+1 L2 = (LINT2*K1P1)/K3P1 113 if (N /= L3) go to 115 I = LINT3+KINT3 XX = X-TCOS(I) DO 114 I=1,M Y3(I) = XX*Y3(I)+W3(I) 114 CONTINUE LINT3 = LINT3+1 L3 = (LINT3*K1P1)/K4P1 115 CONTINUE return end subroutine CMPTRX (IDEGBR, IDEGCR, M, A, B, C, Y, TCOS, D, W) ! !! CMPTRX is subsidiary to CMGNBN. ! !***LIBRARY SLATEC !***TYPE COMPLEX (TRIX-S, CMPTRX-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve a system of linear equations where the ! coefficient matrix is a rational function in the matrix given by ! tridiagonal ( . . . , A(I), B(I), C(I), . . . ). ! !***SEE ALSO CMGNBN !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CMPTRX ! COMPLEX A ,B ,C ,Y , & TCOS ,D ,W ,X , & XX ,Z DIMENSION A(*) ,B(*) ,C(*) ,Y(*) , & TCOS(*) ,D(*) ,W(*) INTEGER KB, KC !***FIRST EXECUTABLE STATEMENT CMPTRX MM1 = M-1 KB = IDEGBR+1 KC = IDEGCR+1 L = KB/KC LINT = 1 DO 108 K=1,IDEGBR X = TCOS(K) if (K /= L) go to 102 I = IDEGBR+LINT XX = X-TCOS(I) DO 101 I=1,M W(I) = Y(I) Y(I) = XX*Y(I) 101 CONTINUE 102 CONTINUE Z = 1./(B(1)-X) D(1) = C(1)*Z Y(1) = Y(1)*Z DO 103 I=2,MM1 Z = 1./(B(I)-X-A(I)*D(I-1)) D(I) = C(I)*Z Y(I) = (Y(I)-A(I)*Y(I-1))*Z 103 CONTINUE Z = B(M)-X-A(M)*D(MM1) if (ABS(Z) /= 0.) go to 104 Y(M) = (0.,0.) go to 105 104 Y(M) = (Y(M)-A(M)*Y(MM1))/Z 105 CONTINUE DO 106 IP=1,MM1 I = M-IP Y(I) = Y(I)-D(I)*Y(I+1) 106 CONTINUE if (K /= L) go to 108 DO 107 I=1,M Y(I) = Y(I)+W(I) 107 CONTINUE LINT = LINT+1 L = (LINT*KB)/KC 108 CONTINUE return end subroutine CNBCO (ABE, LDA, N, ML, MU, IPVT, RCOND, Z) ! !! CNBCO factors a band matrix using Gaussian elimination and ! estimates the condition number. ! !***LIBRARY SLATEC !***CATEGORY D2C2 !***TYPE COMPLEX (SNBCO-S, DNBCO-D, CNBCO-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, ! NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! CNBCO factors a complex band matrix by Gaussian ! elimination and estimates the condition of the matrix. ! ! If RCOND is not needed, CNBFA is slightly faster. ! To solve A*X = B , follow CNBCO by CNBSL. ! To compute INVERSE(A)*C , follow CNBCO by CNBSL. ! To compute DETERMINANT(A) , follow CNBCO by CNBDI. ! ! On Entry ! ! ABE COMPLEX(LDA, NC) ! contains the matrix in band storage. The rows ! of the original matrix are stored in the rows ! of ABE and the diagonals of the original matrix ! are stored in columns 1 through ML+MU+1 of ABE. ! NC must be >= 2*ML+MU+1 . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABE. ! LDA must be >= N . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! ! On Return ! ! ABE an upper triangular matrix in band storage ! and the multipliers which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 through ML+MU+1 of ABE . ! Furthermore, ML additional columns are needed in ! ABE starting with column ML+MU+2 for elements ! generated during the triangularization. The total ! number of columns needed in ABE is 2*ML+MU+1 . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 + , * = not used ! 21222324 + , + = used for pivoting ! 32333435 + ! 43444546 + ! 545556 * + ! 6566 * * + ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC, CNBFA, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 800730 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CNBCO INTEGER LDA,N,ML,MU,IPVT(*) COMPLEX ABE(LDA,*),Z(*) REAL RCOND ! COMPLEX CDOTC,EK,T,WK,WKM REAL ANORM,S,SCASUM,SM,YNORM INTEGER I,INFO,J,JU,K,KB,KP1,L,LDB,LM,LZ,M,ML1,MM,NL,NU COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2)) ! ! COMPUTE 1-NORM OF A ! !***FIRST EXECUTABLE STATEMENT CNBCO ML1=ML+1 LDB = LDA - 1 ANORM = 0.0E0 DO 10 J = 1, N NU = MIN(MU,J-1) NL = MIN(ML,N-J) L = 1 + NU + NL ANORM = MAX(ANORM,SCASUM(L,ABE(J+NL,ML1-NL),LDB)) 10 CONTINUE ! ! FACTOR ! call CNBFA(ABE,LDA,N,ML,MU,IPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND CTRANS(A)*Y = E . ! CTRANS(A) IS THE CONJUGATE TRANSPOSE OF A . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE CTRANS(U)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE CTRANS(U)*W = E ! EK = (1.0E0,0.0E0) DO 20 J = 1, N Z(J) = (0.0E0,0.0E0) 20 CONTINUE M = ML + MU + 1 JU = 0 DO 100 K = 1, N if (CABS1(Z(K)) /= 0.0E0) EK = CSIGN1(EK,-Z(K)) if (CABS1(EK-Z(K)) <= CABS1(ABE(K,ML1))) go to 30 S = CABS1(ABE(K,ML1))/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(ABE(K,ML1)) == 0.0E0) go to 40 WK = WK/CONJG(ABE(K,ML1)) WKM = WKM/CONJG(ABE(K,ML1)) go to 50 40 CONTINUE WK = (1.0E0,0.0E0) WKM = (1.0E0,0.0E0) 50 CONTINUE KP1 = K + 1 JU = MIN(MAX(JU,MU+IPVT(K)),N) MM = ML1 if (KP1 > JU) go to 90 DO 60 I = KP1, JU MM = MM + 1 SM = SM + CABS1(Z(I)+WKM*CONJG(ABE(K,MM))) Z(I) = Z(I) + WK*CONJG(ABE(K,MM)) S = S + CABS1(Z(I)) 60 CONTINUE if (S >= SM) go to 80 T = WKM -WK WK = WKM MM = ML1 DO 70 I = KP1, JU MM = MM + 1 Z(I) = Z(I) + T*CONJG(ABE(K,MM)) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! ! SOLVE CTRANS(L)*Y = W ! DO 120 KB = 1, N K = N + 1 - KB NL = MIN(ML,N-K) if (K < N) Z(K) = Z(K) + CDOTC(NL,ABE(K+NL,ML1-NL),-LDB, & Z(K+1),1) if (CABS1(Z(K)) <= 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) ! YNORM = 1.0E0 ! ! SOLVE L*V = Y ! DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T NL = MIN(ML,N-K) if (K < N) call CAXPY(NL,T,ABE(K+NL,ML1-NL),-LDB,Z(K+1),1) if (CABS1(Z(K)) <= 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 ! ! SOLVE U*Z = V ! DO 160 KB = 1, N K = N + 1 - KB if (CABS1(Z(K)) <= CABS1(ABE(K,ML1))) go to 150 S = CABS1(ABE(K,ML1))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE if (CABS1(ABE(K,ML1)) /= 0.0E0) Z(K) = Z(K)/ABE(K,ML1) if (CABS1(ABE(K,ML1)) == 0.0E0) Z(K) = 1.0E0 LM = MIN(K,M) - 1 LZ = K - LM T = -Z(K) call CAXPY(LM,T,ABE(K-1,ML+2),-LDB,Z(LZ),1) 160 CONTINUE ! MAKE ZNORM = 1.0E0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine CNBDI (ABE, LDA, N, ML, MU, IPVT, DET) ! !! CNBDI computes the determinant of a band matrix using the factors ! computed by CNBCO or CNBFA. ! !***LIBRARY SLATEC !***CATEGORY D3C2 !***TYPE COMPLEX (SNBDI-S, DNBDI-D, CNBDI-C) !***KEYWORDS BANDED, DETERMINANT, LINEAR EQUATIONS, NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! CNBDI computes the determinant of a band matrix ! using the factors computed by CNBCO or CNBFA. ! If the inverse is needed, use CNBSL N times. ! ! On Entry ! ! ABE COMPLEX(LDA, NC) ! the output from CNBCO or CNBFA. ! NC must be >= 2*ML+MU+1 . ! ! LDA INTEGER ! the leading dimension of the array ABE . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from CNBCO or CNBFA. ! ! On Return ! ! DET COMPLEX(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= CABS1(DET(1)) < 10.0 ! or DET(1) = 0.0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800730 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CNBDI INTEGER LDA,N,ML,MU,IPVT(*) COMPLEX ABE(LDA,*),DET(2) ! REAL TEN INTEGER I COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) ! !***FIRST EXECUTABLE STATEMENT CNBDI DET(1) = (1.0E0,0.0E0) DET(2) = (0.0E0,0.0E0) TEN = 10.0E0 DO 50 I = 1, N if (IPVT(I) /= I) DET(1) = -DET(1) DET(1) = ABE(I,ML+1)*DET(1) if (CABS1(DET(1)) == 0.0E0) go to 60 10 if (CABS1(DET(1)) >= 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)) < 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 return end subroutine CNBFA (ABE, LDA, N, ML, MU, IPVT, INFO) ! !! CNBFA factors a band matrix by elimination. ! !***LIBRARY SLATEC !***CATEGORY D2C2 !***TYPE COMPLEX (SNBFA-S, DNBFA-D, CNBFA-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, ! NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! CNBFA factors a complex band matrix by elimination. ! ! CNBFA is usually called by CNBCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! ! On Entry ! ! ABE COMPLEX(LDA, NC) ! contains the matrix in band storage. The rows ! of the original matrix are stored in the rows ! of ABE and the diagonals of the original matrix ! are stored in columns 1 through ML+MU+1 of ABE. ! NC must be >= 2*ML+MU+1 . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABE. ! LDA must be >= N . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! ! On Return ! ! ABE an upper triangular matrix in band storage ! and the multipliers which were used to obtain it. ! the factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! =0 normal value ! =K if U(K,K) == 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that CNBSL will divide by zero if ! called. Use RCOND in CNBCO for a reliable ! indication of singularity. ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 through ML+MU+1 of ABE . ! Furthermore, ML additional columns are needed in ! ABE starting with column ML+MU+2 for elements ! generated during the triangularization. The total ! number of columns needed in ABE is 2*ML+MU+1 . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 + , * = not used ! 21222324 + , + = used for pivoting ! 32333435 + ! 43444546 + ! 545556 * + ! 6566 * * + ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSCAL, CSWAP, ICAMAX !***REVISION HISTORY (YYMMDD) ! 800730 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CNBFA INTEGER LDA,N,ML,MU,IPVT(*),INFO COMPLEX ABE(LDA,*) ! INTEGER ML1,MB,M,N1,LDB,I,J,K,L,LM,LM1,LM2,MP,ICAMAX COMPLEX T COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) ! !***FIRST EXECUTABLE STATEMENT CNBFA ML1=ML+1 MB=ML+MU M=ML+MU+1 N1=N-1 LDB=LDA-1 INFO=0 ! ! SET FILL-IN COLUMNS TO ZERO ! if ( N <= 1)go to 50 if ( ML <= 0)go to 7 DO 6 J=1,ML DO 5 I=1,N ABE(I,M+J)=(0.0E0,0.0E0) 5 CONTINUE 6 CONTINUE 7 CONTINUE ! ! GAUSSIAN ELIMINATION WITH PARTIAL ELIMINATION ! DO 40 K=1,N1 LM=MIN(N-K,ML) LM1=LM+1 LM2=ML1-LM ! ! SEARCH FOR PIVOT INDEX ! L=-ICAMAX(LM1,ABE(LM+K,LM2),LDB)+LM1+K IPVT(K)=L MP=MIN(MB,N-K) ! ! SWAP ROWS if NECESSARY ! if ( L /= K)CALL CSWAP(MP+1,ABE(K,ML1),LDA,ABE(L,ML1+K-L),LDA) ! ! SKIP COLUMN REDUCTION if PIVOT IS ZERO ! if ( CABS1(ABE(K,ML1)) == 0.0E0) go to 20 ! ! COMPUTE MULTIPLIERS ! T=-(1.0E0,0.0E0)/ABE(K,ML1) call CSCAL(LM,T,ABE(LM+K,LM2),LDB) ! ! ROW ELIMINATION WITH COLUMN INDEXING ! DO 10 J=1,MP call CAXPY (LM,ABE(K,ML1+J),ABE(LM+K,LM2),LDB,ABE(LM+K,LM2+J), & LDB) 10 CONTINUE go to 30 20 CONTINUE INFO=K 30 CONTINUE 40 CONTINUE 50 CONTINUE IPVT(N)=N if ( CABS1(ABE(N,ML1)) == 0.0E0) INFO=N return end subroutine CNBFS (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK) ! !! CNBFS solves a general nonsymmetric banded system of linear equations. ! !***LIBRARY SLATEC !***CATEGORY D2C2 !***TYPE COMPLEX (SNBFS-S, DNBFS-D, CNBFS-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine CNBFS solves a general nonsymmetric banded NxN ! system of single precision complex linear equations using ! SLATEC subroutines CNBCO and CNBSL. These are adaptations ! of the LINPACK subroutines CGBCO and CGBSL which require ! a different format for storing the matrix elements. If ! A is an NxN complex matrix and if X and B are complex ! N-vectors, then CNBFS solves the equation ! ! A*X=B. ! ! A band matrix is a matrix whose nonzero elements are all ! fairly near the main diagonal, specifically A(I,J) = 0 ! if I-J is greater than ML or J-I is greater than ! MU . The integers ML and MU are called the lower and upper ! band widths and M = ML+MU+1 is the total band width. ! CNBFS uses less time and storage than the corresponding ! program for general matrices (CGEFS) if 2*ML+MU < N . ! ! The matrix A is first factored into upper and lower tri- ! angular matrices U and L using partial pivoting. These ! factors and the pivoting information are used to find the ! solution vector X. An approximate condition number is ! calculated to provide a rough estimate of the number of ! digits of accuracy in the computed solution. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N and IWORK must not have been altered by the user follow- ! ing factorization (ITASK=1). IND will not be changed by CNBFS ! in this case. ! ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 through ML+MU+1 of ABE . ! Furthermore, ML additional columns are needed in ! ABE starting with column ML+MU+2 for elements ! generated during the triangularization. The total ! number of columns needed in ABE is 2*ML+MU+1 . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 + , * = not used ! 21222324 + , + = used for pivoting ! 32333435 + ! 43444546 + ! 545556 * + ! 6566 * * + ! ! ! Argument Description *** ! ! ABE COMPLEX(LDA,NC) ! on entry, contains the matrix in band storage as ! described above. NC must not be less than ! 2*ML+MU+1 . The user is cautioned to specify NC ! with care since it is not an argument and cannot ! be checked by CNBFS. The rows of the original ! matrix are stored in the rows of ABE and the ! diagonals of the original matrix are stored in ! columns 1 through ML+MU+1 of ABE . ! on return, contains an upper triangular matrix U and ! the multipliers necessary to construct a matrix L ! so that A=L*U. ! LDA INTEGER ! the leading dimension of array ABE. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. N must be greater ! than or equal to 1 . (terminal error message IND=-2) ! ML INTEGER ! the number of diagonals below the main diagonal. ! ML must not be less than zero nor greater than or ! equal to N . (terminal error message IND=-5) ! MU INTEGER ! the number of diagonals above the main diagonal. ! MU must not be less than zero nor greater than or ! equal to N . (terminal error message IND=-6) ! V COMPLEX(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! if ITASK = 1, the matrix A is factored and then the ! linear equation is solved. ! if ITASK > 1, the equation is solved using the existing ! factored matrix A and IWORK. ! if ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. ! LT. 0 see error message corresponding to IND below. ! WORK COMPLEX(N) ! a singly subscripted array of dimension at least N. ! IWORK INTEGER(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than 1. ! IND=-3 terminal ITASK is less than 1. ! IND=-4 terminal The matrix A is computationally singular. ! A solution has not been computed. ! IND=-5 terminal ML is less than zero or is greater than ! or equal to N . ! IND=-6 terminal MU is less than zero or is greater than ! or equal to N . ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! NOTE- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CNBCO, CNBSL, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800813 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to ! IF-THEN-ELSE. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CNBFS ! INTEGER LDA,N,ITASK,IND,IWORK(*),ML,MU COMPLEX ABE(LDA,*),V(*),WORK(*) REAL RCOND REAL R1MACH CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT CNBFS if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'CNBFS', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'CNBFS', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'CNBFS', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ML < 0 .OR. ML >= N) THEN IND = -5 WRITE (XERN1, '(I8)') ML call XERMSG ('SLATEC', 'CNBFS', & 'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1) return end if ! if (MU < 0 .OR. MU >= N) THEN IND = -6 WRITE (XERN1, '(I8)') MU call XERMSG ('SLATEC', 'CNBFS', & 'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1) return end if ! if (ITASK == 1) THEN ! ! FACTOR MATRIX A INTO LU ! call CNBCO(ABE,LDA,N,ML,MU,IWORK,RCOND,WORK) ! ! CHECK FOR COMPUTATIONALLY SINGULAR MATRIX ! if (RCOND == 0.0) THEN IND = -4 call XERMSG ('SLATEC', 'CNBFS', & 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) return ENDIF ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(R1MACH(4)/RCOND) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'CNBFS', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) ENDIF end if ! ! SOLVE AFTER FACTORING ! call CNBSL(ABE,LDA,N,ML,MU,IWORK,V,0) return end subroutine CNBIR (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK) ! !! CNBIR solves a general nonsymmetric banded system of linear equations. ... ! Iterative refinement is used to obtain an error estimate. ! !***LIBRARY SLATEC !***CATEGORY D2C2 !***TYPE COMPLEX (SNBIR-S, CNBIR-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine CNBIR solves a general nonsymmetric banded NxN ! system of single precision complex linear equations using ! SLATEC subroutines CNBFA and CNBSL. These are adaptations ! of the LINPACK subroutines CGBFA and CGBSL which require ! a different format for storing the matrix elements. ! One pass of iterative refinement is used only to obtain an ! estimate of the accuracy. If A is an NxN complex banded ! matrix and if X and B are complex N-vectors, then CNBIR ! solves the equation ! ! A*X=B. ! ! A band matrix is a matrix whose nonzero elements are all ! fairly near the main diagonal, specifically A(I,J) = 0 ! if I-J is greater than ML or J-I is greater than ! MU . The integers ML and MU are called the lower and upper ! band widths and M = ML+MU+1 is the total band width. ! CNBIR uses less time and storage than the corresponding ! program for general matrices (CGEIR) if 2*ML+MU < N . ! ! The matrix A is first factored into upper and lower tri- ! angular matrices U and L using partial pivoting. These ! factors and the pivoting information are used to find the ! solution vector X . Then the residual vector is found and used ! to calculate an estimate of the relative error, IND . IND esti- ! mates the accuracy of the solution only when the input matrix ! and the right hand side are represented exactly in the computer ! and does not take into account any errors in the input data. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, LDA, ! N, WORK and IWORK must not have been altered by the user follow- ! ing factorization (ITASK=1). IND will not be changed by CNBIR ! in this case. ! ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 through ML+MU+1 of ABE . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 , * = not used ! 21222324 ! 32333435 ! 43444546 ! 545556 * ! 6566 * * ! ! ! Argument Description *** ! ! ABE COMPLEX(LDA,MM) ! on entry, contains the matrix in band storage as ! described above. MM must not be less than M = ! ML+MU+1 . The user is cautioned to dimension ABE ! with care since MM is not an argument and cannot ! be checked by CNBIR. The rows of the original ! matrix are stored in the rows of ABE and the ! diagonals of the original matrix are stored in ! columns 1 through ML+MU+1 of ABE . ABE is ! not altered by the program. ! LDA INTEGER ! the leading dimension of array ABE. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. N must be greater ! than or equal to 1 . (terminal error message IND=-2) ! ML INTEGER ! the number of diagonals below the main diagonal. ! ML must not be less than zero nor greater than or ! equal to N . (terminal error message IND=-5) ! MU INTEGER ! the number of diagonals above the main diagonal. ! MU must not be less than zero nor greater than or ! equal to N . (terminal error message IND=-6) ! V COMPLEX(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! if ITASK=1, the matrix A is factored and then the ! linear equation is solved. ! if ITASK > 1, the equation is solved using the existing ! factored matrix A and IWORK. ! if ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X . IND=75 means ! that the solution vector X is zero. ! LT. 0 see error message corresponding to IND below. ! WORK COMPLEX(N*(NC+1)) ! a singly subscripted array of dimension at least ! N*(NC+1) where NC = 2*ML+MU+1 . ! IWORK INTEGER(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than 1. ! IND=-3 terminal ITASK is less than 1. ! IND=-4 terminal The matrix A is computationally singular. ! A solution has not been computed. ! IND=-5 terminal ML is less than zero or is greater than ! or equal to N . ! IND=-6 terminal MU is less than zero or is greater than ! or equal to N . ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! NOTE- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CCOPY, CDCDOT, CNBFA, CNBSL, R1MACH, SCASUM, XERMSG !***REVISION HISTORY (YYMMDD) ! 800819 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to ! IF-THEN-ELSE. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CNBIR ! INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J,K,KK,L,M,ML,MU,NC COMPLEX ABE(LDA,*),V(*),WORK(N,*),CDCDOT REAL XNORM,DNORM,SCASUM,R1MACH CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT CNBIR if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'CNBIR', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'CNBIR', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'CNBIR', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ML < 0 .OR. ML >= N) THEN IND = -5 WRITE (XERN1, '(I8)') ML call XERMSG ('SLATEC', 'CNBIR', & 'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1) return end if ! if (MU < 0 .OR. MU >= N) THEN IND = -6 WRITE (XERN1, '(I8)') MU call XERMSG ('SLATEC', 'CNBIR', & 'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1) return end if ! NC = 2*ML+MU+1 if (ITASK == 1) THEN ! ! MOVE MATRIX ABE TO WORK ! M=ML+MU+1 DO 10 J=1,M call CCOPY(N,ABE(1,J),1,WORK(1,J),1) 10 CONTINUE ! ! FACTOR MATRIX A INTO LU call CNBFA(WORK,N,N,ML,MU,IWORK,INFO) ! ! CHECK FOR COMPUTATIONALLY SINGULAR MATRIX if (INFO /= 0) THEN IND=-4 call XERMSG ('SLATEC', 'CNBIR', & 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) return ENDIF end if ! ! SOLVE WHEN FACTORING COMPLETE ! MOVE VECTOR B TO WORK ! call CCOPY(N,V(1),1,WORK(1,NC+1),1) call CNBSL(WORK,N,N,ML,MU,IWORK,V,0) ! ! FORM NORM OF X0 ! XNORM = SCASUM(N,V(1),1) if (XNORM == 0.0) THEN IND = 75 return end if ! ! COMPUTE RESIDUAL ! DO 40 J=1,N K = MAX(1,ML+2-J) KK = MAX(1,J-ML) L = MIN(J-1,ML)+MIN(N-J,MU)+1 WORK(J,NC+1) = CDCDOT(L,-WORK(J,NC+1),ABE(J,K),LDA,V(KK),1) 40 CONTINUE ! ! SOLVE A*DELTA=R ! call CNBSL(WORK,N,N,ML,MU,IWORK,WORK(1,NC+1),0) ! ! FORM NORM OF DELTA ! DNORM = SCASUM(N,WORK(1,NC+1),1) ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'CNBIR', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) end if return end subroutine CNBSL (ABE, LDA, N, ML, MU, IPVT, B, JOB) ! !! CNBSL solves a complex band system with factors computed by CNBCO or CNBFA. ! !***LIBRARY SLATEC !***CATEGORY D2C2 !***TYPE COMPLEX (SNBSL-S, DNBSL-D, CNBSL-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC, SOLVE !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! CNBSL solves the complex band system ! A * X = B or CTRANS(A) * X = B ! using the factors computed by CNBCO or CNBFA. ! ! On Entry ! ! ABE COMPLEX(LDA, NC) ! the output from CNBCO or CNBFA. ! NC must be >= 2*ML+MU+1 . ! ! LDA INTEGER ! the leading dimension of the array ABE . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from CNBCO or CNBFA. ! ! B COMPLEX(N) ! the right hand side vector. ! ! JOB INTEGER ! = 0 to solve A*X = B . ! = nonzero to solve CTRANS(A)*X = B , where ! CTRANS(A) is the conjugate transpose. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically this indicates singularity ! but it is often caused by improper arguments or improper ! setting of LDA. It will not occur if the subroutines are ! called correctly and if CNBCO has set RCOND > 0.0 ! or CNBFA has set INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call CNBCO(ABE,LDA,N,ML,MU,IPVT,RCOND,Z) ! if (RCOND is too small) go to ... ! DO 10 J = 1, P ! call CNBSL(ABE,LDA,N,ML,MU,IPVT,C(1,J),0) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC !***REVISION HISTORY (YYMMDD) ! 800730 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CNBSL INTEGER LDA,N,ML,MU,IPVT(*),JOB COMPLEX ABE(LDA,*),B(*) ! COMPLEX CDOTC,T INTEGER K,KB,L,LB,LDB,LM,M,MLM,NM1 !***FIRST EXECUTABLE STATEMENT CNBSL M=MU+ML+1 NM1=N-1 LDB=1-LDA if ( JOB /= 0)go to 50 ! ! JOB = 0 , SOLVE A * X = B ! FIRST SOLVE L*Y = B ! if ( ML == 0)go to 30 if ( NM1 < 1)go to 30 DO 20 K=1,NM1 LM=MIN(ML,N-K) L=IPVT(K) T=B(L) if ( L == K)go to 10 B(L)=B(K) B(K)=T 10 CONTINUE MLM=ML-(LM-1) call CAXPY(LM,T,ABE(K+LM,MLM),LDB,B(K+1),1) 20 CONTINUE 30 CONTINUE ! ! NOW SOLVE U*X = Y ! DO 40 KB=1,N K=N+1-KB B(K)=B(K)/ABE(K,ML+1) LM=MIN(K,M)-1 LB=K-LM T=-B(K) call CAXPY(LM,T,ABE(K-1,ML+2),LDB,B(LB),1) 40 CONTINUE go to 100 50 CONTINUE ! ! JOB = NONZERO, SOLVE CTRANS(A) * X = B ! FIRST SOLVE CTRANS(U)*Y = B ! DO 60 K = 1, N LM = MIN(K,M) - 1 LB = K - LM T = CDOTC(LM,ABE(K-1,ML+2),LDB,B(LB),1) B(K) = (B(K) - T)/CONJG(ABE(K,ML+1)) 60 CONTINUE ! ! NOW SOLVE CTRANS(L)*X = Y ! if (ML == 0) go to 90 if (NM1 < 1) go to 90 DO 80 KB = 1, NM1 K = N - KB LM = MIN(ML,N-K) MLM = ML - (LM - 1) B(K) = B(K) + CDOTC(LM,ABE(K+LM,MLM),LDB,B(K+1),1) L = IPVT(K) if (L == 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 COMBAK (NM, LOW, IGH, AR, AI, INT, M, ZR, ZI) ! !! COMBAK forms the eigenvectors of a complex general matrix from the ... ! eigenvectors of a upper Hessenberg matrix output from COMHES. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE COMPLEX (ELMBAK-S, COMBAK-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure COMBAK, ! NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). ! ! This subroutine forms the eigenvectors of a COMPLEX GENERAL ! matrix by back transforming those of the corresponding ! upper Hessenberg matrix determined by COMHES. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, AR, AI, ZR and ZI, as declared in the ! calling program dimension statement. NM is an INTEGER ! variable. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine CBAL. If CBAL has not been used, ! set LOW=1 and IGH equal to the order of the matrix. ! ! AR and AI contain the multipliers which were used in the ! reduction by COMHES in their lower triangles below ! the subdiagonal. AR and AI are two-dimensional REAL ! arrays, dimensioned AR(NM,IGH) and AI(NM,IGH). ! ! INT contains information on the rows and columns ! interchanged in the reduction by COMHES. Only ! elements LOW through IGH are used. INT is a ! one-dimensional INTEGER array, dimensioned INT(IGH). ! ! M is the number of eigenvectors to be back transformed. ! M is an INTEGER variable. ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the eigenvectors to be back transformed in their first M ! columns. ZR and ZI are two-dimensional REAL arrays, ! dimensioned ZR(NM,M) and ZI(NM,M). ! ! On OUTPUT ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the transformed eigenvectors in their first M columns. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COMBAK ! INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 REAL AR(NM,*),AI(NM,*),ZR(NM,*),ZI(NM,*) REAL XR,XI INTEGER INT(*) ! !***FIRST EXECUTABLE STATEMENT COMBAK if (M == 0) go to 200 LA = IGH - 1 KP1 = LOW + 1 if (LA < KP1) go to 200 ! .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = KP1, LA MP = LOW + IGH - MM MP1 = MP + 1 ! DO 110 I = MP1, IGH XR = AR(I,MP-1) XI = AI(I,MP-1) if (XR == 0.0E0 .AND. XI == 0.0E0) go to 110 ! DO 100 J = 1, M ZR(I,J) = ZR(I,J) + XR * ZR(MP,J) - XI * ZI(MP,J) ZI(I,J) = ZI(I,J) + XR * ZI(MP,J) + XI * ZR(MP,J) 100 CONTINUE ! 110 CONTINUE ! I = INT(MP) if (I == MP) go to 140 ! DO 130 J = 1, M XR = ZR(I,J) ZR(I,J) = ZR(MP,J) ZR(MP,J) = XR XI = ZI(I,J) ZI(I,J) = ZI(MP,J) ZI(MP,J) = XI 130 CONTINUE ! 140 CONTINUE ! 200 RETURN end subroutine COMHES (NM, N, LOW, IGH, AR, AI, INT) ! !! COMHES reduces a complex general matrix to complex upper Hessenberg ... ! form using stabilized elementary similarity transformations. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B2 !***TYPE COMPLEX (ELMHES-S, COMHES-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure COMHES, ! NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). ! ! Given a COMPLEX GENERAL matrix, this subroutine ! reduces a submatrix situated in rows and columns ! LOW through IGH to upper Hessenberg form by ! stabilized elementary similarity transformations. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, AR and AI, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A=(AR,AI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine CBAL. If CBAL has not been used, ! set LOW=1 and IGH equal to the order of the matrix, N. ! ! AR and AI contain the real and imaginary parts, respectively, ! of the complex input matrix. AR and AI are two-dimensional ! REAL arrays, dimensioned AR(NM,N) and AI(NM,N). ! ! On OUTPUT ! ! AR and AI contain the real and imaginary parts, respectively, ! of the upper Hessenberg matrix. The multipliers which ! were used in the reduction are stored in the remaining ! triangles under the Hessenberg matrix. ! ! INT contains information on the rows and columns ! interchanged in the reduction. Only elements LOW through ! IGH are used. INT is a one-dimensional INTEGER array, ! dimensioned INT(IGH). ! ! Calls CDIV for complex division. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED CDIV !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COMHES ! INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 REAL AR(NM,*),AI(NM,*) REAL XR,XI,YR,YI INTEGER INT(*) ! !***FIRST EXECUTABLE STATEMENT COMHES LA = IGH - 1 KP1 = LOW + 1 if (LA < KP1) go to 200 ! DO 180 M = KP1, LA MM1 = M - 1 XR = 0.0E0 XI = 0.0E0 I = M ! DO 100 J = M, IGH if (ABS(AR(J,MM1)) + ABS(AI(J,MM1)) & <= ABS(XR) + ABS(XI)) go to 100 XR = AR(J,MM1) XI = AI(J,MM1) I = J 100 CONTINUE ! INT(M) = I if (I == M) go to 130 ! .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI .......... DO 110 J = MM1, N YR = AR(I,J) AR(I,J) = AR(M,J) AR(M,J) = YR YI = AI(I,J) AI(I,J) = AI(M,J) AI(M,J) = YI 110 CONTINUE ! DO 120 J = 1, IGH YR = AR(J,I) AR(J,I) = AR(J,M) AR(J,M) = YR YI = AI(J,I) AI(J,I) = AI(J,M) AI(J,M) = YI 120 CONTINUE ! .......... END INTERCHANGE .......... 130 if (XR == 0.0E0 .AND. XI == 0.0E0) go to 180 MP1 = M + 1 ! DO 160 I = MP1, IGH YR = AR(I,MM1) YI = AI(I,MM1) if (YR == 0.0E0 .AND. YI == 0.0E0) go to 160 call CDIV(YR,YI,XR,XI,YR,YI) AR(I,MM1) = YR AI(I,MM1) = YI ! DO 140 J = M, N AR(I,J) = AR(I,J) - YR * AR(M,J) + YI * AI(M,J) AI(I,J) = AI(I,J) - YR * AI(M,J) - YI * AR(M,J) 140 CONTINUE DO J = 1, IGH AR(J,M) = AR(J,M) + YR * AR(J,I) - YI * AI(J,I) AI(J,M) = AI(J,M) + YR * AI(J,I) + YI * AR(J,I) end do ! 160 CONTINUE ! 180 CONTINUE ! 200 RETURN end subroutine COMLR2 (NM, N, LOW, IGH, INT, HR, HI, WR, WI, ZR, ZI, & IERR) ! !! COMLR2 domputes the eigenvalues and eigenvectors of a complex upper ... ! Hessenberg matrix using the modified LR method. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C2B !***TYPE COMPLEX (COMLR2-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK, LR METHOD !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure COMLR2, ! NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). ! ! This subroutine finds the eigenvalues and eigenvectors ! of a COMPLEX UPPER Hessenberg matrix by the modified LR ! method. The eigenvectors of a COMPLEX GENERAL matrix ! can also be found if COMHES has been used to reduce ! this general matrix to Hessenberg form. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, HR, HI, ZR and ZI, as declared in the ! calling program dimension statement. NM is an INTEGER ! variable. ! ! N is the order of the matrix H=(HR,HI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine CBAL. If CBAL has not been used, ! set LOW=1 and IGH equal to the order of the matrix, N. ! ! INT contains information on the rows and columns ! interchanged in the reduction by COMHES, if performed. ! Only elements LOW through IGH are used. If you want the ! eigenvectors of a complex general matrix, leave INT as it ! came from COMHES. If the eigenvectors of the Hessenberg ! matrix are desired, set INT(J)=J for these elements. INT ! is a one-dimensional INTEGER array, dimensioned INT(IGH). ! ! HR and HI contain the real and imaginary parts, respectively, ! of the complex upper Hessenberg matrix. Their lower ! triangles below the subdiagonal contain the multipliers ! which were used in the reduction by COMHES, if performed. ! If the eigenvectors of a complex general matrix are ! desired, leave these multipliers in the lower triangles. ! If the eigenvectors of the Hessenberg matrix are desired, ! these elements must be set to zero. HR and HI are ! two-dimensional REAL arrays, dimensioned HR(NM,N) and ! HI(NM,N). ! ! On OUTPUT ! ! The upper Hessenberg portions of HR and HI have been ! destroyed, but the location HR(1,1) contains the norm ! of the triangularized matrix. ! ! WR and WI contain the real and imaginary parts, respectively, ! of the eigenvalues of the upper Hessenberg matrix. If an ! error exit is made, the eigenvalues should be correct for ! indices IERR+1, IERR+2, ..., N. WR and WI are one- ! dimensional REAL arrays, dimensioned WR(N) and WI(N). ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the eigenvectors. The eigenvectors are unnormalized. ! If an error exit is made, none of the eigenvectors has been ! found. ZR and ZI are two-dimensional REAL arrays, ! dimensioned ZR(NM,N) and ZI(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after a total of 30*N iterations. ! The eigenvalues should be correct for indices ! IERR+1, IERR+2, ..., N, but no eigenvectors are ! computed. ! ! Calls CSROOT for complex square root. ! Calls CDIV for complex division. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED CDIV, CSROOT !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COMLR2 ! INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NM,NN,IGH,IM1,IP1 INTEGER ITN,ITS,LOW,MP1,ENM1,IEND,IERR REAL HR(NM,*),HI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*) REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2 INTEGER INT(*) ! !***FIRST EXECUTABLE STATEMENT COMLR2 IERR = 0 ! .......... INITIALIZE EIGENVECTOR MATRIX .......... DO 100 I = 1, N ! DO 100 J = 1, N ZR(I,J) = 0.0E0 ZI(I,J) = 0.0E0 if (I == J) ZR(I,J) = 1.0E0 100 CONTINUE ! .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS ! FROM THE INFORMATION LEFT BY COMHES .......... IEND = IGH - LOW - 1 if (IEND <= 0) go to 180 ! .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 160 II = 1, IEND I = IGH - II IP1 = I + 1 ! DO 120 K = IP1, IGH ZR(K,I) = HR(K,I-1) ZI(K,I) = HI(K,I-1) 120 CONTINUE ! J = INT(I) if (I == J) go to 160 ! DO 140 K = I, IGH ZR(I,K) = ZR(J,K) ZI(I,K) = ZI(J,K) ZR(J,K) = 0.0E0 ZI(J,K) = 0.0E0 140 CONTINUE ! ZR(J,I) = 1.0E0 160 CONTINUE ! .......... STORE ROOTS ISOLATED BY CBAL .......... 180 DO 200 I = 1, N if (I >= LOW .AND. I <= IGH) go to 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE ! EN = IGH TR = 0.0E0 TI = 0.0E0 ITN = 30*N ! .......... SEARCH FOR NEXT EIGENVALUE .......... 220 if (EN < LOW) go to 680 ITS = 0 ENM1 = EN - 1 ! .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT ! FOR L=EN STEP -1 UNTIL LOW DO -- .......... 240 DO 260 LL = LOW, EN L = EN + LOW - LL if (L == LOW) go to 300 S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) & + ABS(HR(L,L)) + ABS(HI(L,L)) S2 = S1 + ABS(HR(L,L-1)) + ABS(HI(L,L-1)) if (S2 == S1) go to 300 260 CONTINUE ! .......... FORM SHIFT .......... 300 if (L == EN) go to 660 if (ITN == 0) go to 1000 if (ITS == 10 .OR. ITS == 20) go to 320 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1) XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1) if (XR == 0.0E0 .AND. XI == 0.0E0) go to 340 YR = (HR(ENM1,ENM1) - SR) / 2.0E0 YI = (HI(ENM1,ENM1) - SI) / 2.0E0 call CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) if (YR * ZZR + YI * ZZI >= 0.0E0) go to 310 ZZR = -ZZR ZZI = -ZZI 310 call CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) SR = SR - XR SI = SI - XI go to 340 ! .......... FORM EXCEPTIONAL SHIFT .......... 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) SI = ABS(HI(EN,ENM1)) + ABS(HI(ENM1,EN-2)) ! 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE ! TR = TR + SR TI = TI + SI ITS = ITS + 1 ITN = ITN - 1 ! .......... LOOK FOR TWO CONSECUTIVE SMALL ! SUB-DIAGONAL ELEMENTS .......... XR = ABS(HR(ENM1,ENM1)) + ABS(HI(ENM1,ENM1)) YR = ABS(HR(EN,ENM1)) + ABS(HI(EN,ENM1)) ZZR = ABS(HR(EN,EN)) + ABS(HI(EN,EN)) ! .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... DO 380 MM = L, ENM1 M = ENM1 + L - MM if (M == L) go to 420 YI = YR YR = ABS(HR(M,M-1)) + ABS(HI(M,M-1)) XI = ZZR ZZR = XR XR = ABS(HR(M-1,M-1)) + ABS(HI(M-1,M-1)) S1 = ZZR / YI * (ZZR + XR + XI) S2 = S1 + YR if (S2 == S1) go to 420 380 CONTINUE ! .......... TRIANGULAR DECOMPOSITION H=L*R .......... 420 MP1 = M + 1 ! DO 520 I = MP1, EN IM1 = I - 1 XR = HR(IM1,IM1) XI = HI(IM1,IM1) YR = HR(I,IM1) YI = HI(I,IM1) if (ABS(XR) + ABS(XI) >= ABS(YR) + ABS(YI)) go to 460 ! .......... INTERCHANGE ROWS OF HR AND HI .......... DO 440 J = IM1, N ZZR = HR(IM1,J) HR(IM1,J) = HR(I,J) HR(I,J) = ZZR ZZI = HI(IM1,J) HI(IM1,J) = HI(I,J) HI(I,J) = ZZI 440 CONTINUE ! call CDIV(XR,XI,YR,YI,ZZR,ZZI) WR(I) = 1.0E0 go to 480 460 call CDIV(YR,YI,XR,XI,ZZR,ZZI) WR(I) = -1.0E0 480 HR(I,IM1) = ZZR HI(I,IM1) = ZZI ! DO 500 J = I, N HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J) HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J) 500 CONTINUE ! 520 CONTINUE ! .......... COMPOSITION R*L=H .......... DO 640 J = MP1, EN XR = HR(J,J-1) XI = HI(J,J-1) HR(J,J-1) = 0.0E0 HI(J,J-1) = 0.0E0 ! .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI, ! if NECESSARY .......... if (WR(J) <= 0.0E0) go to 580 ! DO 540 I = 1, J ZZR = HR(I,J-1) HR(I,J-1) = HR(I,J) HR(I,J) = ZZR ZZI = HI(I,J-1) HI(I,J-1) = HI(I,J) HI(I,J) = ZZI 540 CONTINUE ! DO 560 I = LOW, IGH ZZR = ZR(I,J-1) ZR(I,J-1) = ZR(I,J) ZR(I,J) = ZZR ZZI = ZI(I,J-1) ZI(I,J-1) = ZI(I,J) ZI(I,J) = ZZI 560 CONTINUE ! 580 DO 600 I = 1, J HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J) HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J) 600 CONTINUE ! .......... ACCUMULATE TRANSFORMATIONS .......... DO 620 I = LOW, IGH ZR(I,J-1) = ZR(I,J-1) + XR * ZR(I,J) - XI * ZI(I,J) ZI(I,J-1) = ZI(I,J-1) + XR * ZI(I,J) + XI * ZR(I,J) 620 CONTINUE ! 640 CONTINUE ! go to 240 ! .......... 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 ! .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND ! VECTORS OF UPPER TRIANGULAR FORM .......... 680 NORM = 0.0E0 ! DO 720 I = 1, N ! DO 720 J = I, N NORM = NORM + ABS(HR(I,J)) + ABS(HI(I,J)) 720 CONTINUE ! HR(1,1) = NORM if (N == 1 .OR. NORM == 0.0E0) go to 1001 ! .......... 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 ! .......... 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 == ENM1) go to 760 IP1 = I + 1 ! 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 ! 760 YR = XR - WR(I) YI = XI - WI(I) if (YR /= 0.0E0 .OR. YI /= 0.0E0) go to 775 YR = NORM 770 YR = 0.5E0*YR if (NORM + YR > NORM) go to 770 YR = 2.0E0*YR 775 call CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) 780 CONTINUE ! 800 CONTINUE ! .......... END BACKSUBSTITUTION .......... ENM1 = N - 1 ! .......... VECTORS OF ISOLATED ROOTS .......... DO 840 I = 1, ENM1 if (I >= LOW .AND. I <= IGH) go to 840 IP1 = I + 1 ! DO 820 J = IP1, N ZR(I,J) = HR(I,J) ZI(I,J) = HI(I,J) 820 CONTINUE ! 840 CONTINUE ! .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE ! VECTORS OF ORIGINAL FULL MATRIX. ! FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... DO 880 JJ = LOW, ENM1 J = N + LOW - JJ M = MIN(J-1,IGH) ! DO 880 I = LOW, IGH ZZR = ZR(I,J) ZZI = ZI(I,J) ! 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 ! ZR(I,J) = ZZR ZI(I,J) = ZZI 880 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN end subroutine COMLR (NM, N, LOW, IGH, HR, HI, WR, WI, IERR) ! !! COMLR computes the eigenvalues of a complex upper Hessenberg ... ! matrix using the modified LR method. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C2B !***TYPE COMPLEX (COMLR-C) !***KEYWORDS EIGENVALUES, EISPACK, LR METHOD !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure COMLR, ! NUM. MATH. 12, 369-376(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). ! ! This subroutine finds the eigenvalues of a COMPLEX ! UPPER Hessenberg matrix by the modified LR method. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, HR and HI, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix H=(HR,HI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine CBAL. If CBAL has not been used, ! set LOW=1 and IGH equal to the order of the matrix, N. ! ! HR and HI contain the real and imaginary parts, respectively, ! of the complex upper Hessenberg matrix. Their lower ! triangles below the subdiagonal contain the multipliers ! which were used in the reduction by COMHES, if performed. ! HR and HI are two-dimensional REAL arrays, dimensioned ! HR(NM,N) and HI(NM,N). ! ! On OUTPUT ! ! The upper Hessenberg portions of HR and HI have been ! destroyed. Therefore, they must be saved before calling ! COMLR if subsequent calculation of eigenvectors is to ! be performed. ! ! WR and WI contain the real and imaginary parts, respectively, ! of the eigenvalues of the upper Hessenberg matrix. If an ! error exit is made, the eigenvalues should be correct for ! indices IERR+1, IERR+2, ..., N. WR and WI are one- ! dimensional REAL arrays, dimensioned WR(N) and WI(N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after a total of 30*N iterations. ! The eigenvalues should be correct for indices ! IERR+1, IERR+2, ..., N. ! ! Calls CSROOT for complex square root. ! Calls CDIV for complex division. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED CDIV, CSROOT !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COMLR ! INTEGER I,J,L,M,N,EN,LL,MM,NM,IGH,IM1,ITN,ITS,LOW,MP1,ENM1,IERR REAL HR(NM,*),HI(NM,*),WR(*),WI(*) REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,S1,S2 ! !***FIRST EXECUTABLE STATEMENT COMLR IERR = 0 ! .......... STORE ROOTS ISOLATED BY CBAL .......... DO 200 I = 1, N if (I >= LOW .AND. I <= IGH) go to 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE ! EN = IGH TR = 0.0E0 TI = 0.0E0 ITN = 30*N ! .......... SEARCH FOR NEXT EIGENVALUE .......... 220 if (EN < LOW) go to 1001 ITS = 0 ENM1 = EN - 1 ! .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT ! FOR L=EN STEP -1 UNTIL LOWE0 -- .......... 240 DO 260 LL = LOW, EN L = EN + LOW - LL if (L == LOW) go to 300 S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) & + ABS(HR(L,L)) + ABS(HI(L,L)) S2 = S1 + ABS(HR(L,L-1)) + ABS(HI(L,L-1)) if (S2 == S1) go to 300 260 CONTINUE ! .......... FORM SHIFT .......... 300 if (L == EN) go to 660 if (ITN == 0) go to 1000 if (ITS == 10 .OR. ITS == 20) go to 320 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1) XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1) if (XR == 0.0E0 .AND. XI == 0.0E0) go to 340 YR = (HR(ENM1,ENM1) - SR) / 2.0E0 YI = (HI(ENM1,ENM1) - SI) / 2.0E0 call CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) if (YR * ZZR + YI * ZZI >= 0.0E0) go to 310 ZZR = -ZZR ZZI = -ZZI 310 call CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) SR = SR - XR SI = SI - XI go to 340 ! .......... FORM EXCEPTIONAL SHIFT .......... 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) SI = ABS(HI(EN,ENM1)) + ABS(HI(ENM1,EN-2)) ! 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE ! TR = TR + SR TI = TI + SI ITS = ITS + 1 ITN = ITN - 1 ! .......... LOOK FOR TWO CONSECUTIVE SMALL ! SUB-DIAGONAL ELEMENTS .......... XR = ABS(HR(ENM1,ENM1)) + ABS(HI(ENM1,ENM1)) YR = ABS(HR(EN,ENM1)) + ABS(HI(EN,ENM1)) ZZR = ABS(HR(EN,EN)) + ABS(HI(EN,EN)) ! .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... DO 380 MM = L, ENM1 M = ENM1 + L - MM if (M == L) go to 420 YI = YR YR = ABS(HR(M,M-1)) + ABS(HI(M,M-1)) XI = ZZR ZZR = XR XR = ABS(HR(M-1,M-1)) + ABS(HI(M-1,M-1)) S1 = ZZR / YI * (ZZR + XR + XI) S2 = S1 + YR if (S2 == S1) go to 420 380 CONTINUE ! .......... TRIANGULAR DECOMPOSITION H=L*R .......... 420 MP1 = M + 1 ! DO 520 I = MP1, EN IM1 = I - 1 XR = HR(IM1,IM1) XI = HI(IM1,IM1) YR = HR(I,IM1) YI = HI(I,IM1) if (ABS(XR) + ABS(XI) >= ABS(YR) + ABS(YI)) go to 460 ! .......... INTERCHANGE ROWS OF HR AND HI .......... DO 440 J = IM1, EN ZZR = HR(IM1,J) HR(IM1,J) = HR(I,J) HR(I,J) = ZZR ZZI = HI(IM1,J) HI(IM1,J) = HI(I,J) HI(I,J) = ZZI 440 CONTINUE ! call CDIV(XR,XI,YR,YI,ZZR,ZZI) WR(I) = 1.0E0 go to 480 460 call CDIV(YR,YI,XR,XI,ZZR,ZZI) WR(I) = -1.0E0 480 HR(I,IM1) = ZZR HI(I,IM1) = ZZI ! DO 500 J = I, EN HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J) HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J) 500 CONTINUE ! 520 CONTINUE ! .......... COMPOSITION R*L=H .......... DO 640 J = MP1, EN XR = HR(J,J-1) XI = HI(J,J-1) HR(J,J-1) = 0.0E0 HI(J,J-1) = 0.0E0 ! .......... INTERCHANGE COLUMNS OF HR AND HI, ! if NECESSARY .......... if (WR(J) <= 0.0E0) go to 580 ! DO 540 I = L, J ZZR = HR(I,J-1) HR(I,J-1) = HR(I,J) HR(I,J) = ZZR ZZI = HI(I,J-1) HI(I,J-1) = HI(I,J) HI(I,J) = ZZI 540 CONTINUE ! 580 DO 600 I = L, J HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J) HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J) 600 CONTINUE ! 640 CONTINUE ! go to 240 ! .......... A ROOT FOUND .......... 660 WR(EN) = HR(EN,EN) + TR WI(EN) = HI(EN,EN) + TI EN = ENM1 go to 220 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN end subroutine COMPB (N, IERROR, AN, BN, CN, B, AH, BH) ! !! COMPB is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (COMPB-S, CCMPB-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! COMPB computes the roots of the B polynomials using subroutine ! TEVLS which is a modification the EISPACK program TQLRAT. ! IERROR is set to 4 if either TEVLS fails or if A(J+1)*C(J) is ! less than zero for some J. AH,BH are temporary work arrays. ! !***SEE ALSO BLKTRI !***ROUTINES CALLED INDXB, PPADD, R1MACH, TEVLS !***COMMON BLOCKS CBLKT !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE COMPB ! DIMENSION AN(*) ,BN(*) ,CN(*) ,B(*) , & AH(*) ,BH(*) COMMON /CBLKT/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT COMPB EPS = R1MACH(4) BNORM = ABS(BN(1)) DO 102 J=2,NM BNORM = MAX(BNORM,ABS(BN(J))) ARG = AN(J)*CN(J-1) if (ARG) 119,101,101 101 B(J) = SIGN(SQRT(ARG),AN(J)) 102 CONTINUE CNV = EPS*BNORM if = 2**K KDO = K-1 DO 108 L=1,KDO IR = L-1 I2 = 2**IR I4 = I2+I2 IPL = I4-1 IFD = IF-I4 DO 107 I=I4,IFD,I4 call INDXB (I,L,IB,NB) if (NB) 108,108,103 103 JS = I-IPL JF = JS+NB-1 LS = 0 DO 104 J=JS,JF LS = LS+1 BH(LS) = BN(J) AH(LS) = B(J) 104 CONTINUE call TEVLS (NB,BH,AH,IERROR) if (IERROR) 118,105,118 105 LH = IB-1 DO 106 J=1,NB LH = LH+1 B(LH) = -BH(J) 106 CONTINUE 107 CONTINUE 108 CONTINUE DO 109 J=1,NM B(J) = -BN(J) 109 CONTINUE if (NPP) 117,110,117 110 NMP = NM+1 NB = NM+NMP DO 112 J=1,NB L1 = MOD(J-1,NMP)+1 L2 = MOD(J+NM-1,NMP)+1 ARG = AN(L1)*CN(L2) if (ARG) 119,111,111 111 BH(J) = SIGN(SQRT(ARG),-AN(L1)) AH(J) = -BN(L1) 112 CONTINUE call TEVLS (NB,AH,BH,IERROR) if (IERROR) 118,113,118 113 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 114 D1 = ABS(B(J1)-B(J2-1)) D2 = ABS(B(J1)-B(J2)) D3 = ABS(B(J1)-B(J2+1)) if ((D2 < D1) .AND. (D2 < D3)) go to 115 B(LH) = B(J2) J2 = J2+1 LH = LH+1 if (J2-N2M2) 114,114,116 115 J2 = J2+1 J1 = J1+1 if (J2-N2M2) 114,114,116 116 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)) 117 RETURN 118 IERROR = 4 return 119 IERROR = 5 return end subroutine COMQR2 (NM, N, LOW, IGH, ORTR, ORTI, HR, HI, WR, WI, & ZR, ZI, IERR) ! !! COMQR2 computes the eigenvalues and eigenvectors of a complex upper ... ! Hessenberg matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C2B !***TYPE COMPLEX (HQR2-S, COMQR2-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of a unitary analogue of the ! ALGOL procedure COMLR2, NUM. MATH. 16, 181-204(1970) by Peters ! and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). ! The unitary analogue substitutes the QR algorithm of Francis ! (COMP. JOUR. 4, 332-345(1962)) for the LR algorithm. ! ! This subroutine finds the eigenvalues and eigenvectors ! of a COMPLEX UPPER Hessenberg matrix by the QR ! method. The eigenvectors of a COMPLEX GENERAL matrix ! can also be found if CORTH has been used to reduce ! this general matrix to Hessenberg form. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, HR, HI, ZR, and ZI, as declared in the ! calling program dimension statement. NM is an INTEGER ! variable. ! ! N is the order of the matrix H=(HR,HI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine CBAL. If CBAL has not been used, ! set LOW=1 and IGH equal to the order of the matrix, N. ! ! ORTR and ORTI contain information about the unitary trans- ! formations used in the reduction by CORTH, if performed. ! Only elements LOW through IGH are used. If the eigenvectors ! of the Hessenberg matrix are desired, set ORTR(J) and ! ORTI(J) to 0.0E0 for these elements. ORTR and ORTI are ! one-dimensional REAL arrays, dimensioned ORTR(IGH) and ! ORTI(IGH). ! ! HR and HI contain the real and imaginary parts, respectively, ! of the complex upper Hessenberg matrix. Their lower ! triangles below the subdiagonal contain information about ! the unitary transformations used in the reduction by CORTH, ! if performed. If the eigenvectors of the Hessenberg matrix ! are desired, these elements may be arbitrary. HR and HI ! are two-dimensional REAL arrays, dimensioned HR(NM,N) and ! HI(NM,N). ! ! On OUTPUT ! ! ORTR, ORTI, and the upper Hessenberg portions of HR and HI ! have been destroyed. ! ! WR and WI contain the real and imaginary parts, respectively, ! of the eigenvalues of the upper Hessenberg matrix. If an ! error exit is made, the eigenvalues should be correct for ! indices IERR+1, IERR+2, ..., N. WR and WI are one- ! dimensional REAL arrays, dimensioned WR(N) and WI(N). ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the eigenvectors. The eigenvectors are unnormalized. ! If an error exit is made, none of the eigenvectors has been ! found. ZR and ZI are two-dimensional REAL arrays, ! dimensioned ZR(NM,N) and ZI(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after a total of 30*N iterations. ! The eigenvalues should be correct for indices ! IERR+1, IERR+2, ..., N, but no eigenvectors are ! computed. ! ! Calls CSROOT for complex square root. ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! Calls CDIV for complex division. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED CDIV, CSROOT, PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COMQR2 ! INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1 INTEGER ITN,ITS,LOW,LP1,ENM1,IEND,IERR REAL HR(NM,*),HI(NM,*),WR(*),WI(*),ZR(NM,*),ZI(NM,*) REAL ORTR(*),ORTI(*) REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2 REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT COMQR2 IERR = 0 ! .......... INITIALIZE EIGENVECTOR MATRIX .......... DO 100 I = 1, N ! DO 100 J = 1, N ZR(I,J) = 0.0E0 ZI(I,J) = 0.0E0 if (I == J) ZR(I,J) = 1.0E0 100 CONTINUE ! .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS ! FROM THE INFORMATION LEFT BY CORTH .......... IEND = IGH - LOW - 1 if (IEND) 180, 150, 105 ! .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... 105 DO 140 II = 1, IEND I = IGH - II if (ORTR(I) == 0.0E0 .AND. ORTI(I) == 0.0E0) go to 140 if (HR(I,I-1) == 0.0E0 .AND. HI(I,I-1) == 0.0E0) go to 140 ! .......... 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 ! DO 110 K = IP1, IGH ORTR(K) = HR(K,I-1) ORTI(K) = HI(K,I-1) 110 CONTINUE ! DO 130 J = I, IGH SR = 0.0E0 SI = 0.0E0 ! 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 ! SR = SR / NORM SI = SI / NORM ! 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 ! 130 CONTINUE ! 140 CONTINUE ! .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... 150 L = LOW + 1 ! DO 170 I = L, IGH LL = MIN(I+1,IGH) if (HI(I,I-1) == 0.0E0) go to 170 NORM = PYTHAG(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.0E0 ! 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 ! 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 ! 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 ! 170 CONTINUE ! .......... STORE ROOTS ISOLATED BY CBAL .......... 180 DO 200 I = 1, N if (I >= LOW .AND. I <= IGH) go to 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE ! EN = IGH TR = 0.0E0 TI = 0.0E0 ITN = 30*N ! .......... SEARCH FOR NEXT EIGENVALUE .......... 220 if (EN < LOW) go to 680 ITS = 0 ENM1 = EN - 1 ! .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT ! FOR L=EN STEP -1 UNTIL LOW DO -- .......... 240 DO 260 LL = LOW, EN L = EN + LOW - LL if (L == LOW) go to 300 S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) & + ABS(HR(L,L)) +ABS(HI(L,L)) S2 = S1 + ABS(HR(L,L-1)) if (S2 == S1) go to 300 260 CONTINUE ! .......... FORM SHIFT .......... 300 if (L == EN) go to 660 if (ITN == 0) go to 1000 if (ITS == 10 .OR. ITS == 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 == 0.0E0 .AND. XI == 0.0E0) go to 340 YR = (HR(ENM1,ENM1) - SR) / 2.0E0 YI = (HI(ENM1,ENM1) - SI) / 2.0E0 call CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) if (YR * ZZR + YI * ZZI >= 0.0E0) go to 310 ZZR = -ZZR ZZI = -ZZI 310 call CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) SR = SR - XR SI = SI - XI go to 340 ! .......... FORM EXCEPTIONAL SHIFT .......... 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) SI = 0.0E0 ! 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE ! TR = TR + SR TI = TI + SI ITS = ITS + 1 ITN = ITN - 1 ! .......... REDUCE TO TRIANGLE (ROWS) .......... LP1 = L + 1 ! DO 500 I = LP1, EN SR = HR(I,I-1) HR(I,I-1) = 0.0E0 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),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.0E0 HI(I,I-1) = SR / NORM ! 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 ! 500 CONTINUE ! SI = HI(EN,EN) if (SI == 0.0E0) go to 540 NORM = PYTHAG(HR(EN,EN),SI) SR = HR(EN,EN) / NORM SI = SI / NORM HR(EN,EN) = NORM HI(EN,EN) = 0.0E0 if (EN == N) go to 540 IP1 = EN + 1 ! 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 ! .......... INVERSE OPERATION (COLUMNS) .......... 540 DO 600 J = LP1, EN XR = WR(J-1) XI = WI(J-1) ! DO 580 I = 1, J YR = HR(I,J-1) YI = 0.0E0 ZZR = HR(I,J) ZZI = HI(I,J) if (I == 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 ! 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 ! 600 CONTINUE ! if (SI == 0.0E0) go to 240 ! 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 ! 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 ! go to 240 ! .......... 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 ! .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND ! VECTORS OF UPPER TRIANGULAR FORM .......... 680 NORM = 0.0E0 ! DO 720 I = 1, N ! DO 720 J = I, N NORM = NORM + ABS(HR(I,J)) + ABS(HI(I,J)) 720 CONTINUE ! if (N == 1 .OR. NORM == 0.0E0) go to 1001 ! .......... 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 ! .......... 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 == ENM1) go to 760 IP1 = I + 1 ! 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 ! 760 YR = XR - WR(I) YI = XI - WI(I) if (YR /= 0.0E0 .OR. YI /= 0.0E0) go to 775 YR = NORM 770 YR = 0.5E0*YR if (NORM + YR > NORM) go to 770 YR = 2.0E0*YR 775 call CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) 780 CONTINUE ! 800 CONTINUE ! .......... END BACKSUBSTITUTION .......... ENM1 = N - 1 ! .......... VECTORS OF ISOLATED ROOTS .......... DO 840 I = 1, ENM1 if (I >= LOW .AND. I <= IGH) go to 840 IP1 = I + 1 ! DO 820 J = IP1, N ZR(I,J) = HR(I,J) ZI(I,J) = HI(I,J) 820 CONTINUE ! 840 CONTINUE ! .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE ! VECTORS OF ORIGINAL FULL MATRIX. ! FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... DO 880 JJ = LOW, ENM1 J = N + LOW - JJ M = MIN(J-1,IGH) ! DO 880 I = LOW, IGH ZZR = ZR(I,J) ZZI = ZI(I,J) ! 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 ! ZR(I,J) = ZZR ZI(I,J) = ZZI 880 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN end subroutine COMQR (NM, N, LOW, IGH, HR, HI, WR, WI, IERR) ! !! COMQR computes the eigenvalues of complex upper Hessenberg matrix ... ! using the QR method. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C2B !***TYPE COMPLEX (HQR-S, COMQR-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of a unitary analogue of the ! ALGOL procedure COMLR, NUM. MATH. 12, 369-376(1968) by Martin ! and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). ! The unitary analogue substitutes the QR algorithm of Francis ! (COMP. JOUR. 4, 332-345(1962)) for the LR algorithm. ! ! This subroutine finds the eigenvalues of a COMPLEX ! upper Hessenberg matrix by the QR method. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, HR and HI, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix H=(HR,HI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine CBAL. If CBAL has not been used, ! set LOW=1 and IGH equal to the order of the matrix, N. ! ! HR and HI contain the real and imaginary parts, respectively, ! of the complex upper Hessenberg matrix. Their lower ! triangles below the subdiagonal contain information about ! the unitary transformations used in the reduction by CORTH, ! if performed. HR and HI are two-dimensional REAL arrays, ! dimensioned HR(NM,N) and HI(NM,N). ! ! On OUTPUT ! ! The upper Hessenberg portions of HR and HI have been ! destroyed. Therefore, they must be saved before calling ! COMQR if subsequent calculation of eigenvectors is to ! be performed. ! ! WR and WI contain the real and imaginary parts, respectively, ! of the eigenvalues of the upper Hessenberg matrix. If an ! error exit is made, the eigenvalues should be correct for ! indices IERR+1, IERR+2, ..., N. WR and WI are one- ! dimensional REAL arrays, dimensioned WR(N) and WI(N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after a total of 30*N iterations. ! The eigenvalues should be correct for indices ! IERR+1, IERR+2, ..., N. ! ! Calls CSROOT for complex square root. ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! Calls CDIV for complex division. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED CDIV, CSROOT, PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COMQR ! INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR REAL HR(NM,*),HI(NM,*),WR(*),WI(*) REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,S1,S2 REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT COMQR IERR = 0 if (LOW == IGH) go to 180 ! .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... L = LOW + 1 ! DO 170 I = L, IGH LL = MIN(I+1,IGH) if (HI(I,I-1) == 0.0E0) go to 170 NORM = PYTHAG(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.0E0 ! 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 ! 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 ! 170 CONTINUE ! .......... STORE ROOTS ISOLATED BY CBAL .......... 180 DO 200 I = 1, N if (I >= LOW .AND. I <= IGH) go to 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE ! EN = IGH TR = 0.0E0 TI = 0.0E0 ITN = 30*N ! .......... SEARCH FOR NEXT EIGENVALUE .......... 220 if (EN < LOW) go to 1001 ITS = 0 ENM1 = EN - 1 ! .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT ! FOR L=EN STEP -1 UNTIL LOWE0 -- .......... 240 DO 260 LL = LOW, EN L = EN + LOW - LL if (L == LOW) go to 300 S1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) & + ABS(HR(L,L)) +ABS(HI(L,L)) S2 = S1 + ABS(HR(L,L-1)) if (S2 == S1) go to 300 260 CONTINUE ! .......... FORM SHIFT .......... 300 if (L == EN) go to 660 if (ITN == 0) go to 1000 if (ITS == 10 .OR. ITS == 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 == 0.0E0 .AND. XI == 0.0E0) go to 340 YR = (HR(ENM1,ENM1) - SR) / 2.0E0 YI = (HI(ENM1,ENM1) - SI) / 2.0E0 call CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) if (YR * ZZR + YI * ZZI >= 0.0E0) go to 310 ZZR = -ZZR ZZI = -ZZI 310 call CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) SR = SR - XR SI = SI - XI go to 340 ! .......... FORM EXCEPTIONAL SHIFT .......... 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) SI = 0.0E0 ! 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE ! TR = TR + SR TI = TI + SI ITS = ITS + 1 ITN = ITN - 1 ! .......... REDUCE TO TRIANGLE (ROWS) .......... LP1 = L + 1 ! DO 500 I = LP1, EN SR = HR(I,I-1) HR(I,I-1) = 0.0E0 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),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.0E0 HI(I,I-1) = SR / NORM ! 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 ! 500 CONTINUE ! SI = HI(EN,EN) if (SI == 0.0E0) go to 540 NORM = PYTHAG(HR(EN,EN),SI) SR = HR(EN,EN) / NORM SI = SI / NORM HR(EN,EN) = NORM HI(EN,EN) = 0.0E0 ! .......... INVERSE OPERATION (COLUMNS) .......... 540 DO 600 J = LP1, EN XR = WR(J-1) XI = WI(J-1) ! DO 580 I = L, J YR = HR(I,J-1) YI = 0.0E0 ZZR = HR(I,J) ZZI = HI(I,J) if (I == 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 ! 600 CONTINUE ! if (SI == 0.0E0) go to 240 ! 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 ! go to 240 ! .......... A ROOT FOUND .......... 660 WR(EN) = HR(EN,EN) + TR WI(EN) = HI(EN,EN) + TI EN = ENM1 go to 220 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN end subroutine CORTB (NM, LOW, IGH, AR, AI, ORTR, ORTI, M, ZR, ZI) ! !! CORTB forms the eigenvectors of a complex general matrix from ... ! eigenvectors of upper Hessenberg matrix output from CORTH. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE COMPLEX (ORTBAK-S, CORTB-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of a complex analogue of ! the ALGOL procedure ORTBAK, NUM. MATH. 12, 349-368(1968) ! by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). ! ! This subroutine forms the eigenvectors of a COMPLEX GENERAL ! matrix by back transforming those of the corresponding ! upper Hessenberg matrix determined by CORTH. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, AR, AI, ZR, and ZI, as declared in the ! calling program dimension statement. NM is an INTEGER ! variable. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine CBAL. If CBAL has not been used, ! set LOW=1 and IGH equal to the order of the matrix. ! ! AR and AI contain information about the unitary trans- ! formations used in the reduction by CORTH in their ! strict lower triangles. AR and AI are two-dimensional ! REAL arrays, dimensioned AR(NM,IGH) and AI(NM,IGH). ! ! ORTR and ORTI contain further information about the unitary ! transformations used in the reduction by CORTH. Only ! elements LOW through IGH are used. ORTR and ORTI are ! one-dimensional REAL arrays, dimensioned ORTR(IGH) and ! ORTI(IGH). ! ! M is the number of columns of Z=(ZR,ZI) to be back transformed. ! M is an INTEGER variable. ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the eigenvectors to be back transformed in their first ! M columns. ZR and ZI are two-dimensional REAL arrays, ! dimensioned ZR(NM,M) and ZI(NM,M). ! ! On OUTPUT ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the transformed eigenvectors in their first M columns. ! ! ORTR and ORTI have been altered. ! ! Note that CORTB preserves vector Euclidean norms. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CORTB ! INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 REAL AR(NM,*),AI(NM,*),ORTR(*),ORTI(*) REAL ZR(NM,*),ZI(NM,*) REAL H,GI,GR ! !***FIRST EXECUTABLE STATEMENT CORTB if (M == 0) go to 200 LA = IGH - 1 KP1 = LOW + 1 if (LA < KP1) go to 200 ! .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = KP1, LA MP = LOW + IGH - MM if (AR(MP,MP-1) == 0.0E0 .AND. AI(MP,MP-1) == 0.0E0) & go to 140 ! .......... H BELOW IS NEGATIVE OF H FORMED IN CORTH .......... H = AR(MP,MP-1) * ORTR(MP) + AI(MP,MP-1) * ORTI(MP) MP1 = MP + 1 ! DO 100 I = MP1, IGH ORTR(I) = AR(I,MP-1) ORTI(I) = AI(I,MP-1) 100 CONTINUE ! DO 130 J = 1, M GR = 0.0E0 GI = 0.0E0 ! DO 110 I = MP, IGH GR = GR + ORTR(I) * ZR(I,J) + ORTI(I) * ZI(I,J) GI = GI + ORTR(I) * ZI(I,J) - ORTI(I) * ZR(I,J) 110 CONTINUE ! GR = GR / H GI = GI / H ! DO 120 I = MP, IGH ZR(I,J) = ZR(I,J) + GR * ORTR(I) - GI * ORTI(I) ZI(I,J) = ZI(I,J) + GR * ORTI(I) + GI * ORTR(I) 120 CONTINUE ! 130 CONTINUE ! 140 CONTINUE ! 200 RETURN end subroutine CORTH (NM, N, LOW, IGH, AR, AI, ORTR, ORTI) ! !! CORTH reduces a complex general matrix to complex upper Hessenberg ... ! form using unitary similarity transformations. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B2 !***TYPE COMPLEX (ORTHES-S, CORTH-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of a complex analogue of ! the ALGOL procedure ORTHES, NUM. MATH. 12, 349-368(1968) ! by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). ! ! Given a COMPLEX GENERAL matrix, this subroutine ! reduces a submatrix situated in rows and columns ! LOW through IGH to upper Hessenberg form by ! unitary similarity transformations. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, AR and AI, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A=(AR,AI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine CBAL. If CBAL has not been used, ! set LOW=1 and IGH equal to the order of the matrix, N. ! ! AR and AI contain the real and imaginary parts, respectively, ! of the complex input matrix. AR and AI are two-dimensional ! REAL arrays, dimensioned AR(NM,N) and AI(NM,N). ! ! On OUTPUT ! ! AR and AI contain the real and imaginary parts, respectively, ! of the Hessenberg matrix. Information about the unitary ! transformations used in the reduction is stored in the ! remaining triangles under the Hessenberg matrix. ! ! ORTR and ORTI contain further information about the unitary ! transformations. Only elements LOW through IGH are used. ! ORTR and ORTI are one-dimensional REAL arrays, dimensioned ! ORTR(IGH) and ORTI(IGH). ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CORTH ! INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW REAL AR(NM,*),AI(NM,*),ORTR(*),ORTI(*) REAL F,G,H,FI,FR,SCALE REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT CORTH LA = IGH - 1 KP1 = LOW + 1 if (LA < KP1) go to 200 ! DO 180 M = KP1, LA H = 0.0E0 ORTR(M) = 0.0E0 ORTI(M) = 0.0E0 SCALE = 0.0E0 ! .......... 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)) ! if (SCALE == 0.0E0) go to 180 MP = M + IGH ! .......... 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 ! G = SQRT(H) F = PYTHAG(ORTR(M),ORTI(M)) if (F == 0.0E0) go to 103 H = H + F * G G = G / F ORTR(M) = (1.0E0 + G) * ORTR(M) ORTI(M) = (1.0E0 + G) * ORTI(M) go to 105 ! 103 ORTR(M) = G AR(M,M-1) = SCALE ! .......... FORM (I-(U*UT)/H) * A .......... 105 DO 130 J = M, N FR = 0.0E0 FI = 0.0E0 ! .......... 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 ! FR = FR / H FI = FI / H ! 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 ! 130 CONTINUE ! .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... DO 160 I = 1, IGH FR = 0.0E0 FI = 0.0E0 ! .......... 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 ! FR = FR / H FI = FI / H ! 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 ! 160 CONTINUE ! 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 ! 200 RETURN end function COSDG (X) ! !! COSDG computes the cosine of an argument in degrees. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE SINGLE PRECISION (COSDG-S, DCOSDG-D) !***KEYWORDS COSINE, DEGREES, ELEMENTARY FUNCTIONS, FNLIB, ! TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! COSDG(X) evaluates the cosine for real X in degrees. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE COSDG ! JUNE 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. SAVE RADDEG DATA RADDEG / .017453292519943296E0 / ! !***FIRST EXECUTABLE STATEMENT COSDG COSDG = COS (RADDEG*X) ! if (MOD(X,90.) /= 0.) RETURN N = ABS(X)/90.0 + 0.5 N = MOD (N, 2) if (N == 0) COSDG = SIGN (1.0, COSDG) if (N == 1) COSDG = 0.0 ! return end subroutine COSGEN (N, IJUMP, FNUM, FDEN, A) ! !! COSGEN is subsidiary to GENBUN. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (COSGEN-S, CMPCSG-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine computes required cosine values in ascending ! order. When IJUMP > 1 the routine computes values ! ! 2*COS(J*PI/L) , J=1,2,...,L and J /= 0(MOD N/IJUMP+1) ! ! where L = IJUMP*(N/IJUMP+1). ! ! ! when IJUMP = 1 it computes ! ! 2*COS((J-FNUM)*PI/(N+FDEN)) , J=1, 2, ... ,N ! ! where ! FNUM = 0.5, FDEN = 0.0, for regular reduction values. ! FNUM = 0.0, FDEN = 1.0, for B-R and C-R when ISTAG = 1 ! FNUM = 0.0, FDEN = 0.5, for B-R and C-R when ISTAG = 2 ! FNUM = 0.5, FDEN = 0.5, for B-R and C-R when ISTAG = 2 ! in POISN2 only. ! !***SEE ALSO GENBUN !***ROUTINES CALLED PIMACH !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE COSGEN DIMENSION A(*) ! ! !***FIRST EXECUTABLE STATEMENT COSGEN PI = PIMACH(DUM) if (N == 0) go to 105 if (IJUMP == 1) go to 103 K3 = N/IJUMP+1 K4 = K3-1 PIBYN = PI/(N+IJUMP) DO 102 K=1,IJUMP K1 = (K-1)*K3 K5 = (K-1)*K4 DO 101 I=1,K4 X = K1+I K2 = K5+I A(K2) = -2.*COS(X*PIBYN) 101 CONTINUE 102 CONTINUE go to 105 103 CONTINUE NP1 = N+1 Y = PI/(N+FDEN) DO 104 I=1,N X = NP1-I-FNUM A(I) = 2.*COS(X*Y) 104 CONTINUE 105 CONTINUE return end subroutine COSQB1 (N, X, W, XH) ! !! COSQB1 computes the unnormalized inverse of COSQF1. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (COSQB1-S) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine COSQB1 computes the fast Fourier transform of quarter ! wave data. That is, COSQB1 computes a sequence from its ! representation in terms of a cosine series with odd wave numbers. ! The transform is defined below at output parameter X. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTB !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COSQB1 DIMENSION X(*), W(*), XH(*) !***FIRST EXECUTABLE STATEMENT COSQB1 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 == 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 == 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 subroutine COSQB (N, X, WSAVE) ! !! COSQB computes the unnormalized inverse cosine transform. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (COSQB-S) !***KEYWORDS FFTPACK, INVERSE COSINE FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine COSQB computes the fast Fourier transform of quarter ! wave data. That is, COSQB computes a sequence from its ! representation in terms of a cosine series with odd wave numbers. ! The transform is defined below at output parameter X. ! ! COSQB is the unnormalized inverse of COSQF since a call of COSQB ! followed by a call of COSQF will multiply the input sequence X ! by 4*N. ! ! The array WSAVE which is used by subroutine COSQB must be ! initialized by calling subroutine COSQI(N,WSAVE). ! ! ! Input Parameters ! ! N the length of the array X to be transformed. The method ! is most efficient when N is a product of small primes. ! ! X an array which contains the sequence to be transformed ! ! WSAVE a work array which must be dimensioned at least 3*N+15 ! in the program that calls COSQB. The WSAVE array must be ! initialized by calling subroutine COSQI(N,WSAVE), and a ! different WSAVE array must be used for each different ! value of N. This initialization does not have to be ! repeated so long as N remains unchanged. Thus subsequent ! transforms can be obtained faster than the first. ! ! Output Parameters ! ! X For I=1,...,N ! ! X(I)= the sum from K=1 to K=N of ! ! 2*X(K)*COS((2*K-1)*(I-1)*PI/(2*N)) ! ! A call of COSQB followed by a call of ! COSQF will multiply the sequence X by 4*N. ! Therefore COSQF is the unnormalized inverse ! of COSQB. ! ! WSAVE contains initialization calculations which must not ! be destroyed between calls of COSQB or COSQF. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED COSQB1 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variable TSQRT2 by using ! FORTRAN intrinsic function SQRT instead of a DATA ! statement. ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COSQB DIMENSION X(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT COSQB TSQRT2 = 2.*SQRT(2.) 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 COSQF1 (N, X, W, XH) ! !! COSQF1 computes the forward cosine transform with odd wave numbers. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (COSQF1-S) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine COSQF1 computes the fast Fourier transform of quarter ! wave data. That is, COSQF1 computes the coefficients in a cosine ! series representation with only odd wave numbers. The transform ! is defined below at Output Parameter X ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTF !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COSQF1 DIMENSION X(*), W(*), XH(*) !***FIRST EXECUTABLE STATEMENT COSQF1 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 == 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 == 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 subroutine COSQF (N, X, WSAVE) ! !! COSQF computes the forward cosine transform with odd wave numbers. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (COSQF-S) !***KEYWORDS COSINE FOURIER TRANSFORM, FFTPACK !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine COSQF computes the fast Fourier transform of quarter ! wave data. That is, COSQF computes the coefficients in a cosine ! series representation with only odd wave numbers. The transform ! is defined below at Output Parameter X ! ! COSQF is the unnormalized inverse of COSQB since a call of COSQF ! followed by a call of COSQB will multiply the input sequence X ! by 4*N. ! ! The array WSAVE which is used by subroutine COSQF must be ! initialized by calling subroutine COSQI(N,WSAVE). ! ! ! Input Parameters ! ! N the length of the array X to be transformed. The method ! is most efficient when N is a product of small primes. ! ! X an array which contains the sequence to be transformed ! ! WSAVE a work array which must be dimensioned at least 3*N+15 ! in the program that calls COSQF. The WSAVE array must be ! initialized by calling subroutine COSQI(N,WSAVE), and a ! different WSAVE array must be used for each different ! value of N. This initialization does not have to be ! repeated so long as N remains unchanged. Thus subsequent ! transforms can be obtained faster than the first. ! ! Output Parameters ! ! X For I=1,...,N ! ! X(I) = X(1) plus the sum from K=2 to K=N of ! ! 2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N)) ! ! A call of COSQF followed by a call of ! COSQB will multiply the sequence X by 4*N. ! Therefore COSQB is the unnormalized inverse ! of COSQF. ! ! WSAVE contains initialization calculations which must not ! be destroyed between calls of COSQF or COSQB. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED COSQF1 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variable SQRT2 by using ! FORTRAN intrinsic function SQRT instead of a DATA ! statement. ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COSQF DIMENSION X(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT COSQF SQRT2 = SQRT(2.) 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 COSQI (N, WSAVE) ! !! COSQI initializes a work array for COSQF and COSQB. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (COSQI-S) !***KEYWORDS COSINE FOURIER TRANSFORM, FFTPACK !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine COSQI initializes the work array WSAVE which is used in ! both COSQF1 and COSQB1. The prime factorization of N together with ! a tabulation of the trigonometric functions are computed and ! stored in WSAVE. ! ! Input Parameter ! ! N the length of the array to be transformed. The method ! is most efficient when N is a product of small primes. ! ! Output Parameter ! ! WSAVE a work array which must be dimensioned at least 3*N+15. ! The same work array can be used for both COSQF1 and COSQB1 ! as long as N remains unchanged. Different WSAVE arrays ! are required for different values of N. The contents of ! WSAVE must not be changed between calls of COSQF1 or COSQB1. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTI !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing references to intrinsic function FLOAT ! to REAL, and ! (c) changing definition of variable PIH by using ! FORTRAN intrinsic function ATAN instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COSQI DIMENSION WSAVE(*) !***FIRST EXECUTABLE STATEMENT COSQI PIH = 2.*ATAN(1.) DT = PIH/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 subroutine COST (N, X, WSAVE) ! !! COST computes the cosine transform of a real, even sequence. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (COST-S) !***KEYWORDS COSINE FOURIER TRANSFORM, FFTPACK !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine COST computes the discrete Fourier cosine transform ! of an even sequence X(I). The transform is defined below at output ! parameter X. ! ! COST is the unnormalized inverse of itself since a call of COST ! followed by another call of COST will multiply the input sequence ! X by 2*(N-1). The transform is defined below at output parameter X. ! ! The array WSAVE which is used by subroutine COST must be ! initialized by calling subroutine COSTI(N,WSAVE). ! ! Input Parameters ! ! N the length of the sequence X. N must be greater than 1. ! The method is most efficient when N-1 is a product of ! small primes. ! ! X an array which contains the sequence to be transformed ! ! WSAVE a work array which must be dimensioned at least 3*N+15 ! in the program that calls COST. The WSAVE array must be ! initialized by calling subroutine COSTI(N,WSAVE), and a ! different WSAVE array must be used for each different ! value of N. This initialization does not have to be ! repeated so long as N remains unchanged. Thus subsequent ! transforms can be obtained faster than the first. ! ! Output Parameters ! ! X For I=1,...,N ! ! X(I) = X(1)+(-1)**(I-1)*X(N) ! ! + the sum from K=2 to K=N-1 ! ! 2*X(K)*COS((K-1)*(I-1)*PI/(N-1)) ! ! A call of COST followed by another call of ! COST will multiply the sequence X by 2*(N-1). ! Hence COST is the unnormalized inverse ! of itself. ! ! WSAVE contains initialization calculations which must not be ! destroyed between calls of COST. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTF !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*) ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COST DIMENSION X(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT COST NM1 = N-1 NP1 = N+1 NS2 = N/2 if (N-2) 106,101,102 101 X1H = X(1)+X(2) X(2) = X(1)-X(2) X(1) = X1H return 102 if (N > 3) go to 103 X1P3 = X(1)+X(3) TX2 = X(2)+X(2) X(2) = X(1)-X(3) X(1) = X1P3+TX2 X(3) = X1P3-TX2 return 103 C1 = X(1)-X(N) X(1) = X(1)+X(N) DO 104 K=2,NS2 KC = NP1-K T1 = X(K)+X(KC) T2 = X(K)-X(KC) C1 = C1+WSAVE(KC)*T2 T2 = WSAVE(K)*T2 X(K) = T1-T2 X(KC) = T1+T2 104 CONTINUE MODN = MOD(N,2) if (MODN /= 0) X(NS2+1) = X(NS2+1)+X(NS2+1) call RFFTF (NM1,X,WSAVE(N+1)) XIM2 = X(2) X(2) = C1 DO 105 I=4,N,2 XI = X(I) X(I) = X(I-2)-X(I-1) X(I-1) = XIM2 XIM2 = XI 105 CONTINUE if (MODN /= 0) X(N) = XIM2 106 RETURN end subroutine COSTI (N, WSAVE) ! !! COSTI initializes a work array for COST. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (COSTI-S) !***KEYWORDS COSINE FOURIER TRANSFORM, FFTPACK !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine COSTI initializes the array WSAVE which is used in ! subroutine COST. The prime factorization of N together with ! a tabulation of the trigonometric functions are computed and ! stored in WSAVE. ! ! Input Parameter ! ! N the length of the sequence to be transformed. The method ! is most efficient when N-1 is a product of small primes. ! ! Output Parameter ! ! WSAVE a work array which must be dimensioned at least 3*N+15. ! Different WSAVE arrays are required for different values ! of N. The contents of WSAVE must not be changed between ! calls of COST. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTI !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing references to intrinsic function FLOAT ! to REAL, and ! (c) changing definition of variable PI by using ! FORTRAN intrinsic function ATAN instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE COSTI DIMENSION WSAVE(*) !***FIRST EXECUTABLE STATEMENT COSTI if (N <= 3) RETURN PI = 4.*ATAN(1.) NM1 = N-1 NP1 = N+1 NS2 = N/2 DT = PI/NM1 FK = 0. DO 101 K=2,NS2 KC = NP1-K FK = FK+1. WSAVE(K) = 2.*SIN(FK*DT) WSAVE(KC) = 2.*COS(FK*DT) 101 CONTINUE call RFFTI (NM1,WSAVE(N+1)) return end function COT (X) ! !! COT computes the cotangent. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE SINGLE PRECISION (COT-S, DCOT-D, CCOT-C) !***KEYWORDS COTANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! COT(X) calculates the cotangent of the real argument X. X is in ! units of radians. ! ! Series for COT on the interval 0. to 6.25000D-02 ! with weighted error 3.76E-17 ! log weighted error 16.42 ! significant figures required 15.51 ! decimal places required 16.88 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE COT DIMENSION COTCS(8) LOGICAL FIRST SAVE COTCS, PI2REC, NTERMS, XMAX, XSML, XMIN, SQEPS, FIRST DATA COTCS( 1) / .24025916098295630E0 / DATA COTCS( 2) / -.016533031601500228E0 / DATA COTCS( 3) / -.000042998391931724E0 / DATA COTCS( 4) / -.000000159283223327E0 / DATA COTCS( 5) / -.000000000619109313E0 / DATA COTCS( 6) / -.000000000002430197E0 / DATA COTCS( 7) / -.000000000000009560E0 / DATA COTCS( 8) / -.000000000000000037E0 / DATA PI2REC / .0116197723675813430E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT COT if (FIRST) THEN NTERMS = INITS (COTCS, 8, 0.1*R1MACH(3)) XMAX = 1.0/R1MACH(4) XSML = SQRT (3.0*R1MACH(3)) XMIN = EXP ( MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + 0.01) SQEPS = SQRT (R1MACH(4)) end if FIRST = .FALSE. ! Y = ABS(X) if (ABS(X) < XMIN) call XERMSG ('SLATEC', 'COT', & 'ABS(X) IS ZERO OR SO SMALL COT OVERFLOWS', 2, 2) if (Y > XMAX) call XERMSG ('SLATEC', 'COT', & 'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 3, 2) ! ! CAREFULLY COMPUTE Y * (2/PI) = (AINT(Y) + REM(Y)) * (.625 + PI2REC) ! = AINT(.625*Y) + REM(.625*Y) + Y*PI2REC = AINT(.625*Y) + Z ! = AINT(.625*Y) + AINT(Z) + REM(Z) ! AINTY = AINT (Y) YREM = Y - AINTY PRODBG = 0.625*AINTY AINTY = AINT (PRODBG) Y = (PRODBG-AINTY) + 0.625*YREM + Y*PI2REC AINTY2 = AINT (Y) AINTY = AINTY + AINTY2 Y = Y - AINTY2 ! IFN = MOD (AINTY, 2.) if (IFN == 1) Y = 1.0 - Y ! if (ABS(X) > 0.5 .AND. Y < ABS(X)*SQEPS) call XERMSG & ('SLATEC', 'COT', & 'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X NEAR N*PI ' // & '(N /= 0)' , 1, 1) ! if (Y > 0.25) go to 20 COT = 1.0/X if (Y > XSML) COT = (0.5 + CSEVL (32.0*Y*Y-1., COTCS, NTERMS)) /Y go to 40 ! 20 if (Y > 0.5) go to 30 COT = (0.5 + CSEVL (8.0*Y*Y-1., COTCS, NTERMS)) / (0.5*Y) COT = (COT**2 - 1.0) * 0.5 / COT go to 40 ! 30 COT = (0.5 + CSEVL (2.0*Y*Y-1., COTCS, NTERMS)) / (0.25*Y) COT = (COT**2 - 1.0) * 0.5 / COT COT = (COT**2 - 1.0) * 0.5 / COT ! 40 if (X /= 0.) COT = SIGN (COT, X) if (IFN == 1) COT = -COT ! return end subroutine CPADD (N, IERROR, A, C, CBP, BP, BH) ! !! CPADD is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CPADD-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! CPADD computes the eigenvalues of the periodic tridiagonal matrix ! with coefficients AN,BN,CN. ! ! N is the order of the BH and BP polynomials. ! BP contains the eigenvalues on output. ! CBP is the same as BP except type complex. ! BH is used to temporarily store the roots of the B HAT polynomial ! which enters through BP. ! !***SEE ALSO CBLKTR !***ROUTINES CALLED BCRH, PGSF, PPGSF, PPPSF !***COMMON BLOCKS CCBLK !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CPADD ! COMPLEX CX ,FSG ,HSG , & DD ,F ,FP ,FPP , & CDIS ,R1 ,R2 ,R3 , & CBP DIMENSION A(*) ,C(*) ,BP(*) ,BH(*) , & CBP(*) COMMON /CCBLK/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK EXTERNAL PGSF ,PPPSF ,PPGSF !***FIRST EXECUTABLE STATEMENT CPADD SCNV = SQRT(CNV) IZ = N if (BP(N)-BP(1)) 101,142,103 101 DO 102 J=1,N NT = N-J BH(J) = BP(NT+1) 102 CONTINUE go to 105 103 DO 104 J=1,N BH(J) = BP(J) 104 CONTINUE 105 NCMPLX = 0 MODIZ = MOD(IZ,2) IS = 1 if (MODIZ) 106,107,106 106 if (A(1)) 110,142,107 107 XL = BH(1) DB = BH(3)-BH(1) 108 XL = XL-DB if (PGSF(XL,IZ,C,A,BH)) 108,108,109 109 SGN = -1. CBP(1) = CMPLX(BCRH(XL,BH(1),IZ,C,A,BH,PGSF,SGN),0.) IS = 2 110 if = IZ-1 if (MODIZ) 111,112,111 111 if (A(1)) 112,142,115 112 XR = BH(IZ) DB = BH(IZ)-BH(IZ-2) 113 XR = XR+DB if (PGSF(XR,IZ,C,A,BH)) 113,114,114 114 SGN = 1. CBP(IZ) = CMPLX(BCRH(BH(IZ),XR,IZ,C,A,BH,PGSF,SGN),0.) if = IZ-2 115 DO 136 IG=IS,IF,2 XL = BH(IG) XR = BH(IG+1) SGN = -1. XM = BCRH(XL,XR,IZ,C,A,BH,PPPSF,SGN) PSG = PGSF(XM,IZ,C,A,BH) if (ABS(PSG)-EPS) 118,118,116 116 if (PSG*PPGSF(XM,IZ,C,A,BH)) 117,118,119 ! ! CASE OF A REAL ZERO ! 117 SGN = 1. CBP(IG) = CMPLX(BCRH(BH(IG),XM,IZ,C,A,BH,PGSF,SGN),0.) SGN = -1. CBP(IG+1) = CMPLX(BCRH(XM,BH(IG+1),IZ,C,A,BH,PGSF,SGN),0.) go to 136 ! ! CASE OF A MULTIPLE ZERO ! 118 CBP(IG) = CMPLX(XM,0.) CBP(IG+1) = CMPLX(XM,0.) go to 136 ! ! CASE OF A COMPLEX ZERO ! 119 IT = 0 ICV = 0 CX = CMPLX(XM,0.) 120 FSG = (1.,0.) HSG = (1.,0.) FP = (0.,0.) FPP = (0.,0.) DO 121 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 121 CONTINUE if (MODIZ) 123,122,123 122 F = (1.,0.)-FSG-HSG go to 124 123 F = (1.,0.)+FSG+HSG 124 I3 = 0 if (ABS(FP)) 126,126,125 125 I3 = 1 R3 = -F/FP 126 if (ABS(FPP)) 132,132,127 127 CDIS = SQRT(FP**2-2.*F*FPP) R1 = CDIS-FP R2 = -FP-CDIS if (ABS(R1)-ABS(R2)) 129,129,128 128 R1 = R1/FPP go to 130 129 R1 = R2/FPP 130 R2 = 2.*F/FPP/R1 if (ABS(R2) < ABS(R1)) R1 = R2 if (I3) 133,133,131 131 if (ABS(R3) < ABS(R1)) R1 = R3 go to 133 132 R1 = R3 133 CX = CX+R1 IT = IT+1 if (IT > 50) go to 142 if (ABS(R1) > SCNV) go to 120 if (ICV) 134,134,135 134 ICV = 1 go to 120 135 CBP(IG) = CX CBP(IG+1) = CONJG(CX) 136 CONTINUE if (ABS(CBP(N))-ABS(CBP(1))) 137,142,139 137 NHALF = N/2 DO 138 J=1,NHALF NT = N-J CX = CBP(J) CBP(J) = CBP(NT+1) CBP(NT+1) = CX 138 CONTINUE 139 NCMPLX = 1 DO 140 J=2,IZ if (AIMAG(CBP(J))) 143,140,143 140 CONTINUE NCMPLX = 0 DO 141 J=2,IZ BP(J) = REAL(CBP(J)) 141 CONTINUE go to 143 142 IERROR = 4 143 CONTINUE return end subroutine CPBCO (ABD, LDA, N, M, RCOND, Z, INFO) ! !! CPBCO factors a complex Hermitian positive definite matrix stored ... ! in band form and estimate the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D2 !***TYPE COMPLEX (SPBCO-S, DPBCO-D, CPBCO-C) !***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPBCO factors a complex Hermitian positive definite matrix ! stored in band form and estimates the condition of the matrix. ! ! If RCOND is not needed, CPBFA is slightly faster. ! To solve A*X = B , follow CPBCO by CPBSL. ! To compute INVERSE(A)*C , follow CPBCO by CPBSL. ! To compute DETERMINANT(A) , follow CPBCO by CPBDI. ! ! On Entry ! ! ABD COMPLEX(LDA, N) ! the matrix to be factored. The columns of the upper ! triangle are stored in the columns of ABD and the ! diagonals of the upper triangle are stored in the ! rows of ABD . See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= M + 1 . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! 0 <= M < N . ! ! On Return ! ! ABD an upper triangular matrix R , stored in band ! form, so that A = CTRANS(R)*R . ! If INFO /= 0 , the factorization is not complete. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. If INFO /= 0 , RCOND is unchanged. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If A is singular to working precision, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! If INFO /= 0 , Z is unchanged. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! ! Band Storage ! ! If A is a Hermitian positive definite band matrix, ! the following program segment will set up the input. ! ! M = (band width above diagonal) ! DO 20 J = 1, N ! I1 = MAX(1, J-M) ! DO 10 I = I1, J ! K = I-J+M+1 ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses M + 1 rows of A , except for the M by M ! upper left triangle, which is ignored. ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 12222324 0 0 ! 1323333435 0 ! 02434444546 ! 0 035455556 ! 0 0 0465666 ! ! then N = 6 , M = 2 and ABD should contain ! ! * * 13243546 ! * 1223344556 ! 112233445566 ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC, CPBFA, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPBCO INTEGER LDA,N,M,INFO COMPLEX ABD(LDA,*),Z(*) REAL RCOND ! COMPLEX CDOTC,EK,T,WK,WKM REAL ANORM,S,SCASUM,SM,YNORM INTEGER I,J,J2,K,KB,KP1,L,LA,LB,LM,MU COMPLEX ZDUM,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) ! ! FIND NORM OF A ! !***FIRST EXECUTABLE STATEMENT CPBCO DO 30 J = 1, N L = MIN(J,M+1) MU = MAX(M+2-J,1) Z(J) = CMPLX(SCASUM(L,ABD(MU,J),1),0.0E0) K = J - L if (M < MU) go to 20 DO 10 I = MU, M K = K + 1 Z(K) = CMPLX(REAL(Z(K))+CABS1(ABD(I,J)),0.0E0) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,REAL(Z(J))) 40 CONTINUE ! ! FACTOR ! call CPBFA(ABD,LDA,N,M,INFO) if (INFO /= 0) go to 180 ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE CTRANS(R)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE CTRANS(R)*W = E ! EK = (1.0E0,0.0E0) DO 50 J = 1, N Z(J) = (0.0E0,0.0E0) 50 CONTINUE DO 110 K = 1, N if (CABS1(Z(K)) /= 0.0E0) EK = CSIGN1(EK,-Z(K)) if (CABS1(EK-Z(K)) <= REAL(ABD(M+1,K))) go to 60 S = REAL(ABD(M+1,K))/CABS1(EK-Z(K)) call CSSCAL(N,S,Z,1) EK = CMPLX(S,0.0E0)*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = CABS1(WK) SM = CABS1(WKM) WK = WK/ABD(M+1,K) WKM = WKM/ABD(M+1,K) KP1 = K + 1 J2 = MIN(K+M,N) I = M + 1 if (KP1 > J2) go to 100 DO 70 J = KP1, J2 I = I - 1 SM = SM + CABS1(Z(J)+WKM*CONJG(ABD(I,J))) Z(J) = Z(J) + WK*CONJG(ABD(I,J)) S = S + CABS1(Z(J)) 70 CONTINUE if (S >= SM) go to 90 T = WKM - WK WK = WKM I = M + 1 DO 80 J = KP1, J2 I = I - 1 Z(J) = Z(J) + T*CONJG(ABD(I,J)) 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! ! SOLVE R*Y = W ! DO 130 KB = 1, N K = N + 1 - KB if (CABS1(Z(K)) <= REAL(ABD(M+1,K))) go to 120 S = REAL(ABD(M+1,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/ABD(M+1,K) LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM T = -Z(K) call CAXPY(LM,T,ABD(LA,K),1,Z(LB),1) 130 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE CTRANS(R)*V = Y ! DO 150 K = 1, N LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM Z(K) = Z(K) - CDOTC(LM,ABD(LA,K),1,Z(LB),1) if (CABS1(Z(K)) <= REAL(ABD(M+1,K))) go to 140 S = REAL(ABD(M+1,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/ABD(M+1,K) 150 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE R*Z = W ! DO 170 KB = 1, N K = N + 1 - KB if (CABS1(Z(K)) <= REAL(ABD(M+1,K))) go to 160 S = REAL(ABD(M+1,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/ABD(M+1,K) LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM T = -Z(K) call CAXPY(LM,T,ABD(LA,K),1,Z(LB),1) 170 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 180 CONTINUE return end subroutine CPBDI (ABD, LDA, N, M, DET) ! !! CPBDI computes the determinant of a complex Hermitian positive ! definite band matrix using the factors computed by CPBCO or CPBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D3D2 !***TYPE COMPLEX (SPBDI-S, DPBDI-D, CPBDI-C) !***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, ! MATRIX, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPBDI computes the determinant ! of a complex Hermitian positive definite band matrix ! using the factors computed by CPBCO or CPBFA. ! If the inverse is needed, use CPBSL N times. ! ! On Entry ! ! ABD COMPLEX(LDA, N) ! the output from CPBCO or CPBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! ! On Return ! ! DET REAL(2) ! determinant of original matrix in the form ! determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= DET(1) < 10.0 ! or DET(1) == 0.0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPBDI INTEGER LDA,N,M COMPLEX ABD(LDA,*) REAL DET(2) ! REAL S INTEGER I !***FIRST EXECUTABLE STATEMENT CPBDI ! ! COMPUTE DETERMINANT ! DET(1) = 1.0E0 DET(2) = 0.0E0 S = 10.0E0 DO 50 I = 1, N DET(1) = REAL(ABD(M+1,I))**2*DET(1) if (DET(1) == 0.0E0) go to 60 10 if (DET(1) >= 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) < S) go to 40 DET(1) = DET(1)/S DET(2) = DET(2) + 1.0E0 go to 30 40 CONTINUE 50 CONTINUE 60 CONTINUE return end subroutine CPBFA (ABD, LDA, N, M, INFO) ! !! CPBFA factors a complex Hermitian positive definite band matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D2 !***TYPE COMPLEX (SPBFA-S, DPBFA-D, CPBFA-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPBFA factors a complex Hermitian positive definite matrix ! stored in band form. ! ! CPBFA is usually called by CPBCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! ! On Entry ! ! ABD COMPLEX(LDA, N) ! the matrix to be factored. The columns of the upper ! triangle are stored in the columns of ABD and the ! diagonals of the upper triangle are stored in the ! rows of ABD . See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= M + 1 . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! 0 <= M < N . ! ! On Return ! ! ABD an upper triangular matrix R , stored in band ! form, so that A = CTRANS(R)*R . ! ! INFO INTEGER ! = 0 for normal return. ! = K if the leading minor of order K is not ! positive definite. ! ! Band Storage ! ! If A is a Hermitian positive definite band matrix, ! the following program segment will set up the input. ! ! M = (band width above diagonal) ! DO 20 J = 1, N ! I1 = MAX(1, J-M) ! DO 10 I = I1, J ! K = I-J+M+1 ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPBFA INTEGER LDA,N,M,INFO COMPLEX ABD(LDA,*) ! COMPLEX CDOTC,T REAL S INTEGER IK,J,JK,K,MU !***FIRST EXECUTABLE STATEMENT CPBFA DO 30 J = 1, N INFO = J S = 0.0E0 IK = M + 1 JK = MAX(J-M,1) MU = MAX(M+2-J,1) if (M < MU) go to 20 DO 10 K = MU, M T = ABD(K,J) - CDOTC(K-MU,ABD(IK,JK),1,ABD(MU,J),1) T = T/ABD(M+1,JK) ABD(K,J) = T S = S + REAL(T*CONJG(T)) IK = IK - 1 JK = JK + 1 10 CONTINUE 20 CONTINUE S = REAL(ABD(M+1,J)) - S if (S <= 0.0E0 .OR. AIMAG(ABD(M+1,J)) /= 0.0E0) & go to 40 ABD(M+1,J) = CMPLX(SQRT(S),0.0E0) 30 CONTINUE INFO = 0 40 CONTINUE return end subroutine CPBSL (ABD, LDA, N, M, B) ! !! CPBSL solves the complex Hermitian positive definite band system ... ! using the factors computed by CPBCO or CPBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D2 !***TYPE COMPLEX (SPBSL-S, DPBSL-D, CPBSL-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, ! POSITIVE DEFINITE, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPBSL solves the complex Hermitian positive definite band ! system A*X = B ! using the factors computed by CPBCO or CPBFA. ! ! On Entry ! ! ABD COMPLEX(LDA, N) ! the output from CPBCO or CPBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! ! B COMPLEX(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal. Technically this indicates ! singularity but it is usually caused by improper subroutine ! arguments. It will not occur if the subroutines are called ! correctly and INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call CPBCO(ABD,LDA,N,RCOND,Z,INFO) ! if (RCOND is too small .OR. INFO /= 0) go to ... ! DO 10 J = 1, P ! call CPBSL(ABD,LDA,N,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPBSL INTEGER LDA,N,M COMPLEX ABD(LDA,*),B(*) ! COMPLEX CDOTC,T INTEGER K,KB,LA,LB,LM ! ! SOLVE CTRANS(R)*Y = B ! !***FIRST EXECUTABLE STATEMENT CPBSL DO 10 K = 1, N LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM T = CDOTC(LM,ABD(LA,K),1,B(LB),1) B(K) = (B(K) - T)/ABD(M+1,K) 10 CONTINUE ! ! SOLVE R*X = Y ! DO 20 KB = 1, N K = N + 1 - KB LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM B(K) = B(K)/ABD(M+1,K) T = -B(K) call CAXPY(LM,T,ABD(LA,K),1,B(LB),1) 20 CONTINUE return end subroutine CPEVL (N, M, A, Z, C, B, KBD) ! !! CPEVL is subsidiary to CPZERO. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CPEVL-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Evaluate a complex polynomial and its derivatives. ! Optionally compute error bounds for these values. ! ! INPUT... ! N = Degree of the polynomial ! M = Number of derivatives to be calculated, ! M=0 evaluates only the function ! M=1 evaluates the function and first derivative, etc. ! if M > N+1 function and all N derivatives will be ! calculated. ! A = Complex vector containing the N+1 coefficients of polynomial ! A(I)= coefficient of Z**(N+1-I) ! Z = Complex point at which the evaluation is to take place. ! C = Array of 2(M+1) words into which values are placed. ! B = Array of 2(M+1) words only needed if bounds are to be ! calculated. It is not used otherwise. ! KBD = A logical variable, e.g. .TRUE. or .FALSE. which is ! to be set .TRUE. if bounds are to be computed. ! ! OUTPUT... ! C = C(I+1) contains the complex value of the I-th ! derivative at Z, I=0,...,M ! B = B(I) contains the bounds on the real and imaginary parts ! of C(I) if they were requested. ! !***SEE ALSO CPZERO !***ROUTINES CALLED I1MACH !***REVISION HISTORY (YYMMDD) ! 810223 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CPEVL ! COMPLEX A(*),C(*),Z,CI,CIM1,B(*),BI,BIM1,T,ZA,Q LOGICAL KBD SAVE D1 DATA D1 /0.0/ ZA(Q)=CMPLX(ABS(REAL(Q)),ABS(AIMAG(Q))) !***FIRST EXECUTABLE STATEMENT CPEVL if (D1 == 0.0) D1 = REAL(I1MACH(10))**(1-I1MACH(11)) NP1=N+1 DO 1 J=1,NP1 CI=0.0 CIM1=A(J) BI=0.0 BIM1=0.0 MINI=MIN(M+1,N+2-J) DO 1 I=1,MINI if ( J /= 1) CI=C(I) if ( I /= 1) CIM1=C(I-1) C(I)=CIM1+Z*CI if ( .NOT. KBD) go to 1 if ( J /= 1) BI=B(I) if ( I /= 1) BIM1=B(I-1) T=BI+(3.*D1+4.*D1*D1)*ZA(CI) R=REAL(ZA(Z)*CMPLX(REAL(T),-AIMAG(T))) S=AIMAG(ZA(Z)*T) B(I)=(1.+8.*D1)*(BIM1+D1*ZA(CIM1)+CMPLX(R,S)) if ( J == 1) B(I)=0.0 1 CONTINUE return end subroutine CPEVLR (N, M, A, X, C) ! !! CPEVLR is subsidiary to CPZERO. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CPEVLR-S) !***AUTHOR (UNKNOWN) !***SEE ALSO CPZERO !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810223 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CPEVLR REAL A(*),C(*) !***FIRST EXECUTABLE STATEMENT CPEVLR NP1=N+1 DO J=1,NP1 CI=0.0 CIM1=A(J) MINI=MIN(M+1,N+2-J) DO I=1,MINI if ( J /= 1) CI=C(I) if ( I /= 1) CIM1=C(I-1) C(I)=CIM1+X*CI end do end do return end subroutine CPOCO (A, LDA, N, RCOND, Z, INFO) ! !! CPOCO factors a complex Hermitian positive definite matrix ... ! and estimates the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1B !***TYPE COMPLEX (SPOCO-S, DPOCO-D, CPOCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPOCO factors a complex Hermitian positive definite matrix ! and estimates the condition of the matrix. ! ! If RCOND is not needed, CPOFA is slightly faster. ! To solve A*X = B , follow CPOCO by CPOSL. ! To compute INVERSE(A)*C , follow CPOCO by CPOSL. ! To compute DETERMINANT(A) , follow CPOCO by CPODI. ! To compute INVERSE(A) , follow CPOCO by CPODI. ! ! On Entry ! ! A COMPLEX(LDA, N) ! the Hermitian matrix to be factored. Only the ! diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix R so that A = ! CTRANS(R)*R where CTRANS(R) is the conjugate ! transpose. The strict lower triangle is unaltered. ! If INFO /= 0 , the factorization is not complete. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. If INFO /= 0 , RCOND is unchanged. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! If INFO /= 0 , Z is unchanged. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC, CPOFA, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPOCO INTEGER LDA,N,INFO COMPLEX A(LDA,*),Z(*) REAL RCOND ! COMPLEX CDOTC,EK,T,WK,WKM REAL ANORM,S,SCASUM,SM,YNORM INTEGER I,J,JM1,K,KB,KP1 COMPLEX ZDUM,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT CPOCO DO 30 J = 1, N Z(J) = CMPLX(SCASUM(J,A(1,J),1),0.0E0) JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 Z(I) = CMPLX(REAL(Z(I))+CABS1(A(I,J)),0.0E0) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,REAL(Z(J))) 40 CONTINUE ! ! FACTOR ! call CPOFA(A,LDA,N,INFO) if (INFO /= 0) go to 180 ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE CTRANS(R)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE CTRANS(R)*W = E ! EK = (1.0E0,0.0E0) DO 50 J = 1, N Z(J) = (0.0E0,0.0E0) 50 CONTINUE DO 110 K = 1, N if (CABS1(Z(K)) /= 0.0E0) EK = CSIGN1(EK,-Z(K)) if (CABS1(EK-Z(K)) <= REAL(A(K,K))) go to 60 S = REAL(A(K,K))/CABS1(EK-Z(K)) call CSSCAL(N,S,Z,1) EK = CMPLX(S,0.0E0)*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = CABS1(WK) SM = CABS1(WKM) WK = WK/A(K,K) WKM = WKM/A(K,K) KP1 = K + 1 if (KP1 > N) go to 100 DO 70 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)) 70 CONTINUE if (S >= SM) go to 90 T = WKM - WK WK = WKM DO 80 J = KP1, N Z(J) = Z(J) + T*CONJG(A(K,J)) 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! ! SOLVE R*Y = W ! DO 130 KB = 1, N K = N + 1 - KB if (CABS1(Z(K)) <= REAL(A(K,K))) go to 120 S = REAL(A(K,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) call CAXPY(K-1,T,A(1,K),1,Z(1),1) 130 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE CTRANS(R)*V = Y ! DO 150 K = 1, N Z(K) = Z(K) - CDOTC(K-1,A(1,K),1,Z(1),1) if (CABS1(Z(K)) <= REAL(A(K,K))) go to 140 S = REAL(A(K,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/A(K,K) 150 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE R*Z = V ! DO 170 KB = 1, N K = N + 1 - KB if (CABS1(Z(K)) <= REAL(A(K,K))) go to 160 S = REAL(A(K,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) call CAXPY(K-1,T,A(1,K),1,Z(1),1) 170 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 180 CONTINUE return end subroutine CPODI (A, LDA, N, DET, JOB) ! !! CPODI computes the determinant and inverse of a certain complex ... ! Hermitian positive definite matrix using the factors ... ! computed by CPOCO, CPOFA, or CQRDC. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1B, D3D1B !***TYPE COMPLEX (SPODI-S, DPODI-D, CPODI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPODI computes the determinant and inverse of a certain ! complex Hermitian positive definite matrix (see below) ! using the factors computed by CPOCO, CPOFA or CQRDC. ! ! On Entry ! ! A COMPLEX(LDA, N) ! the output A from CPOCO or CPOFA ! or the output X from CQRDC. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! JOB INTEGER ! = 11 both determinant and inverse. ! = 01 inverse only. ! = 10 determinant only. ! ! On Return ! ! A If CPOCO or CPOFA was used to factor A then ! CPODI produces the upper half of INVERSE(A) . ! If CQRDC was used to decompose X then ! CPODI produces the upper half of INVERSE(CTRANS(X)*X) ! where CTRANS(X) is the conjugate transpose. ! Elements of A below the diagonal are unchanged. ! If the units digit of JOB is zero, A is unchanged. ! ! DET REAL(2) ! determinant of A or of CTRANS(X)*X if requested. ! Otherwise not referenced. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= DET(1) < 10.0 ! or DET(1) == 0.0 . ! ! Error Condition ! ! a division by zero will occur if the input factor contains ! a zero on the diagonal and the inverse is requested. ! It will not occur if the subroutines are called correctly ! and if CPOCO or CPOFA has set INFO == 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPODI INTEGER LDA,N,JOB COMPLEX A(LDA,*) REAL DET(2) ! COMPLEX T REAL S INTEGER I,J,JM1,K,KP1 !***FIRST EXECUTABLE STATEMENT CPODI ! ! COMPUTE DETERMINANT ! if (JOB/10 == 0) go to 70 DET(1) = 1.0E0 DET(2) = 0.0E0 S = 10.0E0 DO 50 I = 1, N DET(1) = REAL(A(I,I))**2*DET(1) if (DET(1) == 0.0E0) go to 60 10 if (DET(1) >= 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) < 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 ! ! COMPUTE INVERSE(R) ! if (MOD(JOB,10) == 0) go to 140 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 < 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 ! ! FORM INVERSE(R) * CTRANS(INVERSE(R)) ! DO 130 J = 1, N JM1 = J - 1 if (JM1 < 1) go to 120 DO 110 K = 1, JM1 T = CONJG(A(K,J)) call CAXPY(K,T,A(1,J),1,A(1,K),1) 110 CONTINUE 120 CONTINUE T = CONJG(A(J,J)) call CSCAL(J,T,A(1,J),1) 130 CONTINUE 140 CONTINUE return end subroutine CPOFA (A, LDA, N, INFO) ! !! CPOFA factors a complex Hermitian positive definite matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1B !***TYPE COMPLEX (SPOFA-S, DPOFA-D, CPOFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPOFA factors a complex Hermitian positive definite matrix. ! ! CPOFA is usually called by CPOCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! (Time for CPOCO) = (1 + 18/N)*(Time for CPOFA) . ! ! On Entry ! ! A COMPLEX(LDA, N) ! the Hermitian matrix to be factored. Only the ! diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix R so that A = ! CTRANS(R)*R where CTRANS(R) is the conjugate ! transpose. The strict lower triangle is unaltered. ! If INFO /= 0 , the factorization is not complete. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPOFA INTEGER LDA,N,INFO COMPLEX A(LDA,*) ! COMPLEX CDOTC,T REAL S INTEGER J,JM1,K !***FIRST EXECUTABLE STATEMENT CPOFA DO 30 J = 1, N INFO = J S = 0.0E0 JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 K = 1, JM1 T = A(K,J) - CDOTC(K-1,A(1,K),1,A(1,J),1) T = T/A(K,K) A(K,J) = T S = S + REAL(T*CONJG(T)) 10 CONTINUE 20 CONTINUE S = REAL(A(J,J)) - S if (S <= 0.0E0 .OR. AIMAG(A(J,J)) /= 0.0E0) go to 40 A(J,J) = CMPLX(SQRT(S),0.0E0) 30 CONTINUE INFO = 0 40 CONTINUE return end subroutine CPOFS (A, LDA, N, V, ITASK, IND, WORK) ! !! CPOFS solves a positive definite symmetric complex linear system. ! !***LIBRARY SLATEC !***CATEGORY D2D1B !***TYPE COMPLEX (SPOFS-S, DPOFS-D, CPOFS-C) !***KEYWORDS HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine CPOFS solves a positive definite symmetric ! NxN system of complex linear equations using LINPACK ! subroutines CPOCO and CPOSL. That is, if A is an NxN ! complex positive definite symmetric matrix and if X and B ! are complex N-vectors, then CPOFS solves the equation ! ! A*X=B. ! ! Care should be taken not to use CPOFS with a non-Hermitian ! matrix. ! ! The matrix A is first factored into upper and lower tri- ! angular matrices R and R-TRANSPOSE. These factors are used to ! find the solution vector X. An approximate condition number is ! calculated to provide a rough estimate of the number of ! digits of accuracy in the computed solution. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of a does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, and N must not have been altered by the user following ! factorization (ITASK=1). IND will not be changed by CPOFS ! in this case. ! ! Argument Description *** ! ! A COMPLEX(LDA,N) ! on entry, the doubly subscripted array with dimension ! (LDA,N) which contains the coefficient matrix. Only ! the upper triangle, including the diagonal, of the ! coefficient matrix need be entered and will subse- ! quently be referenced and changed by the routine. ! on return, contains in its upper triangle an upper ! triangular matrix R such that A = (R-TRANSPOSE) * R . ! LDA INTEGER ! the leading dimension of the array A. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. N must be greater ! than or equal to 1. (terminal error message IND=-2) ! V COMPLEX(N) ! on entry the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! if ITASK = 1, the matrix A is factored and then the ! linear equation is solved. ! if ITASK > 1, the equation is solved using the existing ! factored matrix A. ! if ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. ! LT. 0 see error message corresponding to IND below. ! WORK COMPLEX(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than 1. ! IND=-3 terminal ITASK is less than 1. ! IND=-4 terminal The matrix A is computationally singular or ! is not positive definite. A solution ! has not been computed. ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the ! matrix A may be poorly scaled. ! ! NOTE- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CPOCO, CPOSL, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800516 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to ! IF-THEN-ELSE. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPOFS ! INTEGER LDA,N,ITASK,IND,INFO COMPLEX A(LDA,*),V(*),WORK(*) REAL R1MACH REAL RCOND CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT CPOFS if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'CPOFS', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'CPOFS', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'CPOFS', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ITASK == 1) THEN ! ! FACTOR MATRIX A INTO R ! call CPOCO(A,LDA,N,RCOND,WORK,INFO) ! ! CHECK FOR POSITIVE DEFINITE MATRIX ! if (INFO /= 0) THEN IND = -4 call XERMSG ('SLATEC', 'CPOFS', & 'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1) return ENDIF ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(R1MACH(4)/RCOND) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'CPOFS', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) ENDIF end if ! ! SOLVE AFTER FACTORING ! call CPOSL(A,LDA,N,V) return end subroutine CPOIR (A, LDA, N, V, ITASK, IND, WORK) ! !! CPOIR solves a positive definite Hermitian system of linear equations. ... ! Iterative refinement is used to obtain an error estimate. ! !***LIBRARY SLATEC !***CATEGORY D2D1B !***TYPE COMPLEX (SPOIR-S, CPOIR-C) !***KEYWORDS HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine CPOIR solves a complex positive definite Hermitian ! NxN system of single precision linear equations using LINPACK ! subroutines CPOFA and CPOSL. One pass of iterative refine- ! ment is used only to obtain an estimate of the accuracy. That ! is, if A is an NxN complex positive definite Hermitian matrix ! and if X and B are complex N-vectors, then CPOIR solves the ! equation ! ! A*X=B. ! ! Care should be taken not to use CPOIR with a non-Hermitian ! matrix. ! ! The matrix A is first factored into upper and lower ! triangular matrices R and R-TRANSPOSE. These ! factors are used to calculate the solution, X. ! Then the residual vector is found and used ! to calculate an estimate of the relative error, IND. ! IND estimates the accuracy of the solution only when the ! input matrix and the right hand side are represented ! exactly in the computer and does not take into account ! any errors in the input data. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N, and WORK must not have been altered by the user ! following factorization (ITASK=1). IND will not be changed ! by CPOIR in this case. ! ! Argument Description *** ! A COMPLEX(LDA,N) ! the doubly subscripted array with dimension (LDA,N) ! which contains the coefficient matrix. Only the ! upper triangle, including the diagonal, of the ! coefficient matrix need be entered. A is not ! altered by the routine. ! LDA INTEGER ! the leading dimension of the array A. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. N must be greater than ! or equal to one. (terminal error message IND=-2) ! V COMPLEX(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! if ITASK = 1, the matrix A is factored and then the ! linear equation is solved. ! if ITASK > 1, the equation is solved using the existing ! factored matrix A (stored in WORK). ! if ITASK < 1, then terminal terminal error IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. IND=75 means ! that the solution vector X is zero. ! LT. 0 see error message corresponding to IND below. ! WORK COMPLEX(N*(N+1)) ! a singly subscripted array of dimension at least N*(N+1). ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than one. ! IND=-3 terminal ITASK is less than one. ! IND=-4 terminal The matrix A is computationally singular ! or is not positive definite. ! A solution has not been computed. ! IND=-10 warning The solution has no apparent significance. ! the solution may be inaccurate or the matrix ! a may be poorly scaled. ! ! NOTE- the above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CCOPY, CPOFA, CPOSL, DCDOT, R1MACH, SCASUM, XERMSG !***REVISION HISTORY (YYMMDD) ! 800530 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to ! IF-THEN-ELSE. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPOIR ! INTEGER LDA,N,ITASK,IND,INFO,J COMPLEX A(LDA,*),V(*),WORK(N,*) REAL SCASUM,XNORM,DNORM,R1MACH DOUBLE PRECISION DR1,DI1,DR2,DI2 CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT CPOIR if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'CPOIR', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'CPOIR', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'CPOIR', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ITASK == 1) THEN ! ! MOVE MATRIX A TO WORK ! DO 10 J=1,N call CCOPY(N,A(1,J),1,WORK(1,J),1) 10 CONTINUE ! ! FACTOR MATRIX A INTO R ! call CPOFA(WORK,N,N,INFO) ! ! CHECK FOR SINGULAR OR NOT POS.DEF. MATRIX ! if (INFO /= 0) THEN IND = -4 call XERMSG ('SLATEC', 'CPOIR', & 'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1) return ENDIF end if ! ! SOLVE AFTER FACTORING ! MOVE VECTOR B TO WORK ! call CCOPY(N,V(1),1,WORK(1,N+1),1) call CPOSL(WORK,N,N,V) ! ! FORM NORM OF X0 ! XNORM = SCASUM(N,V(1),1) if (XNORM == 0.0) THEN IND = 75 return end if ! ! COMPUTE RESIDUAL ! DO 40 J=1,N call DCDOT(J-1,-1.D0,A(1,J),1,V(1),1,DR1,DI1) call DCDOT(N-J+1,1.D0,A(J,J),LDA,V(J),1,DR2,DI2) DR1 = DR1+DR2-DBLE(REAL(WORK(J,N+1))) DI1 = DI1+DI2-DBLE(AIMAG(WORK(J,N+1))) WORK(J,N+1) = CMPLX(REAL(DR1),REAL(DI1)) 40 CONTINUE ! ! SOLVE A*DELTA=R ! call CPOSL(WORK,N,N,WORK(1,N+1)) ! ! FORM NORM OF DELTA ! DNORM = SCASUM(N,WORK(1,N+1),1) ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'CPOIR', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) end if return end subroutine CPOSL (A, LDA, N, B) ! !! CPOSL solves the complex Hermitian positive definite linear system ... ! using the factors computed by CPOCO or CPOFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1B !***TYPE COMPLEX (SPOSL-S, DPOSL-D, CPOSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPOSL solves the COMPLEX Hermitian positive definite system ! A * X = B ! using the factors computed by CPOCO or CPOFA. ! ! On Entry ! ! A COMPLEX(LDA, N) ! the output from CPOCO or CPOFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! B COMPLEX(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal. Technically this indicates ! singularity but it is usually caused by improper subroutine ! arguments. It will not occur if the subroutines are called ! correctly and INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call CPOCO(A,LDA,N,RCOND,Z,INFO) ! if (RCOND is too small .OR. INFO /= 0) go to ... ! DO 10 J = 1, P ! call CPOSL(A,LDA,N,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPOSL INTEGER LDA,N COMPLEX A(LDA,*),B(*) ! COMPLEX CDOTC,T INTEGER K,KB ! ! SOLVE CTRANS(R)*Y = B ! !***FIRST EXECUTABLE STATEMENT CPOSL DO 10 K = 1, N T = CDOTC(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) 10 CONTINUE ! ! SOLVE R*X = Y ! DO 20 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) 20 CONTINUE return end subroutine CPPCO (AP, N, RCOND, Z, INFO) ! !! CPPCO factors a complex Hermitian positive definite matrix stored ... ! in packed form and estimate the condition number of the ... ! matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1B !***TYPE COMPLEX (SPPCO-S, DPPCO-D, CPPCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, PACKED, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPPCO factors a complex Hermitian positive definite matrix ! stored in packed form and estimates the condition of the matrix. ! ! If RCOND is not needed, CPPFA is slightly faster. ! To solve A*X = B , follow CPPCO by CPPSL. ! To compute INVERSE(A)*C , follow CPPCO by CPPSL. ! To compute DETERMINANT(A) , follow CPPCO by CPPDI. ! To compute INVERSE(A) , follow CPPCO by CPPDI. ! ! On Entry ! ! AP COMPLEX (N*(N+1)/2) ! the packed form of a Hermitian matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! AP an upper triangular matrix R , stored in packed ! form, so that A = CTRANS(R)*R . ! If INFO /= 0 , the factorization is not complete. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. If INFO /= 0 , RCOND is unchanged. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If A is singular to working precision, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! If INFO /= 0 , Z is unchanged. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a Hermitian matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC, CPPFA, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPPCO INTEGER N,INFO COMPLEX AP(*),Z(*) REAL RCOND ! COMPLEX CDOTC,EK,T,WK,WKM REAL ANORM,S,SCASUM,SM,YNORM INTEGER I,IJ,J,JM1,J1,K,KB,KJ,KK,KP1 COMPLEX ZDUM,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) ! ! FIND NORM OF A ! !***FIRST EXECUTABLE STATEMENT CPPCO J1 = 1 DO 30 J = 1, N Z(J) = CMPLX(SCASUM(J,AP(J1),1),0.0E0) IJ = J1 J1 = J1 + J JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 Z(I) = CMPLX(REAL(Z(I))+CABS1(AP(IJ)),0.0E0) IJ = IJ + 1 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,REAL(Z(J))) 40 CONTINUE ! ! FACTOR ! call CPPFA(AP,N,INFO) if (INFO /= 0) go to 180 ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE CTRANS(R)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE CTRANS(R)*W = E ! EK = (1.0E0,0.0E0) DO 50 J = 1, N Z(J) = (0.0E0,0.0E0) 50 CONTINUE KK = 0 DO 110 K = 1, N KK = KK + K if (CABS1(Z(K)) /= 0.0E0) EK = CSIGN1(EK,-Z(K)) if (CABS1(EK-Z(K)) <= REAL(AP(KK))) go to 60 S = REAL(AP(KK))/CABS1(EK-Z(K)) call CSSCAL(N,S,Z,1) EK = CMPLX(S,0.0E0)*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = CABS1(WK) SM = CABS1(WKM) WK = WK/AP(KK) WKM = WKM/AP(KK) KP1 = K + 1 KJ = KK + K if (KP1 > N) go to 100 DO 70 J = KP1, N SM = SM + CABS1(Z(J)+WKM*CONJG(AP(KJ))) Z(J) = Z(J) + WK*CONJG(AP(KJ)) S = S + CABS1(Z(J)) KJ = KJ + J 70 CONTINUE if (S >= SM) go to 90 T = WKM - WK WK = WKM KJ = KK + K DO 80 J = KP1, N Z(J) = Z(J) + T*CONJG(AP(KJ)) KJ = KJ + J 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! ! SOLVE R*Y = W ! DO 130 KB = 1, N K = N + 1 - KB if (CABS1(Z(K)) <= REAL(AP(KK))) go to 120 S = REAL(AP(KK))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/AP(KK) KK = KK - K T = -Z(K) call CAXPY(K-1,T,AP(KK+1),1,Z(1),1) 130 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE CTRANS(R)*V = Y ! DO 150 K = 1, N Z(K) = Z(K) - CDOTC(K-1,AP(KK+1),1,Z(1),1) KK = KK + K if (CABS1(Z(K)) <= REAL(AP(KK))) go to 140 S = REAL(AP(KK))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/AP(KK) 150 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE R*Z = V ! DO 170 KB = 1, N K = N + 1 - KB if (CABS1(Z(K)) <= REAL(AP(KK))) go to 160 S = REAL(AP(KK))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/AP(KK) KK = KK - K T = -Z(K) call CAXPY(K-1,T,AP(KK+1),1,Z(1),1) 170 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 180 CONTINUE return end subroutine CPPDI (AP, N, DET, JOB) ! !! CPPDI computes the determinant and inverse of a complex Hermitian ... ! positive definite matrix using factors from CPPCO or CPPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1B, D3D1B !***TYPE COMPLEX (SPPDI-S, DPPDI-D, CPPDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! PACKED, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPPDI computes the determinant and inverse ! of a complex Hermitian positive definite matrix ! using the factors computed by CPPCO or CPPFA . ! ! On Entry ! ! AP COMPLEX (N*(N+1)/2) ! the output from CPPCO or CPPFA. ! ! N INTEGER ! the order of the matrix A . ! ! JOB INTEGER ! = 11 both determinant and inverse. ! = 01 inverse only. ! = 10 determinant only. ! ! On Return ! ! AP the upper triangular half of the inverse . ! The strict lower triangle is unaltered. ! ! DET REAL(2) ! determinant of original matrix if requested. ! Otherwise not referenced. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= DET(1) < 10.0 ! or DET(1) == 0.0 . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal and the inverse is requested. ! It will not occur if the subroutines are called correctly ! and if CPOCO or CPOFA has set INFO == 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPPDI INTEGER N,JOB COMPLEX AP(*) REAL DET(2) ! COMPLEX T REAL S INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1 !***FIRST EXECUTABLE STATEMENT CPPDI ! ! COMPUTE DETERMINANT ! if (JOB/10 == 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) = REAL(AP(II))**2*DET(1) if (DET(1) == 0.0E0) go to 60 10 if (DET(1) >= 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) < 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 ! ! COMPUTE INVERSE(R) ! if (MOD(JOB,10) == 0) go to 140 KK = 0 DO 100 K = 1, N K1 = KK + 1 KK = KK + K AP(KK) = (1.0E0,0.0E0)/AP(KK) T = -AP(KK) call CSCAL(K-1,T,AP(K1),1) KP1 = K + 1 J1 = KK + 1 KJ = KK + K if (N < KP1) go to 90 DO 80 J = KP1, N T = AP(KJ) AP(KJ) = (0.0E0,0.0E0) call CAXPY(K,T,AP(K1),1,AP(J1),1) J1 = J1 + J KJ = KJ + J 80 CONTINUE 90 CONTINUE 100 CONTINUE ! ! FORM INVERSE(R) * CTRANS(INVERSE(R)) ! JJ = 0 DO 130 J = 1, N J1 = JJ + 1 JJ = JJ + J JM1 = J - 1 K1 = 1 KJ = J1 if (JM1 < 1) go to 120 DO 110 K = 1, JM1 T = CONJG(AP(KJ)) call CAXPY(K,T,AP(J1),1,AP(K1),1) K1 = K1 + K KJ = KJ + 1 110 CONTINUE 120 CONTINUE T = CONJG(AP(JJ)) call CSCAL(J,T,AP(J1),1) 130 CONTINUE 140 CONTINUE return end subroutine CPPFA (AP, N, INFO) ! !! CPPFA factors a complex Hermitian positive definite matrix in packed form. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1B !***TYPE COMPLEX (SPPFA-S, DPPFA-D, CPPFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPPFA factors a complex Hermitian positive definite matrix ! stored in packed form. ! ! CPPFA is usually called by CPPCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! (Time for CPPCO) = (1 + 18/N)*(Time for CPPFA) . ! ! On Entry ! ! AP COMPLEX (N*(N+1)/2) ! the packed form of a Hermitian matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! AP an upper triangular matrix R , stored in packed ! form, so that A = CTRANS(R)*R . ! ! INFO INTEGER ! = 0 for normal return. ! = K If the leading minor of order K is not ! positive definite. ! ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a Hermitian matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPPFA INTEGER N,INFO COMPLEX AP(*) ! COMPLEX CDOTC,T REAL S INTEGER J,JJ,JM1,K,KJ,KK !***FIRST EXECUTABLE STATEMENT CPPFA JJ = 0 DO 30 J = 1, N INFO = J S = 0.0E0 JM1 = J - 1 KJ = JJ KK = 0 if (JM1 < 1) go to 20 DO 10 K = 1, JM1 KJ = KJ + 1 T = AP(KJ) - CDOTC(K-1,AP(KK+1),1,AP(JJ+1),1) KK = KK + K T = T/AP(KK) AP(KJ) = T S = S + REAL(T*CONJG(T)) 10 CONTINUE 20 CONTINUE JJ = JJ + J S = REAL(AP(JJ)) - S if (S <= 0.0E0 .OR. AIMAG(AP(JJ)) /= 0.0E0) go to 40 AP(JJ) = CMPLX(SQRT(S),0.0E0) 30 CONTINUE INFO = 0 40 CONTINUE return end subroutine CPPSL (AP, N, B) ! !! CPPSL solves the complex Hermitian positive definite system using ... ! the factors computed by CPPCO or CPPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D1B !***TYPE COMPLEX (SPPSL-S, DPPSL-D, CPPSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, ! POSITIVE DEFINITE, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CPPSL solves the complex Hermitian positive definite system ! A * X = B ! using the factors computed by CPPCO or CPPFA. ! ! On Entry ! ! AP COMPLEX (N*(N+1)/2) ! the output from CPPCO or CPPFA. ! ! N INTEGER ! the order of the matrix A . ! ! B COMPLEX(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal. Technically this indicates ! singularity but it is usually caused by improper subroutine ! arguments. It will not occur if the subroutines are called ! correctly and INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call CPPCO(AP,N,RCOND,Z,INFO) ! if (RCOND is too small .OR. INFO /= 0) go to ... ! DO 10 J = 1, P ! call CPPSL(AP,N,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPPSL INTEGER N COMPLEX AP(*),B(*) ! COMPLEX CDOTC,T INTEGER K,KB,KK !***FIRST EXECUTABLE STATEMENT CPPSL KK = 0 DO 10 K = 1, N T = CDOTC(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 CAXPY(K-1,T,AP(KK+1),1,B(1),1) 20 CONTINUE return end subroutine CPQR79 (NDEG, COEFF, ROOT, IERR, WORK) ! !! CPQR79 finds the zeros of a polynomial with complex coefficients. ! !***LIBRARY SLATEC !***CATEGORY F1A1B !***TYPE COMPLEX (RPQR79-S, CPQR79-C) !***KEYWORDS COMPLEX POLYNOMIAL, POLYNOMIAL ROOTS, POLYNOMIAL ZEROS !***AUTHOR Vandevender, W. H., (SNLA) !***DESCRIPTION ! ! Abstract ! This routine computes all zeros of a polynomial of degree NDEG ! with complex coefficients by computing the eigenvalues of the ! companion matrix. ! ! Description of Parameters ! The user must dimension all arrays appearing in the call list ! COEFF(NDEG+1), ROOT(NDEG), WORK(2*NDEG*(NDEG+1)) ! ! --Input-- ! NDEG degree of polynomial ! ! COEFF COMPLEX coefficients in descending order. i.e., ! P(Z)= COEFF(1)*(Z**NDEG) + COEFF(NDEG)*Z + COEFF(NDEG+1) ! ! WORK REAL work array of dimension at least 2*NDEG*(NDEG+1) ! ! --Output-- ! ROOT COMPLEX vector of roots ! ! IERR Output Error Code ! - Normal Code ! 0 means the roots were computed. ! - Abnormal Codes ! 1 more than 30 QR iterations on some eigenvalue of the ! companion matrix ! 2 COEFF(1)=0.0 ! 3 NDEG is invalid (less than or equal to 0) ! !***REFERENCES (NONE) !***ROUTINES CALLED COMQR, XERMSG !***REVISION HISTORY (YYMMDD) ! 791201 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 911010 Code reworked and simplified. (RWC and WRB) !***END PROLOGUE CPQR79 COMPLEX COEFF(*), ROOT(*), SCALE, C REAL WORK(*) INTEGER NDEG, IERR, K, KHR, KHI, KWR, KWI, KAD, KJ !***FIRST EXECUTABLE STATEMENT CPQR79 IERR = 0 if (ABS(COEFF(1)) == 0.0) THEN IERR = 2 call XERMSG ('SLATEC', 'CPQR79', & 'LEADING COEFFICIENT IS ZERO.', 2, 1) return end if ! if (NDEG <= 0) THEN IERR = 3 call XERMSG ('SLATEC', 'CPQR79', 'DEGREE INVALID.', 3, 1) return end if ! if (NDEG == 1) THEN ROOT(1) = -COEFF(2)/COEFF(1) return end if ! SCALE = 1.0E0/COEFF(1) KHR = 1 KHI = KHR+NDEG*NDEG KWR = KHI+KHI-KHR KWI = KWR+NDEG ! DO 10 K=1,KWR WORK(K) = 0.0E0 10 CONTINUE ! DO 20 K=1,NDEG KAD = (K-1)*NDEG+1 C = SCALE*COEFF(K+1) WORK(KAD) = -REAL(C) KJ = KHI+KAD-1 WORK(KJ) = -AIMAG(C) if (K /= NDEG) WORK(KAD+K) = 1.0E0 20 CONTINUE ! call COMQR (NDEG,NDEG,1,NDEG,WORK(KHR),WORK(KHI),WORK(KWR), & WORK(KWI),IERR) ! if (IERR /= 0) THEN IERR = 1 call XERMSG ('SLATEC', 'CPQR79', & 'NO CONVERGENCE IN 30 QR ITERATIONS.', 1, 1) return end if ! DO 30 K=1,NDEG KM1 = K-1 ROOT(K) = CMPLX(WORK(KWR+KM1),WORK(KWI+KM1)) 30 CONTINUE return end subroutine CPROC (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, & B, C, D, W, YY) ! !! CPROC is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE COMPLEX (CPROD-S, CPROC-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! PROC applies a sequence of matrix operations to the vector X and ! stores the result in Y. ! AA Array containing scalar multipliers of the vector X. ! ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. ! BD,BM1,BM2 are arrays containing roots of certain B polynomials. ! NA is the length of the array AA. ! X,Y The matrix operations are applied to X and the result is Y. ! A,B,C are arrays which contain the tridiagonal matrix. ! M is the order of the matrix. ! D,W are work arrays. ! ISGN determines whether or not a change in sign is made. ! !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CPROC ! COMPLEX Y ,D ,W ,BD , & CRT ,DEN ,Y1 ,Y2 , & X ,A ,B ,C DIMENSION A(*) ,B(*) ,C(*) ,X(*) , & Y(*) ,D(*) ,W(*) ,BD(*) , & BM1(*) ,BM2(*) ,AA(*) ,YY(*) !***FIRST EXECUTABLE STATEMENT CPROC DO 101 J=1,M Y(J) = X(J) 101 CONTINUE MM = M-1 ID = ND M1 = NM1 M2 = NM2 IA = NA 102 IFLG = 0 if (ID) 109,109,103 103 CRT = BD(ID) ID = ID-1 ! ! BEGIN SOLUTION TO SYSTEM ! D(M) = A(M)/(B(M)-CRT) W(M) = Y(M)/(B(M)-CRT) DO 104 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 104 CONTINUE DEN = B(1)-CRT-C(1)*D(2) if (ABS(DEN)) 105,106,105 105 Y(1) = (Y(1)-C(1)*W(2))/DEN go to 107 106 Y(1) = (1.,0.) 107 DO 108 J=2,M Y(J) = W(J)-D(J)*Y(J-1) 108 CONTINUE 109 if (M1) 110,110,112 110 if (M2) 121,121,111 111 RT = BM2(M2) M2 = M2-1 go to 117 112 if (M2) 113,113,114 113 RT = BM1(M1) M1 = M1-1 go to 117 114 if (ABS(BM1(M1))-ABS(BM2(M2))) 116,116,115 115 RT = BM1(M1) M1 = M1-1 go to 117 116 RT = BM2(M2) M2 = M2-1 117 Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2) if (MM-2) 120,118,118 ! ! MATRIX MULTIPLICATION ! 118 DO 119 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 119 CONTINUE 120 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M) Y(M-1) = Y1 IFLG = 1 go to 102 121 if (IA) 124,124,122 122 RT = AA(IA) IA = IA-1 IFLG = 1 ! ! SCALAR MULTIPLICATION ! DO 123 J=1,M Y(J) = RT*Y(J) 123 CONTINUE 124 if (IFLG) 125,125,102 125 RETURN end subroutine CPROCP (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, & B, C, D, U, YY) ! !! CPROCP is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE COMPLEX (CPRODP-S, CPROCP-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! CPROCP applies a sequence of matrix operations to the vector X and ! stores the result in Y. ! ! BD,BM1,BM2 are arrays containing roots of certain B polynomials. ! ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. ! AA Array containing scalar multipliers of the vector X. ! NA is the length of the array AA. ! X,Y The matrix operations are applied to X and the result is Y. ! A,B,C are arrays which contain the tridiagonal matrix. ! M is the order of the matrix. ! D,U are work arrays. ! ISGN determines whether or not a change in sign is made. ! !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CPROCP ! COMPLEX Y ,D ,U ,V , & DEN ,BH ,YM ,AM , & Y1 ,Y2 ,YH ,BD , & CRT ,X ,A ,B ,C DIMENSION A(*) ,B(*) ,C(*) ,X(*) , & Y(*) ,D(*) ,U(*) ,BD(*) , & BM1(*) ,BM2(*) ,AA(*) ,YY(*) !***FIRST EXECUTABLE STATEMENT CPROCP DO 101 J=1,M Y(J) = X(J) 101 CONTINUE MM = M-1 MM2 = M-2 ID = ND M1 = NM1 M2 = NM2 IA = NA 102 IFLG = 0 if (ID) 111,111,103 103 CRT = BD(ID) ID = ID-1 IFLG = 1 ! ! BEGIN SOLUTION TO SYSTEM ! 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 = C(M) if (MM2-2) 106,104,104 104 DO 105 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) 105 CONTINUE 106 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 (ABS(DEN)) 107,108,107 107 Y(M) = (YM-AM*Y(M-1))/DEN go to 109 108 Y(M) = (1.,0.) 109 Y(M-1) = Y(M-1)-D(M-1)*Y(M) DO 110 J=2,MM K = M-J Y(K) = Y(K)-D(K)*Y(K+1)-U(K)*Y(M) 110 CONTINUE 111 if (M1) 112,112,114 112 if (M2) 123,123,113 113 RT = BM2(M2) M2 = M2-1 go to 119 114 if (M2) 115,115,116 115 RT = BM1(M1) M1 = M1-1 go to 119 116 if (ABS(BM1(M1))-ABS(BM2(M2))) 118,118,117 117 RT = BM1(M1) M1 = M1-1 go to 119 118 RT = BM2(M2) M2 = M2-1 ! ! MATRIX MULTIPLICATION ! 119 YH = Y(1) Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2)+A(1)*Y(M) if (MM-2) 122,120,120 120 DO 121 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 121 CONTINUE 122 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M)+C(M)*YH Y(M-1) = Y1 IFLG = 1 go to 102 123 if (IA) 126,126,124 124 RT = AA(IA) IA = IA-1 IFLG = 1 ! ! SCALAR MULTIPLICATION ! y(1:m) = rt * y(1:m) 126 if (IFLG) 127,127,102 127 RETURN end subroutine CPROD (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, YY, M, A, & B, C, D, W, Y) ! !! CPROD is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CPROD-S, CPROC-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! PROD applies a sequence of matrix operations to the vector X and ! stores the result in YY. (COMPLEX case) ! AA array containing scalar multipliers of the vector X. ! ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. ! BD,BM1,BM2 are arrays containing roots of certain B polynomials. ! NA is the length of the array AA. ! X,YY The matrix operations are applied to X and the result is YY. ! A,B,C are arrays which contain the tridiagonal matrix. ! M is the order of the matrix. ! D,W,Y are working arrays. ! ISGN determines whether or not a change in sign is made. ! !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CPROD ! COMPLEX Y ,D ,W ,BD , & CRT ,DEN ,Y1 ,Y2 DIMENSION A(*) ,B(*) ,C(*) ,X(*) , & Y(*) ,D(*) ,W(*) ,BD(*) , & BM1(*) ,BM2(*) ,AA(*) ,YY(*) !***FIRST EXECUTABLE STATEMENT CPROD DO 101 J=1,M Y(J) = CMPLX(X(J),0.) 101 CONTINUE MM = M-1 ID = ND M1 = NM1 M2 = NM2 IA = NA 102 IFLG = 0 if (ID) 109,109,103 103 CRT = BD(ID) ID = ID-1 ! ! BEGIN SOLUTION TO SYSTEM ! D(M) = A(M)/(B(M)-CRT) W(M) = Y(M)/(B(M)-CRT) DO 104 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 104 CONTINUE DEN = B(1)-CRT-C(1)*D(2) if (ABS(DEN)) 105,106,105 105 Y(1) = (Y(1)-C(1)*W(2))/DEN go to 107 106 Y(1) = (1.,0.) 107 DO 108 J=2,M Y(J) = W(J)-D(J)*Y(J-1) 108 CONTINUE 109 if (M1) 110,110,112 110 if (M2) 121,121,111 111 RT = BM2(M2) M2 = M2-1 go to 117 112 if (M2) 113,113,114 113 RT = BM1(M1) M1 = M1-1 go to 117 114 if (ABS(BM1(M1))-ABS(BM2(M2))) 116,116,115 115 RT = BM1(M1) M1 = M1-1 go to 117 116 RT = BM2(M2) M2 = M2-1 117 Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2) if (MM-2) 120,118,118 ! ! MATRIX MULTIPLICATION ! 118 DO 119 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 119 CONTINUE 120 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M) Y(M-1) = Y1 IFLG = 1 go to 102 121 if (IA) 124,124,122 122 RT = AA(IA) IA = IA-1 IFLG = 1 ! ! SCALAR MULTIPLICATION ! DO 123 J=1,M Y(J) = RT*Y(J) 123 CONTINUE 124 if (IFLG) 125,125,102 125 DO 126 J=1,M YY(J) = REAL(Y(J)) 126 CONTINUE return end subroutine CPRODP (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, YY, M, & A, B, C, D, U, Y) ! !! CPRODP is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CPRODP-S, CPROCP-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! PRODP applies a sequence of matrix operations to the vector X and ! stores the result in YY. (Periodic boundary conditions and COMPLEX ! case) ! ! BD,BM1,BM2 are arrays containing roots of certain B polynomials. ! ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. ! AA Array containing scalar multipliers of the vector X. ! NA is the length of the array AA. ! X,YY The matrix operations are applied to X and the result is YY. ! A,B,C are arrays which contain the tridiagonal matrix. ! M is the order of the matrix. ! D,U,Y are working arrays. ! ISGN determines whether or not a change in sign is made. ! !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CPRODP ! COMPLEX Y ,D ,U ,V , & DEN ,BH ,YM ,AM , & Y1 ,Y2 ,YH ,BD , & CRT DIMENSION A(*) ,B(*) ,C(*) ,X(*) , & Y(*) ,D(*) ,U(*) ,BD(*) , & BM1(*) ,BM2(*) ,AA(*) ,YY(*) !***FIRST EXECUTABLE STATEMENT CPRODP DO 101 J=1,M Y(J) = CMPLX(X(J),0.) 101 CONTINUE MM = M-1 MM2 = M-2 ID = ND M1 = NM1 M2 = NM2 IA = NA 102 IFLG = 0 if (ID) 111,111,103 103 CRT = BD(ID) ID = ID-1 IFLG = 1 ! ! BEGIN SOLUTION TO SYSTEM ! 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) 106,104,104 104 DO 105 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) 105 CONTINUE 106 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 (ABS(DEN)) 107,108,107 107 Y(M) = (YM-AM*Y(M-1))/DEN go to 109 108 Y(M) = (1.,0.) 109 Y(M-1) = Y(M-1)-D(M-1)*Y(M) DO 110 J=2,MM K = M-J Y(K) = Y(K)-D(K)*Y(K+1)-U(K)*Y(M) 110 CONTINUE 111 if (M1) 112,112,114 112 if (M2) 123,123,113 113 RT = BM2(M2) M2 = M2-1 go to 119 114 if (M2) 115,115,116 115 RT = BM1(M1) M1 = M1-1 go to 119 116 if (ABS(BM1(M1))-ABS(BM2(M2))) 118,118,117 117 RT = BM1(M1) M1 = M1-1 go to 119 118 RT = BM2(M2) M2 = M2-1 ! ! MATRIX MULTIPLICATION ! 119 YH = Y(1) Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2)+A(1)*Y(M) if (MM-2) 122,120,120 120 DO 121 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 121 CONTINUE 122 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M)+C(M)*YH Y(M-1) = Y1 IFLG = 1 go to 102 123 if (IA) 126,126,124 124 RT = AA(IA) IA = IA-1 IFLG = 1 ! ! SCALAR MULTIPLICATION ! DO 125 J=1,M Y(J) = RT*Y(J) 125 CONTINUE 126 if (IFLG) 127,127,102 127 DO 128 J=1,M YY(J) = REAL(Y(J)) 128 CONTINUE return end FUNCTION CPSI (ZIN) ! !! CPSI computes the Psi (or Digamma) function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7C !***TYPE COMPLEX (PSI-S, DPSI-D, CPSI-C) !***KEYWORDS DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! PSI(X) calculates the psi (or digamma) function of X. PSI(X) ! is the logarithmic derivative of the gamma function of X. ! !***REFERENCES (NONE) !***ROUTINES CALLED CCOT, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 780501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE CPSI COMPLEX CPSI COMPLEX ZIN, Z, Z2INV, CORR, CCOT DIMENSION BERN(13) LOGICAL FIRST EXTERNAL CCOT SAVE BERN, PI, NTERM, BOUND, DXREL, RMIN, RBIG, FIRST DATA BERN( 1) / .83333333333333333E-1 / DATA BERN( 2) / -.83333333333333333E-2 / DATA BERN( 3) / .39682539682539683E-2 / DATA BERN( 4) / -.41666666666666667E-2 / DATA BERN( 5) / .75757575757575758E-2 / DATA BERN( 6) / -.21092796092796093E-1 / DATA BERN( 7) / .83333333333333333E-1 / DATA BERN( 8) / -.44325980392156863E0 / DATA BERN( 9) / .30539543302701197E1 / DATA BERN(10) / -.26456212121212121E2 / DATA BERN(11) / .28146014492753623E3 / DATA BERN(12) / -.34548853937728938E4 / DATA BERN(13) / .54827583333333333E5 / DATA PI / 3.141592653589793E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT CPSI if (FIRST) THEN NTERM = -0.30*LOG(R1MACH(3)) ! MAYBE BOUND = N*(0.1*EPS)**(-1/(2*N-1)) / (PI*EXP(1)) BOUND = 0.1171*NTERM*(0.1*R1MACH(3))**(-1.0/(2*NTERM-1)) DXREL = SQRT(R1MACH(4)) RMIN = EXP (MAX (LOG(R1MACH(1)), -LOG(R1MACH(2))) + 0.011 ) RBIG = 1.0/R1MACH(3) end if FIRST = .FALSE. ! Z = ZIN X = REAL(Z) Y = AIMAG(Z) if (Y < 0.0) Z = CONJG(Z) ! CORR = (0.0, 0.0) CABSZ = ABS(Z) if (X >= 0.0 .AND. CABSZ > BOUND) go to 50 if (X < 0.0 .AND. ABS(Y) > BOUND) go to 50 ! if (CABSZ < BOUND) go to 20 ! ! USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND ! ABS(AIMAG(Y)) SMALL. ! CORR = -PI*CCOT(PI*Z) Z = 1.0 - Z go to 50 ! ! USE THE RECURSION RELATION FOR ABS(Z) SMALL. ! 20 if (CABSZ < RMIN) call XERMSG ('SLATEC', 'CPSI', & 'CPSI CALLED WITH Z SO NEAR 0 THAT CPSI OVERFLOWS', 2, 2) ! if (X >= (-0.5) .OR. ABS(Y) > DXREL) go to 30 if (ABS((Z-AINT(X-0.5))/X) < DXREL) call XERMSG ('SLATEC', & 'CPSI', & 'ANSWER LT HALF PRECISION BECAUSE Z TOO NEAR NEGATIVE INTEGER', & 1, 1) if (Y == 0.0 .AND. X == AINT(X)) call XERMSG ('SLATEC', & 'CPSI', 'Z IS A NEGATIVE INTEGER', 3, 2) ! 30 N = SQRT(BOUND**2-Y**2) - X + 1.0 DO 40 I=1,N CORR = CORR - 1.0/Z Z = Z + 1.0 40 CONTINUE ! ! NOW EVALUATE THE ASYMPTOTIC SERIES FOR SUITABLY LARGE Z. ! 50 if (CABSZ > RBIG) CPSI = LOG(Z) + CORR if (CABSZ > RBIG) go to 70 ! CPSI = (0.0, 0.0) Z2INV = 1.0/Z**2 DO 60 I=1,NTERM NDX = NTERM + 1 - I CPSI = BERN(NDX) + Z2INV*CPSI 60 CONTINUE CPSI = LOG(Z) - 0.5/Z - CPSI*Z2INV + CORR ! 70 if (Y < 0.0) CPSI = CONJG(CPSI) ! return end subroutine CPTSL (N, D, E, B) ! !! CPTSL solves a positive definite tridiagonal linear system. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2D2A !***TYPE COMPLEX (SPTSL-S, DPTSL-D, CPTSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE, ! TRIDIAGONAL !***AUTHOR Dongarra, J., (ANL) !***DESCRIPTION ! ! CPTSL given a positive definite tridiagonal matrix and a right ! hand side will find the solution. ! ! On Entry ! ! N INTEGER ! is the order of the tridiagonal matrix. ! ! D COMPLEX(N) ! is the diagonal of the tridiagonal matrix. ! On output D is destroyed. ! ! E COMPLEX(N) ! is the offdiagonal of the tridiagonal matrix. ! E(1) through E(N-1) should contain the ! offdiagonal. ! ! B COMPLEX(N) ! is the right hand side vector. ! ! On Return ! ! B contains the solution. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890505 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CPTSL INTEGER N COMPLEX D(*),E(*),B(*) ! INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2 COMPLEX T1,T2 ! ! CHECK FOR 1 X 1 CASE ! !***FIRST EXECUTABLE STATEMENT CPTSL if (N /= 1) go to 10 B(1) = B(1)/D(1) go to 70 10 CONTINUE NM1 = N - 1 NM1D2 = NM1/2 if (N == 2) go to 30 KBM1 = N - 1 ! ! ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF ! SUPERDIAGONAL ! DO 20 K = 1, NM1D2 T1 = CONJG(E(K))/D(K) D(K+1) = D(K+1) - T1*E(K) B(K+1) = B(K+1) - T1*B(K) T2 = E(KBM1)/D(KBM1+1) D(KBM1) = D(KBM1) - T2*CONJG(E(KBM1)) B(KBM1) = B(KBM1) - T2*B(KBM1+1) KBM1 = KBM1 - 1 20 CONTINUE 30 CONTINUE KP1 = NM1D2 + 1 ! ! CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER ! if (MOD(N,2) /= 0) go to 40 T1 = CONJG(E(KP1))/D(KP1) D(KP1+1) = D(KP1+1) - T1*E(KP1) B(KP1+1) = B(KP1+1) - T1*B(KP1) KP1 = KP1 + 1 40 CONTINUE ! ! BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP ! AND BOTTOM ! B(KP1) = B(KP1)/D(KP1) if (N == 2) go to 60 K = KP1 - 1 KE = KP1 + NM1D2 - 1 DO 50 KF = KP1, KE B(K) = (B(K) - E(K)*B(K+1))/D(K) B(KF+1) = (B(KF+1) - CONJG(E(KF))*B(KF))/D(KF+1) K = K - 1 50 CONTINUE 60 CONTINUE if (MOD(N,2) == 0) B(1) = (B(1) - E(1)*B(2))/D(1) 70 CONTINUE return end subroutine CPZERO (IN, A, R, T, IFLG, S) ! !! CPZERO finds the zeros of a polynomial with complex coefficients. ! !***LIBRARY SLATEC !***CATEGORY F1A1B !***TYPE COMPLEX (RPZERO-S, CPZERO-C) !***KEYWORDS POLYNOMIAL ROOTS, POLYNOMIAL ZEROS, REAL ROOTS !***AUTHOR Kahaner, D. K., (NBS) !***DESCRIPTION ! ! Find the zeros of the complex polynomial ! P(Z)= A(1)*Z**N + A(2)*Z**(N-1) +...+ A(N+1) ! ! Input... ! IN = degree of P(Z) ! A = complex vector containing coefficients of P(Z), ! A(I) = coefficient of Z**(N+1-i) ! R = N word complex vector containing initial estimates for zeros ! if these are known. ! T = 4(N+1) word array used for temporary storage ! IFLG = flag to indicate if initial estimates of ! zeros are input. ! If IFLG == 0, no estimates are input. ! If IFLG /= 0, the vector R contains estimates of ! the zeros ! ** WARNING ****** If estimates are input, they must ! be separated, that is, distinct or ! not repeated. ! S = an N word array ! ! Output... ! R(I) = Ith zero, ! S(I) = bound for R(I) . ! IFLG = error diagnostic ! Error Diagnostics... ! If IFLG == 0 on return, all is well ! If IFLG == 1 on return, A(1)=0.0 or N=0 on input ! If IFLG == 2 on return, the program failed to converge ! after 25*N iterations. Best current estimates of the ! zeros are in R(I). Error bounds are not calculated. ! !***REFERENCES (NONE) !***ROUTINES CALLED CPEVL !***REVISION HISTORY (YYMMDD) ! 810223 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CPZERO ! REAL S(*) COMPLEX R(*),T(*),A(*),PN,TEMP !***FIRST EXECUTABLE STATEMENT CPZERO if ( IN <= 0 .OR. ABS(A(1)) == 0.0 ) go to 30 ! ! CHECK FOR EASILY OBTAINED ZEROS ! N=IN N1=N+1 if ( IFLG /= 0) go to 14 1 N1=N+1 if ( N > 1) go to 2 R(1)=-A(2)/A(1) S(1)=0.0 return 2 if ( ABS(A(N1)) /= 0.0 ) go to 3 R(N)=0.0 S(N)=0.0 N=N-1 go to 1 ! ! if INITIAL ESTIMATES FOR ZEROS NOT GIVEN, FIND SOME ! 3 TEMP=-A(2)/(A(1)*N) call CPEVL(N,N,A,TEMP,T,T,.FALSE.) IMAX=N+2 T(N1)=ABS(T(N1)) DO 6 I=2,N1 T(N+I)=-ABS(T(N+2-I)) if ( REAL(T(N+I)) < REAL(T(IMAX))) IMAX=N+I 6 CONTINUE X=(-REAL(T(IMAX))/REAL(T(N1)))**(1./(IMAX-N1)) 7 X=2.*X call CPEVL(N,0,T(N1),CMPLX(X,0.0),PN,PN,.FALSE.) if (REAL(PN) < 0.) go to 7 U=.5*X V=X 10 X=.5*(U+V) call CPEVL(N,0,T(N1),CMPLX(X,0.0),PN,PN,.FALSE.) if (REAL(PN) > 0.) V=X if (REAL(PN) <= 0.) U=X if ( (V-U) > .001*(1.+V)) go to 10 DO 13 I=1,N U=(3.14159265/N)*(2*I-1.5) 13 R(I)=MAX(X,.001*ABS(TEMP))*CMPLX(COS(U),SIN(U))+TEMP ! ! MAIN ITERATION LOOP STARTS HERE ! 14 NR=0 NMAX=25*N DO 19 NIT=1,NMAX DO 18 I=1,N if ( NIT /= 1 .AND. ABS(T(I)) == 0.) go to 18 call CPEVL(N,0,A,R(I),PN,TEMP,.TRUE.) if ( ABS(REAL(PN))+ABS(AIMAG(PN)) > REAL(TEMP)+ & AIMAG(TEMP)) go to 16 T(I)=0.0 NR=NR+1 go to 18 16 TEMP=A(1) DO 17 J=1,N 17 if ( J /= I) TEMP=TEMP*(R(I)-R(J)) T(I)=PN/TEMP 18 CONTINUE DO 15 I=1,N 15 R(I)=R(I)-T(I) if ( NR == N) go to 21 19 CONTINUE go to 26 ! ! CALCULATE ERROR BOUNDS FOR ZEROS ! 21 DO 25 NR=1,N call CPEVL(N,N,A,R(NR),T,T(N+2),.TRUE.) X=ABS(CMPLX(ABS(REAL(T(1))),ABS(AIMAG(T(1))))+T(N+2)) S(NR)=0.0 DO 23 I=1,N X=X*REAL(N1-I)/I TEMP=CMPLX(MAX(ABS(REAL(T(I+1)))-REAL(T(N1+I)),0.0), & MAX(ABS(AIMAG(T(I+1)))-AIMAG(T(N1+I)),0.0)) 23 S(NR)=MAX(S(NR),(ABS(TEMP)/X)**(1./I)) 25 S(NR)=1./S(NR) return ! ERROR EXITS 26 IFLG=2 return 30 IFLG=1 return end subroutine CQRDC (X, LDX, N, P, QRAUX, JPVT, WORK, JOB) ! !! CQRDC uses Householder transformations to compute the QR factorization ... ! of an N by P matrix. Column pivoting is an option. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D5 !***TYPE COMPLEX (SQRDC-S, DQRDC-D, CQRDC-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, ! QR DECOMPOSITION !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! CQRDC uses Householder transformations to compute the QR ! factorization of an N by P matrix X. Column pivoting ! based on the 2-norms of the reduced columns may be ! performed at the users option. ! ! On Entry ! ! X COMPLEX(LDX,P), where LDX >= N. ! X contains the matrix whose decomposition is to be ! computed. ! ! LDX INTEGER. ! LDX is the leading dimension of the array X. ! ! N INTEGER. ! N is the number of rows of the matrix X. ! ! P INTEGER. ! P is the number of columns of the matrix X. ! ! JVPT INTEGER(P). ! JVPT contains integers that control the selection ! of the pivot columns. The K-th column X(K) of X ! is placed in one of three classes according to the ! value of JVPT(K). ! ! If JVPT(K) > 0, then X(K) is an initial ! column. ! ! If JVPT(K) == 0, then X(K) is a free column. ! ! If JVPT(K) < 0, then X(K) is a final column. ! ! Before the decomposition is computed, initial columns ! are moved to the beginning of the array X and final ! columns to the end. Both initial and final columns ! are frozen in place during the computation and only ! free columns are moved. At the K-th stage of the ! reduction, if X(K) is occupied by a free column ! it is interchanged with the free column of largest ! reduced norm. JVPT is not referenced if ! JOB == 0. ! ! WORK COMPLEX(P). ! WORK is a work array. WORK is not referenced if ! JOB == 0. ! ! JOB INTEGER. ! JOB is an integer that initiates column pivoting. ! If JOB == 0, no pivoting is done. ! If JOB /= 0, pivoting is done. ! ! On Return ! ! X X contains in its upper triangle the upper ! triangular matrix R of the QR factorization. ! Below its diagonal X contains information from ! which the unitary part of the decomposition ! can be recovered. Note that if pivoting has ! been requested, the decomposition is not that ! of the original matrix X but that of X ! with its columns permuted as described by JVPT. ! ! QRAUX COMPLEX(P). ! QRAUX contains further information required to recover ! the unitary part of the decomposition. ! ! JVPT JVPT(K) contains the index of the column of the ! original matrix that has been interchanged into ! the K-th column, if pivoting was requested. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC, CSCAL, CSWAP, SCNRM2 !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CQRDC INTEGER LDX,N,P,JOB INTEGER JPVT(*) COMPLEX X(LDX,*),QRAUX(*),WORK(*) ! INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU REAL MAXNRM,SCNRM2,TT COMPLEX CDOTC,NRMXL,T LOGICAL NEGJ,SWAPJ COMPLEX CSIGN,ZDUM,ZDUM1,ZDUM2 REAL CABS1 CSIGN(ZDUM1,ZDUM2) = ABS(ZDUM1)*(ZDUM2/ABS(ZDUM2)) CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) ! !***FIRST EXECUTABLE STATEMENT CQRDC PL = 1 PU = 0 if (JOB == 0) go to 60 ! ! PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS ! ACCORDING TO JPVT. ! DO 20 J = 1, P SWAPJ = JPVT(J) > 0 NEGJ = JPVT(J) < 0 JPVT(J) = J if (NEGJ) JPVT(J) = -J if (.NOT.SWAPJ) go to 10 if (J /= PL) call CSWAP(N,X(1,PL),1,X(1,J),1) JPVT(J) = JPVT(PL) JPVT(PL) = J PL = PL + 1 10 CONTINUE 20 CONTINUE PU = P DO 50 JJ = 1, P J = P - JJ + 1 if (JPVT(J) >= 0) go to 40 JPVT(J) = -JPVT(J) if (J == PU) go to 30 call CSWAP(N,X(1,PU),1,X(1,J),1) JP = JPVT(PU) JPVT(PU) = JPVT(J) JPVT(J) = JP 30 CONTINUE PU = PU - 1 40 CONTINUE 50 CONTINUE 60 CONTINUE ! ! COMPUTE THE NORMS OF THE FREE COLUMNS. ! if (PU < PL) go to 80 DO 70 J = PL, PU QRAUX(J) = CMPLX(SCNRM2(N,X(1,J),1),0.0E0) WORK(J) = QRAUX(J) 70 CONTINUE 80 CONTINUE ! ! PERFORM THE HOUSEHOLDER REDUCTION OF X. ! LUP = MIN(N,P) DO 200 L = 1, LUP if (L < PL .OR. L >= PU) go to 120 ! ! LOCATE THE COLUMN OF LARGEST NORM AND BRING IT ! INTO THE PIVOT POSITION. ! MAXNRM = 0.0E0 MAXJ = L DO 100 J = L, PU if (REAL(QRAUX(J)) <= MAXNRM) go to 90 MAXNRM = REAL(QRAUX(J)) MAXJ = J 90 CONTINUE 100 CONTINUE if (MAXJ == L) go to 110 call CSWAP(N,X(1,L),1,X(1,MAXJ),1) QRAUX(MAXJ) = QRAUX(L) WORK(MAXJ) = WORK(L) JP = JPVT(MAXJ) JPVT(MAXJ) = JPVT(L) JPVT(L) = JP 110 CONTINUE 120 CONTINUE QRAUX(L) = (0.0E0,0.0E0) if (L == N) go to 190 ! ! COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. ! NRMXL = CMPLX(SCNRM2(N-L+1,X(L,L),1),0.0E0) if (CABS1(NRMXL) == 0.0E0) go to 180 if (CABS1(X(L,L)) /= 0.0E0) & NRMXL = CSIGN(NRMXL,X(L,L)) call CSCAL(N-L+1,(1.0E0,0.0E0)/NRMXL,X(L,L),1) X(L,L) = (1.0E0,0.0E0) + X(L,L) ! ! APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, ! UPDATING THE NORMS. ! LP1 = L + 1 if (P < LP1) go to 170 DO 160 J = LP1, P 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) if (J < PL .OR. J > PU) go to 150 if (CABS1(QRAUX(J)) == 0.0E0) go to 150 TT = 1.0E0 - (ABS(X(L,J))/REAL(QRAUX(J)))**2 TT = MAX(TT,0.0E0) T = CMPLX(TT,0.0E0) TT = 1.0E0 & + 0.05E0*TT*(REAL(QRAUX(J))/REAL(WORK(J)))**2 if (TT == 1.0E0) go to 130 QRAUX(J) = QRAUX(J)*SQRT(T) go to 140 130 CONTINUE QRAUX(J) = CMPLX(SCNRM2(N-L,X(L+1,J),1),0.0E0) WORK(J) = QRAUX(J) 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE ! ! SAVE THE TRANSFORMATION. ! QRAUX(L) = X(L,L) X(L,L) = -NRMXL 180 CONTINUE 190 CONTINUE 200 CONTINUE return end subroutine CQRSL (X, LDX, N, K, QRAUX, Y, QY, QTY, B, RSD, XB, & JOB, INFO) ! !! CQRSL applies the output of CQRDC to compute coordinate transformations, ... ! projections, and least squares solutions. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D9, D2C1 !***TYPE COMPLEX (SQRSL-S, DQRSL-D, CQRSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, ! SOLVE !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! CQRSL applies the output of CQRDC to compute coordinate ! transformations, projections, and least squares solutions. ! For K <= MIN(N,P), let XK be the matrix ! ! XK = (X(JVPT(1)),X(JVPT(2)), ... ,X(JVPT(K))) ! ! formed from columns JVPT(1), ... ,JVPT(K) of the original ! N x P matrix X that was input to CQRDC (if no pivoting was ! done, XK consists of the first K columns of X in their ! original order). CQRDC produces a factored unitary matrix Q ! and an upper triangular matrix R such that ! ! XK = Q * (R) ! (0) ! ! This information is contained in coded form in the arrays ! X and QRAUX. ! ! On Entry ! ! X COMPLEX(LDX,P). ! X contains the output of CQRDC. ! ! LDX INTEGER. ! LDX is the leading dimension of the array X. ! ! N INTEGER. ! N is the number of rows of the matrix XK. It must ! have the same value as N in CQRDC. ! ! K INTEGER. ! K is the number of columns of the matrix XK. K ! must not be greater than (N,P), where P is the ! same as in the calling sequence to CQRDC. ! ! QRAUX COMPLEX(P). ! QRAUX contains the auxiliary output from CQRDC. ! ! Y COMPLEX(N) ! Y contains an N-vector that is to be manipulated ! by CQRSL. ! ! JOB INTEGER. ! JOB specifies what is to be computed. JOB has ! the decimal expansion ABCDE, with the following ! meaning. ! ! If A /= 0, compute QY. ! If B,C,D, or E /= 0, compute QTY. ! If C /= 0, compute B. ! If D /= 0, compute RSD . ! If E /= 0, compute XB. ! ! Note that a request to compute B, RSD, or XB ! automatically triggers the computation of QTY, for ! which an array must be provided in the calling ! sequence. ! ! On Return ! ! QY COMPLEX(N). ! QY contains Q*Y, if its computation has been ! requested. ! ! QTY COMPLEX(N). ! QTY contains CTRANS(Q)*Y, if its computation has ! been requested. Here CTRANS(Q) is the conjugate ! transpose of the matrix Q. ! ! B COMPLEX(K) ! B contains the solution of the least squares problem ! ! minimize NORM2(Y - XK*B), ! ! if its computation has been requested. (Note that ! if pivoting was requested in CQRDC, the J-th ! component of B will be associated with column JVPT(J) ! of the original matrix X that was input into CQRDC.) ! ! RSD COMPLEX(N). ! RSD contains the least squares residual Y - XK*B, ! if its computation has been requested. RSD is ! also the orthogonal projection of Y onto the ! orthogonal complement of the column space of XK. ! ! XB COMPLEX(N). ! XB contains the least squares approximation XK*B, ! if its computation has been requested. XB is also ! the orthogonal projection of Y onto the column space ! of X. ! ! INFO INTEGER. ! INFO is zero unless the computation of B has ! been requested and R is exactly singular. In ! this case, INFO is the index of the first zero ! diagonal element of R and B is left unaltered. ! ! The parameters QY, QTY, B, RSD, and XB are not referenced ! if their computation is not requested and in this case ! can be replaced by dummy variables in the calling program. ! To save storage, the user may in some cases use the same ! array for different parameters in the calling sequence. A ! frequently occurring example is when one wishes to compute ! any of B, RSD, or XB and does not need Y or QTY. In this ! case one may identify Y, QTY, and one of B, RSD, or XB, while ! providing separate arrays for anything else that is to be ! computed. Thus the calling sequence ! ! call CQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) ! ! will result in the computation of B and RSD, with RSD ! overwriting Y. More generally, each item in the following ! list contains groups of permissible identifications for ! a single calling sequence. ! ! 1. (Y,QTY,B) (RSD) (XB) (QY) ! ! 2. (Y,QTY,RSD) (B) (XB) (QY) ! ! 3. (Y,QTY,XB) (B) (RSD) (QY) ! ! 4. (Y,QY) (QTY,B) (RSD) (XB) ! ! 5. (Y,QY) (QTY,RSD) (B) (XB) ! ! 6. (Y,QY) (QTY,XB) (B) (RSD) ! ! In any group the value returned in the array allocated to ! the group corresponds to the last member of the group. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CCOPY, CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CQRSL INTEGER LDX,N,K,JOB,INFO COMPLEX X(LDX,*),QRAUX(*),Y(*),QY(*),QTY(*),B(*),RSD(*),XB(*) ! INTEGER I,J,JJ,JU,KP1 COMPLEX CDOTC,T,TEMP LOGICAL CB,CQY,CQTY,CR,CXB COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT CQRSL ! ! SET INFO FLAG. ! INFO = 0 ! ! DETERMINE WHAT IS TO BE COMPUTED. ! CQY = JOB/10000 /= 0 CQTY = MOD(JOB,10000) /= 0 CB = MOD(JOB,1000)/100 /= 0 CR = MOD(JOB,100)/10 /= 0 CXB = MOD(JOB,10) /= 0 JU = MIN(K,N-1) ! ! SPECIAL ACTION WHEN N=1. ! if (JU /= 0) go to 40 if (CQY) QY(1) = Y(1) if (CQTY) QTY(1) = Y(1) if (CXB) XB(1) = Y(1) if (.NOT.CB) go to 30 if (CABS1(X(1,1)) /= 0.0E0) go to 10 INFO = 1 go to 20 10 CONTINUE B(1) = Y(1)/X(1,1) 20 CONTINUE 30 CONTINUE if (CR) RSD(1) = (0.0E0,0.0E0) go to 250 40 CONTINUE ! ! SET UP TO COMPUTE QY OR QTY. ! if (CQY) call CCOPY(N,Y,1,QY,1) if (CQTY) call CCOPY(N,Y,1,QTY,1) if (.NOT.CQY) go to 70 ! ! COMPUTE QY. ! DO 60 JJ = 1, JU J = JU - JJ + 1 if (CABS1(QRAUX(J)) == 0.0E0) go to 50 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -CDOTC(N-J+1,X(J,J),1,QY(J),1)/X(J,J) call CAXPY(N-J+1,T,X(J,J),1,QY(J),1) X(J,J) = TEMP 50 CONTINUE 60 CONTINUE 70 CONTINUE if (.NOT.CQTY) go to 100 ! ! COMPUTE CTRANS(Q)*Y. ! DO 90 J = 1, JU if (CABS1(QRAUX(J)) == 0.0E0) go to 80 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -CDOTC(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) call CAXPY(N-J+1,T,X(J,J),1,QTY(J),1) X(J,J) = TEMP 80 CONTINUE 90 CONTINUE 100 CONTINUE ! ! SET UP TO COMPUTE B, RSD, OR XB. ! if (CB) call CCOPY(K,QTY,1,B,1) KP1 = K + 1 if (CXB) call CCOPY(K,QTY,1,XB,1) if (CR .AND. K < N) call CCOPY(N-K,QTY(KP1),1,RSD(KP1),1) if (.NOT.CXB .OR. KP1 > N) go to 120 DO 110 I = KP1, N XB(I) = (0.0E0,0.0E0) 110 CONTINUE 120 CONTINUE if (.NOT.CR) go to 140 DO 130 I = 1, K RSD(I) = (0.0E0,0.0E0) 130 CONTINUE 140 CONTINUE if (.NOT.CB) go to 190 ! ! COMPUTE B. ! DO 170 JJ = 1, K J = K - JJ + 1 if (CABS1(X(J,J)) /= 0.0E0) go to 150 INFO = J go to 180 150 CONTINUE B(J) = B(J)/X(J,J) if (J == 1) go to 160 T = -B(J) call CAXPY(J-1,T,X(1,J),1,B,1) 160 CONTINUE 170 CONTINUE 180 CONTINUE 190 CONTINUE if (.NOT.CR .AND. .NOT.CXB) go to 240 ! ! COMPUTE RSD OR XB AS REQUIRED. ! DO 230 JJ = 1, JU J = JU - JJ + 1 if (CABS1(QRAUX(J)) == 0.0E0) go to 220 TEMP = X(J,J) X(J,J) = QRAUX(J) if (.NOT.CR) go to 200 T = -CDOTC(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) call CAXPY(N-J+1,T,X(J,J),1,RSD(J),1) 200 CONTINUE if (.NOT.CXB) go to 210 T = -CDOTC(N-J+1,X(J,J),1,XB(J),1)/X(J,J) call CAXPY(N-J+1,T,X(J,J),1,XB(J),1) 210 CONTINUE X(J,J) = TEMP 220 CONTINUE 230 CONTINUE 240 CONTINUE 250 CONTINUE return end subroutine CRATI (Z, FNU, N, CY, TOL) ! !! CRATI is subsidiary to CBESH, CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CRATI-A, ZRATI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD ! RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD ! RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, ! MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, ! BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, ! BY D. J. SOOKNE. ! !***SEE ALSO CBESH, CBESI, CBESK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CRATI COMPLEX CDFNU, CONE, CY, CZERO, PT, P1, P2, RZ, T1, Z REAL AK, AMAGZ, AP1, AP2, ARG, AZ, DFNU, FDNU, FLAM, FNU, FNUP, & RAP1, RHO, TEST, TEST1, TOL INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N DIMENSION CY(N) DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CRATI AZ = ABS(Z) INU = FNU IDNU = INU + N - 1 FDNU = IDNU MAGZ = AZ AMAGZ = MAGZ+1 FNUP = MAX(AMAGZ,FDNU) ID = IDNU - MAGZ - 1 ITIME = 1 K = 1 RZ = (CONE+CONE)/Z T1 = CMPLX(FNUP,0.0E0)*RZ P2 = -T1 P1 = CONE T1 = T1 + RZ if (ID > 0) ID = 0 AP2 = ABS(P2) AP1 = ABS(P1) !----------------------------------------------------------------------- ! THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE call TO CBKNX ! GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT ! P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR ! PREMATURELY. !----------------------------------------------------------------------- ARG = (AP2+AP2)/(AP1*TOL) TEST1 = SQRT(ARG) TEST = TEST1 RAP1 = 1.0E0/AP1 P1 = P1*CMPLX(RAP1,0.0E0) P2 = P2*CMPLX(RAP1,0.0E0) AP2 = AP2*RAP1 10 CONTINUE K = K + 1 AP1 = AP2 PT = P2 P2 = P1 - T1*P2 P1 = PT T1 = T1 + RZ AP2 = ABS(P2) if (AP1 <= TEST) go to 10 if (ITIME == 2) go to 20 AK = ABS(T1)*0.5E0 FLAM = AK + SQRT(AK*AK-1.0E0) RHO = MIN(AP2/AP1,FLAM) TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0E0)) ITIME = 2 go to 10 20 CONTINUE KK = K + 1 - ID AK = KK DFNU = FNU + (N-1) CDFNU = CMPLX(DFNU,0.0E0) T1 = CMPLX(AK,0.0E0) P1 = CMPLX(1.0E0/AP2,0.0E0) P2 = CZERO DO 30 I=1,KK PT = P1 P1 = RZ*(CDFNU+T1)*P1 + P2 P2 = PT T1 = T1 - CONE 30 CONTINUE if (REAL(P1) /= 0.0E0 .OR. AIMAG(P1) /= 0.0E0) go to 40 P1 = CMPLX(TOL,TOL) 40 CONTINUE CY(N) = P2/P1 if (N == 1) RETURN K = N - 1 AK = K T1 = CMPLX(AK,0.0E0) CDFNU = CMPLX(FNU,0.0E0)*RZ DO 60 I=2,N PT = CDFNU + T1*RZ + CY(K+1) if (REAL(PT) /= 0.0E0 .OR. AIMAG(PT) /= 0.0E0) go to 50 PT = CMPLX(TOL,TOL) 50 CONTINUE CY(K) = CONE/PT T1 = T1 - CONE K = K - 1 60 CONTINUE return end subroutine CROTG (CA, CB, C, S) ! !! CROTG constructs a Givens transformation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B10 !***TYPE COMPLEX (SROTG-S, DROTG-D, CROTG-C) !***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, ! LINEAR ALGEBRA, VECTOR !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Complex Givens transformation ! ! Construct the Givens transformation ! ! (C S) ! G = ( ), C**2 + ABS(S)**2 =1, ! (-S C) ! ! which zeros the second entry of the complex 2-vector (CA,CB)**T ! ! The quantity CA/ABS(CA)*NORM(CA,CB) overwrites CA in storage. ! ! Input: ! CA (Complex) ! CB (Complex) ! ! Output: ! CA (Complex) CA/ABS(CA)*NORM(CA,CB) ! C (Real) ! S (Complex) ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CROTG COMPLEX CA, CB, S REAL C REAL NORM, SCALE COMPLEX ALPHA !***FIRST EXECUTABLE STATEMENT CROTG if (ABS(CA) == 0.0) THEN C = 0.0 S = (1.0,0.0) CA = CB ELSE SCALE = ABS(CA) + ABS(CB) NORM = SCALE * SQRT((ABS(CA/SCALE))**2 + (ABS(CB/SCALE))**2) ALPHA = CA /ABS(CA) C = ABS(CA) / NORM S = ALPHA * CONJG(CB) / NORM CA = ALPHA * NORM end if return end subroutine CS1S2 (ZR, S1, S2, NZ, ASCLE, ALIM, IUF) ! !! CS1S2 is subsidiary to CAIRY and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CS1S2-A, ZS1S2-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE ! ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- ! TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. ! ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF ! MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER ! OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE ! PRECISION ABOVE THE UNDERFLOW LIMIT. ! !***SEE ALSO CAIRY, CBESK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CS1S2 COMPLEX CZERO, C1, S1, S1D, S2, ZR REAL AA, ALIM, ALN, ASCLE, AS1, AS2, XX INTEGER IUF, NZ DATA CZERO / (0.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CS1S2 NZ = 0 AS1 = ABS(S1) AS2 = ABS(S2) AA = REAL(S1) ALN = AIMAG(S1) if (AA == 0.0E0 .AND. ALN == 0.0E0) go to 10 if (AS1 == 0.0E0) go to 10 XX = REAL(ZR) ALN = -XX - XX + ALOG(AS1) S1D = S1 S1 = CZERO AS1 = 0.0E0 if (ALN < (-ALIM)) go to 10 C1 = CLOG(S1D) - ZR - ZR S1 = CEXP(C1) AS1 = ABS(S1) IUF = IUF + 1 10 CONTINUE AA = MAX(AS1,AS2) if (AA > ASCLE) RETURN S1 = CZERO S2 = CZERO NZ = 1 IUF = 0 return end subroutine CSCALE (A, NRDA, NROW, NCOL, COLS, COLSAV, ROWS, & ROWSAV, ANORM, SCALES, ISCALE, IC) ! !! CSCALE is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CSCALE-S, DCSCAL-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This routine scales the matrix A by columns when needed ! !***SEE ALSO BVSUP !***ROUTINES CALLED SDOT !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE CSCALE DIMENSION A(NRDA,*),COLS(*),COLSAV(*),SCALES(*), & ROWS(*),ROWSAV(*) ! SAVE TEN4, TEN20 DATA TEN4,TEN20/1.E+4,1.E+20/ ! !***FIRST EXECUTABLE STATEMENT CSCALE if (ISCALE /= (-1)) go to 25 ! if (IC == 0) go to 10 DO 5 K=1,NCOL 5 COLS(K)=SDOT(NROW,A(1,K),1,A(1,K),1) ! 10 ASCALE=ANORM/NCOL DO 20 K=1,NCOL CS=COLS(K) if ((CS > TEN4*ASCALE) .OR. (TEN4*CS < ASCALE)) go to 50 if ((CS < 1./TEN20) .OR. (CS > TEN20)) go to 50 20 CONTINUE ! 25 DO 30 K=1,NCOL 30 SCALES(K)=1. return ! 50 ALOG2=LOG(2.) ANORM=0. DO 100 K=1,NCOL CS=COLS(K) if (CS /= 0.) go to 60 SCALES(K)=1. go to 100 60 P=LOG(CS)/ALOG2 IP=-0.5*P S=2.**IP SCALES(K)=S if (IC == 1) go to 70 COLS(K)=S*S*COLS(K) ANORM=ANORM+COLS(K) COLSAV(K)=COLS(K) 70 DO 80 J=1,NROW 80 A(J,K)=S*A(J,K) 100 CONTINUE ! if (IC == 0) RETURN ! DO 200 K=1,NROW ROWS(K)=SDOT(NCOL,A(K,1),NRDA,A(K,1),NRDA) ROWSAV(K)=ROWS(K) 200 ANORM=ANORM+ROWS(K) return end subroutine CSCAL (N, CA, CX, INCX) ! !! CSCAL multiplies a vector by a constant. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A6 !***TYPE COMPLEX (SSCAL-S, DSCAL-D, CSCAL-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! CA complex scale factor ! CX complex vector with N elements ! INCX storage spacing between elements of CX ! ! --Output-- ! CX complex result (unchanged if N <= 0) ! ! Replace complex CX by complex CA*CX. ! For I = 0 to N-1, replace CX(IX+I*INCX) with CA*CX(IX+I*INCX), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900821 Modified to correct problem with a negative increment. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSCAL COMPLEX CA, CX(*) INTEGER I, INCX, IX, N !***FIRST EXECUTABLE STATEMENT CSCAL if (N <= 0) RETURN ! if (INCX == 1) GOTO 20 ! ! Code for increment not equal to 1. ! IX = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N CX(IX) = CA*CX(IX) IX = IX + INCX 10 CONTINUE return ! ! Code for increment equal to 1. ! 20 continue CX(1:n) = CA * CX(1:n) return end subroutine CSERI (Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM) ! !! CSERI is subsidiary to CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CSERI-A, ZSERI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z) >= 0.0 BY ! MEANS OF THE POWER SERIES FOR LARGE ABS(Z) IN THE ! REGION ABS(Z) <= 2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. ! NZ > 0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO ! DUE TO UNDERFLOW. NZ < 0 MEANS UNDERFLOW OCCURRED, BUT THE ! CONDITION ABS(Z) <= 2*SQRT(FNU+1) WAS VIOLATED AND THE ! COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). ! !***SEE ALSO CBESI, CBESK !***ROUTINES CALLED CUCHK, GAMLN, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CSERI COMPLEX AK1, CK, COEF, CONE, CRSC, CZ, CZERO, HZ, RZ, S1, S2, W, & Y, Z REAL AA, ACZ, AK, ALIM, ARM, ASCLE, ATOL, AZ, DFNU, ELIM, FNU, & FNUP, RAK1, RS, RTR1, S, SS, TOL, X, GAMLN, R1MACH INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NW, NZ DIMENSION Y(N), W(2) DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CSERI NZ = 0 AZ = ABS(Z) if (AZ == 0.0E0) go to 150 X = REAL(Z) ARM = 1.0E+3*R1MACH(1) RTR1 = SQRT(ARM) CRSC = CMPLX(1.0E0,0.0E0) IFLAG = 0 if (AZ < ARM) go to 140 HZ = Z*CMPLX(0.5E0,0.0E0) CZ = CZERO if (AZ > RTR1) CZ = HZ*HZ ACZ = ABS(CZ) NN = N CK = CLOG(HZ) 10 CONTINUE DFNU = FNU + (NN-1) FNUP = DFNU + 1.0E0 !----------------------------------------------------------------------- ! UNDERFLOW TEST !----------------------------------------------------------------------- AK1 = CK*CMPLX(DFNU,0.0E0) AK = GAMLN(FNUP,IDUM) AK1 = AK1 - CMPLX(AK,0.0E0) if (KODE == 2) AK1 = AK1 - CMPLX(X,0.0E0) RAK1 = REAL(AK1) if (RAK1 > (-ELIM)) go to 30 20 CONTINUE NZ = NZ + 1 Y(NN) = CZERO if (ACZ > DFNU) go to 170 NN = NN - 1 if (NN == 0) RETURN go to 10 30 CONTINUE if (RAK1 > (-ALIM)) go to 40 IFLAG = 1 SS = 1.0E0/TOL CRSC = CMPLX(TOL,0.0E0) ASCLE = ARM*SS 40 CONTINUE AK = AIMAG(AK1) AA = EXP(RAK1) if (IFLAG == 1) AA = AA*SS COEF = CMPLX(AA,0.0E0)*CMPLX(COS(AK),SIN(AK)) ATOL = TOL*ACZ/FNUP IL = MIN(2,NN) DO 80 I=1,IL DFNU = FNU + (NN-I) FNUP = DFNU + 1.0E0 S1 = CONE if (ACZ < TOL*FNUP) go to 60 AK1 = CONE AK = FNUP + 2.0E0 S = FNUP AA = 2.0E0 50 CONTINUE RS = 1.0E0/S AK1 = AK1*CZ*CMPLX(RS,0.0E0) S1 = S1 + AK1 S = S + AK AK = AK + 2.0E0 AA = AA*ACZ*RS if (AA > ATOL) go to 50 60 CONTINUE M = NN - I + 1 S2 = S1*COEF W(I) = S2 if (IFLAG == 0) go to 70 call CUCHK(S2, NW, ASCLE, TOL) if (NW /= 0) go to 20 70 CONTINUE Y(M) = S2*CRSC if (I /= IL) COEF = COEF*CMPLX(DFNU,0.0E0)/HZ 80 CONTINUE if (NN <= 2) RETURN K = NN - 2 AK = K RZ = (CONE+CONE)/Z if (IFLAG == 1) go to 110 IB = 3 90 CONTINUE DO 100 I=IB,NN Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2) AK = AK - 1.0E0 K = K - 1 100 CONTINUE return !----------------------------------------------------------------------- ! RECUR BACKWARD WITH SCALED VALUES !----------------------------------------------------------------------- 110 CONTINUE !----------------------------------------------------------------------- ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE ! UNDERFLOW LIMIT = ASCLE = R1MACH(1)*CSCL*1.0E+3 !----------------------------------------------------------------------- S1 = W(1) S2 = W(2) DO 120 L=3,NN CK = S2 S2 = S1 + CMPLX(AK+FNU,0.0E0)*RZ*S2 S1 = CK CK = S2*CRSC Y(K) = CK AK = AK - 1.0E0 K = K - 1 if (ABS(CK) > ASCLE) go to 130 120 CONTINUE return 130 CONTINUE IB = L + 1 if (IB > NN) RETURN go to 90 140 CONTINUE NZ = N if (FNU == 0.0E0) NZ = NZ - 1 150 CONTINUE Y(1) = CZERO if (FNU == 0.0E0) Y(1) = CONE if (N == 1) RETURN DO 160 I=2,N Y(I) = CZERO 160 CONTINUE return !----------------------------------------------------------------------- ! return WITH NZ < 0 if ABS(Z*Z/4) > FNU+N-NZ-1 COMPLETE ! THE CALCULATION IN CBINU WITH N=N-ABS(NZ) !----------------------------------------------------------------------- 170 CONTINUE NZ = -NZ return end function CSEVL (X, CS, N) ! !! CSEVL evaluates a Chebyshev series. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C3A2 !***TYPE SINGLE PRECISION (CSEVL-S, DCSEVL-D) !***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate the N-term Chebyshev series CS at X. Adapted from ! a method presented in the paper by Broucke referenced below. ! ! Input Arguments -- ! X value at which the series is to be evaluated. ! CS array of N terms of a Chebyshev series. In evaluating ! CS, only half the first coefficient is summed. ! N number of terms in array CS. ! !***REFERENCES R. Broucke, Ten subroutines for the manipulation of ! Chebyshev series, Algorithm 446, Communications of ! the A.C.M. 16, (1973) pp. 254-256. ! L. Fox and I. B. Parker, Chebyshev Polynomials in ! Numerical Analysis, Oxford University Press, 1968, ! page 56. !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900329 Prologued revised extensively and code rewritten to allow ! X to be slightly outside interval (-1,+1). (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSEVL REAL B0, B1, B2, CS(*), ONEPL, TWOX, X LOGICAL FIRST SAVE FIRST, ONEPL DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT CSEVL if (FIRST) ONEPL = 1.0E0 + R1MACH(4) FIRST = .FALSE. if (N < 1) call XERMSG ('SLATEC', 'CSEVL', & 'NUMBER OF TERMS <= 0', 2, 2) if (N > 1000) call XERMSG ('SLATEC', 'CSEVL', & 'NUMBER OF TERMS > 1000', 3, 2) if (ABS(X) > ONEPL) call XERMSG ('SLATEC', 'CSEVL', & 'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1) ! B1 = 0.0E0 B0 = 0.0E0 TWOX = 2.0*X DO 10 I = 1,N B2 = B1 B1 = B0 NI = N + 1 - I B0 = TWOX*B1 - B2 + CS(NI) 10 CONTINUE ! CSEVL = 0.5E0*(B0-B2) ! return end subroutine CSHCH (Z, CSH, CCH) ! !! CSHCH is subsidiary to CBESH and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CSHCH-A, ZSHCH-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) ! AND CCH=COSH(X+I*Y), WHERE I**2=-1. ! !***SEE ALSO CBESH, CBESK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CSHCH COMPLEX CCH, CSH, Z REAL CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, X, Y !***FIRST EXECUTABLE STATEMENT CSHCH X = REAL(Z) Y = AIMAG(Z) SH = SINH(X) CH = COSH(X) SN = SIN(Y) CN = COS(Y) CSHR = SH*CN CSHI = CH*SN CSH = CMPLX(CSHR,CSHI) CCHR = CH*CN CCHI = SH*SN CCH = CMPLX(CCHR,CCHI) return end subroutine CSICO (A, LDA, N, KPVT, RCOND, Z) ! !! CSICO factors a complex symmetric matrix by elimination with ... ! symmetric pivoting and estimate the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1 !***TYPE COMPLEX (SSICO-S, DSICO-D, CHICO-C, CSICO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, SYMMETRIC !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CSICO factors a complex symmetric matrix by elimination with ! symmetric pivoting and estimates the condition of the matrix. ! ! If RCOND is not needed, CSIFA is slightly faster. ! To solve A*X = B , follow CSICO by CSISL. ! To compute INVERSE(A)*C , follow CSICO by CSISL. ! To compute INVERSE(A) , follow CSICO by CSIDI. ! To compute DETERMINANT(A) , follow CSICO by CSIDI. ! ! On Entry ! ! A COMPLEX(LDA, N) ! the symmetric matrix to be factored. ! Only the diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A a block diagonal matrix and the multipliers which ! were used to obtain it. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KVPT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTU, CSIFA, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Corrected category and modified routine equivalence ! list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSICO INTEGER LDA,N,KPVT(*) COMPLEX A(LDA,*),Z(*) REAL RCOND ! COMPLEX AK,AKM1,BK,BKM1,CDOTU,DENOM,EK,T REAL ANORM,S,SCASUM,YNORM INTEGER I,INFO,J,JM1,K,KP,KPS,KS COMPLEX ZDUM,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT CSICO DO 30 J = 1, N Z(J) = CMPLX(SCASUM(J,A(1,J),1),0.0E0) JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 Z(I) = CMPLX(REAL(Z(I))+CABS1(A(I,J)),0.0E0) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,REAL(Z(J))) 40 CONTINUE ! ! FACTOR ! call CSIFA(A,LDA,N,KPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE U*D*W = E ! EK = (1.0E0,0.0E0) DO 50 J = 1, N Z(J) = (0.0E0,0.0E0) 50 CONTINUE K = N 60 if (K == 0) go to 120 KS = 1 if (KPVT(K) < 0) KS = 2 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE if (CABS1(Z(K)) /= 0.0E0) EK = CSIGN1(EK,Z(K)) Z(K) = Z(K) + EK call CAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) if (KS == 1) go to 80 if (CABS1(Z(K-1)) /= 0.0E0) EK = CSIGN1(EK,Z(K-1)) Z(K-1) = Z(K-1) + EK call CAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) 80 CONTINUE if (KS == 2) go to 100 if (CABS1(Z(K)) <= CABS1(A(K,K))) go to 90 S = CABS1(A(K,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) EK = CMPLX(S,0.0E0)*EK 90 CONTINUE if (CABS1(A(K,K)) /= 0.0E0) Z(K) = Z(K)/A(K,K) if (CABS1(A(K,K)) == 0.0E0) Z(K) = (1.0E0,0.0E0) go to 110 100 CONTINUE AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = Z(K)/A(K-1,K) BKM1 = Z(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0E0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 110 CONTINUE K = K - KS go to 60 120 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! ! SOLVE TRANS(U)*Y = W ! K = 1 130 if (K > N) go to 160 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 150 Z(K) = Z(K) + CDOTU(K-1,A(1,K),1,Z(1),1) if (KS == 2) & Z(K+1) = Z(K+1) + CDOTU(K-1,A(1,K+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE K = K + KS go to 130 160 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE U*D*V = Y ! K = N 170 if (K == 0) go to 230 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == KS) go to 190 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 180 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 180 CONTINUE call CAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) if (KS == 2) call CAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) 190 CONTINUE if (KS == 2) go to 210 if (CABS1(Z(K)) <= CABS1(A(K,K))) go to 200 S = CABS1(A(K,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 200 CONTINUE if (CABS1(A(K,K)) /= 0.0E0) Z(K) = Z(K)/A(K,K) if (CABS1(A(K,K)) == 0.0E0) Z(K) = (1.0E0,0.0E0) go to 220 210 CONTINUE AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = Z(K)/A(K-1,K) BKM1 = Z(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0E0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 220 CONTINUE K = K - KS go to 170 230 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE TRANS(U)*Z = V ! K = 1 240 if (K > N) go to 270 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 260 Z(K) = Z(K) + CDOTU(K-1,A(1,K),1,Z(1),1) if (KS == 2) & Z(K+1) = Z(K+1) + CDOTU(K-1,A(1,K+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE K = K + KS go to 240 270 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine CSIDI (A, LDA, N, KPVT, DET, WORK, JOB) ! !! CSIDI computes the determinant and inverse of a complex symmetric ... ! matrix using the factors from CSIFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1, D3C1 !***TYPE COMPLEX (SSIDI-S, DSIDI-D, CHIDI-C, CSIDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CSIDI computes the determinant and inverse ! of a complex symmetric matrix using the factors from CSIFA. ! ! On Entry ! ! A COMPLEX(LDA,N) ! the output from CSIFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! KVPT INTEGER(N) ! the pivot vector from CSIFA. ! ! WORK COMPLEX(N) ! work vector. Contents destroyed. ! ! JOB INTEGER ! JOB has the decimal expansion AB where ! If B /= 0, the inverse is computed, ! If A /= 0, the determinant is computed, ! ! For example, JOB = 11 gives both. ! ! On Return ! ! Variables not requested by JOB are not used. ! ! A contains the upper triangle of the inverse of ! the original matrix. The strict lower triangle ! is never referenced. ! ! DET COMPLEX(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0. ! ! Error Condition ! ! A division by zero may occur if the inverse is requested ! and CSICO has set RCOND == 0.0 ! or CSIFA has set INFO /= 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CCOPY, CDOTU, CSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Corrected category and modified routine equivalence ! list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSIDI INTEGER LDA,N,JOB COMPLEX A(LDA,*),DET(2),WORK(*) INTEGER KPVT(*) ! COMPLEX AK,AKP1,AKKP1,CDOTU,D,T,TEMP REAL TEN INTEGER J,JB,K,KM1,KS,KSTEP LOGICAL NOINV,NODET COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) ! !***FIRST EXECUTABLE STATEMENT CSIDI NOINV = MOD(JOB,10) == 0 NODET = MOD(JOB,100)/10 == 0 ! if (NODET) go to 100 DET(1) = (1.0E0,0.0E0) DET(2) = (0.0E0,0.0E0) TEN = 10.0E0 T = (0.0E0,0.0E0) DO 90 K = 1, N D = A(K,K) ! ! CHECK if 1 BY 1 ! if (KPVT(K) > 0) go to 30 ! ! 2 BY 2 BLOCK ! USE DET (D T) = (D/T * C - T) * T ! (T C) ! TO AVOID UNDERFLOW/OVERFLOW TROUBLES. ! TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. ! if (CABS1(T) /= 0.0E0) go to 10 T = A(K,K+1) D = (D/T)*A(K+1,K+1) - T go to 20 10 CONTINUE D = T T = (0.0E0,0.0E0) 20 CONTINUE 30 CONTINUE ! DET(1) = D*DET(1) if (CABS1(DET(1)) == 0.0E0) go to 80 40 if (CABS1(DET(1)) >= 1.0E0) go to 50 DET(1) = CMPLX(TEN,0.0E0)*DET(1) DET(2) = DET(2) - (1.0E0,0.0E0) go to 40 50 CONTINUE 60 if (CABS1(DET(1)) < TEN) go to 70 DET(1) = DET(1)/CMPLX(TEN,0.0E0) DET(2) = DET(2) + (1.0E0,0.0E0) go to 60 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE ! ! COMPUTE INVERSE(A) ! if (NOINV) go to 230 K = 1 110 if (K > N) go to 220 KM1 = K - 1 if (KPVT(K) < 0) go to 140 ! ! 1 BY 1 ! A(K,K) = (1.0E0,0.0E0)/A(K,K) if (KM1 < 1) go to 130 call CCOPY(KM1,A(1,K),1,WORK,1) DO 120 J = 1, KM1 A(J,K) = CDOTU(J,A(1,J),1,WORK,1) call CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 120 CONTINUE A(K,K) = A(K,K) + CDOTU(KM1,WORK,1,A(1,K),1) 130 CONTINUE KSTEP = 1 go to 180 140 CONTINUE ! ! 2 BY 2 ! T = A(K,K+1) AK = A(K,K)/T AKP1 = A(K+1,K+1)/T AKKP1 = A(K,K+1)/T D = T*(AK*AKP1 - (1.0E0,0.0E0)) A(K,K) = AKP1/D A(K+1,K+1) = AK/D A(K,K+1) = -AKKP1/D if (KM1 < 1) go to 170 call CCOPY(KM1,A(1,K+1),1,WORK,1) DO 150 J = 1, KM1 A(J,K+1) = CDOTU(J,A(1,J),1,WORK,1) call CAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1) 150 CONTINUE A(K+1,K+1) = A(K+1,K+1) & + CDOTU(KM1,WORK,1,A(1,K+1),1) A(K,K+1) = A(K,K+1) + CDOTU(KM1,A(1,K),1,A(1,K+1),1) call CCOPY(KM1,A(1,K),1,WORK,1) DO 160 J = 1, KM1 A(J,K) = CDOTU(J,A(1,J),1,WORK,1) call CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 160 CONTINUE A(K,K) = A(K,K) + CDOTU(KM1,WORK,1,A(1,K),1) 170 CONTINUE KSTEP = 2 180 CONTINUE ! ! SWAP ! KS = ABS(KPVT(K)) if (KS == K) go to 210 call CSWAP(KS,A(1,KS),1,A(1,K),1) DO 190 JB = KS, K J = K + KS - JB TEMP = A(J,K) A(J,K) = A(KS,J) A(KS,J) = TEMP 190 CONTINUE if (KSTEP == 1) go to 200 TEMP = A(KS,K+1) A(KS,K+1) = A(K,K+1) A(K,K+1) = TEMP 200 CONTINUE 210 CONTINUE K = K + KSTEP go to 110 220 CONTINUE 230 CONTINUE return end subroutine CSIFA (A, LDA, N, KPVT, INFO) ! !! CSIFA factors a complex symmetric matrix with symmetric pivoting. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1 !***TYPE COMPLEX (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CSIFA factors a complex symmetric matrix by elimination ! with symmetric pivoting. ! ! To solve A*X = B , follow CSIFA by CSISL. ! To compute INVERSE(A)*C , follow CSIFA by CSISL. ! To compute DETERMINANT(A) , follow CSIFA by CSIDI. ! To compute INVERSE(A) , follow CSIFA by CSIDI. ! ! On Entry ! ! A COMPLEX(LDA,N) ! the symmetric matrix to be factored. ! Only the diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A a block diagonal matrix and the multipliers which ! were used to obtain it. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KVPT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th pivot block is singular. This is ! not an error condition for this subroutine, ! but it does indicate that CSISL or CSIDI may ! divide by zero if called. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSWAP, ICAMAX !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Corrected category and modified routine equivalence ! list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSIFA INTEGER LDA,N,KPVT(*),INFO COMPLEX A(LDA,*) ! COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T REAL ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,ICAMAX LOGICAL SWAP COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT CSIFA ! ! INITIALIZE ! ! ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ! ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 ! INFO = 0 ! ! MAIN LOOP ON K, WHICH GOES FROM N TO 1. ! K = N 10 CONTINUE ! ! LEAVE THE LOOP if K=0 OR K=1. ! if (K == 0) go to 200 if (K > 1) go to 20 KPVT(1) = 1 if (CABS1(A(1,1)) == 0.0E0) INFO = 1 go to 200 20 CONTINUE ! ! THIS SECTION OF CODE DETERMINES THE KIND OF ! ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, ! KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND ! SWAP WILL BE SET TO .TRUE. if AN INTERCHANGE IS ! REQUIRED. ! KM1 = K - 1 ABSAKK = CABS1(A(K,K)) ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! COLUMN K. ! IMAX = ICAMAX(K-1,A(1,K),1) COLMAX = CABS1(A(IMAX,K)) if (ABSAKK < ALPHA*COLMAX) go to 30 KSTEP = 1 SWAP = .FALSE. go to 90 30 CONTINUE ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! ROW IMAX. ! ROWMAX = 0.0E0 IMAXP1 = IMAX + 1 DO 40 J = IMAXP1, K ROWMAX = MAX(ROWMAX,CABS1(A(IMAX,J))) 40 CONTINUE if (IMAX == 1) go to 50 JMAX = ICAMAX(IMAX-1,A(1,IMAX),1) ROWMAX = MAX(ROWMAX,CABS1(A(JMAX,IMAX))) 50 CONTINUE if (CABS1(A(IMAX,IMAX)) < ALPHA*ROWMAX) go to 60 KSTEP = 1 SWAP = .TRUE. go to 80 60 CONTINUE if (ABSAKK < ALPHA*COLMAX*(COLMAX/ROWMAX)) go to 70 KSTEP = 1 SWAP = .FALSE. go to 80 70 CONTINUE KSTEP = 2 SWAP = IMAX /= KM1 80 CONTINUE 90 CONTINUE if (MAX(ABSAKK,COLMAX) /= 0.0E0) go to 100 ! ! COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. ! KPVT(K) = K INFO = K go to 190 100 CONTINUE if (KSTEP == 2) go to 140 ! ! 1 X 1 PIVOT BLOCK. ! if (.NOT.SWAP) go to 120 ! ! PERFORM AN INTERCHANGE. ! call CSWAP(IMAX,A(1,IMAX),1,A(1,K),1) DO 110 JJ = IMAX, K J = K + IMAX - JJ T = A(J,K) A(J,K) = A(IMAX,J) A(IMAX,J) = T 110 CONTINUE 120 CONTINUE ! ! PERFORM THE ELIMINATION. ! DO 130 JJ = 1, KM1 J = K - JJ MULK = -A(J,K)/A(K,K) T = MULK call CAXPY(J,T,A(1,K),1,A(1,J),1) A(J,K) = MULK 130 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = K if (SWAP) KPVT(K) = IMAX go to 190 140 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (.NOT.SWAP) go to 160 ! ! PERFORM AN INTERCHANGE. ! call CSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) DO 150 JJ = IMAX, KM1 J = KM1 + IMAX - JJ T = A(J,K-1) A(J,K-1) = A(IMAX,J) A(IMAX,J) = T 150 CONTINUE T = A(K-1,K) A(K-1,K) = A(IMAX,K) A(IMAX,K) = T 160 CONTINUE ! ! PERFORM THE ELIMINATION. ! KM2 = K - 2 if (KM2 == 0) go to 180 AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) DENOM = 1.0E0 - AK*AKM1 DO 170 JJ = 1, KM2 J = KM1 - JJ BK = A(J,K)/A(K-1,K) BKM1 = A(J,K-1)/A(K-1,K) MULK = (AKM1*BK - BKM1)/DENOM MULKM1 = (AK*BKM1 - BK)/DENOM T = MULK call CAXPY(J,T,A(1,K),1,A(1,J),1) T = MULKM1 call CAXPY(J,T,A(1,K-1),1,A(1,J),1) A(J,K) = MULK A(J,K-1) = MULKM1 170 CONTINUE 180 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = 1 - K if (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE K = K - KSTEP go to 10 200 CONTINUE return end FUNCTION CSINH (Z) ! !! CSINH computes the complex hyperbolic sine. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE COMPLEX (CSINH-C) !***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, HYPERBOLIC SINE !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CSINH(Z) calculates the complex hyperbolic sine of complex ! argument Z. Z is in units of radians. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CSINH COMPLEX CSINH COMPLEX Z, CI SAVE CI DATA CI /(0.,1.)/ !***FIRST EXECUTABLE STATEMENT CSINH CSINH = -CI*SIN(CI*Z) ! return end subroutine CSISL (A, LDA, N, KPVT, B) ! !! CSISL solves a complex symmetric system factored by CSIFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1 !***TYPE COMPLEX (SSISL-S, DSISL-D, CHISL-C, CSISL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CSISL solves the complex symmetric system ! A * X = B ! using the factors computed by CSIFA. ! ! On Entry ! ! A COMPLEX(LDA,N) ! the output from CSIFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! KVPT INTEGER(N) ! the pivot vector from CSIFA. ! ! B COMPLEX(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero may occur if CSICO has set RCOND == 0.0 ! or CSIFA has set INFO /= 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call CSIFA(A,LDA,N,KVPT,INFO) ! If (INFO /= 0) go to ... ! DO 10 J = 1, P ! call CSISL(A,LDA,N,KVPT,C(1,j)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTU !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Corrected category and modified routine equivalence ! list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSISL INTEGER LDA,N,KPVT(*) COMPLEX A(LDA,*),B(*) ! COMPLEX AK,AKM1,BK,BKM1,CDOTU,DENOM,TEMP INTEGER K,KP ! ! LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND ! D INVERSE TO B. ! !***FIRST EXECUTABLE STATEMENT CSISL K = N 10 if (K == 0) go to 80 if (KPVT(K) < 0) go to 40 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 30 KP = KPVT(K) if (KP == K) go to 20 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call CAXPY(K-1,B(K),A(1,K),1,B(1),1) 30 CONTINUE ! ! APPLY D INVERSE. ! B(K) = B(K)/A(K,K) K = K - 1 go to 70 40 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (K == 2) go to 60 KP = ABS(KPVT(K)) if (KP == K - 1) go to 50 ! ! INTERCHANGE. ! TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call CAXPY(K-2,B(K),A(1,K),1,B(1),1) call CAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) 60 CONTINUE ! ! APPLY D INVERSE. ! AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = B(K)/A(K-1,K) BKM1 = B(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0E0 B(K) = (AKM1*BK - BKM1)/DENOM B(K-1) = (AK*BKM1 - BK)/DENOM K = K - 2 70 CONTINUE go to 10 80 CONTINUE ! ! LOOP FORWARD APPLYING THE TRANSFORMATIONS. ! K = 1 90 if (K > N) go to 160 if (KPVT(K) < 0) go to 120 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 110 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + CDOTU(K-1,A(1,K),1,B(1),1) KP = KPVT(K) if (KP == K) go to 100 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 100 CONTINUE 110 CONTINUE K = K + 1 go to 150 120 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (K == 1) go to 140 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + CDOTU(K-1,A(1,K),1,B(1),1) B(K+1) = B(K+1) + CDOTU(K-1,A(1,K+1),1,B(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 130 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 130 CONTINUE 140 CONTINUE K = K + 2 150 CONTINUE go to 90 160 CONTINUE return end subroutine CSPCO (AP, N, KPVT, RCOND, Z) ! !! CSPCO factors a complex symmetric matrix stored in packed form ... ! by elimination with symmetric pivoting and estimate the ... ! condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1 !***TYPE COMPLEX (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, PACKED, SYMMETRIC !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CSPCO factors a complex symmetric matrix stored in packed ! form by elimination with symmetric pivoting and estimates ! the condition of the matrix. ! ! If RCOND is not needed, CSPFA is slightly faster. ! To solve A*X = B , follow CSPCO by CSPSL. ! To compute INVERSE(A)*C , follow CSPCO by CSPSL. ! To compute INVERSE(A) , follow CSPCO by CSPDI. ! To compute DETERMINANT(A) , follow CSPCO by CSPDI. ! ! On Entry ! ! AP COMPLEX (N*(N+1)/2) ! the packed form of a symmetric matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! AP a block diagonal matrix and the multipliers which ! were used to obtain it stored in packed form. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KVPT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a symmetric matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTU, CSPFA, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Corrected category and modified routine equivalence ! list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSPCO INTEGER N,KPVT(*) COMPLEX AP(*),Z(*) REAL RCOND ! COMPLEX AK,AKM1,BK,BKM1,CDOTU,DENOM,EK,T REAL ANORM,S,SCASUM,YNORM INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1 INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS COMPLEX ZDUM,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM,ZDUM2) = CABS1(ZDUM)*(ZDUM2/CABS1(ZDUM2)) ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT CSPCO J1 = 1 DO 30 J = 1, N Z(J) = CMPLX(SCASUM(J,AP(J1),1),0.0E0) IJ = J1 J1 = J1 + J JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 Z(I) = CMPLX(REAL(Z(I))+CABS1(AP(IJ)),0.0E0) IJ = IJ + 1 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,REAL(Z(J))) 40 CONTINUE ! ! FACTOR ! call CSPFA(AP,N,KPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE U*D*W = E ! EK = (1.0E0,0.0E0) DO 50 J = 1, N Z(J) = (0.0E0,0.0E0) 50 CONTINUE K = N IK = (N*(N - 1))/2 60 if (K == 0) go to 120 KK = IK + K IKM1 = IK - (K - 1) KS = 1 if (KPVT(K) < 0) KS = 2 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE if (CABS1(Z(K)) /= 0.0E0) EK = CSIGN1(EK,Z(K)) Z(K) = Z(K) + EK call CAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) if (KS == 1) go to 80 if (CABS1(Z(K-1)) /= 0.0E0) EK = CSIGN1(EK,Z(K-1)) Z(K-1) = Z(K-1) + EK call CAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) 80 CONTINUE if (KS == 2) go to 100 if (CABS1(Z(K)) <= CABS1(AP(KK))) go to 90 S = CABS1(AP(KK))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) EK = CMPLX(S,0.0E0)*EK 90 CONTINUE if (CABS1(AP(KK)) /= 0.0E0) Z(K) = Z(K)/AP(KK) if (CABS1(AP(KK)) == 0.0E0) Z(K) = (1.0E0,0.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 == 2) IK = IK - (K + 1) go to 60 120 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! ! SOLVE TRANS(U)*Y = W ! K = 1 IK = 0 130 if (K > N) go to 160 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 150 Z(K) = Z(K) + CDOTU(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K if (KS == 2) & Z(K+1) = Z(K+1) + CDOTU(K-1,AP(IKP1+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE IK = IK + K if (KS == 2) IK = IK + (K + 1) K = K + KS go to 130 160 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE U*D*V = Y ! K = N IK = N*(N - 1)/2 170 if (K == 0) go to 230 KK = IK + K IKM1 = IK - (K - 1) KS = 1 if (KPVT(K) < 0) KS = 2 if (K == KS) go to 190 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 180 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 180 CONTINUE call CAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) if (KS == 2) call CAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) 190 CONTINUE if (KS == 2) go to 210 if (CABS1(Z(K)) <= CABS1(AP(KK))) go to 200 S = CABS1(AP(KK))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 200 CONTINUE if (CABS1(AP(KK)) /= 0.0E0) Z(K) = Z(K)/AP(KK) if (CABS1(AP(KK)) == 0.0E0) Z(K) = (1.0E0,0.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 == 2) IK = IK - (K + 1) go to 170 230 CONTINUE S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE TRANS(U)*Z = V ! K = 1 IK = 0 240 if (K > N) go to 270 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 260 Z(K) = Z(K) + CDOTU(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K if (KS == 2) & Z(K+1) = Z(K+1) + CDOTU(K-1,AP(IKP1+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE IK = IK + K if (KS == 2) IK = IK + (K + 1) K = K + KS go to 240 270 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine CSPDI (AP, N, KPVT, DET, WORK, JOB) ! !! CSPDI computes the determinant and inverse of a complex symmetric ... ! matrix stored in packed form using the factors from CSPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1, D3C1 !***TYPE COMPLEX (SSPDI-S, DSPDI-D, CHPDI-C, CSPDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! PACKED, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CSPDI computes the determinant and inverse ! of a complex symmetric matrix using the factors from CSPFA, ! where the matrix is stored in packed form. ! ! On Entry ! ! AP COMPLEX (N*(N+1)/2) ! the output from CSPFA. ! ! N INTEGER ! the order of the matrix A . ! ! KVPT INTEGER(N) ! the pivot vector from CSPFA. ! ! WORK COMPLEX(N) ! work vector. Contents ignored. ! ! JOB INTEGER ! JOB has the decimal expansion AB where ! if B /= 0, the inverse is computed, ! if A /= 0, the determinant is computed. ! ! For example, JOB = 11 gives both. ! ! On Return ! ! Variables not requested by JOB are not used. ! ! AP contains the upper triangle of the inverse of ! the original matrix, stored in packed form. ! The columns of the upper triangle are stored ! sequentially in a one-dimensional array. ! ! DET COMPLEX(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0. ! ! Error Condition ! ! A division by zero will occur if the inverse is requested ! and CSPCO has set RCOND == 0.0 ! or CSPFA has set INFO /= 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CCOPY, CDOTU, CSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Corrected category and modified routine equivalence ! list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSPDI INTEGER N,JOB COMPLEX AP(*),WORK(*),DET(2) INTEGER KPVT(*) ! COMPLEX AK,AKKP1,AKP1,CDOTU,D,T,TEMP REAL TEN INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1 INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP LOGICAL NOINV,NODET COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) ! !***FIRST EXECUTABLE STATEMENT CSPDI NOINV = MOD(JOB,10) == 0 NODET = MOD(JOB,100)/10 == 0 ! if (NODET) go to 110 DET(1) = (1.0E0,0.0E0) DET(2) = (0.0E0,0.0E0) TEN = 10.0E0 T = (0.0E0,0.0E0) IK = 0 DO 100 K = 1, N KK = IK + K D = AP(KK) ! ! CHECK if 1 BY 1 ! if (KPVT(K) > 0) go to 30 ! ! 2 BY 2 BLOCK ! USE DET (D T) = (D/T * C - T) * T ! (T C) ! TO AVOID UNDERFLOW/OVERFLOW TROUBLES. ! TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. ! if (CABS1(T) /= 0.0E0) go to 10 IKP1 = IK + K KKP1 = IKP1 + K T = AP(KKP1) D = (D/T)*AP(KKP1+1) - T go to 20 10 CONTINUE D = T T = (0.0E0,0.0E0) 20 CONTINUE 30 CONTINUE ! if (NODET) go to 90 DET(1) = D*DET(1) if (CABS1(DET(1)) == 0.0E0) go to 80 40 if (CABS1(DET(1)) >= 1.0E0) go to 50 DET(1) = CMPLX(TEN,0.0E0)*DET(1) DET(2) = DET(2) - (1.0E0,0.0E0) go to 40 50 CONTINUE 60 if (CABS1(DET(1)) < TEN) go to 70 DET(1) = DET(1)/CMPLX(TEN,0.0E0) DET(2) = DET(2) + (1.0E0,0.0E0) go to 60 70 CONTINUE 80 CONTINUE 90 CONTINUE IK = IK + K 100 CONTINUE 110 CONTINUE ! ! COMPUTE INVERSE(A) ! if (NOINV) go to 240 K = 1 IK = 0 120 if (K > N) go to 230 KM1 = K - 1 KK = IK + K IKP1 = IK + K if (KPVT(K) < 0) go to 150 ! ! 1 BY 1 ! AP(KK) = (1.0E0,0.0E0)/AP(KK) if (KM1 < 1) go to 140 call CCOPY(KM1,AP(IK+1),1,WORK,1) IJ = 0 DO 130 J = 1, KM1 JK = IK + J AP(JK) = CDOTU(J,AP(IJ+1),1,WORK,1) call CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) IJ = IJ + J 130 CONTINUE AP(KK) = AP(KK) + CDOTU(KM1,WORK,1,AP(IK+1),1) 140 CONTINUE KSTEP = 1 go to 190 150 CONTINUE ! ! 2 BY 2 ! KKP1 = IKP1 + K T = AP(KKP1) AK = AP(KK)/T AKP1 = AP(KKP1+1)/T AKKP1 = AP(KKP1)/T D = T*(AK*AKP1 - (1.0E0,0.0E0)) AP(KK) = AKP1/D AP(KKP1+1) = AK/D AP(KKP1) = -AKKP1/D if (KM1 < 1) go to 180 call CCOPY(KM1,AP(IKP1+1),1,WORK,1) IJ = 0 DO 160 J = 1, KM1 JKP1 = IKP1 + J AP(JKP1) = CDOTU(J,AP(IJ+1),1,WORK,1) call CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1) IJ = IJ + J 160 CONTINUE AP(KKP1+1) = AP(KKP1+1) & + CDOTU(KM1,WORK,1,AP(IKP1+1),1) AP(KKP1) = AP(KKP1) & + CDOTU(KM1,AP(IK+1),1,AP(IKP1+1),1) call CCOPY(KM1,AP(IK+1),1,WORK,1) IJ = 0 DO 170 J = 1, KM1 JK = IK + J AP(JK) = CDOTU(J,AP(IJ+1),1,WORK,1) call CAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) IJ = IJ + J 170 CONTINUE AP(KK) = AP(KK) + CDOTU(KM1,WORK,1,AP(IK+1),1) 180 CONTINUE KSTEP = 2 190 CONTINUE ! ! SWAP ! KS = ABS(KPVT(K)) if (KS == K) go to 220 IKS = (KS*(KS - 1))/2 call CSWAP(KS,AP(IKS+1),1,AP(IK+1),1) KSJ = IK + KS DO 200 JB = KS, K J = K + KS - JB JK = IK + J TEMP = AP(JK) AP(JK) = AP(KSJ) AP(KSJ) = TEMP KSJ = KSJ - (J - 1) 200 CONTINUE if (KSTEP == 1) go to 210 KSKP1 = IKP1 + KS TEMP = AP(KSKP1) AP(KSKP1) = AP(KKP1) AP(KKP1) = TEMP 210 CONTINUE 220 CONTINUE IK = IK + K if (KSTEP == 2) IK = IK + K + 1 K = K + KSTEP go to 120 230 CONTINUE 240 CONTINUE return end subroutine CSPFA (AP, N, KPVT, INFO) ! !! CSPFA factors a complex symmetric matrix stored in packed form by ... ! elimination with symmetric pivoting. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1 !***TYPE COMPLEX (SSPFA-S, DSPFA-D, CHPFA-C, CSPFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, ! SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CSPFA factors a complex symmetric matrix stored in ! packed form by elimination with symmetric pivoting. ! ! To solve A*X = B , follow CSPFA by CSPSL. ! To compute INVERSE(A)*C , follow CSPFA by CSPSL. ! To compute DETERMINANT(A) , follow CSPFA by CSPDI. ! To compute INVERSE(A) , follow CSPFA by CSPDI. ! ! On Entry ! ! AP COMPLEX (N*(N+1)/2) ! the packed form of a symmetric matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! AP a block diagonal matrix and the multipliers which ! were used to obtain it stored in packed form. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KVPT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th pivot block is singular. This is ! not an error condition for this subroutine, ! but it does indicate that CSPSL or CSPDI may ! divide by zero if called. ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a symmetric matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSWAP, ICAMAX !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Corrected category and modified routine equivalence ! list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSPFA INTEGER N,KPVT(*),INFO COMPLEX AP(*) ! COMPLEX AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T REAL ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER ICAMAX,IJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP LOGICAL SWAP COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT CSPFA ! ! INITIALIZE ! ! ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ! ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 ! INFO = 0 ! ! MAIN LOOP ON K, WHICH GOES FROM N TO 1. ! K = N IK = (N*(N - 1))/2 10 CONTINUE ! ! LEAVE THE LOOP if K=0 OR K=1. ! if (K == 0) go to 200 if (K > 1) go to 20 KPVT(1) = 1 if (CABS1(AP(1)) == 0.0E0) INFO = 1 go to 200 20 CONTINUE ! ! THIS SECTION OF CODE DETERMINES THE KIND OF ! ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, ! KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND ! SWAP WILL BE SET TO .TRUE. if AN INTERCHANGE IS ! REQUIRED. ! KM1 = K - 1 KK = IK + K ABSAKK = CABS1(AP(KK)) ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! COLUMN K. ! IMAX = ICAMAX(K-1,AP(IK+1),1) IMK = IK + IMAX COLMAX = CABS1(AP(IMK)) if (ABSAKK < ALPHA*COLMAX) go to 30 KSTEP = 1 SWAP = .FALSE. go to 90 30 CONTINUE ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! ROW IMAX. ! ROWMAX = 0.0E0 IMAXP1 = IMAX + 1 IM = IMAX*(IMAX - 1)/2 IMJ = IM + 2*IMAX DO 40 J = IMAXP1, K ROWMAX = MAX(ROWMAX,CABS1(AP(IMJ))) IMJ = IMJ + J 40 CONTINUE if (IMAX == 1) go to 50 JMAX = ICAMAX(IMAX-1,AP(IM+1),1) JMIM = JMAX + IM ROWMAX = MAX(ROWMAX,CABS1(AP(JMIM))) 50 CONTINUE IMIM = IMAX + IM if (CABS1(AP(IMIM)) < ALPHA*ROWMAX) go to 60 KSTEP = 1 SWAP = .TRUE. go to 80 60 CONTINUE if (ABSAKK < ALPHA*COLMAX*(COLMAX/ROWMAX)) go to 70 KSTEP = 1 SWAP = .FALSE. go to 80 70 CONTINUE KSTEP = 2 SWAP = IMAX /= KM1 80 CONTINUE 90 CONTINUE if (MAX(ABSAKK,COLMAX) /= 0.0E0) go to 100 ! ! COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. ! KPVT(K) = K INFO = K go to 190 100 CONTINUE if (KSTEP == 2) go to 140 ! ! 1 X 1 PIVOT BLOCK. ! if (.NOT.SWAP) go to 120 ! ! PERFORM AN INTERCHANGE. ! call CSWAP(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 ! ! PERFORM THE ELIMINATION. ! IJ = IK - (K - 1) DO 130 JJ = 1, KM1 J = K - JJ JK = IK + J MULK = -AP(JK)/AP(KK) T = MULK call CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) AP(JK) = MULK IJ = IJ - (J - 1) 130 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = K if (SWAP) KPVT(K) = IMAX go to 190 140 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! KM1K = IK + K - 1 IKM1 = IK - (K - 1) if (.NOT.SWAP) go to 160 ! ! PERFORM AN INTERCHANGE. ! call CSWAP(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 ! ! PERFORM THE ELIMINATION. ! KM2 = K - 2 if (KM2 == 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 CAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) T = MULKM1 call CAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1) AP(JK) = MULK AP(JKM1) = MULKM1 IJ = IJ - (J - 1) 170 CONTINUE 180 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = 1 - K if (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE IK = IK - (K - 1) if (KSTEP == 2) IK = IK - (K - 2) K = K - KSTEP go to 10 200 CONTINUE return end subroutine CSPSL (AP, N, KPVT, B) ! !! CSPSL solves a complex symmetric system factored by CSPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C1 !***TYPE COMPLEX (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! CSISL solves the complex symmetric system ! A * X = B ! using the factors computed by CSPFA. ! ! On Entry ! ! AP COMPLEX(N*(N+1)/2) ! the output from CSPFA. ! ! N INTEGER ! the order of the matrix A . ! ! KVPT INTEGER(N) ! the pivot vector from CSPFA. ! ! B COMPLEX(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero may occur if CSPCO has set RCOND == 0.0 ! or CSPFA has set INFO /= 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call CSPFA(AP,N,KVPT,INFO) ! if (INFO /= 0) go to ... ! DO 10 J = 1, P ! call CSPSL(AP,N,KVPT,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTU !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Corrected category and modified routine equivalence ! list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSPSL INTEGER N,KPVT(*) COMPLEX AP(*),B(*) ! COMPLEX AK,AKM1,BK,BKM1,CDOTU,DENOM,TEMP INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP ! ! LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND ! D INVERSE TO B. ! !***FIRST EXECUTABLE STATEMENT CSPSL K = N IK = (N*(N - 1))/2 10 if (K == 0) go to 80 KK = IK + K if (KPVT(K) < 0) go to 40 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 30 KP = KPVT(K) if (KP == K) go to 20 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call CAXPY(K-1,B(K),AP(IK+1),1,B(1),1) 30 CONTINUE ! ! APPLY D INVERSE. ! B(K) = B(K)/AP(KK) K = K - 1 IK = IK - K go to 70 40 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! IKM1 = IK - (K - 1) if (K == 2) go to 60 KP = ABS(KPVT(K)) if (KP == K - 1) go to 50 ! ! INTERCHANGE. ! TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call CAXPY(K-2,B(K),AP(IK+1),1,B(1),1) call CAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1) 60 CONTINUE ! ! APPLY D INVERSE. ! 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 ! ! LOOP FORWARD APPLYING THE TRANSFORMATIONS. ! K = 1 IK = 0 90 if (K > N) go to 160 if (KPVT(K) < 0) go to 120 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 110 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + CDOTU(K-1,AP(IK+1),1,B(1),1) KP = KPVT(K) if (KP == K) go to 100 ! ! INTERCHANGE. ! 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 ! ! 2 X 2 PIVOT BLOCK. ! if (K == 1) go to 140 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + CDOTU(K-1,AP(IK+1),1,B(1),1) IKP1 = IK + K B(K+1) = B(K+1) + CDOTU(K-1,AP(IKP1+1),1,B(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 130 ! ! INTERCHANGE. ! 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 CSROOT (XR, XI, YR, YI) ! !! CSROOT computes the complex square root of a complex number. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CSROOT-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! (YR,YI) = complex sqrt(XR,XI) ! !***SEE ALSO EISDOC !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 811101 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE CSROOT REAL XR,XI,YR,YI,S,TR,TI,PYTHAG ! ! BRANCH CHOSEN SO THAT YR >= 0.0 AND SIGN(YI) == SIGN(XI) !***FIRST EXECUTABLE STATEMENT CSROOT TR = XR TI = XI S = SQRT(0.5E0*(PYTHAG(TR,TI) + ABS(TR))) if (TR >= 0.0E0) YR = S if (TI < 0.0E0) S = -S if (TR <= 0.0E0) YI = S if (TR < 0.0E0) YR = 0.5E0*(TI/YI) if (TR > 0.0E0) YI = 0.5E0*(TI/YR) return end subroutine CSROT (N, CX, INCX, CY, INCY, C, S) ! !! CSROT applies a plane Givens rotation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B10 !***TYPE COMPLEX (SROT-S, DROT-D, CSROT-C) !***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, ! LINEAR ALGEBRA, PLANE ROTATION, VECTOR !***AUTHOR Dongarra, J., (ANL) !***DESCRIPTION ! ! CSROT applies the complex Givens rotation ! ! (X) ( C S)(X) ! (Y) = (-S C)(Y) ! ! N times where for I = 0,...,N-1 ! ! X = CX(LX+I*INCX) ! Y = CY(LY+I*INCY), ! ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! ! Argument Description ! ! N (integer) number of elements in each vector ! ! CX (complex array) beginning of one vector ! ! INCX (integer) memory spacing of successive elements ! of vector CX ! ! CY (complex array) beginning of the other vector ! ! INCY (integer) memory spacing of successive elements ! of vector CY ! ! C (real) cosine term of the rotation ! ! S (real) sine term of the rotation. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810223 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSROT COMPLEX CX(*), CY(*), CTEMP REAL C, S INTEGER I, INCX, INCY, IX, IY, N !***FIRST EXECUTABLE STATEMENT CSROT if (N <= 0) RETURN if (INCX == 1 .AND. INCY == 1)go to 20 ! ! Code for unequal increments or equal increments not equal to 1. ! IX = 1 IY = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 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 ! ! Code for both increments equal to 1. ! 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 CSSCAL (N, SA, CX, INCX) ! !! CSSCAL scales a complex vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A6 !***TYPE COMPLEX (CSSCAL-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SA single precision scale factor ! CX complex vector with N elements ! INCX storage spacing between elements of CX ! ! --Output-- ! CX scaled result (unchanged if N <= 0) ! ! Replace complex CX by (single precision SA) * (complex CX) ! For I = 0 to N-1, replace CX(IX+I*INCX) with SA * CX(IX+I*INCX), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900821 Modified to correct problem with a negative increment. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSSCAL COMPLEX CX(*) REAL SA INTEGER I, INCX, IX, N !***FIRST EXECUTABLE STATEMENT CSSCAL if (N <= 0) RETURN ! if (INCX == 1) GOTO 20 ! ! Code for increment not equal to 1. ! IX = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N CX(IX) = SA*CX(IX) IX = IX + INCX 10 CONTINUE return ! ! Code for increment equal to 1. ! 20 DO 30 I = 1,N CX(I) = SA*CX(I) 30 CONTINUE return end subroutine CSVDC (X, LDX, N, P, S, E, U, LDU, V, LDV, WORK, JOB, INFO) ! !! CSVDC performs the singular value decomposition of a rectangular matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D6 !***TYPE COMPLEX (SSVDC-S, DSVDC-D, CSVDC-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ! SINGULAR VALUE DECOMPOSITION !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! CSVDC is a subroutine to reduce a complex NxP matrix X by ! unitary transformations U and V to diagonal form. The ! diagonal elements S(I) are the singular values of X. The ! columns of U are the corresponding left singular vectors, ! and the columns of V the right singular vectors. ! ! On Entry ! ! X COMPLEX(LDX,P), where LDX >= N. ! X contains the matrix whose singular value ! decomposition is to be computed. X is ! destroyed by CSVDC. ! ! LDX INTEGER. ! LDX is the leading dimension of the array X. ! ! N INTEGER. ! N is the number of rows of the matrix X. ! ! P INTEGER. ! P is the number of columns of the matrix X. ! ! LDU INTEGER. ! LDU is the leading dimension of the array U ! (see below). ! ! LDV INTEGER. ! LDV is the leading dimension of the array V ! (see below). ! ! WORK COMPLEX(N). ! WORK is a scratch array. ! ! JOB INTEGER. ! JOB controls the computation of the singular ! vectors. It has the decimal expansion AB ! with the following meaning ! ! A == 0 Do not compute the left singular ! vectors. ! A == 1 Return the N left singular vectors ! in U. ! A >= 2 Return the first MIN(N,P) ! left singular vectors in U. ! B == 0 Do not compute the right singular ! vectors. ! B == 1 Return the right singular vectors ! in V. ! ! On Return ! ! S COMPLEX(MM), where MM = MIN(N+1,P). ! The first MIN(N,P) entries of S contain the ! singular values of X arranged in descending ! order of magnitude. ! ! E COMPLEX(P). ! E ordinarily contains zeros. However see the ! discussion of INFO for exceptions. ! ! U COMPLEX(LDU,K), where LDU >= N. If JOBA == 1 ! then K == N. If JOBA >= 2 then ! K == MIN(N,P). ! U contains the matrix of right singular vectors. ! U is not referenced if JOBA == 0. If N <= P ! or if JOBA > 2, then U may be identified with X ! in the subroutine call. ! ! V COMPLEX(LDV,P), where LDV >= P. ! V contains the matrix of right singular vectors. ! V is not referenced if JOB == 0. If P <= N, ! then V may be identified with X in the ! subroutine call. ! ! INFO INTEGER. ! The singular values (and their corresponding ! singular vectors) S(INFO+1),S(INFO+2),...,S(M) ! are correct (here M=MIN(N,P)). Thus if ! INFO == 0, all the singular values and their ! vectors are correct. In any event, the matrix ! B = CTRANS(U)*X*V is the bidiagonal matrix ! with the elements of S on its diagonal and the ! elements of E on its super-diagonal (CTRANS(U) ! is the conjugate-transpose of U). Thus the ! singular values of X and B are the same. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC, CSCAL, CSROT, CSWAP, SCNRM2, SROTG !***REVISION HISTORY (YYMMDD) ! 790319 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSVDC INTEGER LDX,N,P,LDU,LDV,JOB,INFO COMPLEX X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) ! ! 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 COMPLEX CSIGN,ZDUM,ZDUM1,ZDUM2 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN(ZDUM1,ZDUM2) = ABS(ZDUM1)*(ZDUM2/ABS(ZDUM2)) !***FIRST EXECUTABLE STATEMENT CSVDC ! ! SET THE MAXIMUM NUMBER OF ITERATIONS. ! MAXIT = 30 ! ! DETERMINE WHAT IS TO BE COMPUTED. ! WANTU = .FALSE. WANTV = .FALSE. JOBU = MOD(JOB,100)/10 NCU = N if (JOBU > 1) NCU = MIN(N,P) if (JOBU /= 0) WANTU = .TRUE. if (MOD(JOB,10) /= 0) WANTV = .TRUE. ! ! REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS ! IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. ! INFO = 0 NCT = MIN(N-1,P) NRT = MAX(0,MIN(P-2,N)) LU = MAX(NCT,NRT) if (LU < 1) go to 170 DO 160 L = 1, LU LP1 = L + 1 if (L > NCT) go to 20 ! ! COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND ! PLACE THE L-TH DIAGONAL IN S(L). ! S(L) = CMPLX(SCNRM2(N-L+1,X(L,L),1),0.0E0) if (CABS1(S(L)) == 0.0E0) go to 10 if (CABS1(X(L,L)) /= 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 < LP1) go to 50 DO 40 J = LP1, P if (L > NCT) go to 30 if (CABS1(S(L)) == 0.0E0) go to 30 ! ! APPLY THE TRANSFORMATION. ! 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 ! ! PLACE THE L-TH ROW OF X INTO E FOR THE ! SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. ! E(J) = CONJG(X(L,J)) 40 CONTINUE 50 CONTINUE if (.NOT.WANTU .OR. L > NCT) go to 70 ! ! PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK ! MULTIPLICATION. ! DO 60 I = L, N U(I,L) = X(I,L) 60 CONTINUE 70 CONTINUE if (L > NRT) go to 150 ! ! COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE ! L-TH SUPER-DIAGONAL IN E(L). ! E(L) = CMPLX(SCNRM2(P-L,E(LP1),1),0.0E0) if (CABS1(E(L)) == 0.0E0) go to 80 if (CABS1(E(LP1)) /= 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 > N .OR. CABS1(E(L)) == 0.0E0) go to 120 ! ! APPLY THE TRANSFORMATION. ! 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 ! ! PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT ! BACK MULTIPLICATION. ! DO 130 I = LP1, P V(I,L) = E(I) 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE ! ! SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. ! M = MIN(P,N+1) NCTP1 = NCT + 1 NRTP1 = NRT + 1 if (NCT < P) S(NCTP1) = X(NCTP1,NCTP1) if (N < M) S(M) = (0.0E0,0.0E0) if (NRTP1 < M) E(NRTP1) = X(NRTP1,M) E(M) = (0.0E0,0.0E0) ! ! if REQUIRED, GENERATE U. ! if (.NOT.WANTU) go to 300 if (NCU < 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 < 1) go to 290 DO 280 LL = 1, NCT L = NCT - LL + 1 if (CABS1(S(L)) == 0.0E0) go to 250 LP1 = L + 1 if (NCU < 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 < 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 ! ! if IT IS REQUIRED, GENERATE V. ! if (.NOT.WANTV) go to 350 DO 340 LL = 1, P L = P - LL + 1 LP1 = L + 1 if (L > NRT) go to 320 if (CABS1(E(L)) == 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 ! ! TRANSFORM S AND E SO THAT THEY ARE REAL. ! DO 380 I = 1, M if (CABS1(S(I)) == 0.0E0) go to 360 T = CMPLX(ABS(S(I)),0.0E0) R = S(I)/T S(I) = T if (I < M) E(I) = E(I)/R if (WANTU) call CSCAL(N,R,U(1,I),1) 360 CONTINUE if (I == M) go to 390 if (CABS1(E(I)) == 0.0E0) go to 370 T = CMPLX(ABS(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 ! ! MAIN ITERATION LOOP FOR THE SINGULAR VALUES. ! MM = M ITER = 0 400 CONTINUE ! ! QUIT if ALL THE SINGULAR VALUES HAVE BEEN FOUND. ! if (M == 0) go to 660 ! ! if TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET ! FLAG AND RETURN. ! if (ITER < MAXIT) go to 410 INFO = M go to 660 410 CONTINUE ! ! THIS SECTION OF THE PROGRAM INSPECTS FOR ! NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON ! COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. ! ! KASE = 1 if S(M) AND E(L-1) ARE NEGLIGIBLE AND L < M ! KASE = 2 if S(L) IS NEGLIGIBLE AND L < M ! KASE = 3 if E(L-1) IS NEGLIGIBLE, L < M, AND ! S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). ! KASE = 4 if E(M-1) IS NEGLIGIBLE (CONVERGENCE). ! DO 430 LL = 1, M L = M - LL if (L == 0) go to 440 TEST = ABS(S(L)) + ABS(S(L+1)) ZTEST = TEST + ABS(E(L)) if (ZTEST /= TEST) go to 420 E(L) = (0.0E0,0.0E0) go to 440 420 CONTINUE 430 CONTINUE 440 CONTINUE if (L /= 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 if (LS == L) go to 480 TEST = 0.0E0 if (LS /= M) TEST = TEST + ABS(E(LS)) if (LS /= L + 1) TEST = TEST + ABS(E(LS-1)) ZTEST = TEST + ABS(S(LS)) if (ZTEST /= TEST) go to 460 S(LS) = (0.0E0,0.0E0) go to 480 460 CONTINUE 470 CONTINUE 480 CONTINUE if (LS /= L) go to 490 KASE = 3 go to 510 490 CONTINUE if (LS /= M) go to 500 KASE = 1 go to 510 500 CONTINUE KASE = 2 L = LS 510 CONTINUE 520 CONTINUE L = L + 1 ! ! PERFORM THE TASK INDICATED BY KASE. ! go to (530, 560, 580, 610), KASE ! ! DEFLATE NEGLIGIBLE S(M). ! 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 == 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 ! ! SPLIT AT NEGLIGIBLE S(L). ! 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 ! ! PERFORM ONE QR STEP. ! 580 CONTINUE ! ! CALCULATE THE SHIFT. ! SCALE = MAX(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)), & ABS(S(L)),ABS(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 == 0.0E0 .AND. C == 0.0E0) go to 590 SHIFT = SQRT(B**2+C) if (B < 0.0E0) SHIFT = -SHIFT SHIFT = C/(B + SHIFT) 590 CONTINUE F = (SL + SM)*(SL - SM) - SHIFT G = SL*EL ! ! CHASE ZEROS. ! MM1 = M - 1 DO 600 K = L, MM1 call SROTG(F,G,CS,SN) if (K /= 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 < 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 ! ! CONVERGENCE. ! 610 CONTINUE ! ! MAKE THE SINGULAR VALUE POSITIVE ! if (REAL(S(L)) >= 0.0E0) go to 620 S(L) = -S(L) if (WANTV) call CSCAL(P,(-1.0E0,0.0E0),V(1,L),1) 620 CONTINUE ! ! ORDER THE SINGULAR VALUE. ! 630 if (L == MM) go to 640 if (REAL(S(L)) >= REAL(S(L+1))) go to 640 T = S(L) S(L) = S(L+1) S(L+1) = T if (WANTV .AND. L < P) & call CSWAP(P,V(1,L),1,V(1,L+1),1) if (WANTU .AND. L < 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 subroutine CSWAP (N, CX, INCX, CY, INCY) ! !! CSWAP interchanges two vectors. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A5 !***TYPE COMPLEX (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) !***KEYWORDS BLAS, INTERCHANGE, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! CX complex vector with N elements ! INCX storage spacing between elements of CX ! CY complex vector with N elements ! INCY storage spacing between elements of CY ! ! --Output-- ! CX input vector CY (unchanged if N <= 0) ! CY input vector CX (unchanged if N <= 0) ! ! Interchange complex CX and complex CY ! For I = 0 to N-1, interchange CX(LX+I*INCX) and CY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CSWAP COMPLEX CX(*),CY(*),CTEMP !***FIRST EXECUTABLE STATEMENT CSWAP if (N <= 0) RETURN if (INCX == INCY .AND. INCX > 0) go to 20 ! ! Code for unequal or nonpositive increments. ! KX = 1 KY = 1 if (INCX < 0) KX = 1+(1-N)*INCX if (INCY < 0) KY = 1+(1-N)*INCY DO 10 I = 1,N CTEMP = CX(KX) CX(KX) = CY(KY) CY(KY) = CTEMP KX = KX + INCX KY = KY + INCY 10 CONTINUE return ! ! Code for equal, positive, non-unit increments. ! 20 NS = N*INCX DO 30 I = 1,NS,INCX CTEMP = CX(I) CX(I) = CY(I) CY(I) = CTEMP 30 CONTINUE return end subroutine CSYMM (SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, & C, LDC) ! !! CSYMM multiplies a complex general matrix by a complex symmetric matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE COMPLEX (SSYMM-S, DSYMM-D, CSYMM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! CSYMM performs one of the matrix-matrix operations ! ! C := alpha*A*B + beta*C, ! ! or ! ! C := alpha*B*A + beta*C, ! ! where alpha and beta are scalars, A is a symmetric matrix and B and ! C are m by n matrices. ! ! Parameters ! ========== ! ! SIDE - CHARACTER*1. ! On entry, SIDE specifies whether the symmetric matrix A ! appears on the left or right in the operation as follows: ! ! SIDE = 'L' or 'l' C := alpha*A*B + beta*C, ! ! SIDE = 'R' or 'r' C := alpha*B*A + beta*C, ! ! Unchanged on exit. ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the symmetric matrix A is to be ! referenced as follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of the ! symmetric matrix is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of the ! symmetric matrix is to be referenced. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix C. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix C. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is ! m when SIDE = 'L' or 'l' and is n otherwise. ! Before entry with SIDE = 'L' or 'l', the m by m part of ! the array A must contain the symmetric matrix, such that ! when UPLO = 'U' or 'u', the leading m by m upper triangular ! part of the array A must contain the upper triangular part ! of the symmetric matrix and the strictly lower triangular ! part of A is not referenced, and when UPLO = 'L' or 'l', ! the leading m by m lower triangular part of the array A ! must contain the lower triangular part of the symmetric ! matrix and the strictly upper triangular part of A is not ! referenced. ! Before entry with SIDE = 'R' or 'r', the n by n part of ! the array A must contain the symmetric matrix, such that ! when UPLO = 'U' or 'u', the leading n by n upper triangular ! part of the array A must contain the upper triangular part ! of the symmetric matrix and the strictly lower triangular ! part of A is not referenced, and when UPLO = 'L' or 'l', ! the leading n by n lower triangular part of the array A ! must contain the lower triangular part of the symmetric ! matrix and the strictly upper triangular part of A is not ! referenced. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When SIDE = 'L' or 'l' then ! LDA must be at least max( 1, m ), otherwise LDA must be at ! least max( 1, n ). ! Unchanged on exit. ! ! B - COMPLEX array of DIMENSION ( LDB, n ). ! Before entry, the leading m by n part of the array B must ! contain the matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. LDB must be at least ! max( 1, m ). ! Unchanged on exit. ! ! BETA - COMPLEX . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then C need not be set on input. ! Unchanged on exit. ! ! C - COMPLEX array of DIMENSION ( LDC, n ). ! Before entry, the leading m by n part of the array C must ! contain the matrix C, except when beta is zero, in which ! case C need not be set on entry. ! On exit, the array C is overwritten by the m by n updated ! matrix. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CSYMM ! .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC COMPLEX ALPHA, BETA ! .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, K, NROWA COMPLEX TEMP1, TEMP2 ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) !***FIRST EXECUTABLE STATEMENT CSYMM ! ! Set NROWA as the number of rows of A. ! if ( LSAME( SIDE, 'L' ) )THEN NROWA = M ELSE NROWA = N end if UPPER = LSAME( UPLO, 'U' ) ! ! Test the input parameters. ! INFO = 0 if ( ( .NOT.LSAME( SIDE, 'L' ) ).AND. & ( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE if ( M < 0 )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDB < MAX( 1, M ) )THEN INFO = 9 ELSE if ( LDC < MAX( 1, M ) )THEN INFO = 12 end if if ( INFO /= 0 )THEN call XERBLA( 'CSYMM ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if return end if ! ! Start the operations. ! if ( LSAME( SIDE, 'L' ) )THEN ! ! Form C := alpha*A*B + beta*C. ! if ( UPPER )THEN DO 70, J = 1, N DO 60, I = 1, M TEMP1 = ALPHA*B( I, J ) TEMP2 = ZERO DO 50, K = 1, I - 1 C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) TEMP2 = TEMP2 + B( K, J )*A( K, I ) 50 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & TEMP1*A( I, I ) + ALPHA*TEMP2 end if 60 CONTINUE 70 CONTINUE ELSE DO 100, J = 1, N DO 90, I = M, 1, -1 TEMP1 = ALPHA*B( I, J ) TEMP2 = ZERO DO 80, K = I + 1, M C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) TEMP2 = TEMP2 + B( K, J )*A( K, I ) 80 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & TEMP1*A( I, I ) + ALPHA*TEMP2 end if 90 CONTINUE 100 CONTINUE end if ELSE ! ! Form C := alpha*B*A + beta*C. ! DO 170, J = 1, N TEMP1 = ALPHA*A( J, J ) if ( BETA == ZERO )THEN DO 110, I = 1, M C( I, J ) = TEMP1*B( I, J ) 110 CONTINUE ELSE DO 120, I = 1, M C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) 120 CONTINUE end if DO 140, K = 1, J - 1 if ( UPPER )THEN TEMP1 = ALPHA*A( K, J ) ELSE TEMP1 = ALPHA*A( J, K ) end if DO 130, I = 1, M C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 130 CONTINUE 140 CONTINUE DO 160, K = J + 1, N if ( UPPER )THEN TEMP1 = ALPHA*A( J, K ) ELSE TEMP1 = ALPHA*A( K, J ) end if DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 150 CONTINUE 160 CONTINUE 170 CONTINUE end if ! return ! ! End of CSYMM . ! end subroutine CSYR2K (UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, & C, LDC) ! !! CSYR2K performs symmetric rank 2k update of a complex symmetric matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE COMPLEX (SSYR2-S, DSYR2-D, CSYR2-C, CSYR2K-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! CSYR2K performs one of the symmetric rank 2k operations ! ! C := alpha*A*B' + alpha*B*A' + beta*C, ! ! or ! ! C := alpha*A'*B + alpha*B'*A + beta*C, ! ! where alpha and beta are scalars, C is an n by n symmetric matrix ! and A and B are n by k matrices in the first case and k by n ! matrices in the second case. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array C is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of C ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of C ! is to be referenced. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + ! beta*C. ! ! TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + ! beta*C. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with TRANS = 'N' or 'n', K specifies the number ! of columns of the matrices A and B, and on entry with ! TRANS = 'T' or 't', K specifies the number of rows of the ! matrices A and B. K must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array A must contain the matrix A, otherwise ! the leading k by n part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDA must be at least max( 1, n ), otherwise LDA must ! be at least max( 1, k ). ! Unchanged on exit. ! ! B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array B must contain the matrix B, otherwise ! the leading k by n part of the array B must contain the ! matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDB must be at least max( 1, n ), otherwise LDB must ! be at least max( 1, k ). ! Unchanged on exit. ! ! BETA - COMPLEX . ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! C - COMPLEX array of DIMENSION ( LDC, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array C must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of C is not referenced. On exit, the ! upper triangular part of the array C is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array C must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of C is not referenced. On exit, the ! lower triangular part of the array C is overwritten by the ! lower triangular part of the updated matrix. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CSYR2K ! .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC COMPLEX ALPHA, BETA ! .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, L, NROWA COMPLEX TEMP1, TEMP2 ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) !***FIRST EXECUTABLE STATEMENT CSYR2K ! ! Test the input parameters. ! if ( LSAME( TRANS, 'N' ) )THEN NROWA = N ELSE NROWA = K end if UPPER = LSAME( UPLO, 'U' ) ! INFO = 0 if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.LSAME( TRANS, 'N' ) ).AND. & ( .NOT.LSAME( TRANS, 'T' ) ) )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( K < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDB < MAX( 1, NROWA ) )THEN INFO = 9 ELSE if ( LDC < MAX( 1, N ) )THEN INFO = 12 end if if ( INFO /= 0 )THEN call XERBLA( 'CSYR2K', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( UPPER )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, J C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, J C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if ELSE if ( BETA == ZERO )THEN DO 60, J = 1, N DO 50, I = J, N C( I, J ) = ZERO 50 CONTINUE 60 CONTINUE ELSE DO 80, J = 1, N DO 70, I = J, N C( I, J ) = BETA*C( I, J ) 70 CONTINUE 80 CONTINUE end if end if return end if ! ! Start the operations. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form C := alpha*A*B' + alpha*B*A' + C. ! if ( UPPER )THEN DO 130, J = 1, N if ( BETA == ZERO )THEN DO 90, I = 1, J C( I, J ) = ZERO 90 CONTINUE ELSE if ( BETA /= ONE )THEN DO 100, I = 1, J C( I, J ) = BETA*C( I, J ) 100 CONTINUE end if DO 120, L = 1, K if ( ( A( J, L ) /= ZERO ).OR. & ( B( J, L ) /= ZERO ) )THEN TEMP1 = ALPHA*B( J, L ) TEMP2 = ALPHA*A( J, L ) DO 110, I = 1, J C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + & B( I, L )*TEMP2 110 CONTINUE end if 120 CONTINUE 130 CONTINUE ELSE DO 180, J = 1, N if ( BETA == ZERO )THEN DO 140, I = J, N C( I, J ) = ZERO 140 CONTINUE ELSE if ( BETA /= ONE )THEN DO 150, I = J, N C( I, J ) = BETA*C( I, J ) 150 CONTINUE end if DO 170, L = 1, K if ( ( A( J, L ) /= ZERO ).OR. & ( B( J, L ) /= ZERO ) )THEN TEMP1 = ALPHA*B( J, L ) TEMP2 = ALPHA*A( J, L ) DO 160, I = J, N C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + & B( I, L )*TEMP2 160 CONTINUE end if 170 CONTINUE 180 CONTINUE end if ELSE ! ! Form C := alpha*A'*B + alpha*B'*A + C. ! if ( UPPER )THEN DO 210, J = 1, N DO 200, I = 1, J TEMP1 = ZERO TEMP2 = ZERO DO 190, L = 1, K TEMP1 = TEMP1 + A( L, I )*B( L, J ) TEMP2 = TEMP2 + B( L, I )*A( L, J ) 190 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & ALPHA*TEMP1 + ALPHA*TEMP2 end if 200 CONTINUE 210 CONTINUE ELSE DO 240, J = 1, N DO 230, I = J, N TEMP1 = ZERO TEMP2 = ZERO DO 220, L = 1, K TEMP1 = TEMP1 + A( L, I )*B( L, J ) TEMP2 = TEMP2 + B( L, I )*A( L, J ) 220 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & ALPHA*TEMP1 + ALPHA*TEMP2 end if 230 CONTINUE 240 CONTINUE end if end if ! return end subroutine CSYRK (UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) ! !! CSYRK performs symmetric rank k update of a complex symmetric matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE COMPLEX (SSYRK-S, DSYRK-D, CSYRK-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! CSYRK performs one of the symmetric rank k operations ! ! C := alpha*A*A' + beta*C, ! ! or ! ! C := alpha*A'*A + beta*C, ! ! where alpha and beta are scalars, C is an n by n symmetric matrix ! and A is an n by k matrix in the first case and a k by n matrix ! in the second case. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array C is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of C ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of C ! is to be referenced. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. ! ! TRANS = 'T' or 't' C := alpha*A'*A + beta*C. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with TRANS = 'N' or 'n', K specifies the number ! of columns of the matrix A, and on entry with ! TRANS = 'T' or 't', K specifies the number of rows of the ! matrix A. K must be at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array A must contain the matrix A, otherwise ! the leading k by n part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDA must be at least max( 1, n ), otherwise LDA must ! be at least max( 1, k ). ! Unchanged on exit. ! ! BETA - COMPLEX . ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! C - COMPLEX array of DIMENSION ( LDC, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array C must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of C is not referenced. On exit, the ! upper triangular part of the array C is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array C must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of C is not referenced. On exit, the ! lower triangular part of the array C is overwritten by the ! lower triangular part of the updated matrix. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CSYRK ! .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC COMPLEX ALPHA, BETA ! .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, L, NROWA COMPLEX TEMP ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) !***FIRST EXECUTABLE STATEMENT CSYRK ! ! Test the input parameters. ! if ( LSAME( TRANS, 'N' ) )THEN NROWA = N ELSE NROWA = K end if UPPER = LSAME( UPLO, 'U' ) ! INFO = 0 if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.LSAME( TRANS, 'N' ) ).AND. & ( .NOT.LSAME( TRANS, 'T' ) ) )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( K < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDC < MAX( 1, N ) )THEN INFO = 10 end if if ( INFO /= 0 )THEN call XERBLA( 'CSYRK ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( UPPER )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, J C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, J C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if ELSE if ( BETA == ZERO )THEN DO 60, J = 1, N DO 50, I = J, N C( I, J ) = ZERO 50 CONTINUE 60 CONTINUE ELSE DO 80, J = 1, N DO 70, I = J, N C( I, J ) = BETA*C( I, J ) 70 CONTINUE 80 CONTINUE end if end if return end if ! ! Start the operations. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form C := alpha*A*A' + beta*C. ! if ( UPPER )THEN DO 130, J = 1, N if ( BETA == ZERO )THEN DO 90, I = 1, J C( I, J ) = ZERO 90 CONTINUE ELSE if ( BETA /= ONE )THEN DO 100, I = 1, J C( I, J ) = BETA*C( I, J ) 100 CONTINUE end if DO 120, L = 1, K if ( A( J, L ) /= ZERO )THEN TEMP = ALPHA*A( J, L ) DO 110, I = 1, J C( I, J ) = C( I, J ) + TEMP*A( I, L ) 110 CONTINUE end if 120 CONTINUE 130 CONTINUE ELSE DO 180, J = 1, N if ( BETA == ZERO )THEN DO 140, I = J, N C( I, J ) = ZERO 140 CONTINUE ELSE if ( BETA /= ONE )THEN DO 150, I = J, N C( I, J ) = BETA*C( I, J ) 150 CONTINUE end if DO 170, L = 1, K if ( A( J, L ) /= ZERO )THEN TEMP = ALPHA*A( J, L ) DO 160, I = J, N C( I, J ) = C( I, J ) + TEMP*A( I, L ) 160 CONTINUE end if 170 CONTINUE 180 CONTINUE end if ELSE ! ! Form C := alpha*A'*A + beta*C. ! if ( UPPER )THEN DO 210, J = 1, N DO 200, I = 1, J TEMP = ZERO DO 190, L = 1, K TEMP = TEMP + A( L, I )*A( L, J ) 190 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 200 CONTINUE 210 CONTINUE ELSE DO 240, J = 1, N DO 230, I = J, N TEMP = ZERO DO 220, L = 1, K TEMP = TEMP + A( L, I )*A( L, J ) 220 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 230 CONTINUE 240 CONTINUE end if end if ! return ! ! End of CSYRK . ! end FUNCTION CTAN (Z) ! !! CTAN computes the complex tangent. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE COMPLEX (CTAN-C) !***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, TANGENT, TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CTAN(Z) calculates the complex trigonometric tangent of complex ! argument Z. Z is in units of radians. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERCLR, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE CTAN COMPLEX CTAN COMPLEX Z SAVE SQEPS DATA SQEPS /0./ !***FIRST EXECUTABLE STATEMENT CTAN if (SQEPS == 0.) SQEPS = SQRT (R1MACH(4)) ! X2 = 2.0*REAL(Z) Y2 = 2.0*AIMAG(Z) ! SN2X = SIN (X2) call XERCLR ! DEN = COS(X2) + COSH(Y2) if (DEN == 0.) call XERMSG ('SLATEC', 'CTAN', & 'TAN IS SINGULAR FOR INPUT Z (X IS PI/2 OR 3*PI/2 AND Y IS 0)', & 2, 2) ! if (ABS(DEN) > MAX(ABS(X2),1.)*SQEPS) go to 10 call XERCLR call XERMSG ('SLATEC', 'CTAN', & 'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X TOO NEAR ' // & 'PI/2 OR 3*PI/2', 1, 1) ! 10 CTAN = CMPLX (SN2X/DEN, SINH(Y2)/DEN) ! return end FUNCTION CTANH (Z) ! !! CTANH computes the complex hyperbolic tangent. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE COMPLEX (CTANH-C) !***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, HYPERBOLIC TANGENT !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! CTANH(Z) calculates the complex hyperbolic tangent of complex ! argument Z. Z is in units of radians. ! !***REFERENCES (NONE) !***ROUTINES CALLED CTAN !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CTANH COMPLEX CTANH COMPLEX Z, CI, CTAN SAVE CI DATA CI /(0.,1.)/ !***FIRST EXECUTABLE STATEMENT CTANH CTANH = -CI*CTAN(CI*Z) ! return end subroutine CTBMV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) ! !! CTBMV multiplies a complex vector by a complex triangular band matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (STBMV-S, DTBMV-D, CTBMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CTBMV performs one of the matrix-vector operations ! ! x := A*x, or x := A'*x, or x := conjg( A')*x, ! ! where x is an n element vector and A is an n by n unit, or non-unit, ! upper or lower triangular band matrix, with ( k + 1 ) diagonals. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' x := A*x. ! ! TRANS = 'T' or 't' x := A'*x. ! ! TRANS = 'C' or 'c' x := conjg( A' )*x. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with UPLO = 'U' or 'u', K specifies the number of ! super-diagonals of the matrix A. ! On entry with UPLO = 'L' or 'l', K specifies the number of ! sub-diagonals of the matrix A. ! K must satisfy 0 .le. K. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) ! by n part of the array A must contain the upper triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. The top left k by k triangle ! of the array A is not referenced. ! The following program segment will transfer an upper ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = K + 1 - J ! DO 10, I = MAX( 1, J - K ), J ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) ! by n part of the array A must contain the lower triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. The bottom right k by k triangle of the ! array A is not referenced. ! The following program segment will transfer a lower ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = 1 - J ! DO 10, I = J, MIN( N, J + K ) ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Note that when DIAG = 'U' or 'u' the elements of the array A ! corresponding to the diagonal elements of the matrix are not ! referenced, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( k + 1 ). ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. On exit, X is overwritten with the ! transformed vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CTBMV ! .. Scalar Arguments .. INTEGER INCX, K, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L LOGICAL NOCONJ, NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN !***FIRST EXECUTABLE STATEMENT CTBMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( K < 0 )THEN INFO = 5 ELSE if ( LDA < ( K + 1 ) )THEN INFO = 7 ELSE if ( INCX == 0 )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'CTBMV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := A*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = X( J ) L = KPLUS1 - J DO 10, I = MAX( 1, J - K ), J - 1 X( I ) = X( I ) + TEMP*A( L + I, J ) 10 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( KPLUS1, J ) end if 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX L = KPLUS1 - J DO 30, I = MAX( 1, J - K ), J - 1 X( IX ) = X( IX ) + TEMP*A( L + I, J ) IX = IX + INCX 30 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( KPLUS1, J ) end if JX = JX + INCX if ( J > K ) & KX = KX + INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = N, 1, -1 if ( X( J ) /= ZERO )THEN TEMP = X( J ) L = 1 - J DO 50, I = MIN( N, J + K ), J + 1, -1 X( I ) = X( I ) + TEMP*A( L + I, J ) 50 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( 1, J ) end if 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX L = 1 - J DO 70, I = MIN( N, J + K ), J + 1, -1 X( IX ) = X( IX ) + TEMP*A( L + I, J ) IX = IX - INCX 70 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( 1, J ) end if JX = JX - INCX if ( ( N - J ) >= K ) & KX = KX - INCX 80 CONTINUE end if end if ELSE ! ! Form x := A'*x or x := conjg( A' )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 110, J = N, 1, -1 TEMP = X( J ) L = KPLUS1 - J if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*A( KPLUS1, J ) DO 90, I = J - 1, MAX( 1, J - K ), -1 TEMP = TEMP + A( L + I, J )*X( I ) 90 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( A( KPLUS1, J ) ) DO 100, I = J - 1, MAX( 1, J - K ), -1 TEMP = TEMP + CONJG( A( L + I, J ) )*X( I ) 100 CONTINUE end if X( J ) = TEMP 110 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 140, J = N, 1, -1 TEMP = X( JX ) KX = KX - INCX IX = KX L = KPLUS1 - J if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*A( KPLUS1, J ) DO 120, I = J - 1, MAX( 1, J - K ), -1 TEMP = TEMP + A( L + I, J )*X( IX ) IX = IX - INCX 120 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( A( KPLUS1, J ) ) DO 130, I = J - 1, MAX( 1, J - K ), -1 TEMP = TEMP + CONJG( A( L + I, J ) )*X( IX ) IX = IX - INCX 130 CONTINUE end if X( JX ) = TEMP JX = JX - INCX 140 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 170, J = 1, N TEMP = X( J ) L = 1 - J if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*A( 1, J ) DO 150, I = J + 1, MIN( N, J + K ) TEMP = TEMP + A( L + I, J )*X( I ) 150 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( A( 1, J ) ) DO 160, I = J + 1, MIN( N, J + K ) TEMP = TEMP + CONJG( A( L + I, J ) )*X( I ) 160 CONTINUE end if X( J ) = TEMP 170 CONTINUE ELSE JX = KX DO 200, J = 1, N TEMP = X( JX ) KX = KX + INCX IX = KX L = 1 - J if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*A( 1, J ) DO 180, I = J + 1, MIN( N, J + K ) TEMP = TEMP + A( L + I, J )*X( IX ) IX = IX + INCX 180 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( A( 1, J ) ) DO 190, I = J + 1, MIN( N, J + K ) TEMP = TEMP + CONJG( A( L + I, J ) )*X( IX ) IX = IX + INCX 190 CONTINUE end if X( JX ) = TEMP JX = JX + INCX 200 CONTINUE end if end if end if ! return ! ! End of CTBMV . ! end subroutine CTBSV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) ! !! CTBSV solves a complex triangular banded system of equations. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (STBSV-S, DTBSV-D, CTBSV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CTBSV solves one of the systems of equations ! ! A*x = b, or A'*x = b, or conjg( A')*x = b, ! ! where b and x are n element vectors and A is an n by n unit, or ! non-unit, upper or lower triangular band matrix, with ( k + 1 ) ! diagonals. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the equations to be solved as ! follows: ! ! TRANS = 'N' or 'n' A*x = b. ! ! TRANS = 'T' or 't' A'*x = b. ! ! TRANS = 'C' or 'c' conjg( A' )*x = b. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with UPLO = 'U' or 'u', K specifies the number of ! super-diagonals of the matrix A. ! On entry with UPLO = 'L' or 'l', K specifies the number of ! sub-diagonals of the matrix A. ! K must satisfy 0 .le. K. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) ! by n part of the array A must contain the upper triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. The top left k by k triangle ! of the array A is not referenced. ! The following program segment will transfer an upper ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = K + 1 - J ! DO 10, I = MAX( 1, J - K ), J ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) ! by n part of the array A must contain the lower triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. The bottom right k by k triangle of the ! array A is not referenced. ! The following program segment will transfer a lower ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = 1 - J ! DO 10, I = J, MIN( N, J + K ) ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Note that when DIAG = 'U' or 'u' the elements of the array A ! corresponding to the diagonal elements of the matrix are not ! referenced, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( k + 1 ). ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element right-hand side vector b. On exit, X is overwritten ! with the solution vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CTBSV ! .. Scalar Arguments .. INTEGER INCX, K, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L LOGICAL NOCONJ, NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN !***FIRST EXECUTABLE STATEMENT CTBSV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( K < 0 )THEN INFO = 5 ELSE if ( LDA < ( K + 1 ) )THEN INFO = 7 ELSE if ( INCX == 0 )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'CTBSV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed by sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := inv( A )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 20, J = N, 1, -1 if ( X( J ) /= ZERO )THEN L = KPLUS1 - J if ( NOUNIT ) & X( J ) = X( J )/A( KPLUS1, J ) TEMP = X( J ) DO 10, I = J - 1, MAX( 1, J - K ), -1 X( I ) = X( I ) - TEMP*A( L + I, J ) 10 CONTINUE end if 20 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 40, J = N, 1, -1 KX = KX - INCX if ( X( JX ) /= ZERO )THEN IX = KX L = KPLUS1 - J if ( NOUNIT ) & X( JX ) = X( JX )/A( KPLUS1, J ) TEMP = X( JX ) DO 30, I = J - 1, MAX( 1, J - K ), -1 X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX - INCX 30 CONTINUE end if JX = JX - INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN L = 1 - J if ( NOUNIT ) & X( J ) = X( J )/A( 1, J ) TEMP = X( J ) DO 50, I = J + 1, MIN( N, J + K ) X( I ) = X( I ) - TEMP*A( L + I, J ) 50 CONTINUE end if 60 CONTINUE ELSE JX = KX DO 80, J = 1, N KX = KX + INCX if ( X( JX ) /= ZERO )THEN IX = KX L = 1 - J if ( NOUNIT ) & X( JX ) = X( JX )/A( 1, J ) TEMP = X( JX ) DO 70, I = J + 1, MIN( N, J + K ) X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX + INCX 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if end if ELSE ! ! Form x := inv( A' )*x or x := inv( conjg( A') )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 110, J = 1, N TEMP = X( J ) L = KPLUS1 - J if ( NOCONJ )THEN DO 90, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( I ) 90 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( KPLUS1, J ) ELSE DO 100, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - CONJG( A( L + I, J ) )*X( I ) 100 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( A( KPLUS1, J ) ) end if X( J ) = TEMP 110 CONTINUE ELSE JX = KX DO 140, J = 1, N TEMP = X( JX ) IX = KX L = KPLUS1 - J if ( NOCONJ )THEN DO 120, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX + INCX 120 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( KPLUS1, J ) ELSE DO 130, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - CONJG( A( L + I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( A( KPLUS1, J ) ) end if X( JX ) = TEMP JX = JX + INCX if ( J > K ) & KX = KX + INCX 140 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 170, J = N, 1, -1 TEMP = X( J ) L = 1 - J if ( NOCONJ )THEN DO 150, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( I ) 150 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( 1, J ) ELSE DO 160, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - CONJG( A( L + I, J ) )*X( I ) 160 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( A( 1, J ) ) end if X( J ) = TEMP 170 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 200, J = N, 1, -1 TEMP = X( JX ) IX = KX L = 1 - J if ( NOCONJ )THEN DO 180, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX - INCX 180 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( 1, J ) ELSE DO 190, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - CONJG( A( L + I, J ) )*X( IX ) IX = IX - INCX 190 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( A( 1, J ) ) end if X( JX ) = TEMP JX = JX - INCX if ( ( N - J ) >= K ) & KX = KX - INCX 200 CONTINUE end if end if end if ! return ! ! End of CTBSV . ! end subroutine CTPMV (UPLO, TRANS, DIAG, N, AP, X, INCX) ! !! CTPMV performs one of the matrix-vector operations. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (STPMV-S, DTPMV-D, CTPMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CTPMV performs one of the matrix-vector operations ! ! x := A*x, or x := A'*x, or x := conjg( A')*x, ! ! where x is an n element vector and A is an n by n unit, or non-unit, ! upper or lower triangular matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' x := A*x. ! ! TRANS = 'T' or 't' x := A'*x. ! ! TRANS = 'C' or 'c' x := conjg( A' )*x. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! AP - COMPLEX array of DIMENSION at least ! ( ( n*( n + 1 ) )/2 ). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) ! respectively, and so on. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) ! respectively, and so on. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced, but are assumed to be unity. ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. On exit, X is overwritten with the ! transformed vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CTPMV ! .. Scalar Arguments .. INTEGER INCX, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. COMPLEX AP( * ), X( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX LOGICAL NOCONJ, NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG !***FIRST EXECUTABLE STATEMENT CTPMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( INCX == 0 )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'CTPMV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x:= A*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK = 1 if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = X( J ) K = KK DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*AP( K ) K = K + 1 10 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*AP( KK + J - 1 ) end if KK = KK + J 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 30, K = KK, KK + J - 2 X( IX ) = X( IX ) + TEMP*AP( K ) IX = IX + INCX 30 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*AP( KK + J - 1 ) end if JX = JX + INCX KK = KK + J 40 CONTINUE end if ELSE KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 60, J = N, 1, -1 if ( X( J ) /= ZERO )THEN TEMP = X( J ) K = KK DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*AP( K ) K = K - 1 50 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*AP( KK - N + J ) end if KK = KK - ( N - J + 1 ) 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 X( IX ) = X( IX ) + TEMP*AP( K ) IX = IX - INCX 70 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*AP( KK - N + J ) end if JX = JX - INCX KK = KK - ( N - J + 1 ) 80 CONTINUE end if end if ELSE ! ! Form x := A'*x or x := conjg( A' )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 110, J = N, 1, -1 TEMP = X( J ) K = KK - 1 if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*AP( KK ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + AP( K )*X( I ) K = K - 1 90 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( AP( KK ) ) DO 100, I = J - 1, 1, -1 TEMP = TEMP + CONJG( AP( K ) )*X( I ) K = K - 1 100 CONTINUE end if X( J ) = TEMP KK = KK - J 110 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 140, J = N, 1, -1 TEMP = X( JX ) IX = JX if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*AP( KK ) DO 120, K = KK - 1, KK - J + 1, -1 IX = IX - INCX TEMP = TEMP + AP( K )*X( IX ) 120 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( AP( KK ) ) DO 130, K = KK - 1, KK - J + 1, -1 IX = IX - INCX TEMP = TEMP + CONJG( AP( K ) )*X( IX ) 130 CONTINUE end if X( JX ) = TEMP JX = JX - INCX KK = KK - J 140 CONTINUE end if ELSE KK = 1 if ( INCX == 1 )THEN DO 170, J = 1, N TEMP = X( J ) K = KK + 1 if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*AP( KK ) DO 150, I = J + 1, N TEMP = TEMP + AP( K )*X( I ) K = K + 1 150 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( AP( KK ) ) DO 160, I = J + 1, N TEMP = TEMP + CONJG( AP( K ) )*X( I ) K = K + 1 160 CONTINUE end if X( J ) = TEMP KK = KK + ( N - J + 1 ) 170 CONTINUE ELSE JX = KX DO 200, J = 1, N TEMP = X( JX ) IX = JX if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*AP( KK ) DO 180, K = KK + 1, KK + N - J IX = IX + INCX TEMP = TEMP + AP( K )*X( IX ) 180 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( AP( KK ) ) DO 190, K = KK + 1, KK + N - J IX = IX + INCX TEMP = TEMP + CONJG( AP( K ) )*X( IX ) 190 CONTINUE end if X( JX ) = TEMP JX = JX + INCX KK = KK + ( N - J + 1 ) 200 CONTINUE end if end if end if ! return end subroutine CTPSV (UPLO, TRANS, DIAG, N, AP, X, INCX) ! !! CTPSV solves a triangular system of linear equations. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (STPSV-S, DTPSV-D, CTPSV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CTPSV solves one of the systems of equations ! ! A*x = b, or A'*x = b, or conjg( A')*x = b, ! ! where b and x are n element vectors and A is an n by n unit, or ! non-unit, upper or lower triangular matrix, supplied in packed form. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the equations to be solved as ! follows: ! ! TRANS = 'N' or 'n' A*x = b. ! ! TRANS = 'T' or 't' A'*x = b. ! ! TRANS = 'C' or 'c' conjg( A' )*x = b. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! AP - COMPLEX array of DIMENSION at least ! ( ( n*( n + 1 ) )/2 ). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) ! respectively, and so on. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) ! respectively, and so on. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced, but are assumed to be unity. ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element right-hand side vector b. On exit, X is overwritten ! with the solution vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CTPSV ! .. Scalar Arguments .. INTEGER INCX, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. COMPLEX AP( * ), X( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX LOGICAL NOCONJ, NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG !***FIRST EXECUTABLE STATEMENT CTPSV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( INCX == 0 )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'CTPSV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := inv( A )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 20, J = N, 1, -1 if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/AP( KK ) TEMP = X( J ) K = KK - 1 DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*AP( K ) K = K - 1 10 CONTINUE end if KK = KK - J 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/AP( KK ) TEMP = X( JX ) IX = JX DO 30, K = KK - 1, KK - J + 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*AP( K ) 30 CONTINUE end if JX = JX - INCX KK = KK - J 40 CONTINUE end if ELSE KK = 1 if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/AP( KK ) TEMP = X( J ) K = KK + 1 DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*AP( K ) K = K + 1 50 CONTINUE end if KK = KK + ( N - J + 1 ) 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/AP( KK ) TEMP = X( JX ) IX = JX DO 70, K = KK + 1, KK + N - J IX = IX + INCX X( IX ) = X( IX ) - TEMP*AP( K ) 70 CONTINUE end if JX = JX + INCX KK = KK + ( N - J + 1 ) 80 CONTINUE end if end if ELSE ! ! Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK = 1 if ( INCX == 1 )THEN DO 110, J = 1, N TEMP = X( J ) K = KK if ( NOCONJ )THEN DO 90, I = 1, J - 1 TEMP = TEMP - AP( K )*X( I ) K = K + 1 90 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK + J - 1 ) ELSE DO 100, I = 1, J - 1 TEMP = TEMP - CONJG( AP( K ) )*X( I ) K = K + 1 100 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( AP( KK + J - 1 ) ) end if X( J ) = TEMP KK = KK + J 110 CONTINUE ELSE JX = KX DO 140, J = 1, N TEMP = X( JX ) IX = KX if ( NOCONJ )THEN DO 120, K = KK, KK + J - 2 TEMP = TEMP - AP( K )*X( IX ) IX = IX + INCX 120 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK + J - 1 ) ELSE DO 130, K = KK, KK + J - 2 TEMP = TEMP - CONJG( AP( K ) )*X( IX ) IX = IX + INCX 130 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( AP( KK + J - 1 ) ) end if X( JX ) = TEMP JX = JX + INCX KK = KK + J 140 CONTINUE end if ELSE KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 170, J = N, 1, -1 TEMP = X( J ) K = KK if ( NOCONJ )THEN DO 150, I = N, J + 1, -1 TEMP = TEMP - AP( K )*X( I ) K = K - 1 150 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK - N + J ) ELSE DO 160, I = N, J + 1, -1 TEMP = TEMP - CONJG( AP( K ) )*X( I ) K = K - 1 160 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( AP( KK - N + J ) ) end if X( J ) = TEMP KK = KK - ( N - J + 1 ) 170 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 200, J = N, 1, -1 TEMP = X( JX ) IX = KX if ( NOCONJ )THEN DO 180, K = KK, KK - ( N - ( J + 1 ) ), -1 TEMP = TEMP - AP( K )*X( IX ) IX = IX - INCX 180 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK - N + J ) ELSE DO 190, K = KK, KK - ( N - ( J + 1 ) ), -1 TEMP = TEMP - CONJG( AP( K ) )*X( IX ) IX = IX - INCX 190 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( AP( KK - N + J ) ) end if X( JX ) = TEMP JX = JX - INCX KK = KK - ( N - J + 1 ) 200 CONTINUE end if end if end if ! return ! ! End of CTPSV . ! end subroutine CTRCO (T, LDT, N, RCOND, Z, JOB) ! !! CTRCO estimates the condition number of a triangular matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C3 !***TYPE COMPLEX (STRCO-S, DTRCO-D, CTRCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! TRIANGULAR MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CTRCO estimates the condition of a complex triangular matrix. ! ! On Entry ! ! T COMPLEX(LDT,N) ! T contains the triangular matrix. The zero ! elements of the matrix are not referenced, and ! the corresponding elements of the array can be ! used to store other information. ! ! LDT INTEGER ! LDT is the leading dimension of the array T. ! ! N INTEGER ! N is the order of the system. ! ! JOB INTEGER ! = 0 T is lower triangular. ! = nonzero T is upper triangular. ! ! On Return ! ! RCOND REAL ! an estimate of the reciprocal condition of T . ! For the system T*X = B , relative perturbations ! in T and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then T may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z COMPLEX(N) ! a work vector whose contents are usually unimportant. ! If T is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSSCAL, SCASUM !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CTRCO INTEGER LDT,N,JOB COMPLEX T(LDT,*),Z(*) REAL RCOND ! COMPLEX W,WK,WKM,EK REAL TNORM,YNORM,S,SM,SCASUM INTEGER I1,J,J1,J2,K,KK,L LOGICAL LOWER COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2)) ! !***FIRST EXECUTABLE STATEMENT CTRCO LOWER = JOB == 0 ! ! COMPUTE 1-NORM OF T ! TNORM = 0.0E0 DO 10 J = 1, N L = J if (LOWER) L = N + 1 - J I1 = 1 if (LOWER) I1 = J TNORM = MAX(TNORM,SCASUM(L,T(I1,J),1)) 10 CONTINUE ! ! RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND CTRANS(T)*Y = E . ! CTRANS(T) IS THE CONJUGATE TRANSPOSE OF T . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF Y . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE CTRANS(T)*Y = E ! EK = (1.0E0,0.0E0) DO 20 J = 1, N Z(J) = (0.0E0,0.0E0) 20 CONTINUE DO 100 KK = 1, N K = KK if (LOWER) K = N + 1 - KK if (CABS1(Z(K)) /= 0.0E0) EK = CSIGN1(EK,-Z(K)) if (CABS1(EK-Z(K)) <= CABS1(T(K,K))) go to 30 S = CABS1(T(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(T(K,K)) == 0.0E0) go to 40 WK = WK/CONJG(T(K,K)) WKM = WKM/CONJG(T(K,K)) go to 50 40 CONTINUE WK = (1.0E0,0.0E0) WKM = (1.0E0,0.0E0) 50 CONTINUE if (KK == N) go to 90 J1 = K + 1 if (LOWER) J1 = 1 J2 = N if (LOWER) J2 = K - 1 DO 60 J = J1, J2 SM = SM + CABS1(Z(J)+WKM*CONJG(T(K,J))) Z(J) = Z(J) + WK*CONJG(T(K,J)) S = S + CABS1(Z(J)) 60 CONTINUE if (S >= SM) go to 80 W = WKM - WK WK = WKM DO 70 J = J1, J2 Z(J) = Z(J) + W*CONJG(T(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) ! YNORM = 1.0E0 ! ! SOLVE T*Z = Y ! DO 130 KK = 1, N K = N + 1 - KK if (LOWER) K = KK if (CABS1(Z(K)) <= CABS1(T(K,K))) go to 110 S = CABS1(T(K,K))/CABS1(Z(K)) call CSSCAL(N,S,Z,1) YNORM = S*YNORM 110 CONTINUE if (CABS1(T(K,K)) /= 0.0E0) Z(K) = Z(K)/T(K,K) if (CABS1(T(K,K)) == 0.0E0) Z(K) = (1.0E0,0.0E0) I1 = 1 if (LOWER) I1 = K + 1 if (KK >= N) go to 120 W = -Z(K) call CAXPY(N-KK,W,T(I1,K),1,Z(I1),1) 120 CONTINUE 130 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) call CSSCAL(N,S,Z,1) YNORM = S*YNORM ! if (TNORM /= 0.0E0) RCOND = YNORM/TNORM if (TNORM == 0.0E0) RCOND = 0.0E0 return end subroutine CTRDI (T, LDT, N, DET, JOB, INFO) ! !! CTRDI computes the determinant and inverse of a triangular matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C3, D3C3 !***TYPE COMPLEX (STRDI-S, DTRDI-D, CTRDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, ! TRIANGULAR MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! CTRDI computes the determinant and inverse of a complex ! triangular matrix. ! ! On Entry ! ! T COMPLEX(LDT,N) ! T contains the triangular matrix. The zero ! elements of the matrix are not referenced, and ! the corresponding elements of the array can be ! used to store other information. ! ! LDT INTEGER ! LDT is the leading dimension of the array T. ! ! N INTEGER ! N is the order of the system. ! ! JOB INTEGER ! = 010 no det, inverse of lower triangular. ! = 011 no det, inverse of upper triangular. ! = 100 det, no inverse. ! = 110 det, inverse of lower triangular. ! = 111 det, inverse of upper triangular. ! ! On Return ! ! T inverse of original matrix if requested. ! Otherwise unchanged. ! ! DET COMPLEX(2) ! determinant of original matrix if requested. ! Otherwise not referenced. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= CABS1(DET(1)) < 10.0 ! or DET(1) == 0.0 . ! ! INFO INTEGER ! INFO contains zero if the system is nonsingular ! and the inverse is requested. ! Otherwise INFO contains the index of ! a zero diagonal element of T. ! ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CTRDI INTEGER LDT,N,JOB,INFO COMPLEX T(LDT,*),DET(2) ! COMPLEX TEMP REAL TEN INTEGER I,J,K,KB,KM1,KP1 COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT CTRDI ! ! COMPUTE DETERMINANT ! if (JOB/100 == 0) go to 70 DET(1) = (1.0E0,0.0E0) DET(2) = (0.0E0,0.0E0) TEN = 10.0E0 DO 50 I = 1, N DET(1) = T(I,I)*DET(1) if (CABS1(DET(1)) == 0.0E0) go to 60 10 if (CABS1(DET(1)) >= 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)) < 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 ! ! COMPUTE INVERSE OF UPPER TRIANGULAR ! if (MOD(JOB/10,10) == 0) go to 170 if (MOD(JOB,10) == 0) go to 120 DO 100 K = 1, N INFO = K if (CABS1(T(K,K)) == 0.0E0) go to 110 T(K,K) = (1.0E0,0.0E0)/T(K,K) TEMP = -T(K,K) call CSCAL(K-1,TEMP,T(1,K),1) KP1 = K + 1 if (N < KP1) go to 90 DO 80 J = KP1, N TEMP = T(K,J) T(K,J) = (0.0E0,0.0E0) call CAXPY(K,TEMP,T(1,K),1,T(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE INFO = 0 110 CONTINUE go to 160 120 CONTINUE ! ! COMPUTE INVERSE OF LOWER TRIANGULAR ! DO 150 KB = 1, N K = N + 1 - KB INFO = K if (CABS1(T(K,K)) == 0.0E0) go to 180 T(K,K) = (1.0E0,0.0E0)/T(K,K) TEMP = -T(K,K) if (K /= N) call CSCAL(N-K,TEMP,T(K+1,K),1) KM1 = K - 1 if (KM1 < 1) go to 140 DO 130 J = 1, KM1 TEMP = T(K,J) T(K,J) = (0.0E0,0.0E0) call CAXPY(N-K+1,TEMP,T(K,K),1,T(K,J),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE INFO = 0 160 CONTINUE 170 CONTINUE 180 CONTINUE return end subroutine CTRMM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, & B, LDB) ! !! CTRMM multiplies a complex general matrix by a complex triangular matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE COMPLEX (STRMM-S, DTRMM-D, CTRMM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! CTRMM performs one of the matrix-matrix operations ! ! B := alpha*op( A )*B, or B := alpha*B*op( A ) ! ! where alpha is a scalar, B is an m by n matrix, A is a unit, or ! non-unit, upper or lower triangular matrix and op( A ) is one of ! ! op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). ! ! Parameters ! ========== ! ! SIDE - CHARACTER*1. ! On entry, SIDE specifies whether op( A ) multiplies B from ! the left or right as follows: ! ! SIDE = 'L' or 'l' B := alpha*op( A )*B. ! ! SIDE = 'R' or 'r' B := alpha*B*op( A ). ! ! Unchanged on exit. ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix A is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANSA - CHARACTER*1. ! On entry, TRANSA specifies the form of op( A ) to be used in ! the matrix multiplication as follows: ! ! TRANSA = 'N' or 'n' op( A ) = A. ! ! TRANSA = 'T' or 't' op( A ) = A'. ! ! TRANSA = 'C' or 'c' op( A ) = conjg( A' ). ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit triangular ! as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of B. M must be at ! least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of B. N must be ! at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. When alpha is ! zero then A is not referenced and B need not be set before ! entry. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, k ), where k is m ! when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. ! Before entry with UPLO = 'U' or 'u', the leading k by k ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading k by k ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When SIDE = 'L' or 'l' then ! LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' ! then LDA must be at least max( 1, n ). ! Unchanged on exit. ! ! B - COMPLEX array of DIMENSION ( LDB, n ). ! Before entry, the leading m by n part of the array B must ! contain the matrix B, and on exit is overwritten by the ! transformed matrix. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. LDB must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CTRMM ! .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB COMPLEX ALPHA ! .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX ! .. Local Scalars .. LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA COMPLEX TEMP ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) !***FIRST EXECUTABLE STATEMENT CTRMM ! ! Test the input parameters. ! LSIDE = LSAME( SIDE , 'L' ) if ( LSIDE )THEN NROWA = M ELSE NROWA = N end if NOCONJ = LSAME( TRANSA, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) ! INFO = 0 if ( ( .NOT.LSIDE ).AND. & ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE if ( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. & ( .NOT.LSAME( TRANSA, 'T' ) ).AND. & ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE if ( ( .NOT.LSAME( DIAG , 'U' ) ).AND. & ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE if ( M < 0 )THEN INFO = 5 ELSE if ( N < 0 )THEN INFO = 6 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 9 ELSE if ( LDB < MAX( 1, M ) )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'CTRMM ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE return end if ! ! Start the operations. ! if ( LSIDE )THEN if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*A*B. ! if ( UPPER )THEN DO 50, J = 1, N DO 40, K = 1, M if ( B( K, J ) /= ZERO )THEN TEMP = ALPHA*B( K, J ) DO 30, I = 1, K - 1 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 30 CONTINUE if ( NOUNIT ) & TEMP = TEMP*A( K, K ) B( K, J ) = TEMP end if 40 CONTINUE 50 CONTINUE ELSE DO 80, J = 1, N DO 70 K = M, 1, -1 if ( B( K, J ) /= ZERO )THEN TEMP = ALPHA*B( K, J ) B( K, J ) = TEMP if ( NOUNIT ) & B( K, J ) = B( K, J )*A( K, K ) DO 60, I = K + 1, M B( I, J ) = B( I, J ) + TEMP*A( I, K ) 60 CONTINUE end if 70 CONTINUE 80 CONTINUE end if ELSE ! ! Form B := alpha*B*A' or B := alpha*B*conjg( A' ). ! if ( UPPER )THEN DO 120, J = 1, N DO 110, I = M, 1, -1 TEMP = B( I, J ) if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*A( I, I ) DO 90, K = 1, I - 1 TEMP = TEMP + A( K, I )*B( K, J ) 90 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( A( I, I ) ) DO 100, K = 1, I - 1 TEMP = TEMP + CONJG( A( K, I ) )*B( K, J ) 100 CONTINUE end if B( I, J ) = ALPHA*TEMP 110 CONTINUE 120 CONTINUE ELSE DO 160, J = 1, N DO 150, I = 1, M TEMP = B( I, J ) if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*A( I, I ) DO 130, K = I + 1, M TEMP = TEMP + A( K, I )*B( K, J ) 130 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( A( I, I ) ) DO 140, K = I + 1, M TEMP = TEMP + CONJG( A( K, I ) )*B( K, J ) 140 CONTINUE end if B( I, J ) = ALPHA*TEMP 150 CONTINUE 160 CONTINUE end if end if ELSE if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*B*A. ! if ( UPPER )THEN DO 200, J = N, 1, -1 TEMP = ALPHA if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 170, I = 1, M B( I, J ) = TEMP*B( I, J ) 170 CONTINUE DO 190, K = 1, J - 1 if ( A( K, J ) /= ZERO )THEN TEMP = ALPHA*A( K, J ) DO 180, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 180 CONTINUE end if 190 CONTINUE 200 CONTINUE ELSE DO 240, J = 1, N TEMP = ALPHA if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 210, I = 1, M B( I, J ) = TEMP*B( I, J ) 210 CONTINUE DO 230, K = J + 1, N if ( A( K, J ) /= ZERO )THEN TEMP = ALPHA*A( K, J ) DO 220, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 220 CONTINUE end if 230 CONTINUE 240 CONTINUE end if ELSE ! ! Form B := alpha*B*A' or B := alpha*B*conjg( A' ). ! if ( UPPER )THEN DO 280, K = 1, N DO 260, J = 1, K - 1 if ( A( J, K ) /= ZERO )THEN if ( NOCONJ )THEN TEMP = ALPHA*A( J, K ) ELSE TEMP = ALPHA*CONJG( A( J, K ) ) end if DO 250, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 250 CONTINUE end if 260 CONTINUE TEMP = ALPHA if ( NOUNIT )THEN if ( NOCONJ )THEN TEMP = TEMP*A( K, K ) ELSE TEMP = TEMP*CONJG( A( K, K ) ) end if end if if ( TEMP /= ONE )THEN DO 270, I = 1, M B( I, K ) = TEMP*B( I, K ) 270 CONTINUE end if 280 CONTINUE ELSE DO 320, K = N, 1, -1 DO 300, J = K + 1, N if ( A( J, K ) /= ZERO )THEN if ( NOCONJ )THEN TEMP = ALPHA*A( J, K ) ELSE TEMP = ALPHA*CONJG( A( J, K ) ) end if DO 290, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 290 CONTINUE end if 300 CONTINUE TEMP = ALPHA if ( NOUNIT )THEN if ( NOCONJ )THEN TEMP = TEMP*A( K, K ) ELSE TEMP = TEMP*CONJG( A( K, K ) ) end if end if if ( TEMP /= ONE )THEN DO 310, I = 1, M B( I, K ) = TEMP*B( I, K ) 310 CONTINUE end if 320 CONTINUE end if end if end if ! return ! ! End of CTRMM . ! end subroutine CTRMV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) ! !! CTRMV multiplies a complex vector by a complex triangular matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (STRMV-S, DTRMV-D, CTRMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CTRMV performs one of the matrix-vector operations ! ! x := A*x, or x := A'*x, or x := conjg( A')*x, ! ! where x is an n element vector and A is an n by n unit, or non-unit, ! upper or lower triangular matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' x := A*x. ! ! TRANS = 'T' or 't' x := A'*x. ! ! TRANS = 'C' or 'c' x := conjg( A' )*x. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. On exit, X is overwritten with the ! transformed vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CTRMV ! .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOCONJ, NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX !***FIRST EXECUTABLE STATEMENT CTRMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 end if if ( INFO /= 0 )THEN call XERBLA( 'CTRMV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := A*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = X( J ) DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*A( I, J ) 10 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( J, J ) end if 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 30, I = 1, J - 1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX + INCX 30 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( J, J ) end if JX = JX + INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = N, 1, -1 if ( X( J ) /= ZERO )THEN TEMP = X( J ) DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*A( I, J ) 50 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( J, J ) end if 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 70, I = N, J + 1, -1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX - INCX 70 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( J, J ) end if JX = JX - INCX 80 CONTINUE end if end if ELSE ! ! Form x := A'*x or x := conjg( A' )*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 110, J = N, 1, -1 TEMP = X( J ) if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( A( J, J ) ) DO 100, I = J - 1, 1, -1 TEMP = TEMP + CONJG( A( I, J ) )*X( I ) 100 CONTINUE end if X( J ) = TEMP 110 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 140, J = N, 1, -1 TEMP = X( JX ) IX = JX if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 120, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + A( I, J )*X( IX ) 120 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( A( J, J ) ) DO 130, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) 130 CONTINUE end if X( JX ) = TEMP JX = JX - INCX 140 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 170, J = 1, N TEMP = X( J ) if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 150, I = J + 1, N TEMP = TEMP + A( I, J )*X( I ) 150 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( A( J, J ) ) DO 160, I = J + 1, N TEMP = TEMP + CONJG( A( I, J ) )*X( I ) 160 CONTINUE end if X( J ) = TEMP 170 CONTINUE ELSE JX = KX DO 200, J = 1, N TEMP = X( JX ) IX = JX if ( NOCONJ )THEN if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 180, I = J + 1, N IX = IX + INCX TEMP = TEMP + A( I, J )*X( IX ) 180 CONTINUE ELSE if ( NOUNIT ) & TEMP = TEMP*CONJG( A( J, J ) ) DO 190, I = J + 1, N IX = IX + INCX TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) 190 CONTINUE end if X( JX ) = TEMP JX = JX + INCX 200 CONTINUE end if end if end if ! return ! ! End of CTRMV . ! end subroutine CTRSL (T, LDT, N, B, JOB, INFO) ! !! CTRSL solves a system of the form T*X=B or CTRANS(T)*X=B, where ... ! T is a triangular matrix. Here CTRANS(T) is the conjugate ... ! transpose. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2C3 !***TYPE COMPLEX (STRSL-S, DTRSL-D, CTRSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM, ! TRIANGULAR MATRIX !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! CTRSL solves systems of the form ! ! T * X = B ! or ! CTRANS(T) * X = B ! ! where T is a triangular matrix of order N. Here CTRANS(T) ! denotes the conjugate transpose of the matrix T. ! ! On Entry ! ! T COMPLEX(LDT,N) ! T contains the matrix of the system. The zero ! elements of the matrix are not referenced, and ! the corresponding elements of the array can be ! used to store other information. ! ! LDT INTEGER ! LDT is the leading dimension of the array T. ! ! N INTEGER ! N is the order of the system. ! ! B COMPLEX(N). ! B contains the right hand side of the system. ! ! JOB INTEGER ! JOB specifies what kind of system is to be solved. ! If JOB is ! ! 00 solve T*X = B, T lower triangular, ! 01 solve T*X = B, T upper triangular, ! 10 solve CTRANS(T)*X = B, T lower triangular, ! 11 solve CTRANS(T)*X = B, T upper triangular. ! ! On Return ! ! B B contains the solution, if INFO == 0. ! Otherwise B is unaltered. ! ! INFO INTEGER ! INFO contains zero if the system is nonsingular. ! Otherwise INFO contains the index of ! the first zero diagonal element of T. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED CAXPY, CDOTC !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CTRSL INTEGER LDT,N,JOB,INFO COMPLEX T(LDT,*),B(*) ! ! COMPLEX CDOTC,TEMP INTEGER CASE,J,JJ COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT CTRSL ! ! CHECK FOR ZERO DIAGONAL ELEMENTS. ! DO 10 INFO = 1, N if (CABS1(T(INFO,INFO)) == 0.0E0) go to 150 10 CONTINUE INFO = 0 ! ! DETERMINE THE TASK AND go to IT. ! CASE = 1 if (MOD(JOB,10) /= 0) CASE = 2 if (MOD(JOB,100)/10 /= 0) CASE = CASE + 2 go to (20,50,80,110), CASE ! ! SOLVE T*X=B FOR T LOWER TRIANGULAR ! 20 CONTINUE B(1) = B(1)/T(1,1) if (N < 2) go to 40 DO 30 J = 2, N TEMP = -B(J-1) call CAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) B(J) = B(J)/T(J,J) 30 CONTINUE 40 CONTINUE go to 140 ! ! SOLVE T*X=B FOR T UPPER TRIANGULAR. ! 50 CONTINUE B(N) = B(N)/T(N,N) if (N < 2) go to 70 DO 60 JJ = 2, N J = N - JJ + 1 TEMP = -B(J+1) call CAXPY(J,TEMP,T(1,J+1),1,B(1),1) B(J) = B(J)/T(J,J) 60 CONTINUE 70 CONTINUE go to 140 ! ! SOLVE CTRANS(T)*X=B FOR T LOWER TRIANGULAR. ! 80 CONTINUE B(N) = B(N)/CONJG(T(N,N)) if (N < 2) go to 100 DO 90 JJ = 2, N J = N - JJ + 1 B(J) = B(J) - CDOTC(JJ-1,T(J+1,J),1,B(J+1),1) B(J) = B(J)/CONJG(T(J,J)) 90 CONTINUE 100 CONTINUE go to 140 ! ! SOLVE CTRANS(T)*X=B FOR T UPPER TRIANGULAR. ! 110 CONTINUE B(1) = B(1)/CONJG(T(1,1)) if (N < 2) go to 130 DO 120 J = 2, N B(J) = B(J) - CDOTC(J-1,T(1,J),1,B(1),1) B(J) = B(J)/CONJG(T(J,J)) 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE return end subroutine CTRSM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, & B, LDB) ! !! CTRSM solves a complex triangular system of equations with ... ! multiple right-hand sides. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE COMPLEX (STRSM-S, DTRSM-D, CTRSM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! CTRSM solves one of the matrix equations ! ! op( A )*X = alpha*B, or X*op( A ) = alpha*B, ! ! where alpha is a scalar, X and B are m by n matrices, A is a unit, or ! non-unit, upper or lower triangular matrix and op( A ) is one of ! ! op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). ! ! The matrix X is overwritten on B. ! ! Parameters ! ========== ! ! SIDE - CHARACTER*1. ! On entry, SIDE specifies whether op( A ) appears on the left ! or right of X as follows: ! ! SIDE = 'L' or 'l' op( A )*X = alpha*B. ! ! SIDE = 'R' or 'r' X*op( A ) = alpha*B. ! ! Unchanged on exit. ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix A is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANSA - CHARACTER*1. ! On entry, TRANSA specifies the form of op( A ) to be used in ! the matrix multiplication as follows: ! ! TRANSA = 'N' or 'n' op( A ) = A. ! ! TRANSA = 'T' or 't' op( A ) = A'. ! ! TRANSA = 'C' or 'c' op( A ) = conjg( A' ). ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit triangular ! as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of B. M must be at ! least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of B. N must be ! at least zero. ! Unchanged on exit. ! ! ALPHA - COMPLEX . ! On entry, ALPHA specifies the scalar alpha. When alpha is ! zero then A is not referenced and B need not be set before ! entry. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, k ), where k is m ! when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. ! Before entry with UPLO = 'U' or 'u', the leading k by k ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading k by k ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When SIDE = 'L' or 'l' then ! LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' ! then LDA must be at least max( 1, n ). ! Unchanged on exit. ! ! B - COMPLEX array of DIMENSION ( LDB, n ). ! Before entry, the leading m by n part of the array B must ! contain the right-hand side matrix B, and on exit is ! overwritten by the solution matrix X. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. LDB must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CTRSM ! .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB COMPLEX ALPHA ! .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX ! .. Local Scalars .. LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA COMPLEX TEMP ! .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) !***FIRST EXECUTABLE STATEMENT CTRSM ! ! Test the input parameters. ! LSIDE = LSAME( SIDE , 'L' ) if ( LSIDE )THEN NROWA = M ELSE NROWA = N end if NOCONJ = LSAME( TRANSA, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) ! INFO = 0 if ( ( .NOT.LSIDE ).AND. & ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE if ( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. & ( .NOT.LSAME( TRANSA, 'T' ) ).AND. & ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE if ( ( .NOT.LSAME( DIAG , 'U' ) ).AND. & ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE if ( M < 0 )THEN INFO = 5 ELSE if ( N < 0 )THEN INFO = 6 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 9 ELSE if ( LDB < MAX( 1, M ) )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'CTRSM ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE return end if ! ! Start the operations. ! if ( LSIDE )THEN if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*inv( A )*B. ! if ( UPPER )THEN DO 60, J = 1, N if ( ALPHA /= ONE )THEN DO 30, I = 1, M B( I, J ) = ALPHA*B( I, J ) 30 CONTINUE end if DO 50, K = M, 1, -1 if ( B( K, J ) /= ZERO )THEN if ( NOUNIT ) & B( K, J ) = B( K, J )/A( K, K ) DO 40, I = 1, K - 1 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 40 CONTINUE end if 50 CONTINUE 60 CONTINUE ELSE DO 100, J = 1, N if ( ALPHA /= ONE )THEN DO 70, I = 1, M B( I, J ) = ALPHA*B( I, J ) 70 CONTINUE end if DO 90 K = 1, M if ( B( K, J ) /= ZERO )THEN if ( NOUNIT ) & B( K, J ) = B( K, J )/A( K, K ) DO 80, I = K + 1, M B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 80 CONTINUE end if 90 CONTINUE 100 CONTINUE end if ELSE ! ! Form B := alpha*inv( A' )*B ! or B := alpha*inv( conjg( A' ) )*B. ! if ( UPPER )THEN DO 140, J = 1, N DO 130, I = 1, M TEMP = ALPHA*B( I, J ) if ( NOCONJ )THEN DO 110, K = 1, I - 1 TEMP = TEMP - A( K, I )*B( K, J ) 110 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( I, I ) ELSE DO 120, K = 1, I - 1 TEMP = TEMP - CONJG( A( K, I ) )*B( K, J ) 120 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( A( I, I ) ) end if B( I, J ) = TEMP 130 CONTINUE 140 CONTINUE ELSE DO 180, J = 1, N DO 170, I = M, 1, -1 TEMP = ALPHA*B( I, J ) if ( NOCONJ )THEN DO 150, K = I + 1, M TEMP = TEMP - A( K, I )*B( K, J ) 150 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( I, I ) ELSE DO 160, K = I + 1, M TEMP = TEMP - CONJG( A( K, I ) )*B( K, J ) 160 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( A( I, I ) ) end if B( I, J ) = TEMP 170 CONTINUE 180 CONTINUE end if end if ELSE if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*B*inv( A ). ! if ( UPPER )THEN DO 230, J = 1, N if ( ALPHA /= ONE )THEN DO 190, I = 1, M B( I, J ) = ALPHA*B( I, J ) 190 CONTINUE end if DO 210, K = 1, J - 1 if ( A( K, J ) /= ZERO )THEN DO 200, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 200 CONTINUE end if 210 CONTINUE if ( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 220, I = 1, M B( I, J ) = TEMP*B( I, J ) 220 CONTINUE end if 230 CONTINUE ELSE DO 280, J = N, 1, -1 if ( ALPHA /= ONE )THEN DO 240, I = 1, M B( I, J ) = ALPHA*B( I, J ) 240 CONTINUE end if DO 260, K = J + 1, N if ( A( K, J ) /= ZERO )THEN DO 250, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 250 CONTINUE end if 260 CONTINUE if ( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 270, I = 1, M B( I, J ) = TEMP*B( I, J ) 270 CONTINUE end if 280 CONTINUE end if ELSE ! ! Form B := alpha*B*inv( A' ) ! or B := alpha*B*inv( conjg( A' ) ). ! if ( UPPER )THEN DO 330, K = N, 1, -1 if ( NOUNIT )THEN if ( NOCONJ )THEN TEMP = ONE/A( K, K ) ELSE TEMP = ONE/CONJG( A( K, K ) ) end if DO 290, I = 1, M B( I, K ) = TEMP*B( I, K ) 290 CONTINUE end if DO 310, J = 1, K - 1 if ( A( J, K ) /= ZERO )THEN if ( NOCONJ )THEN TEMP = A( J, K ) ELSE TEMP = CONJG( A( J, K ) ) end if DO 300, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 300 CONTINUE end if 310 CONTINUE if ( ALPHA /= ONE )THEN DO 320, I = 1, M B( I, K ) = ALPHA*B( I, K ) 320 CONTINUE end if 330 CONTINUE ELSE DO 380, K = 1, N if ( NOUNIT )THEN if ( NOCONJ )THEN TEMP = ONE/A( K, K ) ELSE TEMP = ONE/CONJG( A( K, K ) ) end if DO 340, I = 1, M B( I, K ) = TEMP*B( I, K ) 340 CONTINUE end if DO 360, J = K + 1, N if ( A( J, K ) /= ZERO )THEN if ( NOCONJ )THEN TEMP = A( J, K ) ELSE TEMP = CONJG( A( J, K ) ) end if DO 350, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 350 CONTINUE end if 360 CONTINUE if ( ALPHA /= ONE )THEN DO 370, I = 1, M B( I, K ) = ALPHA*B( I, K ) 370 CONTINUE end if 380 CONTINUE end if end if end if ! return ! ! End of CTRSM . ! end subroutine CTRSV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) ! !! CTRSV solves a complex triangular system of equations. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE COMPLEX (STRSV-S, DTRSV-D, CTRSV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CTRSV solves one of the systems of equations ! ! A*x = b, or A'*x = b, or conjg( A')*x = b, ! ! where b and x are n element vectors and A is an n by n unit, or ! non-unit, upper or lower triangular matrix. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the equations to be solved as ! follows: ! ! TRANS = 'N' or 'n' A*x = b. ! ! TRANS = 'T' or 't' A'*x = b. ! ! TRANS = 'C' or 'c' conjg( A' )*x = b. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! A - COMPLEX array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! ! X - COMPLEX array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element right-hand side vector b. On exit, X is overwritten ! with the solution vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE CTRSV ! .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. COMPLEX A( LDA, * ), X( * ) ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) ! .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOCONJ, NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC CONJG, MAX !***FIRST EXECUTABLE STATEMENT CTRSV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 end if if ( INFO /= 0 )THEN call XERBLA( 'CTRSV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := inv( A )*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 20, J = N, 1, -1 if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE end if 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE end if JX = JX - INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE end if 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if end if ELSE ! ! Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 110, J = 1, N TEMP = X( J ) if ( NOCONJ )THEN DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) ELSE DO 100, I = 1, J - 1 TEMP = TEMP - CONJG( A( I, J ) )*X( I ) 100 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( A( J, J ) ) end if X( J ) = TEMP 110 CONTINUE ELSE JX = KX DO 140, J = 1, N IX = KX TEMP = X( JX ) if ( NOCONJ )THEN DO 120, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) ELSE DO 130, I = 1, J - 1 TEMP = TEMP - CONJG( A( I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( A( J, J ) ) end if X( JX ) = TEMP JX = JX + INCX 140 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 170, J = N, 1, -1 TEMP = X( J ) if ( NOCONJ )THEN DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 150 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) ELSE DO 160, I = N, J + 1, -1 TEMP = TEMP - CONJG( A( I, J ) )*X( I ) 160 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( A( J, J ) ) end if X( J ) = TEMP 170 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 200, J = N, 1, -1 IX = KX TEMP = X( JX ) if ( NOCONJ )THEN DO 180, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 180 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) ELSE DO 190, I = N, J + 1, -1 TEMP = TEMP - CONJG( A( I, J ) )*X( IX ) IX = IX - INCX 190 CONTINUE if ( NOUNIT ) & TEMP = TEMP/CONJG( A( J, J ) ) end if X( JX ) = TEMP JX = JX - INCX 200 CONTINUE end if end if end if ! return ! ! End of CTRSV . ! end subroutine CUCHK (Y, NZ, ASCLE, TOL) ! !! CUCHK is subsidiary to SERI, CUOIK, CUNK1, CUNK2, CUNI1, CUNI2 and CKSCL. ! !***LIBRARY SLATEC !***TYPE ALL (CUCHK-A, ZUCHK-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN ! EXP(-ALIM)=ASCLE=1.0E+3*R1MACH(1)/TOL. THE TEST IS MADE TO SEE ! if THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDER FLOW ! WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED ! if THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE ! OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE ! ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. ! !***SEE ALSO CKSCL, CUNI1, CUNI2, CUNK1, CUNK2, CUOIK, SERI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CUCHK ! COMPLEX Y REAL ASCLE, SS, ST, TOL, YR, YI INTEGER NZ !***FIRST EXECUTABLE STATEMENT CUCHK NZ = 0 YR = REAL(Y) YI = AIMAG(Y) YR = ABS(YR) YI = ABS(YI) ST = MIN(YR,YI) if (ST > ASCLE) RETURN SS = MAX(YR,YI) ST=ST/TOL if (SS < ST) NZ = 1 return end subroutine CUNHJ (Z, FNU, IPMTR, TOL, PHI, ARG, ZETA1, ZETA2, & ASUM, BSUM) ! !! CUNHJ is subsidiary to CBESI and CBESK ! !***LIBRARY SLATEC !***TYPE ALL (CUNHJ-A, ZUNHJ-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! REFERENCES ! HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. ! STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. ! ! ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC ! PRESS, N.Y., 1974, PAGE 420 ! ! ABSTRACT ! CUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = ! J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU ! BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION ! ! C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) ! ! FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS ! AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. ! ! (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, ! ! ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING ! PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. ! ! MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND ! MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= ! 1 COMPUTES ALL EXCEPT ASUM AND BSUM. ! !***SEE ALSO CBESI, CBESK !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CUNHJ COMPLEX ARG, ASUM, BSUM, CFNU, CONE, CR, CZERO, DR, P, PHI, & PRZTH, PTFN, RFN13, RTZTA, RZTH, SUMA, SUMB, TFN, T2, UP, W, W2, & Z, ZA, ZB, ZC, ZETA, ZETA1, ZETA2, ZTH REAL ALFA, ANG, AP, AR, ATOL, AW2, AZTH, BETA, BR, BTOL, C, EX1, & EX2, FNU, FN13, FN23, GAMA, HPI, PI, PP, RFNU, RFNU2, THPI, TOL, & WI, WR, ZCI, ZCR, ZETAI, ZETAR, ZTHI, ZTHR, ASUMR, ASUMI, BSUMR, & BSUMI, TEST, TSTR, TSTI, AC, R1MACH INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, & LRP1, L1, L2, M DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), & AP(30), P(30), UP(14), CR(14), DR(14) DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8), & AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/ & 1.00000000000000000E+00, 1.04166666666666667E-01, & 8.35503472222222222E-02, 1.28226574556327160E-01, & 2.91849026464140464E-01, 8.81627267443757652E-01, & 3.32140828186276754E+00, 1.49957629868625547E+01, & 7.89230130115865181E+01, 4.74451538868264323E+02, & 3.20749009089066193E+03, 2.40865496408740049E+04, & 1.98923119169509794E+05, 1.79190200777534383E+06/ DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), & BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/ & 1.00000000000000000E+00, -1.45833333333333333E-01, & -9.87413194444444444E-02, -1.43312053915895062E-01, & -3.17227202678413548E-01, -9.42429147957120249E-01, & -3.51120304082635426E+00, -1.57272636203680451E+01, & -8.22814390971859444E+01, -4.92355370523670524E+02, & -3.31621856854797251E+03, -2.48276742452085896E+04, & -2.04526587315129788E+05, -1.83844491706820990E+06/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), & C(19), C(20), C(21), C(22), C(23), C(24)/ & 1.00000000000000000E+00, -2.08333333333333333E-01, & 1.25000000000000000E-01, 3.34201388888888889E-01, & -4.01041666666666667E-01, 7.03125000000000000E-02, & -1.02581259645061728E+00, 1.84646267361111111E+00, & -8.91210937500000000E-01, 7.32421875000000000E-02, & 4.66958442342624743E+00, -1.12070026162229938E+01, & 8.78912353515625000E+00, -2.36408691406250000E+00, & 1.12152099609375000E-01, -2.82120725582002449E+01, & 8.46362176746007346E+01, -9.18182415432400174E+01, & 4.25349987453884549E+01, -7.36879435947963170E+00, & 2.27108001708984375E-01, 2.12570130039217123E+02, & -7.65252468141181642E+02, 1.05999045252799988E+03/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ & -6.99579627376132541E+02, 2.18190511744211590E+02, & -2.64914304869515555E+01, 5.72501420974731445E-01, & -1.91945766231840700E+03, 8.06172218173730938E+03, & -1.35865500064341374E+04, 1.16553933368645332E+04, & -5.30564697861340311E+03, 1.20090291321635246E+03, & -1.08090919788394656E+02, 1.72772750258445740E+00, & 2.02042913309661486E+04, -9.69805983886375135E+04, & 1.92547001232531532E+05, -2.03400177280415534E+05, & 1.22200464983017460E+05, -4.11926549688975513E+04, & 7.10951430248936372E+03, -4.93915304773088012E+02, & 6.07404200127348304E+00, -2.42919187900551333E+05, & 1.31176361466297720E+06, -2.99801591853810675E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), & C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ & 3.76327129765640400E+06, -2.81356322658653411E+06, & 1.26836527332162478E+06, -3.31645172484563578E+05, & 4.52187689813627263E+04, -2.49983048181120962E+03, & 2.43805296995560639E+01, 3.28446985307203782E+06, & -1.97068191184322269E+07, 5.09526024926646422E+07, & -7.41051482115326577E+07, 6.63445122747290267E+07, & -3.75671766607633513E+07, 1.32887671664218183E+07, & -2.78561812808645469E+06, 3.08186404612662398E+05, & -1.38860897537170405E+04, 1.10017140269246738E+02, & -4.93292536645099620E+07, 3.25573074185765749E+08, & -9.39462359681578403E+08, 1.55359689957058006E+09, & -1.62108055210833708E+09, 1.10684281682301447E+09/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), & C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), & C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ & -4.95889784275030309E+08, 1.42062907797533095E+08, & -2.44740627257387285E+07, 2.24376817792244943E+06, & -8.40054336030240853E+04, 5.51335896122020586E+02, & 8.14789096118312115E+08, -5.86648149205184723E+09, & 1.86882075092958249E+10, -3.46320433881587779E+10, & 4.12801855797539740E+10, -3.30265997498007231E+10, & 1.79542137311556001E+10, -6.56329379261928433E+09, & 1.55927986487925751E+09, -2.25105661889415278E+08, & 1.73951075539781645E+07, -5.49842327572288687E+05, & 3.03809051092238427E+03, -1.46792612476956167E+10, & 1.14498237732025810E+11, -3.99096175224466498E+11, & 8.19218669548577329E+11, -1.09837515608122331E+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), & C(105)/ & 1.00815810686538209E+12, -6.45364869245376503E+11, & 2.87900649906150589E+11, -8.78670721780232657E+10, & 1.76347306068349694E+10, -2.16716498322379509E+09, & 1.43157876718888981E+08, -3.87183344257261262E+06, & 1.82577554742931747E+04/ DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6), & ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12), & ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18), & ALFA(19), ALFA(20), ALFA(21), ALFA(22)/ & -4.44444444444444444E-03, -9.22077922077922078E-04, & -8.84892884892884893E-05, 1.65927687832449737E-04, & 2.46691372741792910E-04, 2.65995589346254780E-04, & 2.61824297061500945E-04, 2.48730437344655609E-04, & 2.32721040083232098E-04, 2.16362485712365082E-04, & 2.00738858762752355E-04, 1.86267636637545172E-04, & 1.73060775917876493E-04, 1.61091705929015752E-04, & 1.50274774160908134E-04, 1.40503497391269794E-04, & 1.31668816545922806E-04, 1.23667445598253261E-04, & 1.16405271474737902E-04, 1.09798298372713369E-04, & 1.03772410422992823E-04, 9.82626078369363448E-05/ DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28), & ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34), & ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40), & ALFA(41), ALFA(42), ALFA(43), ALFA(44)/ & 9.32120517249503256E-05, 8.85710852478711718E-05, & 8.42963105715700223E-05, 8.03497548407791151E-05, & 7.66981345359207388E-05, 7.33122157481777809E-05, & 7.01662625163141333E-05, 6.72375633790160292E-05, & 6.93735541354588974E-04, 2.32241745182921654E-04, & -1.41986273556691197E-05, -1.16444931672048640E-04, & -1.50803558053048762E-04, -1.55121924918096223E-04, & -1.46809756646465549E-04, -1.33815503867491367E-04, & -1.19744975684254051E-04, -1.06184319207974020E-04, & -9.37699549891194492E-05, -8.26923045588193274E-05, & -7.29374348155221211E-05, -6.44042357721016283E-05/ DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50), & ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56), & ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62), & ALFA(63), ALFA(64), ALFA(65), ALFA(66)/ & -5.69611566009369048E-05, -5.04731044303561628E-05, & -4.48134868008882786E-05, -3.98688727717598864E-05, & -3.55400532972042498E-05, -3.17414256609022480E-05, & -2.83996793904174811E-05, -2.54522720634870566E-05, & -2.28459297164724555E-05, -2.05352753106480604E-05, & -1.84816217627666085E-05, -1.66519330021393806E-05, & -1.50179412980119482E-05, -1.35554031379040526E-05, & -1.22434746473858131E-05, -1.10641884811308169E-05, & -3.54211971457743841E-04, -1.56161263945159416E-04, & 3.04465503594936410E-05, 1.30198655773242693E-04, & 1.67471106699712269E-04, 1.70222587683592569E-04/ DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72), & ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78), & ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84), & ALFA(85), ALFA(86), ALFA(87), ALFA(88)/ & 1.56501427608594704E-04, 1.36339170977445120E-04, & 1.14886692029825128E-04, 9.45869093034688111E-05, & 7.64498419250898258E-05, 6.07570334965197354E-05, & 4.74394299290508799E-05, 3.62757512005344297E-05, & 2.69939714979224901E-05, 1.93210938247939253E-05, & 1.30056674793963203E-05, 7.82620866744496661E-06, & 3.59257485819351583E-06, 1.44040049814251817E-07, & -2.65396769697939116E-06, -4.91346867098485910E-06, & -6.72739296091248287E-06, -8.17269379678657923E-06, & -9.31304715093561232E-06, -1.02011418798016441E-05, & -1.08805962510592880E-05, -1.13875481509603555E-05/ DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94), & ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100), & ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105), & ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/ & -1.17519675674556414E-05, -1.19987364870944141E-05, & 3.78194199201772914E-04, 2.02471952761816167E-04, & -6.37938506318862408E-05, -2.38598230603005903E-04, & -3.10916256027361568E-04, -3.13680115247576316E-04, & -2.78950273791323387E-04, -2.28564082619141374E-04, & -1.75245280340846749E-04, -1.25544063060690348E-04, & -8.22982872820208365E-05, -4.62860730588116458E-05, & -1.72334302366962267E-05, 5.60690482304602267E-06, & 2.31395443148286800E-05, 3.62642745856793957E-05, & 4.58006124490188752E-05, 5.24595294959114050E-05, & 5.68396208545815266E-05, 5.94349820393104052E-05/ DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115), & ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120), & ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125), & ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/ & 6.06478527578421742E-05, 6.08023907788436497E-05, & 6.01577894539460388E-05, 5.89199657344698500E-05, & 5.72515823777593053E-05, 5.52804375585852577E-05, & 5.31063773802880170E-05, 5.08069302012325706E-05, & 4.84418647620094842E-05, 4.60568581607475370E-05, & -6.91141397288294174E-04, -4.29976633058871912E-04, & 1.83067735980039018E-04, 6.60088147542014144E-04, & 8.75964969951185931E-04, 8.77335235958235514E-04, & 7.49369585378990637E-04, 5.63832329756980918E-04, & 3.68059319971443156E-04, 1.88464535514455599E-04/ DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135), & ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140), & ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145), & ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/ & 3.70663057664904149E-05, -8.28520220232137023E-05, & -1.72751952869172998E-04, -2.36314873605872983E-04, & -2.77966150694906658E-04, -3.02079514155456919E-04, & -3.12594712643820127E-04, -3.12872558758067163E-04, & -3.05678038466324377E-04, -2.93226470614557331E-04, & -2.77255655582934777E-04, -2.59103928467031709E-04, & -2.39784014396480342E-04, -2.20048260045422848E-04, & -2.00443911094971498E-04, -1.81358692210970687E-04, & -1.63057674478657464E-04, -1.45712672175205844E-04, & -1.29425421983924587E-04, -1.14245691942445952E-04/ DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155), & ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160), & ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165), & ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/ & 1.92821964248775885E-03, 1.35592576302022234E-03, & -7.17858090421302995E-04, -2.58084802575270346E-03, & -3.49271130826168475E-03, -3.46986299340960628E-03, & -2.82285233351310182E-03, -1.88103076404891354E-03, & -8.89531718383947600E-04, 3.87912102631035228E-06, & 7.28688540119691412E-04, 1.26566373053457758E-03, & 1.62518158372674427E-03, 1.83203153216373172E-03, & 1.91588388990527909E-03, 1.90588846755546138E-03, & 1.82798982421825727E-03, 1.70389506421121530E-03, & 1.55097127171097686E-03, 1.38261421852276159E-03/ DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175), & ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/ & 1.20881424230064774E-03, 1.03676532638344962E-03, & 8.71437918068619115E-04, 7.16080155297701002E-04, & 5.72637002558129372E-04, 4.42089819465802277E-04, & 3.24724948503090564E-04, 2.20342042730246599E-04, & 1.28412898401353882E-04, 4.82005924552095464E-05/ DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6), & BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12), & BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18), & BETA(19), BETA(20), BETA(21), BETA(22)/ & 1.79988721413553309E-02, 5.59964911064388073E-03, & 2.88501402231132779E-03, 1.80096606761053941E-03, & 1.24753110589199202E-03, 9.22878876572938311E-04, & 7.14430421727287357E-04, 5.71787281789704872E-04, & 4.69431007606481533E-04, 3.93232835462916638E-04, & 3.34818889318297664E-04, 2.88952148495751517E-04, & 2.52211615549573284E-04, 2.22280580798883327E-04, & 1.97541838033062524E-04, 1.76836855019718004E-04, & 1.59316899661821081E-04, 1.44347930197333986E-04, & 1.31448068119965379E-04, 1.20245444949302884E-04, & 1.10449144504599392E-04, 1.01828770740567258E-04/ DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28), & BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34), & BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40), & BETA(41), BETA(42), BETA(43), BETA(44)/ & 9.41998224204237509E-05, 8.74130545753834437E-05, & 8.13466262162801467E-05, 7.59002269646219339E-05, & 7.09906300634153481E-05, 6.65482874842468183E-05, & 6.25146958969275078E-05, 5.88403394426251749E-05, & -1.49282953213429172E-03, -8.78204709546389328E-04, & -5.02916549572034614E-04, -2.94822138512746025E-04, & -1.75463996970782828E-04, -1.04008550460816434E-04, & -5.96141953046457895E-05, -3.12038929076098340E-05, & -1.26089735980230047E-05, -2.42892608575730389E-07, & 8.05996165414273571E-06, 1.36507009262147391E-05, & 1.73964125472926261E-05, 1.98672978842133780E-05/ DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50), & BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56), & BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62), & BETA(63), BETA(64), BETA(65), BETA(66)/ & 2.14463263790822639E-05, 2.23954659232456514E-05, & 2.28967783814712629E-05, 2.30785389811177817E-05, & 2.30321976080909144E-05, 2.28236073720348722E-05, & 2.25005881105292418E-05, 2.20981015361991429E-05, & 2.16418427448103905E-05, 2.11507649256220843E-05, & 2.06388749782170737E-05, 2.01165241997081666E-05, & 1.95913450141179244E-05, 1.90689367910436740E-05, & 1.85533719641636667E-05, 1.80475722259674218E-05, & 5.52213076721292790E-04, 4.47932581552384646E-04, & 2.79520653992020589E-04, 1.52468156198446602E-04, & 6.93271105657043598E-05, 1.76258683069991397E-05/ DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72), & BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78), & BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84), & BETA(85), BETA(86), BETA(87), BETA(88)/ & -1.35744996343269136E-05, -3.17972413350427135E-05, & -4.18861861696693365E-05, -4.69004889379141029E-05, & -4.87665447413787352E-05, -4.87010031186735069E-05, & -4.74755620890086638E-05, -4.55813058138628452E-05, & -4.33309644511266036E-05, -4.09230193157750364E-05, & -3.84822638603221274E-05, -3.60857167535410501E-05, & -3.37793306123367417E-05, -3.15888560772109621E-05, & -2.95269561750807315E-05, -2.75978914828335759E-05, & -2.58006174666883713E-05, -2.41308356761280200E-05, & -2.25823509518346033E-05, -2.11479656768912971E-05, & -1.98200638885294927E-05, -1.85909870801065077E-05/ DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94), & BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100), & BETA(101), BETA(102), BETA(103), BETA(104), BETA(105), & BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/ & -1.74532699844210224E-05, -1.63997823854497997E-05, & -4.74617796559959808E-04, -4.77864567147321487E-04, & -3.20390228067037603E-04, -1.61105016119962282E-04, & -4.25778101285435204E-05, 3.44571294294967503E-05, & 7.97092684075674924E-05, 1.03138236708272200E-04, & 1.12466775262204158E-04, 1.13103642108481389E-04, & 1.08651634848774268E-04, 1.01437951597661973E-04, & 9.29298396593363896E-05, 8.40293133016089978E-05, & 7.52727991349134062E-05, 6.69632521975730872E-05, & 5.92564547323194704E-05, 5.22169308826975567E-05, & 4.58539485165360646E-05, 4.01445513891486808E-05/ DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115), & BETA(116), BETA(117), BETA(118), BETA(119), BETA(120), & BETA(121), BETA(122), BETA(123), BETA(124), BETA(125), & BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/ & 3.50481730031328081E-05, 3.05157995034346659E-05, & 2.64956119950516039E-05, 2.29363633690998152E-05, & 1.97893056664021636E-05, 1.70091984636412623E-05, & 1.45547428261524004E-05, 1.23886640995878413E-05, & 1.04775876076583236E-05, 8.79179954978479373E-06, & 7.36465810572578444E-04, 8.72790805146193976E-04, & 6.22614862573135066E-04, 2.85998154194304147E-04, & 3.84737672879366102E-06, -1.87906003636971558E-04, & -2.97603646594554535E-04, -3.45998126832656348E-04, & -3.53382470916037712E-04, -3.35715635775048757E-04/ DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135), & BETA(136), BETA(137), BETA(138), BETA(139), BETA(140), & BETA(141), BETA(142), BETA(143), BETA(144), BETA(145), & BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/ & -3.04321124789039809E-04, -2.66722723047612821E-04, & -2.27654214122819527E-04, -1.89922611854562356E-04, & -1.55058918599093870E-04, -1.23778240761873630E-04, & -9.62926147717644187E-05, -7.25178327714425337E-05, & -5.22070028895633801E-05, -3.50347750511900522E-05, & -2.06489761035551757E-05, -8.70106096849767054E-06, & 1.13698686675100290E-06, 9.16426474122778849E-06, & 1.56477785428872620E-05, 2.08223629482466847E-05, & 2.48923381004595156E-05, 2.80340509574146325E-05, & 3.03987774629861915E-05, 3.21156731406700616E-05/ DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155), & BETA(156), BETA(157), BETA(158), BETA(159), BETA(160), & BETA(161), BETA(162), BETA(163), BETA(164), BETA(165), & BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/ & -1.80182191963885708E-03, -2.43402962938042533E-03, & -1.83422663549856802E-03, -7.62204596354009765E-04, & 2.39079475256927218E-04, 9.49266117176881141E-04, & 1.34467449701540359E-03, 1.48457495259449178E-03, & 1.44732339830617591E-03, 1.30268261285657186E-03, & 1.10351597375642682E-03, 8.86047440419791759E-04, & 6.73073208165665473E-04, 4.77603872856582378E-04, & 3.05991926358789362E-04, 1.60315694594721630E-04, & 4.00749555270613286E-05, -5.66607461635251611E-05, & -1.32506186772982638E-04, -1.90296187989614057E-04/ DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175), & BETA(176), BETA(177), BETA(178), BETA(179), BETA(180), & BETA(181), BETA(182), BETA(183), BETA(184), BETA(185), & BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/ & -2.32811450376937408E-04, -2.62628811464668841E-04, & -2.82050469867598672E-04, -2.93081563192861167E-04, & -2.97435962176316616E-04, -2.96557334239348078E-04, & -2.91647363312090861E-04, -2.83696203837734166E-04, & -2.73512317095673346E-04, -2.61750155806768580E-04, & 6.38585891212050914E-03, 9.62374215806377941E-03, & 7.61878061207001043E-03, 2.83219055545628054E-03, & -2.09841352012720090E-03, -5.73826764216626498E-03, & -7.70804244495414620E-03, -8.21011692264844401E-03, & -7.65824520346905413E-03, -6.47209729391045177E-03/ DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195), & BETA(196), BETA(197), BETA(198), BETA(199), BETA(200), & BETA(201), BETA(202), BETA(203), BETA(204), BETA(205), & BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/ & -4.99132412004966473E-03, -3.45612289713133280E-03, & -2.01785580014170775E-03, -7.59430686781961401E-04, & 2.84173631523859138E-04, 1.10891667586337403E-03, & 1.72901493872728771E-03, 2.16812590802684701E-03, & 2.45357710494539735E-03, 2.61281821058334862E-03, & 2.67141039656276912E-03, 2.65203073395980430E-03, & 2.57411652877287315E-03, 2.45389126236094427E-03, & 2.30460058071795494E-03, 2.13684837686712662E-03, & 1.95896528478870911E-03, 1.77737008679454412E-03, & 1.59690280765839059E-03, 1.42111975664438546E-03/ DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6), & GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12), & GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18), & GAMA(19), GAMA(20), GAMA(21), GAMA(22)/ & 6.29960524947436582E-01, 2.51984209978974633E-01, & 1.54790300415655846E-01, 1.10713062416159013E-01, & 8.57309395527394825E-02, 6.97161316958684292E-02, & 5.86085671893713576E-02, 5.04698873536310685E-02, & 4.42600580689154809E-02, 3.93720661543509966E-02, & 3.54283195924455368E-02, 3.21818857502098231E-02, & 2.94646240791157679E-02, 2.71581677112934479E-02, & 2.51768272973861779E-02, 2.34570755306078891E-02, & 2.19508390134907203E-02, 2.06210828235646240E-02, & 1.94388240897880846E-02, 1.83810633800683158E-02, & 1.74293213231963172E-02, 1.65685837786612353E-02/ DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), & GAMA(29), GAMA(30)/ & 1.57865285987918445E-02, 1.50729501494095594E-02, & 1.44193250839954639E-02, 1.38184805735341786E-02, & 1.32643378994276568E-02, 1.27517121970498651E-02, & 1.22761545318762767E-02, 1.18338262398482403E-02/ DATA EX1, EX2, HPI, PI, THPI / & 3.33333333333333333E-01, 6.66666666666666667E-01, & 1.57079632679489662E+00, 3.14159265358979324E+00, & 4.71238898038468986E+00/ DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CUNHJ RFNU = 1.0E0/FNU ! ZB = Z*CMPLX(RFNU,0.0E0) !----------------------------------------------------------------------- ! OVERFLOW TEST (Z/FNU TOO SMALL) !----------------------------------------------------------------------- TSTR = REAL(Z) TSTI = AIMAG(Z) TEST = R1MACH(1)*1.0E+3 AC = FNU*TEST if (ABS(TSTR) > AC .OR. ABS(TSTI) > AC) go to 15 AC = 2.0E0*ABS(ALOG(TEST))+FNU ZETA1 = CMPLX(AC,0.0E0) ZETA2 = CMPLX(FNU,0.0E0) PHI=CONE ARG=CONE return 15 CONTINUE ZB = Z*CMPLX(RFNU,0.0E0) RFNU2 = RFNU*RFNU !----------------------------------------------------------------------- ! COMPUTE IN THE FOURTH QUADRANT !----------------------------------------------------------------------- FN13 = FNU**EX1 FN23 = FN13*FN13 RFN13 = CMPLX(1.0E0/FN13,0.0E0) W2 = CONE - ZB*ZB AW2 = ABS(W2) if (AW2 > 0.25E0) go to 130 !----------------------------------------------------------------------- ! POWER SERIES FOR ABS(W2) <= 0.25E0 !----------------------------------------------------------------------- K = 1 P(1) = CONE SUMA = CMPLX(GAMA(1),0.0E0) AP(1) = 1.0E0 if (AW2 < TOL) go to 20 DO 10 K=2,30 P(K) = P(K-1)*W2 SUMA = SUMA + P(K)*CMPLX(GAMA(K),0.0E0) AP(K) = AP(K-1)*AW2 if (AP(K) < TOL) go to 20 10 CONTINUE K = 30 20 CONTINUE KMAX = K ZETA = W2*SUMA ARG = ZETA*CMPLX(FN23,0.0E0) ZA = CSQRT(SUMA) ZETA2 = CSQRT(W2)*CMPLX(FNU,0.0E0) ZETA1 = ZETA2*(CONE+ZETA*ZA*CMPLX(EX2,0.0E0)) ZA = ZA + ZA PHI = CSQRT(ZA)*RFN13 if (IPMTR == 1) go to 120 !----------------------------------------------------------------------- ! SUM SERIES FOR ASUM AND BSUM !----------------------------------------------------------------------- SUMB = CZERO DO 30 K=1,KMAX SUMB = SUMB + P(K)*CMPLX(BETA(K),0.0E0) 30 CONTINUE ASUM = CZERO BSUM = SUMB L1 = 0 L2 = 30 BTOL = TOL*ABS(BSUM) ATOL = TOL PP = 1.0E0 IAS = 0 IBS = 0 if (RFNU2 < TOL) go to 110 DO 100 IS=2,7 ATOL = ATOL/RFNU2 PP = PP*RFNU2 if (IAS == 1) go to 60 SUMA = CZERO DO 40 K=1,KMAX M = L1 + K SUMA = SUMA + P(K)*CMPLX(ALFA(M),0.0E0) if (AP(K) < ATOL) go to 50 40 CONTINUE 50 CONTINUE ASUM = ASUM + SUMA*CMPLX(PP,0.0E0) if (PP < TOL) IAS = 1 60 CONTINUE if (IBS == 1) go to 90 SUMB = CZERO DO 70 K=1,KMAX M = L2 + K SUMB = SUMB + P(K)*CMPLX(BETA(M),0.0E0) if (AP(K) < ATOL) go to 80 70 CONTINUE 80 CONTINUE BSUM = BSUM + SUMB*CMPLX(PP,0.0E0) if (PP < BTOL) IBS = 1 90 CONTINUE if (IAS == 1 .AND. IBS == 1) go to 110 L1 = L1 + 30 L2 = L2 + 30 100 CONTINUE 110 CONTINUE ASUM = ASUM + CONE PP = RFNU*REAL(RFN13) BSUM = BSUM*CMPLX(PP,0.0E0) 120 CONTINUE return !----------------------------------------------------------------------- ! ABS(W2) > 0.25E0 !----------------------------------------------------------------------- 130 CONTINUE W = CSQRT(W2) WR = REAL(W) WI = AIMAG(W) if (WR < 0.0E0) WR = 0.0E0 if (WI < 0.0E0) WI = 0.0E0 W = CMPLX(WR,WI) ZA = (CONE+W)/ZB ZC = CLOG(ZA) ZCR = REAL(ZC) ZCI = AIMAG(ZC) if (ZCI < 0.0E0) ZCI = 0.0E0 if (ZCI > HPI) ZCI = HPI if (ZCR < 0.0E0) ZCR = 0.0E0 ZC = CMPLX(ZCR,ZCI) ZTH = (ZC-W)*CMPLX(1.5E0,0.0E0) CFNU = CMPLX(FNU,0.0E0) ZETA1 = ZC*CFNU ZETA2 = W*CFNU AZTH = ABS(ZTH) ZTHR = REAL(ZTH) ZTHI = AIMAG(ZTH) ANG = THPI if (ZTHR >= 0.0E0 .AND. ZTHI < 0.0E0) go to 140 ANG = HPI if (ZTHR == 0.0E0) go to 140 ANG = ATAN(ZTHI/ZTHR) if (ZTHR < 0.0E0) ANG = ANG + PI 140 CONTINUE PP = AZTH**EX2 ANG = ANG*EX2 ZETAR = PP*COS(ANG) ZETAI = PP*SIN(ANG) if (ZETAI < 0.0E0) ZETAI = 0.0E0 ZETA = CMPLX(ZETAR,ZETAI) ARG = ZETA*CMPLX(FN23,0.0E0) RTZTA = ZTH/ZETA ZA = RTZTA/W PHI = CSQRT(ZA+ZA)*RFN13 if (IPMTR == 1) go to 120 TFN = CMPLX(RFNU,0.0E0)/W RZTH = CMPLX(RFNU,0.0E0)/ZTH ZC = RZTH*CMPLX(AR(2),0.0E0) T2 = CONE/W2 UP(2) = (T2*CMPLX(C(2),0.0E0)+CMPLX(C(3),0.0E0))*TFN BSUM = UP(2) + ZC ASUM = CZERO if (RFNU < TOL) go to 220 PRZTH = RZTH PTFN = TFN UP(1) = CONE PP = 1.0E0 BSUMR = REAL(BSUM) BSUMI = AIMAG(BSUM) BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI)) KS = 0 KP1 = 2 L = 3 IAS = 0 IBS = 0 DO 210 LR=2,12,2 LRP1 = LR + 1 !----------------------------------------------------------------------- ! COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN ! NEXT SUMA AND SUMB !----------------------------------------------------------------------- DO 160 K=LR,LRP1 KS = KS + 1 KP1 = KP1 + 1 L = L + 1 ZA = CMPLX(C(L),0.0E0) DO 150 J=2,KP1 L = L + 1 ZA = ZA*T2 + CMPLX(C(L),0.0E0) 150 CONTINUE PTFN = PTFN*TFN UP(KP1) = PTFN*ZA CR(KS) = PRZTH*CMPLX(BR(KS+1),0.0E0) PRZTH = PRZTH*RZTH DR(KS) = PRZTH*CMPLX(AR(KS+2),0.0E0) 160 CONTINUE PP = PP*RFNU2 if (IAS == 1) go to 180 SUMA = UP(LRP1) JU = LRP1 DO 170 JR=1,LR JU = JU - 1 SUMA = SUMA + CR(JR)*UP(JU) 170 CONTINUE ASUM = ASUM + SUMA ASUMR = REAL(ASUM) ASUMI = AIMAG(ASUM) TEST = ABS(ASUMR) + ABS(ASUMI) if (PP < TOL .AND. TEST < TOL) IAS = 1 180 CONTINUE if (IBS == 1) go to 200 SUMB = UP(LR+2) + UP(LRP1)*ZC JU = LRP1 DO 190 JR=1,LR JU = JU - 1 SUMB = SUMB + DR(JR)*UP(JU) 190 CONTINUE BSUM = BSUM + SUMB BSUMR = REAL(BSUM) BSUMI = AIMAG(BSUM) TEST = ABS(BSUMR) + ABS(BSUMI) if (PP < BTOL .AND. TEST < TOL) IBS = 1 200 CONTINUE if (IAS == 1 .AND. IBS == 1) go to 220 210 CONTINUE 220 CONTINUE ASUM = ASUM + CONE BSUM = -BSUM*RFN13/RTZTA go to 120 end subroutine CUNI1 (Z, FNU, KODE, N, Y, NZ, NLAST, FNUL, TOL, ELIM, & ALIM) ! !! CUNI1 is subsidiary to CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNI1-A, ZUNI1-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC ! EXPANSION FOR I(FNU,Z) IN -PI/3 <= ARG Z <= PI/3. ! ! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC ! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. ! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER ! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL. ! Y(I)=CZERO FOR I=NLAST+1,N ! !***SEE ALSO CBESI, CBESK !***ROUTINES CALLED CUCHK, CUNIK, CUOIK, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CUNI1 COMPLEX CFN, CONE, CRSC, CSCL, CSR, CSS, CWRK, CZERO, C1, C2, & PHI, RZ, SUM, S1, S2, Y, Z, ZETA1, ZETA2, CY REAL ALIM, APHI, ASCLE, BRY, C2I, C2M, C2R, ELIM, FN, FNU, FNUL, & RS1, TOL, YY, R1MACH INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ DIMENSION BRY(3), Y(N), CWRK(16), CSS(3), CSR(3), CY(2) DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / !***FIRST EXECUTABLE STATEMENT CUNI1 NZ = 0 ND = N NLAST = 0 !----------------------------------------------------------------------- ! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- ! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, ! EXP(ALIM)=EXP(ELIM)*TOL !----------------------------------------------------------------------- CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = 1.0E+3*R1MACH(1)/TOL !----------------------------------------------------------------------- ! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER !----------------------------------------------------------------------- FN = MAX(FNU,1.0E0) INIT = 0 call CUNIK(Z, FN, 1, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, CWRK) if (KODE == 1) go to 10 CFN = CMPLX(FN,0.0E0) S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) go to 20 10 CONTINUE S1 = -ZETA1 + ZETA2 20 CONTINUE RS1 = REAL(S1) if (ABS(RS1) > ELIM) go to 130 30 CONTINUE NN = MIN(2,ND) DO 80 I=1,NN FN = FNU + (ND-I) INIT = 0 call CUNIK(Z, FN, 1, 0, TOL, INIT, PHI, ZETA1, ZETA2, SUM, CWRK) if (KODE == 1) go to 40 CFN = CMPLX(FN,0.0E0) YY = AIMAG(Z) S1 = -ZETA1 + CFN*(CFN/(Z+ZETA2)) + CMPLX(0.0E0,YY) go to 50 40 CONTINUE S1 = -ZETA1 + ZETA2 50 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = REAL(S1) if (ABS(RS1) > ELIM) go to 110 if (I == 1) IFLAG = 2 if (ABS(RS1) < ALIM) go to 60 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- APHI = ABS(PHI) RS1 = RS1 + ALOG(APHI) if (ABS(RS1) > ELIM) go to 110 if (I == 1) IFLAG = 1 if (RS1 < 0.0E0) go to 60 if (I == 1) IFLAG = 3 60 CONTINUE !----------------------------------------------------------------------- ! SCALE S1 if ABS(S1) < ASCLE !----------------------------------------------------------------------- S2 = PHI*SUM C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG /= 1) go to 70 call CUCHK(S2, NW, BRY(1), TOL) if (NW /= 0) go to 110 70 CONTINUE M = ND - I + 1 CY(I) = S2 Y(M) = S2*CSR(IFLAG) 80 CONTINUE if (ND <= 2) go to 100 RZ = CMPLX(2.0E0,0.0E0)/Z BRY(2) = 1.0E0/BRY(1) BRY(3) = R1MACH(2) S1 = CY(1) S2 = CY(2) C1 = CSR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = K DO 90 I=3,ND C2 = S2 S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 S1 = C2 C2 = S2*C1 Y(K) = C2 K = K - 1 FN = FN - 1.0E0 if (IFLAG >= 3) go to 90 C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M <= ASCLE) go to 90 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) C1 = CSR(IFLAG) 90 CONTINUE 100 CONTINUE return !----------------------------------------------------------------------- ! SET UNDERFLOW AND UPDATE PARAMETERS !----------------------------------------------------------------------- 110 CONTINUE if (RS1 > 0.0E0) go to 120 Y(ND) = CZERO NZ = NZ + 1 ND = ND - 1 if (ND == 0) go to 100 call CUOIK(Z, FNU, KODE, 1, ND, Y, NUF, TOL, ELIM, ALIM) if (NUF < 0) go to 120 ND = ND - NUF NZ = NZ + NUF if (ND == 0) go to 100 FN = FNU + (ND-1) if (FN >= FNUL) go to 30 NLAST = ND return 120 CONTINUE NZ = -1 return 130 CONTINUE if (RS1 > 0.0E0) go to 120 NZ = N DO 140 I=1,N Y(I) = CZERO 140 CONTINUE return end subroutine CUNI2 (Z, FNU, KODE, N, Y, NZ, NLAST, FNUL, TOL, ELIM, & ALIM) ! !! CUNI2 is subsidiary to CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNI2-A, ZUNI2-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF ! UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I ! OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. ! ! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC ! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. ! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER ! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL. ! Y(I)=CZERO FOR I=NLAST+1,N ! !***SEE ALSO CBESI, CBESK !***ROUTINES CALLED CAIRY, CUCHK, CUNHJ, CUOIK, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CUNI2 COMPLEX AI, ARG, ASUM, BSUM, CFN, CI, CID, CIP, CONE, CRSC, CSCL, & CSR, CSS, CY, CZERO, C1, C2, DAI, PHI, RZ, S1, S2, Y, Z, ZB, & ZETA1, ZETA2, ZN, ZAR REAL AARG, AIC, ALIM, ANG, APHI, ASCLE, AY, BRY, CAR, C2I, C2M, & C2R, ELIM, FN, FNU, FNUL, HPI, RS1, SAR, TOL, YY, R1MACH INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, & NN, NUF, NW, NZ, IDUM DIMENSION BRY(3), Y(N), CIP(4), CSS(3), CSR(3), CY(2) DATA CZERO,CONE,CI/(0.0E0,0.0E0),(1.0E0,0.0E0),(0.0E0,1.0E0)/ DATA CIP(1),CIP(2),CIP(3),CIP(4)/ & (1.0E0,0.0E0), (0.0E0,1.0E0), (-1.0E0,0.0E0), (0.0E0,-1.0E0)/ DATA HPI, AIC / & 1.57079632679489662E+00, 1.265512123484645396E+00/ !***FIRST EXECUTABLE STATEMENT CUNI2 NZ = 0 ND = N NLAST = 0 !----------------------------------------------------------------------- ! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- ! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, ! EXP(ALIM)=EXP(ELIM)*TOL !----------------------------------------------------------------------- CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = 1.0E+3*R1MACH(1)/TOL YY = AIMAG(Z) !----------------------------------------------------------------------- ! ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI !----------------------------------------------------------------------- ZN = -Z*CI ZB = Z CID = -CI INU = FNU ANG = HPI*(FNU-INU) CAR = COS(ANG) SAR = SIN(ANG) C2 = CMPLX(CAR,SAR) ZAR = C2 IN = INU + N - 1 IN = MOD(IN,4) C2 = C2*CIP(IN+1) if (YY > 0.0E0) go to 10 ZN = CONJG(-ZN) ZB = CONJG(ZB) CID = -CID C2 = CONJG(C2) 10 CONTINUE !----------------------------------------------------------------------- ! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER !----------------------------------------------------------------------- FN = MAX(FNU,1.0E0) call CUNHJ(ZN, FN, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) if (KODE == 1) go to 20 CFN = CMPLX(FNU,0.0E0) S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) go to 30 20 CONTINUE S1 = -ZETA1 + ZETA2 30 CONTINUE RS1 = REAL(S1) if (ABS(RS1) > ELIM) go to 150 40 CONTINUE NN = MIN(2,ND) DO 90 I=1,NN FN = FNU + (ND-I) call CUNHJ(ZN, FN, 0, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) if (KODE == 1) go to 50 CFN = CMPLX(FN,0.0E0) AY = ABS(YY) S1 = -ZETA1 + CFN*(CFN/(ZB+ZETA2)) + CMPLX(0.0E0,AY) go to 60 50 CONTINUE S1 = -ZETA1 + ZETA2 60 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = REAL(S1) if (ABS(RS1) > ELIM) go to 120 if (I == 1) IFLAG = 2 if (ABS(RS1) < ALIM) go to 70 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- !----------------------------------------------------------------------- APHI = ABS(PHI) AARG = ABS(ARG) RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC if (ABS(RS1) > ELIM) go to 120 if (I == 1) IFLAG = 1 if (RS1 < 0.0E0) go to 70 if (I == 1) IFLAG = 3 70 CONTINUE !----------------------------------------------------------------------- ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES !----------------------------------------------------------------------- call CAIRY(ARG, 0, 2, AI, NAI, IDUM) call CAIRY(ARG, 1, 2, DAI, NDAI, IDUM) S2 = PHI*(AI*ASUM+DAI*BSUM) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG /= 1) go to 80 call CUCHK(S2, NW, BRY(1), TOL) if (NW /= 0) go to 120 80 CONTINUE if (YY <= 0.0E0) S2 = CONJG(S2) J = ND - I + 1 S2 = S2*C2 CY(I) = S2 Y(J) = S2*CSR(IFLAG) C2 = C2*CID 90 CONTINUE if (ND <= 2) go to 110 RZ = CMPLX(2.0E0,0.0E0)/Z BRY(2) = 1.0E0/BRY(1) BRY(3) = R1MACH(2) S1 = CY(1) S2 = CY(2) C1 = CSR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = K DO 100 I=3,ND C2 = S2 S2 = S1 + CMPLX(FNU+FN,0.0E0)*RZ*S2 S1 = C2 C2 = S2*C1 Y(K) = C2 K = K - 1 FN = FN - 1.0E0 if (IFLAG >= 3) go to 100 C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M <= ASCLE) go to 100 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) C1 = CSR(IFLAG) 100 CONTINUE 110 CONTINUE return 120 CONTINUE if (RS1 > 0.0E0) go to 140 !----------------------------------------------------------------------- ! SET UNDERFLOW AND UPDATE PARAMETERS !----------------------------------------------------------------------- Y(ND) = CZERO NZ = NZ + 1 ND = ND - 1 if (ND == 0) go to 110 call CUOIK(Z, FNU, KODE, 1, ND, Y, NUF, TOL, ELIM, ALIM) if (NUF < 0) go to 140 ND = ND - NUF NZ = NZ + NUF if (ND == 0) go to 110 FN = FNU + (ND-1) if (FN < FNUL) go to 130 ! FN = AIMAG(CID) ! J = NUF + 1 ! K = MOD(J,4) + 1 ! S1 = CIP(K) ! if (FN < 0.0E0) S1 = CONJG(S1) ! C2 = C2*S1 IN = INU + ND - 1 IN = MOD(IN,4) + 1 C2 = ZAR*CIP(IN) if (YY <= 0.0E0)C2=CONJG(C2) go to 40 130 CONTINUE NLAST = ND return 140 CONTINUE NZ = -1 return 150 CONTINUE if (RS1 > 0.0E0) go to 140 NZ = N DO 160 I=1,N Y(I) = CZERO 160 CONTINUE return end subroutine CUNIK (ZR, FNU, IKFLG, IPMTR, TOL, INIT, PHI, ZETA1, & ZETA2, SUM, CWRK) ! !! CUNIK is subsidiary to CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNIK-A, ZUNIK-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC ! EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 ! RESPECTIVELY BY ! ! W(FNU,ZR) = PHI*EXP(ZETA)*SUM ! ! WHERE ZETA=-ZETA1 + ZETA2 OR ! ZETA1 - ZETA2 ! ! THE FIRST call MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE ! SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= ! 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK ! ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, ! ZETA1,ZETA2. ! !***SEE ALSO CBESI, CBESK !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CUNIK COMPLEX CFN, CON, CONE, CRFN, CWRK, CZERO, PHI, S, SR, SUM, T, & T2, ZETA1, ZETA2, ZN, ZR REAL AC, C, FNU, RFN, TEST, TOL, TSTR, TSTI, R1MACH INTEGER I, IKFLG, INIT, IPMTR, J, K, L DIMENSION C(120), CWRK(16), CON(2) DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) / DATA CON(1), CON(2) / & (3.98942280401432678E-01,0.0E0),(1.25331413731550025E+00,0.0E0)/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), & C(19), C(20), C(21), C(22), C(23), C(24)/ & 1.00000000000000000E+00, -2.08333333333333333E-01, & 1.25000000000000000E-01, 3.34201388888888889E-01, & -4.01041666666666667E-01, 7.03125000000000000E-02, & -1.02581259645061728E+00, 1.84646267361111111E+00, & -8.91210937500000000E-01, 7.32421875000000000E-02, & 4.66958442342624743E+00, -1.12070026162229938E+01, & 8.78912353515625000E+00, -2.36408691406250000E+00, & 1.12152099609375000E-01, -2.82120725582002449E+01, & 8.46362176746007346E+01, -9.18182415432400174E+01, & 4.25349987453884549E+01, -7.36879435947963170E+00, & 2.27108001708984375E-01, 2.12570130039217123E+02, & -7.65252468141181642E+02, 1.05999045252799988E+03/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ & -6.99579627376132541E+02, 2.18190511744211590E+02, & -2.64914304869515555E+01, 5.72501420974731445E-01, & -1.91945766231840700E+03, 8.06172218173730938E+03, & -1.35865500064341374E+04, 1.16553933368645332E+04, & -5.30564697861340311E+03, 1.20090291321635246E+03, & -1.08090919788394656E+02, 1.72772750258445740E+00, & 2.02042913309661486E+04, -9.69805983886375135E+04, & 1.92547001232531532E+05, -2.03400177280415534E+05, & 1.22200464983017460E+05, -4.11926549688975513E+04, & 7.10951430248936372E+03, -4.93915304773088012E+02, & 6.07404200127348304E+00, -2.42919187900551333E+05, & 1.31176361466297720E+06, -2.99801591853810675E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), & C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ & 3.76327129765640400E+06, -2.81356322658653411E+06, & 1.26836527332162478E+06, -3.31645172484563578E+05, & 4.52187689813627263E+04, -2.49983048181120962E+03, & 2.43805296995560639E+01, 3.28446985307203782E+06, & -1.97068191184322269E+07, 5.09526024926646422E+07, & -7.41051482115326577E+07, 6.63445122747290267E+07, & -3.75671766607633513E+07, 1.32887671664218183E+07, & -2.78561812808645469E+06, 3.08186404612662398E+05, & -1.38860897537170405E+04, 1.10017140269246738E+02, & -4.93292536645099620E+07, 3.25573074185765749E+08, & -9.39462359681578403E+08, 1.55359689957058006E+09, & -1.62108055210833708E+09, 1.10684281682301447E+09/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), & C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), & C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ & -4.95889784275030309E+08, 1.42062907797533095E+08, & -2.44740627257387285E+07, 2.24376817792244943E+06, & -8.40054336030240853E+04, 5.51335896122020586E+02, & 8.14789096118312115E+08, -5.86648149205184723E+09, & 1.86882075092958249E+10, -3.46320433881587779E+10, & 4.12801855797539740E+10, -3.30265997498007231E+10, & 1.79542137311556001E+10, -6.56329379261928433E+09, & 1.55927986487925751E+09, -2.25105661889415278E+08, & 1.73951075539781645E+07, -5.49842327572288687E+05, & 3.03809051092238427E+03, -1.46792612476956167E+10, & 1.14498237732025810E+11, -3.99096175224466498E+11, & 8.19218669548577329E+11, -1.09837515608122331E+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), & C(105), C(106), C(107), C(108), C(109), C(110), C(111), & C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ & 1.00815810686538209E+12, -6.45364869245376503E+11, & 2.87900649906150589E+11, -8.78670721780232657E+10, & 1.76347306068349694E+10, -2.16716498322379509E+09, & 1.43157876718888981E+08, -3.87183344257261262E+06, & 1.82577554742931747E+04, 2.86464035717679043E+11, & -2.40629790002850396E+12, 9.10934118523989896E+12, & -2.05168994109344374E+13, 3.05651255199353206E+13, & -3.16670885847851584E+13, 2.33483640445818409E+13, & -1.23204913055982872E+13, 4.61272578084913197E+12, & -1.19655288019618160E+12, 2.05914503232410016E+11, & -2.18229277575292237E+10, 1.24700929351271032E+09/ DATA C(119), C(120)/ & -2.91883881222208134E+07, 1.18838426256783253E+05/ !***FIRST EXECUTABLE STATEMENT CUNIK if (INIT /= 0) go to 40 !----------------------------------------------------------------------- ! INITIALIZE ALL VARIABLES !----------------------------------------------------------------------- RFN = 1.0E0/FNU CRFN = CMPLX(RFN,0.0E0) ! T = ZR*CRFN !----------------------------------------------------------------------- ! OVERFLOW TEST (ZR/FNU TOO SMALL) !----------------------------------------------------------------------- TSTR = REAL(ZR) TSTI = AIMAG(ZR) TEST = R1MACH(1)*1.0E+3 AC = FNU*TEST if (ABS(TSTR) > AC .OR. ABS(TSTI) > AC) go to 15 AC = 2.0E0*ABS(ALOG(TEST))+FNU ZETA1 = CMPLX(AC,0.0E0) ZETA2 = CMPLX(FNU,0.0E0) PHI=CONE return 15 CONTINUE T=ZR*CRFN S = CONE + T*T SR = CSQRT(S) CFN = CMPLX(FNU,0.0E0) ZN = (CONE+SR)/T ZETA1 = CFN*CLOG(ZN) ZETA2 = CFN*SR T = CONE/SR SR = T*CRFN CWRK(16) = CSQRT(SR) PHI = CWRK(16)*CON(IKFLG) if (IPMTR /= 0) RETURN T2 = CONE/S CWRK(1) = CONE CRFN = CONE AC = 1.0E0 L = 1 DO 20 K=2,15 S = CZERO DO 10 J=1,K L = L + 1 S = S*T2 + CMPLX(C(L),0.0E0) 10 CONTINUE CRFN = CRFN*SR CWRK(K) = CRFN*S AC = AC*RFN TSTR = REAL(CWRK(K)) TSTI = AIMAG(CWRK(K)) TEST = ABS(TSTR) + ABS(TSTI) if (AC < TOL .AND. TEST < TOL) go to 30 20 CONTINUE K = 15 30 CONTINUE INIT = K 40 CONTINUE if (IKFLG == 2) go to 60 !----------------------------------------------------------------------- ! COMPUTE SUM FOR THE I FUNCTION !----------------------------------------------------------------------- S = CZERO DO 50 I=1,INIT S = S + CWRK(I) 50 CONTINUE SUM = S PHI = CWRK(16)*CON(1) return 60 CONTINUE !----------------------------------------------------------------------- ! COMPUTE SUM FOR THE K FUNCTION !----------------------------------------------------------------------- S = CZERO T = CONE DO 70 I=1,INIT S = S + T*CWRK(I) T = -T 70 CONTINUE SUM = S PHI = CWRK(16)*CON(2) return end subroutine CUNK1 (Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) ! !! CUNK1 is subsidiary to CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNK1-A, ZUNK1-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE ! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE ! UNIFORM ASYMPTOTIC EXPANSION. ! MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. ! NZ=-1 MEANS AN OVERFLOW WILL OCCUR ! !***SEE ALSO CBESK !***ROUTINES CALLED CS1S2, CUCHK, CUNIK, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CUNK1 COMPLEX CFN, CK, CONE, CRSC, CS, CSCL, CSGN, CSPN, CSR, CSS, & CWRK, CY, CZERO, C1, C2, PHI, RZ, SUM, S1, S2, Y, Z, & ZETA1, ZETA2, ZR, PHID, ZETA1D, ZETA2D, SUMD REAL ALIM, ANG, APHI, ASC, ASCLE, BRY, CPN, C2I, C2M, C2R, ELIM, & FMR, FN, FNF, FNU, PI, RS1, SGN, SPN, TOL, X, R1MACH INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, & KK, KODE, MR, N, NW, NZ, J, IPARD, INITD, IC, M DIMENSION BRY(3), INIT(2), Y(N), SUM(2), PHI(2), ZETA1(2), & ZETA2(2), CY(2), CWRK(16,3), CSS(3), CSR(3) DATA CZERO, CONE / (0.0E0,0.0E0) , (1.0E0,0.0E0) / DATA PI / 3.14159265358979324E0 / !***FIRST EXECUTABLE STATEMENT CUNK1 KDFLG = 1 NZ = 0 !----------------------------------------------------------------------- ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN ! THE UNDERFLOW LIMIT !----------------------------------------------------------------------- CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = 1.0E+3*R1MACH(1)/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = R1MACH(2) X = REAL(Z) ZR = Z if (X < 0.0E0) ZR = -Z J=2 DO 70 I=1,N !----------------------------------------------------------------------- ! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J !----------------------------------------------------------------------- J = 3 - J FN = FNU + (I-1) INIT(J) = 0 call CUNIK(ZR, FN, 2, 0, TOL, INIT(J), PHI(J), ZETA1(J), & ZETA2(J), SUM(J), CWRK(1,J)) if (KODE == 1) go to 20 CFN = CMPLX(FN,0.0E0) S1 = ZETA1(J) - CFN*(CFN/(ZR+ZETA2(J))) go to 30 20 CONTINUE S1 = ZETA1(J) - ZETA2(J) 30 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = REAL(S1) if (ABS(RS1) > ELIM) go to 60 if (KDFLG == 1) KFLAG = 2 if (ABS(RS1) < ALIM) go to 40 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- APHI = ABS(PHI(J)) RS1 = RS1 + ALOG(APHI) if (ABS(RS1) > ELIM) go to 60 if (KDFLG == 1) KFLAG = 1 if (RS1 < 0.0E0) go to 40 if (KDFLG == 1) KFLAG = 3 40 CONTINUE !----------------------------------------------------------------------- ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES !----------------------------------------------------------------------- S2 = PHI(J)*SUM(J) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(KFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (KFLAG /= 1) go to 50 call CUCHK(S2, NW, BRY(1), TOL) if (NW /= 0) go to 60 50 CONTINUE CY(KDFLG) = S2 Y(I) = S2*CSR(KFLAG) if (KDFLG == 2) go to 75 KDFLG = 2 go to 70 60 CONTINUE if (RS1 > 0.0E0) go to 290 !----------------------------------------------------------------------- ! FOR X < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW !----------------------------------------------------------------------- if (X < 0.0E0) go to 290 KDFLG = 1 Y(I) = CZERO NZ=NZ+1 if (I == 1) go to 70 if (Y(I-1) == CZERO) go to 70 Y(I-1) = CZERO NZ=NZ+1 70 CONTINUE I=N 75 CONTINUE RZ = CMPLX(2.0E0,0.0E0)/ZR CK = CMPLX(FN,0.0E0)*RZ IB = I+1 if (N < IB) go to 160 !----------------------------------------------------------------------- ! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO ! ON UNDERFLOW !----------------------------------------------------------------------- FN = FNU+(N-1) IPARD = 1 if (MR /= 0) IPARD = 0 INITD = 0 call CUNIK(ZR,FN,2,IPARD,TOL,INITD,PHID,ZETA1D,ZETA2D,SUMD, & CWRK(1,3)) if (KODE == 1) go to 80 CFN=CMPLX(FN,0.0E0) S1=ZETA1D-CFN*(CFN/(ZR+ZETA2D)) go to 90 80 CONTINUE S1=ZETA1D-ZETA2D 90 CONTINUE RS1=REAL(S1) if (ABS(RS1) > ELIM) go to 95 if (ABS(RS1) < ALIM) go to 100 !----------------------------------------------------------------------- ! REFINE ESTIMATE AND TEST !----------------------------------------------------------------------- APHI=ABS(PHID) RS1=RS1+ALOG(APHI) if (ABS(RS1) < ELIM) go to 100 95 CONTINUE if (RS1 > 0.0E0) go to 290 !----------------------------------------------------------------------- ! FOR X < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW !----------------------------------------------------------------------- if (X < 0.0E0) go to 290 NZ=N DO 96 I=1,N Y(I) = CZERO 96 CONTINUE return 100 CONTINUE !----------------------------------------------------------------------- ! RECUR FORWARD FOR REMAINDER OF THE SEQUENCE !----------------------------------------------------------------------- S1 = CY(1) S2 = CY(2) C1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 120 I=IB,N C2 = S2 S2 = CK*S2 + S1 S1 = C2 CK = CK + RZ C2 = S2*C1 Y(I) = C2 if (KFLAG >= 3) go to 120 C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M <= ASCLE) go to 120 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) C1 = CSR(KFLAG) 120 CONTINUE 160 CONTINUE if (MR == 0) RETURN !----------------------------------------------------------------------- ! ANALYTIC CONTINUATION FOR RE(Z) < 0.0E0 !----------------------------------------------------------------------- NZ = 0 FMR = MR SGN = -SIGN(PI,FMR) !----------------------------------------------------------------------- ! CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. !----------------------------------------------------------------------- CSGN = CMPLX(0.0E0,SGN) INU = FNU FNF = FNU - INU IFN = INU + N - 1 ANG = FNF*SGN CPN = COS(ANG) SPN = SIN(ANG) CSPN = CMPLX(CPN,SPN) if (MOD(IFN,2) == 1) CSPN = -CSPN ASC = BRY(1) KK = N IUF = 0 KDFLG = 1 IB = IB-1 IC = IB-1 DO 260 K=1,N FN = FNU + (KK-1) !----------------------------------------------------------------------- ! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K ! FUNCTION ABOVE !----------------------------------------------------------------------- M=3 if (N > 2) go to 175 170 CONTINUE INITD = INIT(J) PHID = PHI(J) ZETA1D = ZETA1(J) ZETA2D = ZETA2(J) SUMD = SUM(J) M = J J = 3 - J go to 180 175 CONTINUE if ((KK == N).AND.(IB < N)) go to 180 if ((KK == IB).OR.(KK == IC)) go to 170 INITD = 0 180 CONTINUE call CUNIK(ZR, FN, 1, 0, TOL, INITD, PHID, ZETA1D, & ZETA2D, SUMD, CWRK(1,M)) if (KODE == 1) go to 190 CFN = CMPLX(FN,0.0E0) S1 = -ZETA1D + CFN*(CFN/(ZR+ZETA2D)) go to 200 190 CONTINUE S1 = -ZETA1D + ZETA2D 200 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = REAL(S1) if (ABS(RS1) > ELIM) go to 250 if (KDFLG == 1) IFLAG = 2 if (ABS(RS1) < ALIM) go to 210 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- APHI = ABS(PHID) RS1 = RS1 + ALOG(APHI) if (ABS(RS1) > ELIM) go to 250 if (KDFLG == 1) IFLAG = 1 if (RS1 < 0.0E0) go to 210 if (KDFLG == 1) IFLAG = 3 210 CONTINUE S2 = CSGN*PHID*SUMD C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG /= 1) go to 220 call CUCHK(S2, NW, BRY(1), TOL) if (NW /= 0) S2 = CMPLX(0.0E0,0.0E0) 220 CONTINUE CY(KDFLG) = S2 C2 = S2 S2 = S2*CSR(IFLAG) !----------------------------------------------------------------------- ! ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N !----------------------------------------------------------------------- S1 = Y(KK) if (KODE == 1) go to 240 call CS1S2(ZR, S1, S2, NW, ASC, ALIM, IUF) NZ = NZ + NW 240 CONTINUE Y(KK) = S1*CSPN + S2 KK = KK - 1 CSPN = -CSPN if (C2 /= CZERO) go to 245 KDFLG = 1 go to 260 245 CONTINUE if (KDFLG == 2) go to 265 KDFLG = 2 go to 260 250 CONTINUE if (RS1 > 0.0E0) go to 290 S2 = CZERO go to 220 260 CONTINUE K = N 265 CONTINUE IL = N - K if (IL == 0) RETURN !----------------------------------------------------------------------- ! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE ! K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP ! INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. !----------------------------------------------------------------------- S1 = CY(1) S2 = CY(2) CS = CSR(IFLAG) ASCLE = BRY(IFLAG) FN = (INU+IL) DO 280 I=1,IL C2 = S2 S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 S1 = C2 FN = FN - 1.0E0 C2 = S2*CS CK = C2 C1 = Y(KK) if (KODE == 1) go to 270 call CS1S2(ZR, C1, C2, NW, ASC, ALIM, IUF) NZ = NZ + NW 270 CONTINUE Y(KK) = C1*CSPN + C2 KK = KK - 1 CSPN = -CSPN if (IFLAG >= 3) go to 280 C2R = REAL(CK) C2I = AIMAG(CK) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M <= ASCLE) go to 280 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*CS S2 = CK S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) CS = CSR(IFLAG) 280 CONTINUE return 290 CONTINUE NZ = -1 return end subroutine CUNK2 (Z, FNU, KODE, MR, N, Y, NZ, TOL, ELIM, ALIM) ! !! CUNK2 is subsidiary to CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNK2-A, ZUNK2-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE ! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE ! UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) ! WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR ! -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z if Z IS IN THE RIGHT ! HALF PLANE OR ZR=-Z if Z IS IN THE LEFT HALF PLANE. MR INDIC- ! ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. ! NZ=-1 MEANS AN OVERFLOW WILL OCCUR ! !***SEE ALSO CBESK !***ROUTINES CALLED CAIRY, CS1S2, CUCHK, CUNHJ, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CUNK2 COMPLEX AI, ARG, ASUM, BSUM, CFN, CI, CIP, & CK, CONE, CRSC, CR1, CR2, CS, CSCL, CSGN, CSPN, CSR, CSS, CY, & CZERO, C1, C2, DAI, PHI, RZ, S1, S2, Y, Z, ZB, ZETA1, & ZETA2, ZN, ZR, PHID, ARGD, ZETA1D, ZETA2D, ASUMD, BSUMD REAL AARG, AIC, ALIM, ANG, APHI, ASC, ASCLE, BRY, CAR, CPN, C2I, & C2M, C2R, ELIM, FMR, FN, FNF, FNU, HPI, PI, RS1, SAR, SGN, SPN, & TOL, X, YY, R1MACH INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK, & KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC DIMENSION BRY(3), Y(N), ASUM(2), BSUM(2), PHI(2), ARG(2), & ZETA1(2), ZETA2(2), CY(2), CIP(4), CSS(3), CSR(3) DATA CZERO, CONE, CI, CR1, CR2 / & (0.0E0,0.0E0),(1.0E0,0.0E0),(0.0E0,1.0E0), & (1.0E0,1.73205080756887729E0),(-0.5E0,-8.66025403784438647E-01)/ DATA HPI, PI, AIC / & 1.57079632679489662E+00, 3.14159265358979324E+00, & 1.26551212348464539E+00/ DATA CIP(1),CIP(2),CIP(3),CIP(4)/ & (1.0E0,0.0E0), (0.0E0,-1.0E0), (-1.0E0,0.0E0), (0.0E0,1.0E0)/ !***FIRST EXECUTABLE STATEMENT CUNK2 KDFLG = 1 NZ = 0 !----------------------------------------------------------------------- ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN ! THE UNDERFLOW LIMIT !----------------------------------------------------------------------- CSCL = CMPLX(1.0E0/TOL,0.0E0) CRSC = CMPLX(TOL,0.0E0) CSS(1) = CSCL CSS(2) = CONE CSS(3) = CRSC CSR(1) = CRSC CSR(2) = CONE CSR(3) = CSCL BRY(1) = 1.0E+3*R1MACH(1)/TOL BRY(2) = 1.0E0/BRY(1) BRY(3) = R1MACH(2) X = REAL(Z) ZR = Z if (X < 0.0E0) ZR = -Z YY = AIMAG(ZR) ZN = -ZR*CI ZB = ZR INU = FNU FNF = FNU - INU ANG = -HPI*FNF CAR = COS(ANG) SAR = SIN(ANG) CPN = -HPI*CAR SPN = -HPI*SAR C2 = CMPLX(-SPN,CPN) KK = MOD(INU,4) + 1 CS = CR1*C2*CIP(KK) if (YY > 0.0E0) go to 10 ZN = CONJG(-ZN) ZB = CONJG(ZB) 10 CONTINUE !----------------------------------------------------------------------- ! K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST ! QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE COMPUTED BY ! CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS !----------------------------------------------------------------------- J = 2 DO 70 I=1,N !----------------------------------------------------------------------- ! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J !----------------------------------------------------------------------- J = 3 - J FN = FNU + (I-1) call CUNHJ(ZN, FN, 0, TOL, PHI(J), ARG(J), ZETA1(J), ZETA2(J), & ASUM(J), BSUM(J)) if (KODE == 1) go to 20 CFN = CMPLX(FN,0.0E0) S1 = ZETA1(J) - CFN*(CFN/(ZB+ZETA2(J))) go to 30 20 CONTINUE S1 = ZETA1(J) - ZETA2(J) 30 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = REAL(S1) if (ABS(RS1) > ELIM) go to 60 if (KDFLG == 1) KFLAG = 2 if (ABS(RS1) < ALIM) go to 40 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- APHI = ABS(PHI(J)) AARG = ABS(ARG(J)) RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC if (ABS(RS1) > ELIM) go to 60 if (KDFLG == 1) KFLAG = 1 if (RS1 < 0.0E0) go to 40 if (KDFLG == 1) KFLAG = 3 40 CONTINUE !----------------------------------------------------------------------- ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES !----------------------------------------------------------------------- C2 = ARG(J)*CR2 call CAIRY(C2, 0, 2, AI, NAI, IDUM) call CAIRY(C2, 1, 2, DAI, NDAI, IDUM) S2 = CS*PHI(J)*(AI*ASUM(J)+CR2*DAI*BSUM(J)) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(KFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (KFLAG /= 1) go to 50 call CUCHK(S2, NW, BRY(1), TOL) if (NW /= 0) go to 60 50 CONTINUE if (YY <= 0.0E0) S2 = CONJG(S2) CY(KDFLG) = S2 Y(I) = S2*CSR(KFLAG) CS = -CI*CS if (KDFLG == 2) go to 75 KDFLG = 2 go to 70 60 CONTINUE if (RS1 > 0.0E0) go to 300 !----------------------------------------------------------------------- ! FOR X < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW !----------------------------------------------------------------------- if (X < 0.0E0) go to 300 KDFLG = 1 Y(I) = CZERO CS = -CI*CS NZ=NZ+1 if (I == 1) go to 70 if (Y(I-1) == CZERO) go to 70 Y(I-1) = CZERO NZ=NZ+1 70 CONTINUE I=N 75 CONTINUE RZ = CMPLX(2.0E0,0.0E0)/ZR CK = CMPLX(FN,0.0E0)*RZ IB = I + 1 if (N < IB) go to 170 !----------------------------------------------------------------------- ! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO ! ON UNDERFLOW !----------------------------------------------------------------------- FN = FNU+(N-1) IPARD = 1 if (MR /= 0) IPARD = 0 call CUNHJ(ZN,FN,IPARD,TOL,PHID,ARGD,ZETA1D,ZETA2D,ASUMD,BSUMD) if (KODE == 1) go to 80 CFN=CMPLX(FN,0.0E0) S1=ZETA1D-CFN*(CFN/(ZB+ZETA2D)) go to 90 80 CONTINUE S1=ZETA1D-ZETA2D 90 CONTINUE RS1=REAL(S1) if (ABS(RS1) > ELIM) go to 95 if (ABS(RS1) < ALIM) go to 100 !----------------------------------------------------------------------- ! REFINE ESTIMATE AND TEST !----------------------------------------------------------------------- APHI=ABS(PHID) AARG = ABS(ARGD) RS1=RS1+ALOG(APHI)-0.25E0*ALOG(AARG)-AIC if (ABS(RS1) < ELIM) go to 100 95 CONTINUE if (RS1 > 0.0E0) go to 300 !----------------------------------------------------------------------- ! FOR X < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW !----------------------------------------------------------------------- if (X < 0.0E0) go to 300 NZ=N DO 96 I=1,N Y(I) = CZERO 96 CONTINUE return 100 CONTINUE !----------------------------------------------------------------------- ! SCALED FORWARD RECURRENCE FOR REMAINDER OF THE SEQUENCE !----------------------------------------------------------------------- S1 = CY(1) S2 = CY(2) C1 = CSR(KFLAG) ASCLE = BRY(KFLAG) DO 120 I=IB,N C2 = S2 S2 = CK*S2 + S1 S1 = C2 CK = CK + RZ C2 = S2*C1 Y(I) = C2 if (KFLAG >= 3) go to 120 C2R = REAL(C2) C2I = AIMAG(C2) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M <= ASCLE) go to 120 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1 = S1*C1 S2 = C2 S1 = S1*CSS(KFLAG) S2 = S2*CSS(KFLAG) C1 = CSR(KFLAG) 120 CONTINUE 170 CONTINUE if (MR == 0) RETURN !----------------------------------------------------------------------- ! ANALYTIC CONTINUATION FOR RE(Z) < 0.0E0 !----------------------------------------------------------------------- NZ = 0 FMR = MR SGN = -SIGN(PI,FMR) !----------------------------------------------------------------------- ! CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. !----------------------------------------------------------------------- CSGN = CMPLX(0.0E0,SGN) if (YY <= 0.0E0) CSGN = CONJG(CSGN) IFN = INU + N - 1 ANG = FNF*SGN CPN = COS(ANG) SPN = SIN(ANG) CSPN = CMPLX(CPN,SPN) if (MOD(IFN,2) == 1) CSPN = -CSPN !----------------------------------------------------------------------- ! CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS ! COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST ! QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE COMPUTED BY ! CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS !----------------------------------------------------------------------- CS = CMPLX(CAR,-SAR)*CSGN IN = MOD(IFN,4) + 1 C2 = CIP(IN) CS = CS*CONJG(C2) ASC = BRY(1) KK = N KDFLG = 1 IB = IB-1 IC = IB-1 IUF = 0 DO 270 K=1,N !----------------------------------------------------------------------- ! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K ! FUNCTION ABOVE !----------------------------------------------------------------------- FN = FNU+(KK-1) if (N > 2) go to 180 175 CONTINUE PHID = PHI(J) ARGD = ARG(J) ZETA1D = ZETA1(J) ZETA2D = ZETA2(J) ASUMD = ASUM(J) BSUMD = BSUM(J) J = 3 - J go to 190 180 CONTINUE if ((KK == N).AND.(IB < N)) go to 190 if ((KK == IB).OR.(KK == IC)) go to 175 call CUNHJ(ZN, FN, 0, TOL, PHID, ARGD, ZETA1D, ZETA2D, & ASUMD, BSUMD) 190 CONTINUE if (KODE == 1) go to 200 CFN = CMPLX(FN,0.0E0) S1 = -ZETA1D + CFN*(CFN/(ZB+ZETA2D)) go to 210 200 CONTINUE S1 = -ZETA1D + ZETA2D 210 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = REAL(S1) if (ABS(RS1) > ELIM) go to 260 if (KDFLG == 1) IFLAG = 2 if (ABS(RS1) < ALIM) go to 220 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- APHI = ABS(PHID) AARG = ABS(ARGD) RS1 = RS1 + ALOG(APHI) - 0.25E0*ALOG(AARG) - AIC if (ABS(RS1) > ELIM) go to 260 if (KDFLG == 1) IFLAG = 1 if (RS1 < 0.0E0) go to 220 if (KDFLG == 1) IFLAG = 3 220 CONTINUE call CAIRY(ARGD, 0, 2, AI, NAI, IDUM) call CAIRY(ARGD, 1, 2, DAI, NDAI, IDUM) S2 = CS*PHID*(AI*ASUMD+DAI*BSUMD) C2R = REAL(S1) C2I = AIMAG(S1) C2M = EXP(C2R)*REAL(CSS(IFLAG)) S1 = CMPLX(C2M,0.0E0)*CMPLX(COS(C2I),SIN(C2I)) S2 = S2*S1 if (IFLAG /= 1) go to 230 call CUCHK(S2, NW, BRY(1), TOL) if (NW /= 0) S2 = CMPLX(0.0E0,0.0E0) 230 CONTINUE if (YY <= 0.0E0) S2 = CONJG(S2) CY(KDFLG) = S2 C2 = S2 S2 = S2*CSR(IFLAG) !----------------------------------------------------------------------- ! ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N !----------------------------------------------------------------------- S1 = Y(KK) if (KODE == 1) go to 250 call CS1S2(ZR, S1, S2, NW, ASC, ALIM, IUF) NZ = NZ + NW 250 CONTINUE Y(KK) = S1*CSPN + S2 KK = KK - 1 CSPN = -CSPN CS = -CS*CI if (C2 /= CZERO) go to 255 KDFLG = 1 go to 270 255 CONTINUE if (KDFLG == 2) go to 275 KDFLG = 2 go to 270 260 CONTINUE if (RS1 > 0.0E0) go to 300 S2 = CZERO go to 230 270 CONTINUE K = N 275 CONTINUE IL = N-K if (IL == 0) RETURN !----------------------------------------------------------------------- ! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE ! K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP ! INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. !----------------------------------------------------------------------- S1 = CY(1) S2 = CY(2) CS = CSR(IFLAG) ASCLE = BRY(IFLAG) FN = INU+IL DO 290 I=1,IL C2 = S2 S2 = S1 + CMPLX(FN+FNF,0.0E0)*RZ*S2 S1 = C2 FN = FN - 1.0E0 C2 = S2*CS CK = C2 C1 = Y(KK) if (KODE == 1) go to 280 call CS1S2(ZR, C1, C2, NW, ASC, ALIM, IUF) NZ = NZ + NW 280 CONTINUE Y(KK) = C1*CSPN + C2 KK = KK - 1 CSPN = -CSPN if (IFLAG >= 3) go to 290 C2R = REAL(CK) C2I = AIMAG(CK) C2R = ABS(C2R) C2I = ABS(C2I) C2M = MAX(C2R,C2I) if (C2M <= ASCLE) go to 290 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1 = S1*CS S2 = CK S1 = S1*CSS(IFLAG) S2 = S2*CSS(IFLAG) CS = CSR(IFLAG) 290 CONTINUE return 300 CONTINUE NZ = -1 return end subroutine CUOIK (Z, FNU, KODE, IKFLG, N, Y, NUF, TOL, ELIM, ALIM) ! !! CUOIK is subsidiary to CBESH, CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUOIK-A, ZUOIK-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC ! EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM ! (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW ! WHERE ALIM < ELIM. if THE MAGNITUDE, BASED ON THE LEADING ! EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN ! THE RESULT IS ON SCALE. if NOT, THEN A REFINED TEST USING OTHER ! MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE ! EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= ! EXP(-ELIM)/TOL ! ! IKFLG=1 MEANS THE I SEQUENCE IS TESTED ! =2 MEANS THE K SEQUENCE IS TESTED ! NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE ! =-1 MEANS AN OVERFLOW WOULD OCCUR ! IKFLG=1 AND NUF > 0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO ! THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE ! IKFLG=2 AND NUF == N MEANS ALL Y VALUES WERE SET TO ZERO ! IKFLG=2 AND 0 < NUF < N NOT CONSIDERED. Y MUST BE SET BY ! ANOTHER ROUTINE ! !***SEE ALSO CBESH, CBESI, CBESK !***ROUTINES CALLED CUCHK, CUNHJ, CUNIK, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CUOIK COMPLEX ARG, ASUM, BSUM, CWRK, CZ, CZERO, PHI, SUM, Y, Z, ZB, & ZETA1, ZETA2, ZN, ZR REAL AARG, AIC, ALIM, APHI, ASCLE, AX, AY, ELIM, FNN, FNU, GNN, & GNU, RCZ, TOL, X, YY, R1MACH INTEGER I, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW DIMENSION Y(N), CWRK(16) DATA CZERO / (0.0E0,0.0E0) / DATA AIC / 1.265512123484645396E+00 / !***FIRST EXECUTABLE STATEMENT CUOIK NUF = 0 NN = N X = REAL(Z) ZR = Z if (X < 0.0E0) ZR = -Z ZB = ZR YY = AIMAG(ZR) AX = ABS(X)*1.7321E0 AY = ABS(YY) IFORM = 1 if (AY > AX) IFORM = 2 GNU = MAX(FNU,1.0E0) if (IKFLG == 1) go to 10 FNN = NN GNN = FNU + FNN - 1.0E0 GNU = MAX(GNN,FNN) 10 CONTINUE !----------------------------------------------------------------------- ! ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE ! REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET ! THE SIGN OF THE IMAGINARY PART CORRECT. !----------------------------------------------------------------------- if (IFORM == 2) go to 20 INIT = 0 call CUNIK(ZR, GNU, IKFLG, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, & CWRK) CZ = -ZETA1 + ZETA2 go to 40 20 CONTINUE ZN = -ZR*CMPLX(0.0E0,1.0E0) if (YY > 0.0E0) go to 30 ZN = CONJG(-ZN) 30 CONTINUE call CUNHJ(ZN, GNU, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) CZ = -ZETA1 + ZETA2 AARG = ABS(ARG) 40 CONTINUE if (KODE == 2) CZ = CZ - ZB if (IKFLG == 2) CZ = -CZ APHI = ABS(PHI) RCZ = REAL(CZ) !----------------------------------------------------------------------- ! OVERFLOW TEST !----------------------------------------------------------------------- if (RCZ > ELIM) go to 170 if (RCZ < ALIM) go to 50 RCZ = RCZ + ALOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC if (RCZ > ELIM) go to 170 go to 100 50 CONTINUE !----------------------------------------------------------------------- ! UNDERFLOW TEST !----------------------------------------------------------------------- if (RCZ < (-ELIM)) go to 60 if (RCZ > (-ALIM)) go to 100 RCZ = RCZ + ALOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC if (RCZ > (-ELIM)) go to 80 60 CONTINUE DO 70 I=1,NN Y(I) = CZERO 70 CONTINUE NUF = NN return 80 CONTINUE ASCLE = 1.0E+3*R1MACH(1)/TOL CZ = CZ + CLOG(PHI) if (IFORM == 1) go to 90 CZ = CZ - CMPLX(0.25E0,0.0E0)*CLOG(ARG) - CMPLX(AIC,0.0E0) 90 CONTINUE AX = EXP(RCZ)/TOL AY = AIMAG(CZ) CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) call CUCHK(CZ, NW, ASCLE, TOL) if (NW == 1) go to 60 100 CONTINUE if (IKFLG == 2) RETURN if (N == 1) RETURN !----------------------------------------------------------------------- ! SET UNDERFLOWS ON I SEQUENCE !----------------------------------------------------------------------- 110 CONTINUE GNU = FNU + (NN-1) if (IFORM == 2) go to 120 INIT = 0 call CUNIK(ZR, GNU, IKFLG, 1, TOL, INIT, PHI, ZETA1, ZETA2, SUM, & CWRK) CZ = -ZETA1 + ZETA2 go to 130 120 CONTINUE call CUNHJ(ZN, GNU, 1, TOL, PHI, ARG, ZETA1, ZETA2, ASUM, BSUM) CZ = -ZETA1 + ZETA2 AARG = ABS(ARG) 130 CONTINUE if (KODE == 2) CZ = CZ - ZB APHI = ABS(PHI) RCZ = REAL(CZ) if (RCZ < (-ELIM)) go to 140 if (RCZ > (-ALIM)) RETURN RCZ = RCZ + ALOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25E0*ALOG(AARG) - AIC if (RCZ > (-ELIM)) go to 150 140 CONTINUE Y(NN) = CZERO NN = NN - 1 NUF = NUF + 1 if (NN == 0) RETURN go to 110 150 CONTINUE ASCLE = 1.0E+3*R1MACH(1)/TOL CZ = CZ + CLOG(PHI) if (IFORM == 1) go to 160 CZ = CZ - CMPLX(0.25E0,0.0E0)*CLOG(ARG) - CMPLX(AIC,0.0E0) 160 CONTINUE AX = EXP(RCZ)/TOL AY = AIMAG(CZ) CZ = CMPLX(AX,0.0E0)*CMPLX(COS(AY),SIN(AY)) call CUCHK(CZ, NW, ASCLE, TOL) if (NW == 1) go to 140 return 170 CONTINUE NUF = -1 return end FUNCTION CV (XVAL, NDATA, NCONST, NORD, NBKPT, BKPT, W) ! !! CV evaluates the variance function of the curve obtained by FC. ! !***LIBRARY SLATEC !***CATEGORY L7A3 !***TYPE SINGLE PRECISION (CV-S, DCV-D) !***KEYWORDS ANALYSIS OF COVARIANCE, B-SPLINE, ! CONSTRAINED LEAST SQUARES, CURVE FITTING !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! CV( ) is a companion function subprogram for FC( ). The ! documentation for FC( ) has complete usage instructions. ! ! CV( ) is used to evaluate the variance function of the curve ! obtained by the constrained B-spline fitting subprogram, FC( ). ! The variance function defines the square of the probable error ! of the fitted curve at any point, XVAL. One can use the square ! root of this variance function to determine a probable error band ! around the fitted curve. ! ! CV( ) is used after a call to FC( ). MODE, an input variable to ! FC( ), is used to indicate if the variance function is desired. ! In order to use CV( ), MODE must equal 2 or 4 on input to FC( ). ! MODE is also used as an output flag from FC( ). Check to make ! sure that MODE = 0 after calling FC( ), indicating a successful ! constrained curve fit. The array SDDATA, as input to FC( ), must ! also be defined with the standard deviation or uncertainty of the ! Y values to use CV( ). ! ! To evaluate the variance function after calling FC( ) as stated ! above, use CV( ) as shown here ! ! VAR=CV(XVAL,NDATA,NCONST,NORD,NBKPT,BKPT,W) ! ! The variance function is given by ! ! VAR=(transpose of B(XVAL))*C*B(XVAL)/MAX(NDATA-N,1) ! ! where N = NBKPT - NORD. ! ! The vector B(XVAL) is the B-spline basis function values at ! X=XVAL. The covariance matrix, C, of the solution coefficients ! accounts only for the least squares equations and the explicitly ! stated equality constraints. This fact must be considered when ! interpreting the variance function from a data fitting problem ! that has inequality constraints on the fitted curve. ! ! All the variables in the calling sequence for CV( ) are used in ! FC( ) except the variable XVAL. Do not change the values of these ! variables between the call to FC( ) and the use of CV( ). ! ! The following is a brief description of the variables ! ! XVAL The point where the variance is desired. ! ! NDATA The number of discrete (X,Y) pairs for which FC( ) ! calculated a piece-wise polynomial curve. ! ! NCONST The number of conditions that constrained the B-spline in ! FC( ). ! ! NORD The order of the B-spline used in FC( ). ! The value of NORD must satisfy 1 < NORD < 20 . ! ! (The order of the spline is one more than the degree of ! the piece-wise polynomial defined on each interval. This ! is consistent with the B-spline package convention. For ! example, NORD=4 when we are using piece-wise cubics.) ! ! NBKPT The number of knots in the array BKPT(*). ! The value of NBKPT must satisfy NBKPT >= 2*NORD. ! ! BKPT(*) The real array of knots. Normally the problem data ! interval will be included between the limits BKPT(NORD) ! and BKPT(NBKPT-NORD+1). The additional end knots ! BKPT(I),I=1,...,NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are ! required by FC( ) to compute the functions used to fit ! the data. ! ! W(*) Real work array as used in FC( ). See FC( ) for the ! required length of W(*). The contents of W(*) must not ! be modified by the user if the variance function is ! desired. ! !***REFERENCES R. J. Hanson, Constrained least squares curve fitting ! to discrete data using B-splines, a users guide, ! Report SAND78-1291, Sandia Laboratories, December ! 1978. !***ROUTINES CALLED BSPLVN, SDOT !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE CV REAL CV DIMENSION BKPT(NBKPT), W(*), V(40) !***FIRST EXECUTABLE STATEMENT CV ZERO = 0. MDG = NBKPT - NORD + 3 MDW = NBKPT - NORD + 1 + NCONST IS = MDG*(NORD+1) + 2*MAX(NDATA,NBKPT) + NBKPT + NORD**2 LAST = NBKPT - NORD + 1 ILEFT = NORD 10 if (.NOT.(XVAL >= BKPT(ILEFT+1) .AND. ILEFT < LAST-1)) go to 20 ILEFT = ILEFT + 1 go to 10 20 call BSPLVN(BKPT, NORD, 1, XVAL, ILEFT, V(NORD+1)) ILEFT = ILEFT - NORD + 1 IP = MDW*(ILEFT-1) + ILEFT + IS N = NBKPT - NORD DO 30 I=1,NORD V(I) = SDOT(NORD,W(IP),1,V(NORD+1),1) IP = IP + MDW 30 CONTINUE CV = MAX(SDOT(NORD,V,1,V(NORD+1),1),ZERO) ! ! SCALE THE VARIANCE SO IT IS AN UNBIASED ESTIMATE. CV = CV/MAX(NDATA-N,1) return end subroutine CWRSK (ZR, FNU, KODE, N, Y, NZ, CW, TOL, ELIM, ALIM) ! !! CWRSK is subsidiary to CBESI and CBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CWRSK-A, ZWRSK-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! CWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z) >= 0.0 BY ! NORMALIZING THE I FUNCTION RATIOS FROM CRATI BY THE WRONSKIAN ! !***SEE ALSO CBESI, CBESK !***ROUTINES CALLED CBKNU, CRATI, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CWRSK COMPLEX CINU, CSCL, CT, CW, C1, C2, RCT, ST, Y, ZR REAL ACT, ACW, ALIM, ASCLE, ELIM, FNU, S1, S2, TOL, YY, R1MACH INTEGER I, KODE, N, NW, NZ DIMENSION Y(N), CW(2) !***FIRST EXECUTABLE STATEMENT CWRSK ! ! I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS ! Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE ! WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. ! NZ = 0 call CBKNU(ZR, FNU, KODE, 2, CW, NW, TOL, ELIM, ALIM) if (NW /= 0) go to 50 call CRATI(ZR, FNU, N, Y, TOL) !----------------------------------------------------------------------- ! RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), ! R(FNU+J-1,Z)=Y(J), J=1,...,N !----------------------------------------------------------------------- CINU = CMPLX(1.0E0,0.0E0) if (KODE == 1) go to 10 YY = AIMAG(ZR) S1 = COS(YY) S2 = SIN(YY) CINU = CMPLX(S1,S2) 10 CONTINUE !----------------------------------------------------------------------- ! ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH ! THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE ! SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT ! THE RESULT IS ON SCALE. !----------------------------------------------------------------------- ACW = ABS(CW(2)) ASCLE = 1.0E+3*R1MACH(1)/TOL CSCL = CMPLX(1.0E0,0.0E0) if (ACW > ASCLE) go to 20 CSCL = CMPLX(1.0E0/TOL,0.0E0) go to 30 20 CONTINUE ASCLE = 1.0E0/ASCLE if (ACW < ASCLE) go to 30 CSCL = CMPLX(TOL,0.0E0) 30 CONTINUE C1 = CW(1)*CSCL C2 = CW(2)*CSCL ST = Y(1) !----------------------------------------------------------------------- ! CINU=CINU*(CONJG(CT)/ABS(CT))*(1.0E0/ABS(CT) PREVENTS ! UNDER- OR OVERFLOW PREMATURELY BY SQUARING ABS(CT) !----------------------------------------------------------------------- CT = ZR*(C2+ST*C1) ACT = ABS(CT) RCT = CMPLX(1.0E0/ACT,0.0E0) CT = CONJG(CT)*RCT CINU = CINU*RCT*CT Y(1) = CINU*CSCL if (N == 1) RETURN DO 40 I=2,N CINU = ST*CINU ST = Y(I) Y(I) = CINU*CSCL 40 CONTINUE return 50 CONTINUE NZ = -1 if ( NW == (-2)) NZ=-2 return end FUNCTION D1MACH (I) ! !! D1MACH returns floating point machine dependent constants. ! !***LIBRARY SLATEC !***CATEGORY R1 !***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) !***KEYWORDS MACHINE CONSTANTS !***AUTHOR Fox, P. A., (Bell Labs) ! Hall, A. D., (Bell Labs) ! Schryer, N. L., (Bell Labs) !***DESCRIPTION ! ! D1MACH can be used to obtain machine-dependent parameters for the ! local machine environment. It is a function subprogram with one ! (input) argument, and can be referenced as follows: ! ! D = D1MACH(I) ! ! where I=1,...,5. The (output) value of D above is determined by ! the (input) value of I. The results for various values of I are ! discussed below. ! ! D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. ! D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. ! D1MACH( 3) = B**(-T), the smallest relative spacing. ! D1MACH( 4) = B**(1-T), the largest relative spacing. ! D1MACH( 5) = LOG10(B) ! ! Assume double precision numbers are represented in the T-digit, ! base-B form ! ! sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) ! ! where 0 <= X(I) < B for I=1,...,T, 0 < X(1), and ! EMIN <= E <= EMAX. ! ! The values of B, T, EMIN and EMAX are provided in I1MACH as ! follows: ! I1MACH(10) = B, the base. ! I1MACH(14) = T, the number of base-B digits. ! I1MACH(15) = EMIN, the smallest exponent E. ! I1MACH(16) = EMAX, the largest exponent E. ! ! To alter this function for a particular environment, the desired ! set of DATA statements should be activated by removing the C from ! column 1. Also, the values of D1MACH(1) - D1MACH(4) should be ! checked for consistency with the local operating system. ! !***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for ! a portable library, ACM Transactions on Mathematical ! Software 4, 2 (June 1978), pp. 177-188. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890213 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900618 Added DEC RISC constants. (WRB) ! 900723 Added IBM RS 6000 constants. (WRB) ! 900911 Added SUN 386i constants. (WRB) ! 910710 Added HP 730 constants. (SMR) ! 911114 Added Convex IEEE constants. (WRB) ! 920121 Added SUN -r8 compiler option constants. (WRB) ! 920229 Added Touchstone Delta i860 constants. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 920625 Added CONVEX -p8 and -pd8 compiler option constants. ! (BKS, WRB) ! 930201 Added DEC Alpha and SGI constants. (RWC and WRB) !***END PROLOGUE D1MACH ! double precision d1mach INTEGER SMALL(4) INTEGER LARGE(4) INTEGER RIGHT(4) INTEGER DIVER(4) INTEGER LOG10(4) ! DOUBLE PRECISION DMACH(5) SAVE DMACH ! EQUIVALENCE (DMACH(1),SMALL(1)) EQUIVALENCE (DMACH(2),LARGE(1)) EQUIVALENCE (DMACH(3),RIGHT(1)) EQUIVALENCE (DMACH(4),DIVER(1)) EQUIVALENCE (DMACH(5),LOG10(1)) ! ! MACHINE CONSTANTS FOR THE AMIGA ! ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION ! ! DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / ! DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / ! DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / ! DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / ! DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / ! ! MACHINE CONSTANTS FOR THE AMIGA ! ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT ! ! DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / ! DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / ! DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / ! DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / ! DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / ! ! MACHINE CONSTANTS FOR THE APOLLO ! ! DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / ! DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / ! DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / ! DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / ! DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / ! ! MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM ! ! DATA SMALL(1) / ZC00800000 / ! DATA SMALL(2) / Z000000000 / ! DATA LARGE(1) / ZDFFFFFFFF / ! DATA LARGE(2) / ZFFFFFFFFF / ! DATA RIGHT(1) / ZCC5800000 / ! DATA RIGHT(2) / Z000000000 / ! DATA DIVER(1) / ZCC6800000 / ! DATA DIVER(2) / Z000000000 / ! DATA LOG10(1) / ZD00E730E7 / ! DATA LOG10(2) / ZC77800DC0 / ! ! MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM ! ! DATA SMALL(1) / O1771000000000000 / ! DATA SMALL(2) / O0000000000000000 / ! DATA LARGE(1) / O0777777777777777 / ! DATA LARGE(2) / O0007777777777777 / ! DATA RIGHT(1) / O1461000000000000 / ! DATA RIGHT(2) / O0000000000000000 / ! DATA DIVER(1) / O1451000000000000 / ! DATA DIVER(2) / O0000000000000000 / ! DATA LOG10(1) / O1157163034761674 / ! DATA LOG10(2) / O0006677466732724 / ! ! MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS ! ! DATA SMALL(1) / O1771000000000000 / ! DATA SMALL(2) / O7770000000000000 / ! DATA LARGE(1) / O0777777777777777 / ! DATA LARGE(2) / O7777777777777777 / ! DATA RIGHT(1) / O1461000000000000 / ! DATA RIGHT(2) / O0000000000000000 / ! DATA DIVER(1) / O1451000000000000 / ! DATA DIVER(2) / O0000000000000000 / ! DATA LOG10(1) / O1157163034761674 / ! DATA LOG10(2) / O0006677466732724 / ! ! MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE ! ! DATA SMALL(1) / Z"3001800000000000" / ! DATA SMALL(2) / Z"3001000000000000" / ! DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / ! DATA LARGE(2) / Z"4FFE000000000000" / ! DATA RIGHT(1) / Z"3FD2800000000000" / ! DATA RIGHT(2) / Z"3FD2000000000000" / ! DATA DIVER(1) / Z"3FD3800000000000" / ! DATA DIVER(2) / Z"3FD3000000000000" / ! DATA LOG10(1) / Z"3FFF9A209A84FBCF" / ! DATA LOG10(2) / Z"3FFFF7988F8959AC" / ! ! MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES ! ! DATA SMALL(1) / 00564000000000000000B / ! DATA SMALL(2) / 00000000000000000000B / ! DATA LARGE(1) / 37757777777777777777B / ! DATA LARGE(2) / 37157777777777777777B / ! DATA RIGHT(1) / 15624000000000000000B / ! DATA RIGHT(2) / 00000000000000000000B / ! DATA DIVER(1) / 15634000000000000000B / ! DATA DIVER(2) / 00000000000000000000B / ! DATA LOG10(1) / 17164642023241175717B / ! DATA LOG10(2) / 16367571421742254654B / ! ! MACHINE CONSTANTS FOR THE CELERITY C1260 ! ! DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / ! DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / ! DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / ! DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / ! DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / ! ! MACHINE CONSTANTS FOR THE CONVEX ! USING THE -fn OR -pd8 COMPILER OPTION ! ! DATA DMACH(1) / Z'0010000000000000' / ! DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / ! DATA DMACH(3) / Z'3CC0000000000000' / ! DATA DMACH(4) / Z'3CD0000000000000' / ! DATA DMACH(5) / Z'3FF34413509F79FF' / ! ! MACHINE CONSTANTS FOR THE CONVEX ! USING THE -fi COMPILER OPTION ! ! DATA DMACH(1) / Z'0010000000000000' / ! DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / ! DATA DMACH(3) / Z'3CA0000000000000' / ! DATA DMACH(4) / Z'3CB0000000000000' / ! DATA DMACH(5) / Z'3FD34413509F79FF' / ! ! MACHINE CONSTANTS FOR THE CONVEX ! USING THE -p8 COMPILER OPTION ! ! DATA DMACH(1) / Z'00010000000000000000000000000000' / ! DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / ! DATA DMACH(3) / Z'3F900000000000000000000000000000' / ! DATA DMACH(4) / Z'3F910000000000000000000000000000' / ! DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / ! ! MACHINE CONSTANTS FOR THE CRAY ! ! DATA SMALL(1) / 201354000000000000000B / ! DATA SMALL(2) / 000000000000000000000B / ! DATA LARGE(1) / 577767777777777777777B / ! DATA LARGE(2) / 000007777777777777774B / ! DATA RIGHT(1) / 376434000000000000000B / ! DATA RIGHT(2) / 000000000000000000000B / ! DATA DIVER(1) / 376444000000000000000B / ! DATA DIVER(2) / 000000000000000000000B / ! DATA LOG10(1) / 377774642023241175717B / ! DATA LOG10(2) / 000007571421742254654B / ! ! MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 ! NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - ! STATIC DMACH(5) ! ! DATA SMALL / 20K, 3*0 / ! DATA LARGE / 77777K, 3*177777K / ! DATA RIGHT / 31420K, 3*0 / ! DATA DIVER / 32020K, 3*0 / ! DATA LOG10 / 40423K, 42023K, 50237K, 74776K / ! ! MACHINE CONSTANTS FOR THE DEC ALPHA ! USING G_FLOAT ! ! DATA DMACH(1) / '0000000000000010'X / ! DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / ! DATA DMACH(3) / '0000000000003CC0'X / ! DATA DMACH(4) / '0000000000003CD0'X / ! DATA DMACH(5) / '79FF509F44133FF3'X / ! ! MACHINE CONSTANTS FOR THE DEC ALPHA ! USING IEEE_FORMAT ! DATA DMACH(1) / Z'0010000000000000' / DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / DATA DMACH(3) / Z'3CA0000000000000' / DATA DMACH(4) / Z'3CB0000000000000' / DATA DMACH(5) / Z'3FD34413509F79FF' / ! ! MACHINE CONSTANTS FOR THE DEC RISC ! ! DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ ! DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ ! DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ ! DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ ! DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ ! ! MACHINE CONSTANTS FOR THE DEC VAX ! USING D_FLOATING ! (EXPRESSED IN INTEGER AND HEXADECIMAL) ! THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS ! THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS ! ! DATA SMALL(1), SMALL(2) / 128, 0 / ! DATA LARGE(1), LARGE(2) / -32769, -1 / ! DATA RIGHT(1), RIGHT(2) / 9344, 0 / ! DATA DIVER(1), DIVER(2) / 9472, 0 / ! DATA LOG10(1), LOG10(2) / 546979738, -805796613 / ! ! DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / ! DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / ! DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / ! DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / ! DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / ! ! MACHINE CONSTANTS FOR THE DEC VAX ! USING G_FLOATING ! (EXPRESSED IN INTEGER AND HEXADECIMAL) ! THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS ! THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS ! ! DATA SMALL(1), SMALL(2) / 16, 0 / ! DATA LARGE(1), LARGE(2) / -32769, -1 / ! DATA RIGHT(1), RIGHT(2) / 15552, 0 / ! DATA DIVER(1), DIVER(2) / 15568, 0 / ! DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / ! ! DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / ! DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / ! DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / ! DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / ! DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / ! ! MACHINE CONSTANTS FOR THE ELXSI 6400 ! (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) ! ! DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / ! DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / ! DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / ! DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / ! DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / ! ! MACHINE CONSTANTS FOR THE HARRIS 220 ! ! DATA SMALL(1), SMALL(2) / '20000000, '00000201 / ! DATA LARGE(1), LARGE(2) / '37777777, '37777577 / ! DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / ! DATA DIVER(1), DIVER(2) / '20000000, '00000334 / ! DATA LOG10(1), LOG10(2) / '23210115, '10237777 / ! ! MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES ! ! DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / ! DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / ! DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / ! DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / ! DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / ! ! MACHINE CONSTANTS FOR THE HP 730 ! ! DATA DMACH(1) / Z'0010000000000000' / ! DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / ! DATA DMACH(3) / Z'3CA0000000000000' / ! DATA DMACH(4) / Z'3CB0000000000000' / ! DATA DMACH(5) / Z'3FD34413509F79FF' / ! ! MACHINE CONSTANTS FOR THE HP 2100 ! THREE WORD DOUBLE PRECISION OPTION WITH FTN4 ! ! DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / ! DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / ! DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / ! DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / ! DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / ! ! MACHINE CONSTANTS FOR THE HP 2100 ! FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 ! ! DATA SMALL(1), SMALL(2) / 40000B, 0 / ! DATA SMALL(3), SMALL(4) / 0, 1 / ! DATA LARGE(1), LARGE(2) / 77777B, 177777B / ! DATA LARGE(3), LARGE(4) / 177777B, 177776B / ! DATA RIGHT(1), RIGHT(2) / 40000B, 0 / ! DATA RIGHT(3), RIGHT(4) / 0, 225B / ! DATA DIVER(1), DIVER(2) / 40000B, 0 / ! DATA DIVER(3), DIVER(4) / 0, 227B / ! DATA LOG10(1), LOG10(2) / 46420B, 46502B / ! DATA LOG10(3), LOG10(4) / 76747B, 176377B / ! ! MACHINE CONSTANTS FOR THE HP 9000 ! ! DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / ! DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / ! DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / ! DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / ! DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / ! ! MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, ! THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND ! THE PERKIN ELMER (INTERDATA) 7/32. ! ! DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / ! DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / ! DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / ! DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / ! DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / ! ! MACHINE CONSTANTS FOR THE IBM PC ! ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION ! ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. ! ! DATA SMALL(1) / 2.23D-308 / ! DATA LARGE(1) / 1.79D+308 / ! DATA RIGHT(1) / 1.11D-16 / ! DATA DIVER(1) / 2.22D-16 / ! DATA LOG10(1) / 0.301029995663981195D0 / ! ! MACHINE CONSTANTS FOR THE IBM RS 6000 ! ! DATA DMACH(1) / Z'0010000000000000' / ! DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / ! DATA DMACH(3) / Z'3CA0000000000000' / ! DATA DMACH(4) / Z'3CB0000000000000' / ! DATA DMACH(5) / Z'3FD34413509F79FF' / ! ! MACHINE CONSTANTS FOR THE INTEL i860 ! ! DATA DMACH(1) / Z'0010000000000000' / ! DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / ! DATA DMACH(3) / Z'3CA0000000000000' / ! DATA DMACH(4) / Z'3CB0000000000000' / ! DATA DMACH(5) / Z'3FD34413509F79FF' / ! ! MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) ! ! DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / ! DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / ! DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / ! DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / ! DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / ! ! MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) ! ! DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / ! DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / ! DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / ! DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / ! DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / ! ! MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING ! 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). ! ! DATA SMALL(1), SMALL(2) / 8388608, 0 / ! DATA LARGE(1), LARGE(2) / 2147483647, -1 / ! DATA RIGHT(1), RIGHT(2) / 612368384, 0 / ! DATA DIVER(1), DIVER(2) / 620756992, 0 / ! DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / ! ! DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / ! DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / ! DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / ! DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / ! DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / ! ! MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING ! 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). ! ! DATA SMALL(1), SMALL(2) / 128, 0 / ! DATA SMALL(3), SMALL(4) / 0, 0 / ! DATA LARGE(1), LARGE(2) / 32767, -1 / ! DATA LARGE(3), LARGE(4) / -1, -1 / ! DATA RIGHT(1), RIGHT(2) / 9344, 0 / ! DATA RIGHT(3), RIGHT(4) / 0, 0 / ! DATA DIVER(1), DIVER(2) / 9472, 0 / ! DATA DIVER(3), DIVER(4) / 0, 0 / ! DATA LOG10(1), LOG10(2) / 16282, 8346 / ! DATA LOG10(3), LOG10(4) / -31493, -12296 / ! ! DATA SMALL(1), SMALL(2) / O000200, O000000 / ! DATA SMALL(3), SMALL(4) / O000000, O000000 / ! DATA LARGE(1), LARGE(2) / O077777, O177777 / ! DATA LARGE(3), LARGE(4) / O177777, O177777 / ! DATA RIGHT(1), RIGHT(2) / O022200, O000000 / ! DATA RIGHT(3), RIGHT(4) / O000000, O000000 / ! DATA DIVER(1), DIVER(2) / O022400, O000000 / ! DATA DIVER(3), DIVER(4) / O000000, O000000 / ! DATA LOG10(1), LOG10(2) / O037632, O020232 / ! DATA LOG10(3), LOG10(4) / O102373, O147770 / ! ! MACHINE CONSTANTS FOR THE SILICON GRAPHICS ! ! DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / ! DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / ! DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / ! DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / ! DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / ! ! MACHINE CONSTANTS FOR THE SUN ! ! DATA DMACH(1) / Z'0010000000000000' / ! DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / ! DATA DMACH(3) / Z'3CA0000000000000' / ! DATA DMACH(4) / Z'3CB0000000000000' / ! DATA DMACH(5) / Z'3FD34413509F79FF' / ! ! MACHINE CONSTANTS FOR THE SUN ! USING THE -r8 COMPILER OPTION ! ! DATA DMACH(1) / Z'00010000000000000000000000000000' / ! DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / ! DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / ! DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / ! DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / ! ! MACHINE CONSTANTS FOR THE SUN 386i ! ! DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / ! DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / ! DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / ! DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' ! DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / ! ! MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER ! ! DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / ! DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / ! DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / ! DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / ! DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / ! !***FIRST EXECUTABLE STATEMENT D1MACH ! if ( I < 1 .OR. I > 5 ) then call XERMSG ('SLATEC', 'D1MACH', 'I OUT OF BOUNDS', 1, 2) end if D1MACH = DMACH(I) return end subroutine D1MERG (TCOS, I1, M1, I2, M2, I3) ! !! D1MERG merges two strings of ascending double precision numbers. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (S1MERG-S, D1MERG-D, CMERGE-C, I1MERG-I) !***AUTHOR Boland, W. Robert, (LANL) ! Clemens, Reginald, (PLK) !***DESCRIPTION ! ! This subroutine merges two ascending strings of numbers in the ! array TCOS. The first string is of length M1 and starts at ! TCOS(I1+1). The second string is of length M2 and starts at ! TCOS(I2+1). The merged string goes into TCOS(I3+1). ! ! This routine is currently unused, but was added to complete ! the set of routines S1MERG and C1MERG (both of which are used). ! !***ROUTINES CALLED DCOPY !***REVISION HISTORY (YYMMDD) ! 910819 DATE WRITTEN !***END PROLOGUE D1MERG INTEGER I1, I2, I3, M1, M2 DOUBLE PRECISION TCOS(*) ! INTEGER J1, J2, J3 ! !***FIRST EXECUTABLE STATEMENT D1MERG if (M1 == 0 .AND. M2 == 0) RETURN ! if (M1 == 0 .AND. M2 /= 0) THEN call DCOPY (M2, TCOS(I2+1), 1, TCOS(I3+1), 1) return end if ! if (M1 /= 0 .AND. M2 == 0) THEN call DCOPY (M1, TCOS(I1+1), 1, TCOS(I3+1), 1) return end if ! J1 = 1 J2 = 1 J3 = 1 ! 10 if (TCOS(I1+J1) <= TCOS(I2+J2)) THEN TCOS(I3+J3) = TCOS(I1+J1) J1 = J1+1 if (J1 > M1) THEN call DCOPY (M2-J2+1, TCOS(I2+J2), 1, TCOS(I3+J3+1), 1) return ENDIF ELSE TCOS(I3+J3) = TCOS(I2+J2) J2 = J2+1 if (J2 > M2) THEN call DCOPY (M1-J1+1, TCOS(I1+J1), 1, TCOS(I3+J3+1), 1) return ENDIF end if J3 = J3+1 go to 10 end subroutine D1MPYQ (M, N, A, LDA, V, W) ! !! D1MPYQ is subsidiary to DNSQ and DNSQE. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (R1MPYQ-S, D1MPYQ-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an M by N matrix A, this subroutine computes A*Q where ! Q is the product of 2*(N - 1) transformations ! ! GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) ! ! and GV(I), GW(I) are Givens rotations in the (I,N) plane which ! eliminate elements in the I-th and N-th planes, respectively. ! Q itself is not given, rather the information to recover the ! GV, GW rotations is supplied. ! ! The SUBROUTINE statement is ! ! SUBROUTINE D1MPYQ(M,N,A,LDA,V,W) ! ! where ! ! M is a positive integer input variable set to the number ! of rows of A. ! ! N IS a positive integer input variable set to the number ! of columns of A. ! ! A is an M by N array. On input A must contain the matrix ! to be postmultiplied by the orthogonal matrix Q ! described above. On output A*Q has replaced A. ! ! LDA is a positive integer input variable not less than M ! which specifies the leading dimension of the array A. ! ! V is an input array of length N. V(I) must contain the ! information necessary to recover the Givens rotation GV(I) ! described above. ! ! W is an input array of length N. W(I) must contain the ! information necessary to recover the Givens rotation GW(I) ! described above. ! !***SEE ALSO DNSQ, DNSQE !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE D1MPYQ INTEGER I, J, LDA, M, N, NM1, NMJ DOUBLE PRECISION A(LDA,*), COS, ONE, SIN, TEMP, V(*), W(*) SAVE ONE DATA ONE /1.0D0/ ! ! APPLY THE FIRST SET OF GIVENS ROTATIONS TO A. ! !***FIRST EXECUTABLE STATEMENT D1MPYQ NM1 = N - 1 if (NM1 < 1) go to 50 DO 20 NMJ = 1, NM1 J = N - NMJ if (ABS(V(J)) > ONE) COS = ONE/V(J) if (ABS(V(J)) > ONE) SIN = SQRT(ONE-COS**2) if (ABS(V(J)) <= ONE) SIN = V(J) if (ABS(V(J)) <= 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 ! ! APPLY THE SECOND SET OF GIVENS ROTATIONS TO A. ! DO 40 J = 1, NM1 if (ABS(W(J)) > ONE) COS = ONE/W(J) if (ABS(W(J)) > ONE) SIN = SQRT(ONE-COS**2) if (ABS(W(J)) <= ONE) SIN = W(J) if (ABS(W(J)) <= 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 ! ! LAST CARD OF SUBROUTINE D1MPYQ. ! end subroutine D1UPDT (M, N, S, LS, U, V, W, SING) ! !! D1UPDT is subsidiary to DNSQ and DNSQE. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (R1UPDT-S, D1UPDT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an M by N lower trapezoidal matrix S, an M-vector U, ! and an N-vector V, the problem is to determine an ! orthogonal matrix Q such that ! ! t ! (S + U*V )*Q ! ! is again lower trapezoidal. ! ! This subroutine determines Q as the product of 2*(N - 1) ! transformations ! ! GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) ! ! where GV(I), GW(I) are Givens rotations in the (I,N) plane ! which eliminate elements in the I-th and N-th planes, ! respectively. Q itself is not accumulated, rather the ! information to recover the GV, GW rotations is returned. ! ! The SUBROUTINE statement is ! ! SUBROUTINE D1UPDT(M,N,S,LS,U,V,W,SING) ! ! where ! ! M is a positive integer input variable set to the number ! of rows of S. ! ! N is a positive integer input variable set to the number ! of columns of S. N must not exceed M. ! ! S is an array of length LS. On input S must contain the lower ! trapezoidal matrix S stored by columns. On output S contains ! the lower trapezoidal matrix produced as described above. ! ! LS is a positive integer input variable not less than ! (N*(2*M-N+1))/2. ! ! U is an input array of length M which must contain the ! vector U. ! ! V is an array of length N. On input V must contain the vector ! V. On output V(I) contains the information necessary to ! recover the Givens rotation GV(I) described above. ! ! W is an output array of length M. W(I) contains information ! necessary to recover the Givens rotation GW(I) described ! above. ! ! SING is a LOGICAL output variable. SING is set TRUE if any ! of the diagonal elements of the output S are zero. Otherwise ! SING is set FALSE. ! !***SEE ALSO DNSQ, DNSQE !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE D1UPDT DOUBLE PRECISION D1MACH INTEGER I, J, JJ, L, LS, M, N, NM1, NMJ DOUBLE PRECISION COS, COTAN, GIANT, ONE, P25, P5, S(*), & SIN, TAN, TAU, TEMP, U(*), V(*), W(*), ZERO LOGICAL SING SAVE ONE, P5, P25, ZERO DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/ ! ! GIANT IS THE LARGEST MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT D1UPDT GIANT = D1MACH(2) ! ! INITIALIZE THE DIAGONAL ELEMENT POINTER. ! JJ = (N*(2*M - N + 1))/2 - (M - N) ! ! MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W. ! L = JJ DO 10 I = N, M W(I) = S(L) L = L + 1 10 CONTINUE ! ! ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR ! IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W. ! NM1 = N - 1 if (NM1 < 1) go to 70 DO 60 NMJ = 1, NM1 J = N - NMJ JJ = JJ - (M - J + 1) W(J) = ZERO if (V(J) == ZERO) go to 50 ! ! DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE ! J-TH ELEMENT OF V. ! if (ABS(V(N)) >= 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 > 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 ! ! APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION ! NECESSARY TO RECOVER THE GIVENS ROTATION. ! V(N) = SIN*V(J) + COS*V(N) V(J) = TAU ! ! APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W. ! 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 ! ! ADD THE SPIKE FROM THE RANK 1 UPDATE TO W. ! DO 80 I = 1, M W(I) = W(I) + V(N)*U(I) 80 CONTINUE ! ! ELIMINATE THE SPIKE. ! SING = .FALSE. if (NM1 < 1) go to 140 DO 130 J = 1, NM1 if (W(J) == ZERO) go to 120 ! ! DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE ! J-TH ELEMENT OF THE SPIKE. ! if (ABS(S(JJ)) >= 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 > 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 ! ! APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W. ! 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 ! ! STORE THE INFORMATION NECESSARY TO RECOVER THE ! GIVENS ROTATION. ! W(J) = TAU 120 CONTINUE ! ! TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S. ! if (S(JJ) == ZERO) SING = .TRUE. JJ = JJ + (M - J + 1) 130 CONTINUE 140 CONTINUE ! ! MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S. ! L = JJ DO 150 I = N, M S(L) = W(I) L = L + 1 150 CONTINUE if (S(JJ) == ZERO) SING = .TRUE. return ! ! LAST CARD OF SUBROUTINE D1UPDT. ! end subroutine D9AIMP (X, AMPL, THETA) ! !! D9AIMP evaluates the Airy modulus and phase. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10D !***TYPE DOUBLE PRECISION (R9AIMP-S, D9AIMP-D) !***KEYWORDS AIRY FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate the Airy modulus and phase for X <= -1.0 ! ! Series for AM20 on the interval -1.56250E-02 to 0. ! with weighted error 3.12E-32 ! log weighted error 31.51 ! significant figures required 29.24 ! decimal places required 32.38 ! ! Series for ATH0 on the interval -1.56250E-02 to 0. ! with weighted error 2.75E-32 ! log weighted error 31.56 ! significant figures required 30.17 ! decimal places required 32.42 ! ! Series for AM21 on the interval -1.25000E-01 to -1.56250E-02 ! with weighted error 3.40E-32 ! log weighted error 31.47 ! significant figures required 29.02 ! decimal places required 32.36 ! ! Series for ATH1 on the interval -1.25000E-01 to -1.56250E-02 ! with weighted error 2.94E-32 ! log weighted error 31.53 ! significant figures required 30.08 ! decimal places required 32.41 ! ! Series for AM22 on the interval -1.00000E+00 to -1.25000E-01 ! with weighted error 3.76E-32 ! log weighted error 31.42 ! significant figures required 29.47 ! decimal places required 32.36 ! ! Series for ATH2 on the interval -1.00000E+00 to -1.25000E-01 ! with weighted error 4.97E-32 ! log weighted error 31.30 ! significant figures required 29.79 ! decimal places required 32.23 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE D9AIMP DOUBLE PRECISION X, AMPL, THETA, AM20CS(57), ATH0CS(53), & AM21CS(60), ATH1CS(58), AM22CS(74), ATH2CS(72), PI4, SQRTX, & XSML, Z, D1MACH, DCSEVL LOGICAL FIRST SAVE AM20CS, ATH0CS, AM21CS, ATH1CS, AM22CS, ATH2CS, & PI4, NAM20, NATH0, NAM21, NATH1, NAM22, NATH2, XSML, FIRST DATA AM20CS( 1) / +.108716749086561856615730588125D-1 / DATA AM20CS( 2) / +.369489228982663555091728665146D-3 / DATA AM20CS( 3) / +.440680100484689563667507001327D-5 / DATA AM20CS( 4) / +.143686762361911153929183952833D-6 / DATA AM20CS( 5) / +.824275552390078308670628855353D-8 / DATA AM20CS( 6) / +.684426758893661606173927278180D-9 / DATA AM20CS( 7) / +.739566697282739287731004740213D-10 / DATA AM20CS( 8) / +.974595633696825017638702600847D-11 / DATA AM20CS( 9) / +.150076885829405775650973119497D-11 / DATA AM20CS( 10) / +.262147910221527634206252854802D-12 / DATA AM20CS( 11) / +.508354111376487180357278966914D-13 / DATA AM20CS( 12) / +.107684753358811440492985997070D-13 / DATA AM20CS( 13) / +.246091286618433429335914062617D-14 / DATA AM20CS( 14) / +.600786380358656418436110373550D-15 / DATA AM20CS( 15) / +.155449156102388071150651388384D-15 / DATA AM20CS( 16) / +.423535125035576604426382780182D-16 / DATA AM20CS( 17) / +.120862166289299840154401109189D-16 / DATA AM20CS( 18) / +.359609651214658240861499706423D-17 / DATA AM20CS( 19) / +.111134218386395638261774604677D-17 / DATA AM20CS( 20) / +.355559532432366609893680289225D-18 / DATA AM20CS( 21) / +.117433021600139309998766947387D-18 / DATA AM20CS( 22) / +.399397454661077561389162200966D-19 / DATA AM20CS( 23) / +.139576671528916310425606325640D-19 / DATA AM20CS( 24) / +.500240055309236041393459280716D-20 / DATA AM20CS( 25) / +.183552760958132679184834866457D-20 / DATA AM20CS( 26) / +.688490998179202743197790112404D-21 / DATA AM20CS( 27) / +.263631035611417012359996885105D-21 / DATA AM20CS( 28) / +.102924890237338360287153563785D-21 / DATA AM20CS( 29) / +.409246966671594885489762960571D-22 / DATA AM20CS( 30) / +.165558573406734651039727903828D-22 / DATA AM20CS( 31) / +.680797467063033356116599685727D-23 / DATA AM20CS( 32) / +.284326559934079832419751134476D-23 / DATA AM20CS( 33) / +.120507398348965255097287818819D-23 / DATA AM20CS( 34) / +.517961243287505217976613610424D-24 / DATA AM20CS( 35) / +.225622613427562816303268640887D-24 / DATA AM20CS( 36) / +.995418801147745168832117078246D-25 / DATA AM20CS( 37) / +.444551696397342424308280582053D-25 / DATA AM20CS( 38) / +.200865195461501101425916097338D-25 / DATA AM20CS( 39) / +.917786344151775165973885645402D-26 / DATA AM20CS( 40) / +.423872958105589240661672197948D-26 / DATA AM20CS( 41) / +.197789272007846092370846251490D-26 / DATA AM20CS( 42) / +.932116351284620665680435253373D-27 / DATA AM20CS( 43) / +.443482133249918099955611379722D-27 / DATA AM20CS( 44) / +.212945672365573895594589552837D-27 / DATA AM20CS( 45) / +.103158569651075977552209344907D-27 / DATA AM20CS( 46) / +.504023773022591199157904590029D-28 / DATA AM20CS( 47) / +.248301304570155945304046541005D-28 / DATA AM20CS( 48) / +.123301783128562196054198238560D-28 / DATA AM20CS( 49) / +.617033449920521746121976730507D-29 / DATA AM20CS( 50) / +.311092617415918897233869792213D-29 / DATA AM20CS( 51) / +.157983085201706173015269071503D-29 / DATA AM20CS( 52) / +.807931987538283607678121339092D-30 / DATA AM20CS( 53) / +.415997394138667562722951360052D-30 / DATA AM20CS( 54) / +.215610934097716900471935862504D-30 / DATA AM20CS( 55) / +.112468857265869178296752823613D-30 / DATA AM20CS( 56) / +.590331560632838091123040811797D-31 / DATA AM20CS( 57) / +.311735667692928562046280505333D-31 / DATA ATH0CS( 1) / -.8172601764161634499840208700543D-1 / DATA ATH0CS( 2) / -.8004012824788273287596481113068D-3 / DATA ATH0CS( 3) / -.3186525268782113203795553628242D-5 / DATA ATH0CS( 4) / -.6688388266477509330741698865033D-7 / DATA ATH0CS( 5) / -.2931759284994564516506822463184D-8 / DATA ATH0CS( 6) / -.2011263760883621669049030307186D-9 / DATA ATH0CS( 7) / -.1877522678055973426074008166652D-10 / DATA ATH0CS( 8) / -.2199637137704601251899002199848D-11 / DATA ATH0CS( 9) / -.3071616682592272449025746605586D-12 / DATA ATH0CS( 10) / -.4936140553673418361025600985389D-13 / DATA ATH0CS( 11) / -.8902833722583660416935236969866D-14 / DATA ATH0CS( 12) / -.1768987764615272613656814199467D-14 / DATA ATH0CS( 13) / -.3817868689032277014678199609600D-15 / DATA ATH0CS( 14) / -.8851159014819947594156286509984D-16 / DATA ATH0CS( 15) / -.2184818181414365953149677679568D-16 / DATA ATH0CS( 16) / -.5700849046986452380599442295119D-17 / DATA ATH0CS( 17) / -.1563121122177875392516031795495D-17 / DATA ATH0CS( 18) / -.4481437996768995067906688776353D-18 / DATA ATH0CS( 19) / -.1337794883736188022044566044098D-18 / DATA ATH0CS( 20) / -.4143340036874114453776852445442D-19 / DATA ATH0CS( 21) / -.1327263385718805025080481164652D-19 / DATA ATH0CS( 22) / -.4385728589128440522215756835955D-20 / DATA ATH0CS( 23) / -.1491360695952818067686201743956D-20 / DATA ATH0CS( 24) / -.5208104738630711377154238188773D-21 / DATA ATH0CS( 25) / -.1864382222390498923872526604979D-21 / DATA ATH0CS( 26) / -.6830263751167969012975435381881D-22 / DATA ATH0CS( 27) / -.2557117058029329629296207591347D-22 / DATA ATH0CS( 28) / -.9770158640254300218246907254046D-23 / DATA ATH0CS( 29) / -.3805161433416679084068428254886D-23 / DATA ATH0CS( 30) / -.1509022750737054063493926482995D-23 / DATA ATH0CS( 31) / -.6087551341242424929005568014525D-24 / DATA ATH0CS( 32) / -.2495879513809711495425982124058D-24 / DATA ATH0CS( 33) / -.1039157654581920948909588084274D-24 / DATA ATH0CS( 34) / -.4390235913976846536974594969051D-25 / DATA ATH0CS( 35) / -.1880790678447990211675826820582D-25 / DATA ATH0CS( 36) / -.8165070764199462948863022205753D-26 / DATA ATH0CS( 37) / -.3589944503749750514266435585041D-26 / DATA ATH0CS( 38) / -.1597658126632132872981291608708D-26 / DATA ATH0CS( 39) / -.7193250175703823969113802835305D-27 / DATA ATH0CS( 40) / -.3274943012727856506209351132721D-27 / DATA ATH0CS( 41) / -.1507042445783690665816975047272D-27 / DATA ATH0CS( 42) / -.7006624198319904717843967949140D-28 / DATA ATH0CS( 43) / -.3289907402983718226528815678356D-28 / DATA ATH0CS( 44) / -.1559518084365146526445322711496D-28 / DATA ATH0CS( 45) / -.7460690508208254582833851119721D-29 / DATA ATH0CS( 46) / -.3600877034824662020563277249431D-29 / DATA ATH0CS( 47) / -.1752851437473772257350402219197D-29 / DATA ATH0CS( 48) / -.8603275775188512909623778628724D-30 / DATA ATH0CS( 49) / -.4256432603226946534668039480105D-30 / DATA ATH0CS( 50) / -.2122161865044262927723650698206D-30 / DATA ATH0CS( 51) / -.1065996156704879052472060798561D-30 / DATA ATH0CS( 52) / -.5393568608816949116410688086892D-31 / DATA ATH0CS( 53) / -.2748174851043954822278496517870D-31 / DATA AM21CS( 1) / +.592790266721309588375717482814D-2 / DATA AM21CS( 2) / +.200569405393165186428695217690D-2 / DATA AM21CS( 3) / +.911081850262275893553072526291D-4 / DATA AM21CS( 4) / +.849894306372047155633172107475D-5 / DATA AM21CS( 5) / +.113297908976913076637929215494D-5 / DATA AM21CS( 6) / +.187517946100666496180950627804D-6 / DATA AM21CS( 7) / +.359306519018245832699035211192D-7 / DATA AM21CS( 8) / +.765757714071683864039093517470D-8 / DATA AM21CS( 9) / +.176999967168039173925953460744D-8 / DATA AM21CS( 10) / +.436259555654598932720546585535D-9 / DATA AM21CS( 11) / +.113291641337853230035520085219D-9 / DATA AM21CS( 12) / +.307257690982419244137868398126D-10 / DATA AM21CS( 13) / +.864482416482201075541200465766D-11 / DATA AM21CS( 14) / +.251015250060924402115104562212D-11 / DATA AM21CS( 15) / +.749102496764440371601802227751D-12 / DATA AM21CS( 16) / +.228996928487994073089565214432D-12 / DATA AM21CS( 17) / +.715113658927987694949327491175D-13 / DATA AM21CS( 18) / +.227607924959566841946395165061D-13 / DATA AM21CS( 19) / +.736942142760886513969953227782D-14 / DATA AM21CS( 20) / +.242328675267827490463991742006D-14 / DATA AM21CS( 21) / +.808153774548239869283406558403D-15 / DATA AM21CS( 22) / +.273008079804356086659174563386D-15 / DATA AM21CS( 23) / +.933236070891385318473519474326D-16 / DATA AM21CS( 24) / +.322508099681084622213867546973D-16 / DATA AM21CS( 25) / +.112581932346444541217757573416D-16 / DATA AM21CS( 26) / +.396699463986938821660259459530D-17 / DATA AM21CS( 27) / +.141006567944319504660865034527D-17 / DATA AM21CS( 28) / +.505302086537851213375537393032D-18 / DATA AM21CS( 29) / +.182461523215945141197999102789D-18 / DATA AM21CS( 30) / +.663584568262130466928029121642D-19 / DATA AM21CS( 31) / +.242963731631276179741747455826D-19 / DATA AM21CS( 32) / +.895238915123687802013669922963D-20 / DATA AM21CS( 33) / +.331845289350050791260229250755D-20 / DATA AM21CS( 34) / +.123706196188658315384437905922D-20 / DATA AM21CS( 35) / +.463636677012390840306767734243D-21 / DATA AM21CS( 36) / +.174653135947764475469758765989D-21 / DATA AM21CS( 37) / +.661116810234991176307910643111D-22 / DATA AM21CS( 38) / +.251409918994072486176125666459D-22 / DATA AM21CS( 39) / +.960274995571732568694034386998D-23 / DATA AM21CS( 40) / +.368324952289296395686436898078D-23 / DATA AM21CS( 41) / +.141843138269159136145535939553D-23 / DATA AM21CS( 42) / +.548342674276935830106345800990D-24 / DATA AM21CS( 43) / +.212761054623118806650372562616D-24 / DATA AM21CS( 44) / +.828443700849418591487734760953D-25 / DATA AM21CS( 45) / +.323670563926127001421028600927D-25 / DATA AM21CS( 46) / +.126868882963286057355055062493D-25 / DATA AM21CS( 47) / +.498843818992121626935068934362D-26 / DATA AM21CS( 48) / +.196734584467649390967119381790D-26 / DATA AM21CS( 49) / +.778135971020326957713212064836D-27 / DATA AM21CS( 50) / +.308633941498911152919192968451D-27 / DATA AM21CS( 51) / +.122744647045453119789338037234D-27 / DATA AM21CS( 52) / +.489431279134292205885241216204D-28 / DATA AM21CS( 53) / +.195646879802909821175925099724D-28 / DATA AM21CS( 54) / +.783988952922426171166311492266D-29 / DATA AM21CS( 55) / +.314896914002484223748298978099D-29 / DATA AM21CS( 56) / +.126769763137250681307067842559D-29 / DATA AM21CS( 57) / +.511470691906900141641632107724D-30 / DATA AM21CS( 58) / +.206801709795538770250900316706D-30 / DATA AM21CS( 59) / +.837891344768519001325996867583D-31 / DATA AM21CS( 60) / +.340168991971489802052339079577D-31 / DATA ATH1CS( 1) / -.6972849916208883845888148415037D-1 / DATA ATH1CS( 2) / -.5108722790650044987073448077961D-2 / DATA ATH1CS( 3) / -.8644335996989755094525334749512D-4 / DATA ATH1CS( 4) / -.5604720044235263542188698916125D-5 / DATA ATH1CS( 5) / -.6045735125623897409156376640077D-6 / DATA ATH1CS( 6) / -.8639802632488334393219721138499D-7 / DATA ATH1CS( 7) / -.1480809484309927157147782480780D-7 / DATA ATH1CS( 8) / -.2885809334577236039999449908712D-8 / DATA ATH1CS( 9) / -.6191631975665699609309191231800D-9 / DATA ATH1CS( 10) / -.1431992808860957830931365259879D-9 / DATA ATH1CS( 11) / -.3518141102137214721504616874321D-10 / DATA ATH1CS( 12) / -.9084761919955078290070339808051D-11 / DATA ATH1CS( 13) / -.2446171672688598449343283664767D-11 / DATA ATH1CS( 14) / -.6826083203213446240828996710264D-12 / DATA ATH1CS( 15) / -.1964579931194940171278546257802D-12 / DATA ATH1CS( 16) / -.5808933227139693164009191265856D-13 / DATA ATH1CS( 17) / -.1759042249527441992795400959024D-13 / DATA ATH1CS( 18) / -.5440902932714896613632538945319D-14 / DATA ATH1CS( 19) / -.1715247407486806802622358519451D-14 / DATA ATH1CS( 20) / -.5500929233576991546871101847161D-15 / DATA ATH1CS( 21) / -.1791878287739317259495152638754D-15 / DATA ATH1CS( 22) / -.5920372520086694197778411062231D-16 / DATA ATH1CS( 23) / -.1981713027876483962470972206590D-16 / DATA ATH1CS( 24) / -.6713232347016352262049984343790D-17 / DATA ATH1CS( 25) / -.2299450243658281116122358619832D-17 / DATA ATH1CS( 26) / -.7957300928236376595304637145634D-18 / DATA ATH1CS( 27) / -.2779994027291784157172290233739D-18 / DATA ATH1CS( 28) / -.9798924361326985224406795480814D-19 / DATA ATH1CS( 29) / -.3482717006061574386702645565849D-19 / DATA ATH1CS( 30) / -.1247489122558599057173300058084D-19 / DATA ATH1CS( 31) / -.4501210041478228113487751824452D-20 / DATA ATH1CS( 32) / -.1635346244013352135596114164667D-20 / DATA ATH1CS( 33) / -.5980102897780336268098762265941D-21 / DATA ATH1CS( 34) / -.2200246286286123454028196295475D-21 / DATA ATH1CS( 35) / -.8142463073515085897408205291519D-22 / DATA ATH1CS( 36) / -.3029924773660042537432330709674D-22 / DATA ATH1CS( 37) / -.1133390098574623537722943969689D-22 / DATA ATH1CS( 38) / -.4260766024749295719283049889791D-23 / DATA ATH1CS( 39) / -.1609363396278189718797500634453D-23 / DATA ATH1CS( 40) / -.6106377190825026293045330444287D-24 / DATA ATH1CS( 41) / -.2326954318021694061836577887573D-24 / DATA ATH1CS( 42) / -.8903987877472252604474129558186D-25 / DATA ATH1CS( 43) / -.3420558530005675024117914752341D-25 / DATA ATH1CS( 44) / -.1319026715257272659017212100607D-25 / DATA ATH1CS( 45) / -.5104899493612043091316191177386D-26 / DATA ATH1CS( 46) / -.1982599478474547451242444663466D-26 / DATA ATH1CS( 47) / -.7725702356880830535636111851519D-27 / DATA ATH1CS( 48) / -.3020234733664680100815776863573D-27 / DATA ATH1CS( 49) / -.1184379739074169993712946380800D-27 / DATA ATH1CS( 50) / -.4658430227922308520573252840106D-28 / DATA ATH1CS( 51) / -.1837554188100384647157502006613D-28 / DATA ATH1CS( 52) / -.7268566894427990953321876684800D-29 / DATA ATH1CS( 53) / -.2882863120391468135527089875626D-29 / DATA ATH1CS( 54) / -.1146374629459906350417591664639D-29 / DATA ATH1CS( 55) / -.4570031437748533058179991688533D-30 / DATA ATH1CS( 56) / -.1826276602045346104809934028799D-30 / DATA ATH1CS( 57) / -.7315349993385250469111066350933D-31 / DATA ATH1CS( 58) / -.2936925599971429781637815773866D-31 / DATA AM22CS( 1) / -.156284448062534112753545828583D-1 / DATA AM22CS( 2) / +.778336445239681307018943100334D-2 / DATA AM22CS( 3) / +.867057770477189528406072812110D-3 / DATA AM22CS( 4) / +.156966273156113719469953482266D-3 / DATA AM22CS( 5) / +.356396257143286511324100666302D-4 / DATA AM22CS( 6) / +.924598335425043154495080090994D-5 / DATA AM22CS( 7) / +.262110161850422389523194982066D-5 / DATA AM22CS( 8) / +.791882216516012561489469982263D-6 / DATA AM22CS( 9) / +.251041527921011847803162690862D-6 / DATA AM22CS( 10) / +.826522320665407734472997712940D-7 / DATA AM22CS( 11) / +.280571166281305264396384290014D-7 / DATA AM22CS( 12) / +.976821090484680786674631273890D-8 / DATA AM22CS( 13) / +.347407923227710343287279035573D-8 / DATA AM22CS( 14) / +.125828132169836914219092738164D-8 / DATA AM22CS( 15) / +.462988260641895264497330784625D-9 / DATA AM22CS( 16) / +.172728258813604072468143128696D-9 / DATA AM22CS( 17) / +.652319200131154135148574124970D-10 / DATA AM22CS( 18) / +.249047168520982056019881087112D-10 / DATA AM22CS( 19) / +.960156820553765948078189890126D-11 / DATA AM22CS( 20) / +.373448002067726856974776596757D-11 / DATA AM22CS( 21) / +.146417565032053391722216189678D-11 / DATA AM22CS( 22) / +.578265471168512825475827881553D-12 / DATA AM22CS( 23) / +.229915407244706118560254184494D-12 / DATA AM22CS( 24) / +.919780711231997257150883662365D-13 / DATA AM22CS( 25) / +.370060068813090065807504045556D-13 / DATA AM22CS( 26) / +.149675761698672987823326345205D-13 / DATA AM22CS( 27) / +.608361194938461148720451399443D-14 / DATA AM22CS( 28) / +.248404087115121397635425326873D-14 / DATA AM22CS( 29) / +.101862476526769080727914465339D-14 / DATA AM22CS( 30) / +.419383856352753989429640310957D-15 / DATA AM22CS( 31) / +.173318901762930756149702493501D-15 / DATA AM22CS( 32) / +.718821902388508517820445406811D-16 / DATA AM22CS( 33) / +.299123633598403607712470896113D-16 / DATA AM22CS( 34) / +.124868990433238627855713110880D-16 / DATA AM22CS( 35) / +.522829344609483661928651193632D-17 / DATA AM22CS( 36) / +.219532961724713396595998454359D-17 / DATA AM22CS( 37) / +.924298325229777281154410024332D-18 / DATA AM22CS( 38) / +.390157708236091407825543197309D-18 / DATA AM22CS( 39) / +.165093892693863707213759030367D-18 / DATA AM22CS( 40) / +.700221815715994367565716554487D-19 / DATA AM22CS( 41) / +.297651833616786915573214963506D-19 / DATA AM22CS( 42) / +.126796539086902072571134261229D-19 / DATA AM22CS( 43) / +.541243400697077628687581725061D-20 / DATA AM22CS( 44) / +.231487350218155252296382133283D-20 / DATA AM22CS( 45) / +.991920288386566563462623851167D-21 / DATA AM22CS( 46) / +.425803015323732357158897608174D-21 / DATA AM22CS( 47) / +.183101842973024501678402003088D-21 / DATA AM22CS( 48) / +.788678712311075375564526811022D-22 / DATA AM22CS( 49) / +.340254607386229874956582997235D-22 / DATA AM22CS( 50) / +.147020881405712530791860892535D-22 / DATA AM22CS( 51) / +.636211018324916957733348071767D-23 / DATA AM22CS( 52) / +.275707050680980721919395987768D-23 / DATA AM22CS( 53) / +.119645858090104071356261780457D-23 / DATA AM22CS( 54) / +.519912545729242147981768210567D-24 / DATA AM22CS( 55) / +.226217674847104475260575286850D-24 / DATA AM22CS( 56) / +.985526113754431819448565068283D-25 / DATA AM22CS( 57) / +.429870630332508717223681286187D-25 / DATA AM22CS( 58) / +.187723641661580639829657670189D-25 / DATA AM22CS( 59) / +.820721941772842137268801052115D-26 / DATA AM22CS( 60) / +.359214665604615507812767944463D-26 / DATA AM22CS( 61) / +.157390594612773315611458940587D-26 / DATA AM22CS( 62) / +.690329781039333834965319153586D-27 / DATA AM22CS( 63) / +.303092079078968534607859331415D-27 / DATA AM22CS( 64) / +.133204934160481219185689121944D-27 / DATA AM22CS( 65) / +.585978836851523490117937981442D-28 / DATA AM22CS( 66) / +.258016868489487806338425080457D-28 / DATA AM22CS( 67) / +.113712433637283667223632182863D-28 / DATA AM22CS( 68) / +.501592557226068509236430548549D-29 / DATA AM22CS( 69) / +.221445829395509373322569708484D-29 / DATA AM22CS( 70) / +.978470283886507289984691416411D-30 / DATA AM22CS( 71) / +.432695414934180170112000952983D-30 / DATA AM22CS( 72) / +.191497288193994570612929860440D-30 / DATA AM22CS( 73) / +.848164622402392354171298331562D-31 / DATA AM22CS( 74) / +.375947065173955919947455052934D-31 / DATA ATH2CS( 1) / +.4405273458718778997061127057775D-2 / DATA ATH2CS( 2) / -.3042919452318454608483844239873D-1 / DATA ATH2CS( 3) / -.1385653283771793791602692842653D-2 / DATA ATH2CS( 4) / -.1804443908954952302670486910952D-3 / DATA ATH2CS( 5) / -.3380847108327308671057465323618D-4 / DATA ATH2CS( 6) / -.7678183535229023055257676817765D-5 / DATA ATH2CS( 7) / -.1967839443716035324690935417077D-5 / DATA ATH2CS( 8) / -.5483727115877700361586143659281D-6 / DATA ATH2CS( 9) / -.1625461550532612452712696212258D-6 / DATA ATH2CS( 10) / -.5053049981268895015277637842078D-7 / DATA ATH2CS( 11) / -.1631580701124066881183851715617D-7 / DATA ATH2CS( 12) / -.5434204112348517507963436694817D-8 / DATA ATH2CS( 13) / -.1857398556409900325763850109630D-8 / DATA ATH2CS( 14) / -.6489512033326108816213513640676D-9 / DATA ATH2CS( 15) / -.2310594885800944720482995987079D-9 / DATA ATH2CS( 16) / -.8363282183204411682819329546745D-10 / DATA ATH2CS( 17) / -.3071196844890191462660661303891D-10 / DATA ATH2CS( 18) / -.1142367142432716819409514579892D-10 / DATA ATH2CS( 19) / -.4298116066345803065822470108971D-11 / DATA ATH2CS( 20) / -.1633898699596715440601646086632D-11 / DATA ATH2CS( 21) / -.6269328620016619432123443754076D-12 / DATA ATH2CS( 22) / -.2426052694816257357356159203991D-12 / DATA ATH2CS( 23) / -.9461198321624039090742527765052D-13 / DATA ATH2CS( 24) / -.3716060313411504806847798281269D-13 / DATA ATH2CS( 25) / -.1469155684097526763170138810309D-13 / DATA ATH2CS( 26) / -.5843694726140911944556401363094D-14 / DATA ATH2CS( 27) / -.2337502595591951298832675034934D-14 / DATA ATH2CS( 28) / -.9399231371171435401160167358411D-15 / DATA ATH2CS( 29) / -.3798014669372894500076335263715D-15 / DATA ATH2CS( 30) / -.1541731043984972524883443681775D-15 / DATA ATH2CS( 31) / -.6285287079535307162925662365202D-16 / DATA ATH2CS( 32) / -.2572731812811455424755383992774D-16 / DATA ATH2CS( 33) / -.1057098119354017809340974866555D-16 / DATA ATH2CS( 34) / -.4359080267402696966695992699964D-17 / DATA ATH2CS( 35) / -.1803634315959978013953176945540D-17 / DATA ATH2CS( 36) / -.7486838064380536821719431676914D-18 / DATA ATH2CS( 37) / -.3117261367347604656799597209985D-18 / DATA ATH2CS( 38) / -.1301687980927700734792871620696D-18 / DATA ATH2CS( 39) / -.5450527587519522468973883909909D-19 / DATA ATH2CS( 40) / -.2288293490114231872268635931903D-19 / DATA ATH2CS( 41) / -.9631059503829538655655060440088D-20 / DATA ATH2CS( 42) / -.4063281001524614089092195416434D-20 / DATA ATH2CS( 43) / -.1718203980908026763900413858510D-20 / DATA ATH2CS( 44) / -.7281574619892536367415322473328D-21 / DATA ATH2CS( 45) / -.3092352652680643127960680345790D-21 / DATA ATH2CS( 46) / -.1315917855965440490383417023254D-21 / DATA ATH2CS( 47) / -.5610606786087055512664907412668D-22 / DATA ATH2CS( 48) / -.2396621894086355206020304337895D-22 / DATA ATH2CS( 49) / -.1025574332390581200832954423924D-22 / DATA ATH2CS( 50) / -.4396264138143656476403607323663D-23 / DATA ATH2CS( 51) / -.1887652998372577373342508719450D-23 / DATA ATH2CS( 52) / -.8118140359576807603579433230445D-24 / DATA ATH2CS( 53) / -.3496734274366286856375952089214D-24 / DATA ATH2CS( 54) / -.1508402925156873215171751475867D-24 / DATA ATH2CS( 55) / -.6516268284778671059787773834341D-25 / DATA ATH2CS( 56) / -.2818945797529207424505942114583D-25 / DATA ATH2CS( 57) / -.1221127596512262744598094464505D-25 / DATA ATH2CS( 58) / -.5296674341169867168620011705073D-26 / DATA ATH2CS( 59) / -.2300359270773673431358870971744D-26 / DATA ATH2CS( 60) / -.1000279482355367494781220348930D-26 / DATA ATH2CS( 61) / -.4354760404180879394806893162179D-27 / DATA ATH2CS( 62) / -.1898056134741477522515482827030D-27 / DATA ATH2CS( 63) / -.8282111868712974697554009309315D-28 / DATA ATH2CS( 64) / -.3617815493066569006586213484374D-28 / DATA ATH2CS( 65) / -.1582018896178003654858941843636D-28 / DATA ATH2CS( 66) / -.6925068597802270011772820383247D-29 / DATA ATH2CS( 67) / -.3034390239778629128908629727335D-29 / DATA ATH2CS( 68) / -.1330889568166725224761977446509D-29 / DATA ATH2CS( 69) / -.5842848522173090120487606971706D-30 / DATA ATH2CS( 70) / -.2567488423238302631121274357678D-30 / DATA ATH2CS( 71) / -.1129232322268882185791505819151D-30 / DATA ATH2CS( 72) / -.4970947029753336916550570105023D-31 / DATA PI4 / 0.78539816339744830961566084581988D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9AIMP if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NAM20 = INITDS (AM20CS, 57, ETA) NATH0 = INITDS (ATH0CS, 53, ETA) NAM21 = INITDS (AM21CS, 60, ETA) NATH1 = INITDS (ATH1CS, 58, ETA) NAM22 = INITDS (AM22CS, 74, ETA) NATH2 = INITDS (ATH2CS, 72, ETA) ! XSML = -1.0D0/D1MACH(3)**0.3333D0 end if FIRST = .FALSE. ! if (X >= (-4.0D0)) go to 20 Z = 1.0D0 if (X > XSML) Z = 128.D0/X**3 + 1.0D0 AMPL = 0.3125D0 + DCSEVL (Z, AM20CS, NAM20) THETA = -0.625D0 + DCSEVL (Z, ATH0CS, NATH0) go to 40 ! 20 if (X >= (-2.0D0)) go to 30 Z = (128.D0/X**3 + 9.0D0)/7.0D0 AMPL = 0.3125D0 + DCSEVL (Z, AM21CS, NAM21) THETA = -0.625D0 + DCSEVL (Z, ATH1CS, NATH1) go to 40 ! 30 if (X >= (-1.0D0)) call XERMSG ('SLATEC', 'D9AIMP', & 'X MUST BE LE -1.0', 1, 2) ! Z = (16.D0/X**3 + 9.0D0)/7.0D0 AMPL = 0.3125D0 + DCSEVL (Z, AM22CS, NAM22) THETA = -0.625D0 + DCSEVL (Z, ATH2CS, NATH2) ! 40 SQRTX = SQRT(-X) AMPL = SQRT(AMPL/SQRTX) THETA = PI4 - X*SQRTX*THETA ! return end DOUBLE PRECISION FUNCTION D9ATN1 (X) ! !! D9ATN1 evaluates DATAN(X) from first order relative accuracy ... ! so that DATAN(X) = X + X**3*D9ATN1(X). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE DOUBLE PRECISION (R9ATN1-S, D9ATN1-D) !***KEYWORDS ARC TANGENT, ELEMENTARY FUNCTIONS, FIRST ORDER, FNLIB, ! TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate DATAN(X) from first order, that is, evaluate ! (DATAN(X)-X)/X**3 with relative error accuracy so that ! DATAN(X) = X + X**3*D9ATN1(X). ! ! Series for ATN1 on the interval 0. to 1.00000E+00 ! with weighted error 3.39E-32 ! log weighted error 31.47 ! significant figures required 30.26 ! decimal places required 32.27 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 780401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891115 Corrected third argument in reference to INITDS. (WRB) ! 891115 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE D9ATN1 DOUBLE PRECISION X, XBIG, XMAX, XSML, Y, ATN1CS(40), EPS, & DCSEVL, D1MACH LOGICAL FIRST SAVE ATN1CS, NTATN1, XSML, XBIG, XMAX, FIRST DATA ATN1CS( 1) / -.3283997535355202356907939922990D-1 / DATA ATN1CS( 2) / +.5833432343172412449951669914907D-1 / DATA ATN1CS( 3) / -.7400369696719646463809011551413D-2 / DATA ATN1CS( 4) / +.1009784199337288083590357511639D-2 / DATA ATN1CS( 5) / -.1439787163565205621471303697700D-3 / DATA ATN1CS( 6) / +.2114512648992107572072112243439D-4 / DATA ATN1CS( 7) / -.3172321074254667167402564996757D-5 / DATA ATN1CS( 8) / +.4836620365460710825377859384800D-6 / DATA ATN1CS( 9) / -.7467746546814112670437614322776D-7 / DATA ATN1CS( 10) / +.1164800896824429830620998641342D-7 / DATA ATN1CS( 11) / -.1832088370847201392699956242452D-8 / DATA ATN1CS( 12) / +.2901908277966063313175351230455D-9 / DATA ATN1CS( 13) / -.4623885312106326738351805721512D-10 / DATA ATN1CS( 14) / +.7405528668775736917992197048286D-11 / DATA ATN1CS( 15) / -.1191354457845136682370820373417D-11 / DATA ATN1CS( 16) / +.1924090144391772599867855692518D-12 / DATA ATN1CS( 17) / -.3118271051076194272254476155327D-13 / DATA ATN1CS( 18) / +.5069240036567731789694520593032D-14 / DATA ATN1CS( 19) / -.8263694719802866053818284405964D-15 / DATA ATN1CS( 20) / +.1350486709817079420526506123029D-15 / DATA ATN1CS( 21) / -.2212023650481746045840137823191D-16 / DATA ATN1CS( 22) / +.3630654747381356783829047647709D-17 / DATA ATN1CS( 23) / -.5970345328847154052451215859165D-18 / DATA ATN1CS( 24) / +.9834816050077133119448329005738D-19 / DATA ATN1CS( 25) / -.1622655075855062336144387604480D-19 / DATA ATN1CS( 26) / +.2681186176945436796301320301226D-20 / DATA ATN1CS( 27) / -.4436309706785255479636243688106D-21 / DATA ATN1CS( 28) / +.7349691897652496945072465510400D-22 / DATA ATN1CS( 29) / -.1219077508350052588289401378133D-22 / DATA ATN1CS( 30) / +.2024298836805215403184540876799D-23 / DATA ATN1CS( 31) / -.3364871555797354579925576362666D-24 / DATA ATN1CS( 32) / +.5598673968346988749492933973333D-25 / DATA ATN1CS( 33) / -.9323939267272320229628532053333D-26 / DATA ATN1CS( 34) / +.1554133116995970222934807893333D-26 / DATA ATN1CS( 35) / -.2592569534179745922757427199999D-27 / DATA ATN1CS( 36) / +.4328193466245734685037909333333D-28 / DATA ATN1CS( 37) / -.7231013125595437471192405333333D-29 / DATA ATN1CS( 38) / +.1208902859830494772942165333333D-29 / DATA ATN1CS( 39) / -.2022404543449897579315199999999D-30 / DATA ATN1CS( 40) / +.3385428713046493843073706666666D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9ATN1 if (FIRST) THEN EPS = D1MACH(3) NTATN1 = INITDS (ATN1CS, 40, 0.1*REAL(EPS)) ! XSML = SQRT (0.1D0*EPS) XBIG = 1.571D0/SQRT(EPS) XMAX = 1.571D0/EPS end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 1.0D0) go to 20 ! if (Y <= XSML) D9ATN1 = -1.0D0/3.0D0 if (Y <= XSML) RETURN ! D9ATN1 = -0.25D0 + DCSEVL (2.D0*Y*Y-1.D0, ATN1CS, NTATN1) return ! 20 if (Y > XMAX) call XERMSG ('SLATEC', 'D9ATN1', & 'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 2, 2) if (Y > XBIG) call XERMSG ('SLATEC', 'D9ATN1', & 'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 1, 1) ! D9ATN1 = (ATAN(X) - X) / X**3 return end subroutine D9B0MP (X, AMPL, THETA) ! !! D9B0MP evaluates the modulus and phase for the J0 and Y0 Bessel functions. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10A1 !***TYPE DOUBLE PRECISION (D9B0MP-D) !***KEYWORDS BESSEL FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate the modulus and phase for the Bessel J0 and Y0 functions. ! ! Series for BM0 on the interval 1.56250E-02 to 6.25000E-02 ! with weighted error 4.40E-32 ! log weighted error 31.36 ! significant figures required 30.02 ! decimal places required 32.14 ! ! Series for BTH0 on the interval 0. to 1.56250E-02 ! with weighted error 2.66E-32 ! log weighted error 31.57 ! significant figures required 30.67 ! decimal places required 32.40 ! ! Series for BM02 on the interval 0. to 1.56250E-02 ! with weighted error 4.72E-32 ! log weighted error 31.33 ! significant figures required 30.00 ! decimal places required 32.13 ! ! Series for BT02 on the interval 1.56250E-02 to 6.25000E-02 ! with weighted error 2.99E-32 ! log weighted error 31.52 ! significant figures required 30.61 ! decimal places required 32.32 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE D9B0MP DOUBLE PRECISION X, AMPL, THETA, BM0CS(37), BT02CS(39), & BM02CS(40), BTH0CS(44), XMAX, PI4, Z, D1MACH, DCSEVL LOGICAL FIRST SAVE BM0CS, BTH0CS, BM02CS, BT02CS, PI4, NBM0, NBT02, & NBM02, NBTH0, XMAX, FIRST DATA BM0CS( 1) / +.9211656246827742712573767730182D-1 / DATA BM0CS( 2) / -.1050590997271905102480716371755D-2 / DATA BM0CS( 3) / +.1470159840768759754056392850952D-4 / DATA BM0CS( 4) / -.5058557606038554223347929327702D-6 / DATA BM0CS( 5) / +.2787254538632444176630356137881D-7 / DATA BM0CS( 6) / -.2062363611780914802618841018973D-8 / DATA BM0CS( 7) / +.1870214313138879675138172596261D-9 / DATA BM0CS( 8) / -.1969330971135636200241730777825D-10 / DATA BM0CS( 9) / +.2325973793999275444012508818052D-11 / DATA BM0CS( 10) / -.3009520344938250272851224734482D-12 / DATA BM0CS( 11) / +.4194521333850669181471206768646D-13 / DATA BM0CS( 12) / -.6219449312188445825973267429564D-14 / DATA BM0CS( 13) / +.9718260411336068469601765885269D-15 / DATA BM0CS( 14) / -.1588478585701075207366635966937D-15 / DATA BM0CS( 15) / +.2700072193671308890086217324458D-16 / DATA BM0CS( 16) / -.4750092365234008992477504786773D-17 / DATA BM0CS( 17) / +.8615128162604370873191703746560D-18 / DATA BM0CS( 18) / -.1605608686956144815745602703359D-18 / DATA BM0CS( 19) / +.3066513987314482975188539801599D-19 / DATA BM0CS( 20) / -.5987764223193956430696505617066D-20 / DATA BM0CS( 21) / +.1192971253748248306489069841066D-20 / DATA BM0CS( 22) / -.2420969142044805489484682581333D-21 / DATA BM0CS( 23) / +.4996751760510616453371002879999D-22 / DATA BM0CS( 24) / -.1047493639351158510095040511999D-22 / DATA BM0CS( 25) / +.2227786843797468101048183466666D-23 / DATA BM0CS( 26) / -.4801813239398162862370542933333D-24 / DATA BM0CS( 27) / +.1047962723470959956476996266666D-24 / DATA BM0CS( 28) / -.2313858165678615325101260800000D-25 / DATA BM0CS( 29) / +.5164823088462674211635199999999D-26 / DATA BM0CS( 30) / -.1164691191850065389525401599999D-26 / DATA BM0CS( 31) / +.2651788486043319282958336000000D-27 / DATA BM0CS( 32) / -.6092559503825728497691306666666D-28 / DATA BM0CS( 33) / +.1411804686144259308038826666666D-28 / DATA BM0CS( 34) / -.3298094961231737245750613333333D-29 / DATA BM0CS( 35) / +.7763931143074065031714133333333D-30 / DATA BM0CS( 36) / -.1841031343661458478421333333333D-30 / DATA BM0CS( 37) / +.4395880138594310737100799999999D-31 / DATA BTH0CS( 1) / -.24901780862128936717709793789967D+0 / DATA BTH0CS( 2) / +.48550299609623749241048615535485D-3 / DATA BTH0CS( 3) / -.54511837345017204950656273563505D-5 / DATA BTH0CS( 4) / +.13558673059405964054377445929903D-6 / DATA BTH0CS( 5) / -.55691398902227626227583218414920D-8 / DATA BTH0CS( 6) / +.32609031824994335304004205719468D-9 / DATA BTH0CS( 7) / -.24918807862461341125237903877993D-10 / DATA BTH0CS( 8) / +.23449377420882520554352413564891D-11 / DATA BTH0CS( 9) / -.26096534444310387762177574766136D-12 / DATA BTH0CS( 10) / +.33353140420097395105869955014923D-13 / DATA BTH0CS( 11) / -.47890000440572684646750770557409D-14 / DATA BTH0CS( 12) / +.75956178436192215972642568545248D-15 / DATA BTH0CS( 13) / -.13131556016891440382773397487633D-15 / DATA BTH0CS( 14) / +.24483618345240857495426820738355D-16 / DATA BTH0CS( 15) / -.48805729810618777683256761918331D-17 / DATA BTH0CS( 16) / +.10327285029786316149223756361204D-17 / DATA BTH0CS( 17) / -.23057633815057217157004744527025D-18 / DATA BTH0CS( 18) / +.54044443001892693993017108483765D-19 / DATA BTH0CS( 19) / -.13240695194366572724155032882385D-19 / DATA BTH0CS( 20) / +.33780795621371970203424792124722D-20 / DATA BTH0CS( 21) / -.89457629157111779003026926292299D-21 / DATA BTH0CS( 22) / +.24519906889219317090899908651405D-21 / DATA BTH0CS( 23) / -.69388422876866318680139933157657D-22 / DATA BTH0CS( 24) / +.20228278714890138392946303337791D-22 / DATA BTH0CS( 25) / -.60628500002335483105794195371764D-23 / DATA BTH0CS( 26) / +.18649748964037635381823788396270D-23 / DATA BTH0CS( 27) / -.58783732384849894560245036530867D-24 / DATA BTH0CS( 28) / +.18958591447999563485531179503513D-24 / DATA BTH0CS( 29) / -.62481979372258858959291620728565D-25 / DATA BTH0CS( 30) / +.21017901684551024686638633529074D-25 / DATA BTH0CS( 31) / -.72084300935209253690813933992446D-26 / DATA BTH0CS( 32) / +.25181363892474240867156405976746D-26 / DATA BTH0CS( 33) / -.89518042258785778806143945953643D-27 / DATA BTH0CS( 34) / +.32357237479762298533256235868587D-27 / DATA BTH0CS( 35) / -.11883010519855353657047144113796D-27 / DATA BTH0CS( 36) / +.44306286907358104820579231941731D-28 / DATA BTH0CS( 37) / -.16761009648834829495792010135681D-28 / DATA BTH0CS( 38) / +.64292946921207466972532393966088D-29 / DATA BTH0CS( 39) / -.24992261166978652421207213682763D-29 / DATA BTH0CS( 40) / +.98399794299521955672828260355318D-30 / DATA BTH0CS( 41) / -.39220375242408016397989131626158D-30 / DATA BTH0CS( 42) / +.15818107030056522138590618845692D-30 / DATA BTH0CS( 43) / -.64525506144890715944344098365426D-31 / DATA BTH0CS( 44) / +.26611111369199356137177018346367D-31 / DATA BM02CS( 1) / +.9500415145228381369330861335560D-1 / DATA BM02CS( 2) / -.3801864682365670991748081566851D-3 / DATA BM02CS( 3) / +.2258339301031481192951829927224D-5 / DATA BM02CS( 4) / -.3895725802372228764730621412605D-7 / DATA BM02CS( 5) / +.1246886416512081697930990529725D-8 / DATA BM02CS( 6) / -.6065949022102503779803835058387D-10 / DATA BM02CS( 7) / +.4008461651421746991015275971045D-11 / DATA BM02CS( 8) / -.3350998183398094218467298794574D-12 / DATA BM02CS( 9) / +.3377119716517417367063264341996D-13 / DATA BM02CS( 10) / -.3964585901635012700569356295823D-14 / DATA BM02CS( 11) / +.5286111503883857217387939744735D-15 / DATA BM02CS( 12) / -.7852519083450852313654640243493D-16 / DATA BM02CS( 13) / +.1280300573386682201011634073449D-16 / DATA BM02CS( 14) / -.2263996296391429776287099244884D-17 / DATA BM02CS( 15) / +.4300496929656790388646410290477D-18 / DATA BM02CS( 16) / -.8705749805132587079747535451455D-19 / DATA BM02CS( 17) / +.1865862713962095141181442772050D-19 / DATA BM02CS( 18) / -.4210482486093065457345086972301D-20 / DATA BM02CS( 19) / +.9956676964228400991581627417842D-21 / DATA BM02CS( 20) / -.2457357442805313359605921478547D-21 / DATA BM02CS( 21) / +.6307692160762031568087353707059D-22 / DATA BM02CS( 22) / -.1678773691440740142693331172388D-22 / DATA BM02CS( 23) / +.4620259064673904433770878136087D-23 / DATA BM02CS( 24) / -.1311782266860308732237693402496D-23 / DATA BM02CS( 25) / +.3834087564116302827747922440276D-24 / DATA BM02CS( 26) / -.1151459324077741271072613293576D-24 / DATA BM02CS( 27) / +.3547210007523338523076971345213D-25 / DATA BM02CS( 28) / -.1119218385815004646264355942176D-25 / DATA BM02CS( 29) / +.3611879427629837831698404994257D-26 / DATA BM02CS( 30) / -.1190687765913333150092641762463D-26 / DATA BM02CS( 31) / +.4005094059403968131802476449536D-27 / DATA BM02CS( 32) / -.1373169422452212390595193916017D-27 / DATA BM02CS( 33) / +.4794199088742531585996491526437D-28 / DATA BM02CS( 34) / -.1702965627624109584006994476452D-28 / DATA BM02CS( 35) / +.6149512428936330071503575161324D-29 / DATA BM02CS( 36) / -.2255766896581828349944300237242D-29 / DATA BM02CS( 37) / +.8399707509294299486061658353200D-30 / DATA BM02CS( 38) / -.3172997595562602355567423936152D-30 / DATA BM02CS( 39) / +.1215205298881298554583333026514D-30 / DATA BM02CS( 40) / -.4715852749754438693013210568045D-31 / DATA BT02CS( 1) / -.24548295213424597462050467249324D+0 / DATA BT02CS( 2) / +.12544121039084615780785331778299D-2 / DATA BT02CS( 3) / -.31253950414871522854973446709571D-4 / DATA BT02CS( 4) / +.14709778249940831164453426969314D-5 / DATA BT02CS( 5) / -.99543488937950033643468850351158D-7 / DATA BT02CS( 6) / +.85493166733203041247578711397751D-8 / DATA BT02CS( 7) / -.86989759526554334557985512179192D-9 / DATA BT02CS( 8) / +.10052099533559791084540101082153D-9 / DATA BT02CS( 9) / -.12828230601708892903483623685544D-10 / DATA BT02CS( 10) / +.17731700781805131705655750451023D-11 / DATA BT02CS( 11) / -.26174574569485577488636284180925D-12 / DATA BT02CS( 12) / +.40828351389972059621966481221103D-13 / DATA BT02CS( 13) / -.66751668239742720054606749554261D-14 / DATA BT02CS( 14) / +.11365761393071629448392469549951D-14 / DATA BT02CS( 15) / -.20051189620647160250559266412117D-15 / DATA BT02CS( 16) / +.36497978794766269635720591464106D-16 / DATA BT02CS( 17) / -.68309637564582303169355843788800D-17 / DATA BT02CS( 18) / +.13107583145670756620057104267946D-17 / DATA BT02CS( 19) / -.25723363101850607778757130649599D-18 / DATA BT02CS( 20) / +.51521657441863959925267780949333D-19 / DATA BT02CS( 21) / -.10513017563758802637940741461333D-19 / DATA BT02CS( 22) / +.21820381991194813847301084501333D-20 / DATA BT02CS( 23) / -.46004701210362160577225905493333D-21 / DATA BT02CS( 24) / +.98407006925466818520953651199999D-22 / DATA BT02CS( 25) / -.21334038035728375844735986346666D-22 / DATA BT02CS( 26) / +.46831036423973365296066286933333D-23 / DATA BT02CS( 27) / -.10400213691985747236513382399999D-23 / DATA BT02CS( 28) / +.23349105677301510051777740800000D-24 / DATA BT02CS( 29) / -.52956825323318615788049749333333D-25 / DATA BT02CS( 30) / +.12126341952959756829196287999999D-25 / DATA BT02CS( 31) / -.28018897082289428760275626666666D-26 / DATA BT02CS( 32) / +.65292678987012873342593706666666D-27 / DATA BT02CS( 33) / -.15337980061873346427835733333333D-27 / DATA BT02CS( 34) / +.36305884306364536682359466666666D-28 / DATA BT02CS( 35) / -.86560755713629122479172266666666D-29 / DATA BT02CS( 36) / +.20779909972536284571238399999999D-29 / DATA BT02CS( 37) / -.50211170221417221674325333333333D-30 / DATA BT02CS( 38) / +.12208360279441714184191999999999D-30 / DATA BT02CS( 39) / -.29860056267039913454250666666666D-31 / DATA PI4 / 0.785398163397448309615660845819876D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9B0MP if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NBM0 = INITDS (BM0CS, 37, ETA) NBT02 = INITDS (BT02CS, 39, ETA) NBM02 = INITDS (BM02CS, 40, ETA) NBTH0 = INITDS (BTH0CS, 44, ETA) ! XMAX = 1.0D0/D1MACH(4) end if FIRST = .FALSE. ! if (X < 4.D0) call XERMSG ('SLATEC', 'D9B0MP', & 'X MUST BE GE 4', 1, 2) ! if (X > 8.D0) go to 20 Z = (128.D0/(X*X) - 5.D0)/3.D0 AMPL = (.75D0 + DCSEVL (Z, BM0CS, NBM0))/SQRT(X) THETA = X - PI4 + DCSEVL (Z, BT02CS, NBT02)/X return ! 20 if (X > XMAX) call XERMSG ('SLATEC', 'D9B0MP', & 'NO PRECISION BECAUSE X IS BIG', 2, 2) ! Z = 128.D0/(X*X) - 1.D0 AMPL = (.75D0 + DCSEVL (Z, BM02CS, NBM02))/SQRT(X) THETA = X - PI4 + DCSEVL (Z, BTH0CS, NBTH0)/X return ! end subroutine D9B1MP (X, AMPL, THETA) ! !! D9B1MP evaluates the modulus and phase for the J1 and Y1 Bessel functions. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10A1 !***TYPE DOUBLE PRECISION (D9B1MP-D) !***KEYWORDS BESSEL FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate the modulus and phase for the Bessel J1 and Y1 functions. ! ! Series for BM1 on the interval 1.56250E-02 to 6.25000E-02 ! with weighted error 4.91E-32 ! log weighted error 31.31 ! significant figures required 30.04 ! decimal places required 32.09 ! ! Series for BT12 on the interval 1.56250E-02 to 6.25000E-02 ! with weighted error 3.33E-32 ! log weighted error 31.48 ! significant figures required 31.05 ! decimal places required 32.27 ! ! Series for BM12 on the interval 0. to 1.56250E-02 ! with weighted error 5.01E-32 ! log weighted error 31.30 ! significant figures required 29.99 ! decimal places required 32.10 ! ! Series for BTH1 on the interval 0. to 1.56250E-02 ! with weighted error 2.82E-32 ! log weighted error 31.55 ! significant figures required 31.12 ! decimal places required 32.37 ! !***SEE ALSO DBESJ1, DBESY1 !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) ! 920618 Removed space from variable name and code restructured to ! use IF-THEN-ELSE. (RWC, WRB) !***END PROLOGUE D9B1MP DOUBLE PRECISION X, AMPL, THETA, BM1CS(37), BT12CS(39), & BM12CS(40), BTH1CS(44), XMAX, PI4, Z, D1MACH, DCSEVL LOGICAL FIRST SAVE BM1CS, BT12CS, BTH1CS, BM12CS, PI4, NBM1, NBT12, & NBM12, NBTH1, XMAX, FIRST DATA BM1CS( 1) / +.1069845452618063014969985308538D+0 / DATA BM1CS( 2) / +.3274915039715964900729055143445D-2 / DATA BM1CS( 3) / -.2987783266831698592030445777938D-4 / DATA BM1CS( 4) / +.8331237177991974531393222669023D-6 / DATA BM1CS( 5) / -.4112665690302007304896381725498D-7 / DATA BM1CS( 6) / +.2855344228789215220719757663161D-8 / DATA BM1CS( 7) / -.2485408305415623878060026596055D-9 / DATA BM1CS( 8) / +.2543393338072582442742484397174D-10 / DATA BM1CS( 9) / -.2941045772822967523489750827909D-11 / DATA BM1CS( 10) / +.3743392025493903309265056153626D-12 / DATA BM1CS( 11) / -.5149118293821167218720548243527D-13 / DATA BM1CS( 12) / +.7552535949865143908034040764199D-14 / DATA BM1CS( 13) / -.1169409706828846444166290622464D-14 / DATA BM1CS( 14) / +.1896562449434791571721824605060D-15 / DATA BM1CS( 15) / -.3201955368693286420664775316394D-16 / DATA BM1CS( 16) / +.5599548399316204114484169905493D-17 / DATA BM1CS( 17) / -.1010215894730432443119390444544D-17 / DATA BM1CS( 18) / +.1873844985727562983302042719573D-18 / DATA BM1CS( 19) / -.3563537470328580219274301439999D-19 / DATA BM1CS( 20) / +.6931283819971238330422763519999D-20 / DATA BM1CS( 21) / -.1376059453406500152251408930133D-20 / DATA BM1CS( 22) / +.2783430784107080220599779327999D-21 / DATA BM1CS( 23) / -.5727595364320561689348669439999D-22 / DATA BM1CS( 24) / +.1197361445918892672535756799999D-22 / DATA BM1CS( 25) / -.2539928509891871976641440426666D-23 / DATA BM1CS( 26) / +.5461378289657295973069619199999D-24 / DATA BM1CS( 27) / -.1189211341773320288986289493333D-24 / DATA BM1CS( 28) / +.2620150977340081594957824000000D-25 / DATA BM1CS( 29) / -.5836810774255685901920938666666D-26 / DATA BM1CS( 30) / +.1313743500080595773423615999999D-26 / DATA BM1CS( 31) / -.2985814622510380355332778666666D-27 / DATA BM1CS( 32) / +.6848390471334604937625599999999D-28 / DATA BM1CS( 33) / -.1584401568222476721192960000000D-28 / DATA BM1CS( 34) / +.3695641006570938054301013333333D-29 / DATA BM1CS( 35) / -.8687115921144668243012266666666D-30 / DATA BM1CS( 36) / +.2057080846158763462929066666666D-30 / DATA BM1CS( 37) / -.4905225761116225518523733333333D-31 / DATA BT12CS( 1) / +.73823860128742974662620839792764D+0 / DATA BT12CS( 2) / -.33361113174483906384470147681189D-2 / DATA BT12CS( 3) / +.61463454888046964698514899420186D-4 / DATA BT12CS( 4) / -.24024585161602374264977635469568D-5 / DATA BT12CS( 5) / +.14663555577509746153210591997204D-6 / DATA BT12CS( 6) / -.11841917305589180567005147504983D-7 / DATA BT12CS( 7) / +.11574198963919197052125466303055D-8 / DATA BT12CS( 8) / -.13001161129439187449366007794571D-9 / DATA BT12CS( 9) / +.16245391141361731937742166273667D-10 / DATA BT12CS( 10) / -.22089636821403188752155441770128D-11 / DATA BT12CS( 11) / +.32180304258553177090474358653778D-12 / DATA BT12CS( 12) / -.49653147932768480785552021135381D-13 / DATA BT12CS( 13) / +.80438900432847825985558882639317D-14 / DATA BT12CS( 14) / -.13589121310161291384694712682282D-14 / DATA BT12CS( 15) / +.23810504397147214869676529605973D-15 / DATA BT12CS( 16) / -.43081466363849106724471241420799D-16 / DATA BT12CS( 17) / +.80202544032771002434993512550400D-17 / DATA BT12CS( 18) / -.15316310642462311864230027468799D-17 / DATA BT12CS( 19) / +.29928606352715568924073040554666D-18 / DATA BT12CS( 20) / -.59709964658085443393815636650666D-19 / DATA BT12CS( 21) / +.12140289669415185024160852650666D-19 / DATA BT12CS( 22) / -.25115114696612948901006977706666D-20 / DATA BT12CS( 23) / +.52790567170328744850738380799999D-21 / DATA BT12CS( 24) / -.11260509227550498324361161386666D-21 / DATA BT12CS( 25) / +.24348277359576326659663462400000D-22 / DATA BT12CS( 26) / -.53317261236931800130038442666666D-23 / DATA BT12CS( 27) / +.11813615059707121039205990399999D-23 / DATA BT12CS( 28) / -.26465368283353523514856789333333D-24 / DATA BT12CS( 29) / +.59903394041361503945577813333333D-25 / DATA BT12CS( 30) / -.13690854630829503109136383999999D-25 / DATA BT12CS( 31) / +.31576790154380228326413653333333D-26 / DATA BT12CS( 32) / -.73457915082084356491400533333333D-27 / DATA BT12CS( 33) / +.17228081480722747930705920000000D-27 / DATA BT12CS( 34) / -.40716907961286507941068800000000D-28 / DATA BT12CS( 35) / +.96934745136779622700373333333333D-29 / DATA BT12CS( 36) / -.23237636337765716765354666666666D-29 / DATA BT12CS( 37) / +.56074510673522029406890666666666D-30 / DATA BT12CS( 38) / -.13616465391539005860522666666666D-30 / DATA BT12CS( 39) / +.33263109233894654388906666666666D-31 / DATA BM12CS( 1) / +.9807979156233050027272093546937D-1 / DATA BM12CS( 2) / +.1150961189504685306175483484602D-2 / DATA BM12CS( 3) / -.4312482164338205409889358097732D-5 / DATA BM12CS( 4) / +.5951839610088816307813029801832D-7 / DATA BM12CS( 5) / -.1704844019826909857400701586478D-8 / DATA BM12CS( 6) / +.7798265413611109508658173827401D-10 / DATA BM12CS( 7) / -.4958986126766415809491754951865D-11 / DATA BM12CS( 8) / +.4038432416421141516838202265144D-12 / DATA BM12CS( 9) / -.3993046163725175445765483846645D-13 / DATA BM12CS( 10) / +.4619886183118966494313342432775D-14 / DATA BM12CS( 11) / -.6089208019095383301345472619333D-15 / DATA BM12CS( 12) / +.8960930916433876482157048041249D-16 / DATA BM12CS( 13) / -.1449629423942023122916518918925D-16 / DATA BM12CS( 14) / +.2546463158537776056165149648068D-17 / DATA BM12CS( 15) / -.4809472874647836444259263718620D-18 / DATA BM12CS( 16) / +.9687684668292599049087275839124D-19 / DATA BM12CS( 17) / -.2067213372277966023245038117551D-19 / DATA BM12CS( 18) / +.4646651559150384731802767809590D-20 / DATA BM12CS( 19) / -.1094966128848334138241351328339D-20 / DATA BM12CS( 20) / +.2693892797288682860905707612785D-21 / DATA BM12CS( 21) / -.6894992910930374477818970026857D-22 / DATA BM12CS( 22) / +.1830268262752062909890668554740D-22 / DATA BM12CS( 23) / -.5025064246351916428156113553224D-23 / DATA BM12CS( 24) / +.1423545194454806039631693634194D-23 / DATA BM12CS( 25) / -.4152191203616450388068886769801D-24 / DATA BM12CS( 26) / +.1244609201503979325882330076547D-24 / DATA BM12CS( 27) / -.3827336370569304299431918661286D-25 / DATA BM12CS( 28) / +.1205591357815617535374723981835D-25 / DATA BM12CS( 29) / -.3884536246376488076431859361124D-26 / DATA BM12CS( 30) / +.1278689528720409721904895283461D-26 / DATA BM12CS( 31) / -.4295146689447946272061936915912D-27 / DATA BM12CS( 32) / +.1470689117829070886456802707983D-27 / DATA BM12CS( 33) / -.5128315665106073128180374017796D-28 / DATA BM12CS( 34) / +.1819509585471169385481437373286D-28 / DATA BM12CS( 35) / -.6563031314841980867618635050373D-29 / DATA BM12CS( 36) / +.2404898976919960653198914875834D-29 / DATA BM12CS( 37) / -.8945966744690612473234958242979D-30 / DATA BM12CS( 38) / +.3376085160657231026637148978240D-30 / DATA BM12CS( 39) / -.1291791454620656360913099916966D-30 / DATA BM12CS( 40) / +.5008634462958810520684951501254D-31 / DATA BTH1CS( 1) / +.74749957203587276055443483969695D+0 / DATA BTH1CS( 2) / -.12400777144651711252545777541384D-2 / DATA BTH1CS( 3) / +.99252442404424527376641497689592D-5 / DATA BTH1CS( 4) / -.20303690737159711052419375375608D-6 / DATA BTH1CS( 5) / +.75359617705690885712184017583629D-8 / DATA BTH1CS( 6) / -.41661612715343550107630023856228D-9 / DATA BTH1CS( 7) / +.30701618070834890481245102091216D-10 / DATA BTH1CS( 8) / -.28178499637605213992324008883924D-11 / DATA BTH1CS( 9) / +.30790696739040295476028146821647D-12 / DATA BTH1CS( 10) / -.38803300262803434112787347554781D-13 / DATA BTH1CS( 11) / +.55096039608630904934561726208562D-14 / DATA BTH1CS( 12) / -.86590060768383779940103398953994D-15 / DATA BTH1CS( 13) / +.14856049141536749003423689060683D-15 / DATA BTH1CS( 14) / -.27519529815904085805371212125009D-16 / DATA BTH1CS( 15) / +.54550796090481089625036223640923D-17 / DATA BTH1CS( 16) / -.11486534501983642749543631027177D-17 / DATA BTH1CS( 17) / +.25535213377973900223199052533522D-18 / DATA BTH1CS( 18) / -.59621490197413450395768287907849D-19 / DATA BTH1CS( 19) / +.14556622902372718620288302005833D-19 / DATA BTH1CS( 20) / -.37022185422450538201579776019593D-20 / DATA BTH1CS( 21) / +.97763074125345357664168434517924D-21 / DATA BTH1CS( 22) / -.26726821639668488468723775393052D-21 / DATA BTH1CS( 23) / +.75453300384983271794038190655764D-22 / DATA BTH1CS( 24) / -.21947899919802744897892383371647D-22 / DATA BTH1CS( 25) / +.65648394623955262178906999817493D-23 / DATA BTH1CS( 26) / -.20155604298370207570784076869519D-23 / DATA BTH1CS( 27) / +.63417768556776143492144667185670D-24 / DATA BTH1CS( 28) / -.20419277885337895634813769955591D-24 / DATA BTH1CS( 29) / +.67191464220720567486658980018551D-25 / DATA BTH1CS( 30) / -.22569079110207573595709003687336D-25 / DATA BTH1CS( 31) / +.77297719892989706370926959871929D-26 / DATA BTH1CS( 32) / -.26967444512294640913211424080920D-26 / DATA BTH1CS( 33) / +.95749344518502698072295521933627D-27 / DATA BTH1CS( 34) / -.34569168448890113000175680827627D-27 / DATA BTH1CS( 35) / +.12681234817398436504211986238374D-27 / DATA BTH1CS( 36) / -.47232536630722639860464993713445D-28 / DATA BTH1CS( 37) / +.17850008478186376177858619796417D-28 / DATA BTH1CS( 38) / -.68404361004510395406215223566746D-29 / DATA BTH1CS( 39) / +.26566028671720419358293422672212D-29 / DATA BTH1CS( 40) / -.10450402527914452917714161484670D-29 / DATA BTH1CS( 41) / +.41618290825377144306861917197064D-30 / DATA BTH1CS( 42) / -.16771639203643714856501347882887D-30 / DATA BTH1CS( 43) / +.68361997776664389173535928028528D-31 / DATA BTH1CS( 44) / -.28172247861233641166739574622810D-31 / DATA PI4 / 0.785398163397448309615660845819876D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9B1MP if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NBM1 = INITDS (BM1CS, 37, ETA) NBT12 = INITDS (BT12CS, 39, ETA) NBM12 = INITDS (BM12CS, 40, ETA) NBTH1 = INITDS (BTH1CS, 44, ETA) ! XMAX = 1.0D0/D1MACH(4) end if FIRST = .FALSE. ! if (X < 4.0D0) THEN call XERMSG ('SLATEC', 'D9B1MP', 'X must be >= 4', 1, 2) AMPL = 0.0D0 THETA = 0.0D0 ELSE if (X <= 8.0D0) THEN Z = (128.0D0/(X*X) - 5.0D0)/3.0D0 AMPL = (0.75D0 + DCSEVL (Z, BM1CS, NBM1))/SQRT(X) THETA = X - 3.0D0*PI4 + DCSEVL (Z, BT12CS, NBT12)/X ELSE if (X > XMAX) call XERMSG ('SLATEC', 'D9B1MP', & 'No precision because X is too big', 2, 2) ! Z = 128.0D0/(X*X) - 1.0D0 AMPL = (0.75D0 + DCSEVL (Z, BM12CS, NBM12))/SQRT(X) THETA = X - 3.0D0*PI4 + DCSEVL (Z, BTH1CS, NBTH1)/X end if return end DOUBLE PRECISION FUNCTION D9CHU (A, B, Z) ! !! D9CHU evaluates, for large Z, Z**A * U(A,B,Z), where U is the ... ! logarithmic confluent hypergeometric function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C11 !***TYPE DOUBLE PRECISION (R9CHU-S, D9CHU-D) !***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate for large Z Z**A * U(A,B,Z) where U is the logarithmic ! confluent hypergeometric function. A rational approximation due to Y. ! L. Luke is used. When U is not in the asymptotic region, i.e., when A ! or B is large compared with Z, considerable significance loss occurs. ! A warning is provided when the computed result is less than half ! precision. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE D9CHU DOUBLE PRECISION A, B, Z, AA(4), BB(4), AB, ANBN, BP, CT1, CT2, & CT3, C2, D1Z, EPS, G1, G2, G3, SAB, SQEPS, X2I1, D1MACH LOGICAL FIRST SAVE EPS, SQEPS, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9CHU if (FIRST) THEN EPS = 4.0D0*D1MACH(4) SQEPS = SQRT(D1MACH(4)) end if FIRST = .FALSE. ! BP = 1.0D0 + A - B AB = A*BP CT2 = 2.0D0 * (Z - AB) SAB = A + BP ! BB(1) = 1.0D0 AA(1) = 1.0D0 ! CT3 = SAB + 1.0D0 + AB BB(2) = 1.0D0 + 2.0D0*Z/CT3 AA(2) = 1.0D0 + CT2/CT3 ! ANBN = CT3 + SAB + 3.0D0 CT1 = 1.0D0 + 2.0D0*Z/ANBN BB(3) = 1.0D0 + 6.0D0*CT1*Z/CT3 AA(3) = 1.0D0 + 6.0D0*AB/ANBN + 3.0D0*CT1*CT2/CT3 ! DO 30 I=4,300 X2I1 = 2*I - 3 CT1 = X2I1/(X2I1-2.0D0) ANBN = ANBN + X2I1 + SAB CT2 = (X2I1 - 1.0D0)/ANBN C2 = X2I1*CT2 - 1.0D0 D1Z = X2I1*2.0D0*Z/ANBN ! CT3 = SAB*CT2 G1 = D1Z + CT1*(C2+CT3) G2 = D1Z - C2 G3 = CT1*(1.0D0 - CT3 - 2.0D0*CT2) ! BB(4) = G1*BB(3) + G2*BB(2) + G3*BB(1) AA(4) = G1*AA(3) + G2*AA(2) + G3*AA(1) if (ABS(AA(4)*BB(1)-AA(1)*BB(4)) < EPS*ABS(BB(4)*BB(1))) & go to 40 ! ! if OVERFLOWS OR UNDERFLOWS PROVE TO BE A PROBLEM, THE STATEMENTS ! BELOW COULD BE ALTERED TO INCORPORATE A DYNAMICALLY ADJUSTED SCALE ! FACTOR. ! DO 20 J=1,3 AA(J) = AA(J+1) BB(J) = BB(J+1) 20 CONTINUE 30 CONTINUE call XERMSG ('SLATEC', 'D9CHU', 'NO CONVERGENCE IN 300 TERMS', 2, & 2) ! 40 D9CHU = AA(4)/BB(4) ! if (D9CHU < SQEPS .OR. D9CHU > 1.0D0/SQEPS) call XERMSG & ('SLATEC', 'D9CHU', 'ANSWER LT HALF PRECISION', 2, 1) ! return end DOUBLE PRECISION FUNCTION D9GMIC (A, X, ALX) ! !! D9GMIC computes the complementary incomplete Gamma function ... ! for A near a negative integer and X small. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE DOUBLE PRECISION (R9GMIC-S, D9GMIC-D) !***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute the complementary incomplete gamma function for A near ! a negative integer and for small X. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DLNGAM, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE D9GMIC DOUBLE PRECISION A, X, ALX, ALNG, BOT, EPS, EULER, FK, FKP1, FM, & S, SGNG, T, TE, D1MACH, DLNGAM LOGICAL FIRST SAVE EULER, EPS, BOT, FIRST DATA EULER / 0.57721566490153286060651209008240D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9GMIC if (FIRST) THEN EPS = 0.5D0*D1MACH(3) BOT = LOG (D1MACH(1)) end if FIRST = .FALSE. ! if (A > 0.D0) call XERMSG ('SLATEC', 'D9GMIC', & 'A MUST BE NEAR A NEGATIVE INTEGER', 2, 2) if (X <= 0.D0) call XERMSG ('SLATEC', 'D9GMIC', & 'X MUST BE GT ZERO', 3, 2) ! M = -(A - 0.5D0) FM = M ! TE = 1.0D0 T = 1.0D0 S = T DO 20 K=1,200 FKP1 = K + 1 TE = -X*TE/(FM+FKP1) T = TE/FKP1 S = S + T if (ABS(T) < EPS*S) go to 30 20 CONTINUE call XERMSG ('SLATEC', 'D9GMIC', & 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 4, 2) ! 30 D9GMIC = -ALX - EULER + X*S/(FM+1.0D0) if (M == 0) RETURN ! if (M == 1) D9GMIC = -D9GMIC - 1.D0 + 1.D0/X if (M == 1) RETURN ! TE = FM T = 1.D0 S = T MM1 = M - 1 DO 40 K=1,MM1 FK = K TE = -X*TE/FK T = TE/(FM-FK) S = S + T if (ABS(T) < EPS*ABS(S)) go to 50 40 CONTINUE ! 50 DO 60 K=1,M D9GMIC = D9GMIC + 1.0D0/K 60 CONTINUE ! SGNG = 1.0D0 if (MOD(M,2) == 1) SGNG = -1.0D0 ALNG = LOG(D9GMIC) - DLNGAM(FM+1.D0) ! D9GMIC = 0.D0 if (ALNG > BOT) D9GMIC = SGNG * EXP(ALNG) if (S /= 0.D0) D9GMIC = D9GMIC + & SIGN (EXP(-FM*ALX+LOG(ABS(S)/FM)), S) ! if (D9GMIC == 0.D0 .AND. S == 0.D0) call XERMSG ('SLATEC', & 'D9GMIC', 'RESULT UNDERFLOWS', 1, 1) return ! end DOUBLE PRECISION FUNCTION D9GMIT (A, X, ALGAP1, SGNGAM, ALX) ! !! D9GMIT computes Tricomi's incomplete Gamma function for small arguments. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE DOUBLE PRECISION (R9GMIT-S, D9GMIT-D) !***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, ! SPECIAL FUNCTIONS, TRICOMI !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute Tricomi's incomplete gamma function for small X. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DLNGAM, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE D9GMIT DOUBLE PRECISION A, X, ALGAP1, SGNGAM, ALX, AE, AEPS, ALGS, ALG2, & BOT, EPS, FK, S, SGNG2, T, TE, D1MACH, DLNGAM LOGICAL FIRST SAVE EPS, BOT, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9GMIT if (FIRST) THEN EPS = 0.5D0*D1MACH(3) BOT = LOG (D1MACH(1)) end if FIRST = .FALSE. ! if (X <= 0.D0) call XERMSG ('SLATEC', 'D9GMIT', & 'X SHOULD BE GT 0', 1, 2) ! MA = A + 0.5D0 if (A < 0.D0) MA = A - 0.5D0 AEPS = A - MA ! AE = A if (A < (-0.5D0)) AE = AEPS ! T = 1.D0 TE = AE S = T DO 20 K=1,200 FK = K TE = -X*TE/FK T = TE/(AE+FK) S = S + T if (ABS(T) < EPS*ABS(S)) go to 30 20 CONTINUE call XERMSG ('SLATEC', 'D9GMIT', & 'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2) ! 30 if (A >= (-0.5D0)) ALGS = -ALGAP1 + LOG(S) if (A >= (-0.5D0)) go to 60 ! ALGS = -DLNGAM(1.D0+AEPS) + LOG(S) S = 1.0D0 M = -MA - 1 if (M == 0) go to 50 T = 1.0D0 DO 40 K=1,M T = X*T/(AEPS-(M+1-K)) S = S + T if (ABS(T) < EPS*ABS(S)) go to 50 40 CONTINUE ! 50 D9GMIT = 0.0D0 ALGS = -MA*LOG(X) + ALGS if (S == 0.D0 .OR. AEPS == 0.D0) go to 60 ! SGNG2 = SGNGAM * SIGN (1.0D0, S) ALG2 = -X - ALGAP1 + LOG(ABS(S)) ! if (ALG2 > BOT) D9GMIT = SGNG2 * EXP(ALG2) if (ALGS > BOT) D9GMIT = D9GMIT + EXP(ALGS) return ! 60 D9GMIT = EXP (ALGS) return ! end subroutine D9KNUS (XNU, X, BKNU, BKNU1, ISWTCH) ! !! D9KNUS computes Bessel functions EXP(X)*K-SUB-XNU(X) and ... ! EXP(X)*K-SUB-XNU+1(X) for 0.0 <= XNU < 1.0. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B3 !***TYPE DOUBLE PRECISION (R9KNUS-S, D9KNUS-D) !***KEYWORDS BESSEL FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute Bessel functions EXP(X) * K-sub-XNU (X) and ! EXP(X) * K-sub-XNU+1 (X) for 0.0 <= XNU < 1.0 . ! ! Series for C0K on the interval 0. to 2.50000E-01 ! with weighted error 2.16E-32 ! log weighted error 31.67 ! significant figures required 30.86 ! decimal places required 32.40 ! ! Series for ZNU1 on the interval -7.00000E-01 to 0. ! with weighted error 2.45E-33 ! log weighted error 32.61 ! significant figures required 31.85 ! decimal places required 33.26 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, DGAMMA, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) ! 900727 Added EXTERNAL statement. (WRB) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE D9KNUS DOUBLE PRECISION XNU, X, BKNU, BKNU1, ALPHA(32), BETA(32), A(32), & C0KCS(29), ZNU1CS(20), ALNZ, ALN2, A0, BKNUD, BKNU0, & B0, C0, EULER, EXPX, P1, P2, P3, QQ, RESULT, SQPI2, SQRTX, V, & VLNZ, XI, XMU, XNUSML, XSML, X2N, X2TOV, Z, ZTOV, ALNSML, & ALNBIG REAL ALNEPS DOUBLE PRECISION D1MACH, DCSEVL, DGAMMA LOGICAL FIRST EXTERNAL DGAMMA SAVE C0KCS, ZNU1CS, EULER, SQPI2, ALN2, NTC0K, & NTZNU1, XNUSML, XSML, ALNSML, ALNBIG, ALNEPS, FIRST DATA C0KCS( 1) / +.60183057242626108387577445180329D-1 / DATA C0KCS( 2) / -.15364871433017286092959755943124D+0 / DATA C0KCS( 3) / -.11751176008210492040068229226213D-1 / DATA C0KCS( 4) / -.85248788891979509827048401550987D-3 / DATA C0KCS( 5) / -.61329838767496791874098176922111D-4 / DATA C0KCS( 6) / -.44052281245510444562679889548505D-5 / DATA C0KCS( 7) / -.31631246728384488192915445892199D-6 / DATA C0KCS( 8) / -.22710719382899588330673771793396D-7 / DATA C0KCS( 9) / -.16305644608077609552274620515360D-8 / DATA C0KCS( 10) / -.11706939299414776568756044043130D-9 / DATA C0KCS( 11) / -.84052063786464437174546593413792D-11 / DATA C0KCS( 12) / -.60346670118979991487096050737198D-12 / DATA C0KCS( 13) / -.43326960335681371952045997366903D-13 / DATA C0KCS( 14) / -.31107358030203546214634697772237D-14 / DATA C0KCS( 15) / -.22334078226736982254486133409840D-15 / DATA C0KCS( 16) / -.16035146716864226300635791528610D-16 / DATA C0KCS( 17) / -.11512717363666556196035697705305D-17 / DATA C0KCS( 18) / -.82657591746836959105169479089258D-19 / DATA C0KCS( 19) / -.59345480806383948172333436695984D-20 / DATA C0KCS( 20) / -.42608138196467143926499613023976D-21 / DATA C0KCS( 21) / -.30591266864812876299263698370542D-22 / DATA C0KCS( 22) / -.21963541426734575224975501815516D-23 / DATA C0KCS( 23) / -.15769113261495836071105750684760D-24 / DATA C0KCS( 24) / -.11321713935950320948757731048056D-25 / DATA C0KCS( 25) / -.81286248834598404082792349714433D-27 / DATA C0KCS( 26) / -.58360900893453226552829349315949D-28 / DATA C0KCS( 27) / -.41901241623610922519452337780905D-29 / DATA C0KCS( 28) / -.30083737960206435069530504212862D-30 / DATA C0KCS( 29) / -.21599152067808647728342168089832D-31 / DATA ZNU1CS( 1) / +.203306756994191729674444001216911D+0 / DATA ZNU1CS( 2) / +.140077933413219771062943670790563D+0 / DATA ZNU1CS( 3) / +.791679696100161352840972241972320D-2 / DATA ZNU1CS( 4) / +.339801182532104045352930092205750D-3 / DATA ZNU1CS( 5) / +.117419756889893366664507228352690D-4 / DATA ZNU1CS( 6) / +.339357570612261680333825865475121D-6 / DATA ZNU1CS( 7) / +.842594176976219910194629891264803D-8 / DATA ZNU1CS( 8) / +.183336677024850089184748150900090D-9 / DATA ZNU1CS( 9) / +.354969844704416310863007064469557D-11 / DATA ZNU1CS( 10) / +.619032496469887332205244342078407D-13 / DATA ZNU1CS( 11) / +.981964535680439424960346115456527D-15 / DATA ZNU1CS( 12) / +.142851314396490474211473563005985D-16 / DATA ZNU1CS( 13) / +.191894921887825298966162467488436D-18 / DATA ZNU1CS( 14) / +.239430979739498914162313140597128D-20 / DATA ZNU1CS( 15) / +.278890246815347354835870465474995D-22 / DATA ZNU1CS( 16) / +.304606650633033442582845214092865D-24 / DATA ZNU1CS( 17) / +.313173237042191815771564260932089D-26 / DATA ZNU1CS( 18) / +.304133098987854951645174908005034D-28 / DATA ZNU1CS( 19) / +.279840384636833084343185097659733D-30 / DATA ZNU1CS( 20) / +.244637186274497596485238794922666D-32 / DATA EULER / 0.57721566490153286060651209008240D0 / DATA SQPI2 / +1.2533141373155002512078826424055D0 / DATA ALN2 / 0.69314718055994530941723212145818D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9KNUS if (FIRST) THEN ETA = 0.1D0*D1MACH(3) NTC0K = INITDS (C0KCS, 29, ETA) NTZNU1 = INITDS (ZNU1CS, 20, ETA) ! XNUSML = SQRT(D1MACH(3)/8.D0) XSML = 0.1D0*D1MACH(3) ALNSML = LOG (D1MACH(1)) ALNBIG = LOG (D1MACH(2)) ALNEPS = LOG (0.1D0*D1MACH(3)) end if FIRST = .FALSE. ! if (XNU < 0.D0 .OR. XNU >= 1.D0) call XERMSG ('SLATEC', & 'D9KNUS', 'XNU MUST BE GE 0 AND LT 1', 1, 2) if (X <= 0.) call XERMSG ('SLATEC', 'D9KNUS', 'X MUST BE GT 0', & 2, 2) ! ISWTCH = 0 if (X > 2.0D0) go to 50 ! ! X IS SMALL. COMPUTE K-SUB-XNU (X) AND THE DERIVATIVE OF K-SUB-XNU (X) ! THEN FIND K-SUB-XNU+1 (X). XNU IS REDUCED TO THE INTERVAL (-.5,+.5) ! THEN TO (0., .5), BECAUSE K OF NEGATIVE ORDER (-NU) = K OF POSITIVE ! ORDER (+NU). ! V = XNU if (XNU > 0.5D0) V = 1.0D0 - XNU ! ! CAREFULLY FIND (X/2)**XNU AND Z**XNU WHERE Z = X*X/4. ALNZ = 2.D0 * (LOG(X) - ALN2) ! if (X > XNU) go to 20 if (-0.5D0*XNU*ALNZ-ALN2-LOG(XNU) > ALNBIG) call XERMSG & ('SLATEC', 'D9KNUS', 'X SO SMALL BESSEL K-SUB-XNU OVERFLOWS', & 3, 2) ! 20 VLNZ = V*ALNZ X2TOV = EXP (0.5D0*VLNZ) ZTOV = 0.0D0 if (VLNZ > ALNSML) ZTOV = X2TOV**2 ! A0 = 0.5D0*DGAMMA(1.0D0+V) B0 = 0.5D0*DGAMMA(1.0D0-V) C0 = -EULER if (ZTOV > 0.5D0 .AND. V > XNUSML) C0 = -0.75D0 + & DCSEVL ((8.0D0*V)*V-1.0D0, C0KCS, NTC0K) ! if (ZTOV <= 0.5D0) ALPHA(1) = (A0-ZTOV*B0)/V if (ZTOV > 0.5D0) ALPHA(1) = C0 - ALNZ*(0.75D0 + & DCSEVL (VLNZ/0.35D0+1.0D0, ZNU1CS, NTZNU1))*B0 BETA(1) = -0.5D0*(A0+ZTOV*B0) ! Z = 0.0D0 if (X > XSML) Z = 0.25D0*X*X NTERMS = MAX (2.0, 11.0+(8.*REAL(ALNZ)-25.19-ALNEPS) & /(4.28-REAL(ALNZ))) DO 30 I=2,NTERMS XI = I - 1 A0 = A0/(XI*(XI-V)) B0 = B0/(XI*(XI+V)) ALPHA(I) = (ALPHA(I-1)+2.0D0*XI*A0)/(XI*(XI+V)) BETA(I) = (XI-0.5D0*V)*ALPHA(I) - ZTOV*B0 30 CONTINUE ! BKNU = ALPHA(NTERMS) BKNUD = BETA(NTERMS) DO 40 II=2,NTERMS I = NTERMS + 1 - II BKNU = ALPHA(I) + BKNU*Z BKNUD = BETA(I) + BKNUD*Z 40 CONTINUE ! EXPX = EXP(X) BKNU = EXPX*BKNU/X2TOV ! if (-0.5D0*(XNU+1.D0)*ALNZ-2.0D0*ALN2 > ALNBIG) ISWTCH = 1 if (ISWTCH == 1) RETURN BKNUD = EXPX*BKNUD*2.0D0/(X2TOV*X) ! if (XNU <= 0.5D0) BKNU1 = V*BKNU/X - BKNUD if (XNU <= 0.5D0) RETURN ! BKNU0 = BKNU BKNU = -V*BKNU/X - BKNUD BKNU1 = 2.0D0*XNU*BKNU/X + BKNU0 return ! ! X IS LARGE. FIND K-SUB-XNU (X) AND K-SUB-XNU+1 (X) WITH Y. L. LUKE-S ! RATIONAL EXPANSION. ! 50 SQRTX = SQRT(X) if (X > 1.0D0/XSML) go to 90 AN = -0.60 - 1.02/REAL(X) BN = -0.27 - 0.53/REAL(X) NTERMS = MIN (32, MAX1 (3.0, AN+BN*ALNEPS)) ! DO 80 INU=1,2 XMU = 0.D0 if (INU == 1 .AND. XNU > XNUSML) XMU = (4.0D0*XNU)*XNU if (INU == 2) XMU = 4.0D0*(ABS(XNU)+1.D0)**2 ! A(1) = 1.0D0 - XMU A(2) = 9.0D0 - XMU A(3) = 25.0D0 - XMU if (A(2) == 0.D0) RESULT = SQPI2*(16.D0*X+XMU+7.D0) / & (16.D0*X*SQRTX) if (A(2) == 0.D0) go to 70 ! ALPHA(1) = 1.0D0 ALPHA(2) = (16.D0*X+A(2))/A(2) ALPHA(3) = ((768.D0*X+48.D0*A(3))*X + A(2)*A(3))/(A(2)*A(3)) ! BETA(1) = 1.0D0 BETA(2) = (16.D0*X+(XMU+7.D0))/A(2) BETA(3) = ((768.D0*X+48.D0*(XMU+23.D0))*X + & ((XMU+62.D0)*XMU+129.D0))/(A(2)*A(3)) ! if (NTERMS < 4) go to 65 DO 60 I=4,NTERMS N = I - 1 X2N = 2*N - 1 ! A(I) = (X2N+2.D0)**2 - XMU QQ = 16.D0*X2N/A(I) P1 = -X2N*((12*N*N-20*N)-A(1))/((X2N-2.D0)*A(I)) & - QQ*X P2 = ((12*N*N-28*N+8)-A(1))/A(I) - QQ*X P3 = -X2N*A(I-3)/((X2N-2.D0)*A(I)) ! ALPHA(I) = -P1*ALPHA(I-1) - P2*ALPHA(I-2) - P3*ALPHA(I-3) BETA(I) = -P1*BETA(I-1) - P2*BETA(I-2) - P3*BETA(I-3) 60 CONTINUE ! 65 RESULT = SQPI2*BETA(NTERMS)/(SQRTX*ALPHA(NTERMS)) ! 70 if (INU == 1) BKNU = RESULT if (INU == 2) BKNU1 = RESULT 80 CONTINUE return ! 90 BKNU = SQPI2/SQRTX BKNU1 = BKNU return ! end DOUBLE PRECISION FUNCTION D9LGIC (A, X, ALX) ! !! D9LGIC computes the log complementary incomplete Gamma function ... ! for large X and for A <= X. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE DOUBLE PRECISION (R9LGIC-S, D9LGIC-D) !***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X, ! LOGARITHM, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute the log complementary incomplete gamma function for large X ! and for A <= X. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE D9LGIC DOUBLE PRECISION A, X, ALX, EPS, FK, P, R, S, T, XMA, XPA, D1MACH SAVE EPS DATA EPS / 0.D0 / !***FIRST EXECUTABLE STATEMENT D9LGIC if (EPS == 0.D0) EPS = 0.5D0*D1MACH(3) ! XPA = X + 1.0D0 - A XMA = X - 1.D0 - A ! R = 0.D0 P = 1.D0 S = P DO 10 K=1,300 FK = K T = FK*(A-FK)*(1.D0+R) R = -T/((XMA+2.D0*FK)*(XPA+2.D0*FK)+T) P = R*P S = S + P if (ABS(P) < EPS*S) go to 20 10 CONTINUE call XERMSG ('SLATEC', 'D9LGIC', & 'NO CONVERGENCE IN 300 TERMS OF CONTINUED FRACTION', 1, 2) ! 20 D9LGIC = A*ALX - X + LOG(S/XPA) ! return end DOUBLE PRECISION FUNCTION D9LGIT (A, X, ALGAP1) ! !! D9LGIT computes the logarithm of Tricomi's incomplete Gamma function ... ! with Perron's continued fraction for large X and A >= X. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE DOUBLE PRECISION (R9LGIT-S, D9LGIT-D) !***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM, ! PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute the log of Tricomi's incomplete gamma function with Perron's ! continued fraction for large X and for A >= X. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE D9LGIT DOUBLE PRECISION A, X, ALGAP1, AX, A1X, EPS, FK, HSTAR, P, R, S, & SQEPS, T, D1MACH LOGICAL FIRST SAVE EPS, SQEPS, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9LGIT if (FIRST) THEN EPS = 0.5D0*D1MACH(3) SQEPS = SQRT(D1MACH(4)) end if FIRST = .FALSE. ! if (X <= 0.D0 .OR. A < X) call XERMSG ('SLATEC', 'D9LGIT', & 'X SHOULD BE GT 0.0 AND LE A', 2, 2) ! AX = A + X A1X = AX + 1.0D0 R = 0.D0 P = 1.D0 S = P DO 20 K=1,200 FK = K T = (A+FK)*X*(1.D0+R) R = T/((AX+FK)*(A1X+FK)-T) P = R*P S = S + P if (ABS(P) < EPS*S) go to 30 20 CONTINUE call XERMSG ('SLATEC', 'D9LGIT', & 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 3, 2) ! 30 HSTAR = 1.0D0 - X*S/A1X if (HSTAR < SQEPS) call XERMSG ('SLATEC', 'D9LGIT', & 'RESULT LESS THAN HALF PRECISION', 1, 1) ! D9LGIT = -X - ALGAP1 - LOG(HSTAR) return ! end DOUBLE PRECISION FUNCTION D9LGMC (X) ! !! D9LGMC computes the log Gamma correction factor so that ... ! LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X + D9LGMC(X). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) !***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, ! LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute the log gamma correction factor for X >= 10. so that ! LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X) ! ! Series for ALGM on the interval 0. to 1.00000E-02 ! with weighted error 1.28E-31 ! log weighted error 30.89 ! significant figures required 29.81 ! decimal places required 31.48 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE D9LGMC DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVL, D1MACH LOGICAL FIRST SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST DATA ALGMCS( 1) / +.1666389480451863247205729650822D+0 / DATA ALGMCS( 2) / -.1384948176067563840732986059135D-4 / DATA ALGMCS( 3) / +.9810825646924729426157171547487D-8 / DATA ALGMCS( 4) / -.1809129475572494194263306266719D-10 / DATA ALGMCS( 5) / +.6221098041892605227126015543416D-13 / DATA ALGMCS( 6) / -.3399615005417721944303330599666D-15 / DATA ALGMCS( 7) / +.2683181998482698748957538846666D-17 / DATA ALGMCS( 8) / -.2868042435334643284144622399999D-19 / DATA ALGMCS( 9) / +.3962837061046434803679306666666D-21 / DATA ALGMCS( 10) / -.6831888753985766870111999999999D-23 / DATA ALGMCS( 11) / +.1429227355942498147573333333333D-24 / DATA ALGMCS( 12) / -.3547598158101070547199999999999D-26 / DATA ALGMCS( 13) / +.1025680058010470912000000000000D-27 / DATA ALGMCS( 14) / -.3401102254316748799999999999999D-29 / DATA ALGMCS( 15) / +.1276642195630062933333333333333D-30 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9LGMC if (FIRST) THEN NALGM = INITDS (ALGMCS, 15, REAL(D1MACH(3)) ) XBIG = 1.0D0/SQRT(D1MACH(3)) XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1)))) end if FIRST = .FALSE. ! if (X < 10.D0) call XERMSG ('SLATEC', 'D9LGMC', & 'X MUST BE GE 10', 1, 2) if (X >= XMAX) go to 20 ! D9LGMC = 1.D0/(12.D0*X) if (X < XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS, & NALGM) / X return ! 20 D9LGMC = 0.D0 call XERMSG ('SLATEC', 'D9LGMC', 'X SO BIG D9LGMC UNDERFLOWS', 2, & 1) return ! end DOUBLE PRECISION FUNCTION D9LN2R (X) ! !! D9LN2R evaluates LOG(1+X) from second order relative accuracy ... ! so that LOG(1+X) = X - X**2/2 + X**3*D9LN2R(X). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4B !***TYPE DOUBLE PRECISION (R9LN2R-S, D9LN2R-D, C9LN2R-C) !***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM, SECOND ORDER !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate LOG(1+X) from 2-nd order with relative error accuracy so ! that LOG(1+X) = X - X**2/2 + X**3*D9LN2R(X) ! ! Series for LN21 on the interval -6.25000E-01 to 0. ! with weighted error 1.82E-32 ! log weighted error 31.74 ! significant figures required 31.00 ! decimal places required 32.59 ! ! Series for LN22 on the interval 0. to 8.12500E-01 ! with weighted error 6.10E-32 ! log weighted error 31.21 ! significant figures required 30.32 ! decimal places required 32.00 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 780401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE D9LN2R DOUBLE PRECISION X, XBIG, TXBIG, XMAX, TXMAX, XMIN, LN21CS(50), & LN22CS(37), DCSEVL, D1MACH LOGICAL FIRST SAVE LN21CS, LN22CS, NTLN21, NTLN22, XMIN, XBIG, XMAX, FIRST DATA LN21CS( 1) / +.18111962513478809875894953043071D+0 / DATA LN21CS( 2) / -.15627123192872462669625155541078D+0 / DATA LN21CS( 3) / +.28676305361557275209540627102051D-1 / DATA LN21CS( 4) / -.55586996559481398781157725126781D-2 / DATA LN21CS( 5) / +.11178976652299837657335666279727D-2 / DATA LN21CS( 6) / -.23080508982327947182299279585705D-3 / DATA LN21CS( 7) / +.48598853341100175874681558068750D-4 / DATA LN21CS( 8) / -.10390127388903210765514242633338D-4 / DATA LN21CS( 9) / +.22484563707390128494621804946408D-5 / DATA LN21CS( 10) / -.49140592739266484875327802597091D-6 / DATA LN21CS( 11) / +.10828256507077483336620152971597D-6 / DATA LN21CS( 12) / -.24025872763420701435976675416719D-7 / DATA LN21CS( 13) / +.53624600472708133762984443250163D-8 / DATA LN21CS( 14) / -.12029951362138772264671646424377D-8 / DATA LN21CS( 15) / +.27107889277591860785622551632266D-9 / DATA LN21CS( 16) / -.61323562618319010068796728430690D-10 / DATA LN21CS( 17) / +.13920858369159469857436908543978D-10 / DATA LN21CS( 18) / -.31699300330223494015283057260883D-11 / DATA LN21CS( 19) / +.72383754044307505335214326197011D-12 / DATA LN21CS( 20) / -.16570017184764411391498805506268D-12 / DATA LN21CS( 21) / +.38018428663117424257364422631876D-13 / DATA LN21CS( 22) / -.87411189296972700259724429899137D-14 / DATA LN21CS( 23) / +.20135619845055748302118751028154D-14 / DATA LN21CS( 24) / -.46464456409033907031102008154477D-15 / DATA LN21CS( 25) / +.10739282147018339453453338554925D-15 / DATA LN21CS( 26) / -.24858534619937794755534021833960D-16 / DATA LN21CS( 27) / +.57620197950800189813888142628181D-17 / DATA LN21CS( 28) / -.13373063769804394701402199958050D-17 / DATA LN21CS( 29) / +.31074653227331824966533807166805D-18 / DATA LN21CS( 30) / -.72288104083040539906901957917627D-19 / DATA LN21CS( 31) / +.16833783788037385103313258186888D-19 / DATA LN21CS( 32) / -.39239463312069958052519372739925D-20 / DATA LN21CS( 33) / +.91551468387536789746385528640853D-21 / DATA LN21CS( 34) / -.21378895321320159520982095801002D-21 / DATA LN21CS( 35) / +.49964507479047864699828564568746D-22 / DATA LN21CS( 36) / -.11686240636080170135360806147413D-22 / DATA LN21CS( 37) / +.27353123470391863775628686786559D-23 / DATA LN21CS( 38) / -.64068025084792111965050345881599D-24 / DATA LN21CS( 39) / +.15016293204334124162949071940266D-24 / DATA LN21CS( 40) / -.35217372410398479759497145002666D-25 / DATA LN21CS( 41) / +.82643901014814767012482733397333D-26 / DATA LN21CS( 42) / -.19404930275943401918036617898666D-26 / DATA LN21CS( 43) / +.45587880018841283562451588437333D-27 / DATA LN21CS( 44) / -.10715492087545202154378625023999D-27 / DATA LN21CS( 45) / +.25199408007927592978096674133333D-28 / DATA LN21CS( 46) / -.59289088400120969341750476800000D-29 / DATA LN21CS( 47) / +.13955864061057513058237153279999D-29 / DATA LN21CS( 48) / -.32864578813478583431436697599999D-30 / DATA LN21CS( 49) / +.77424967950478166247254698666666D-31 / DATA LN21CS( 50) / -.18247735667260887638125226666666D-31 / DATA LN22CS( 1) / -.2224253253502046082986015223552D+0 / DATA LN22CS( 2) / -.6104710010807862398680104755764D-1 / DATA LN22CS( 3) / +.7427235009750394590519629755729D-2 / DATA LN22CS( 4) / -.9335018261636970565612779606397D-3 / DATA LN22CS( 5) / +.1200499076872601283350731287359D-3 / DATA LN22CS( 6) / -.1570472295282004112823352608243D-4 / DATA LN22CS( 7) / +.2081874781051271096050783592759D-5 / DATA LN22CS( 8) / -.2789195577646713654057213051375D-6 / DATA LN22CS( 9) / +.3769355823760132058422895135447D-7 / DATA LN22CS( 10) / -.5130902896527711258240589938003D-8 / DATA LN22CS( 11) / +.7027141178150694738206218215392D-9 / DATA LN22CS( 12) / -.9674859550134342389243972005137D-10 / DATA LN22CS( 13) / +.1338104645924887306588496449748D-10 / DATA LN22CS( 14) / -.1858102603534063981628453846591D-11 / DATA LN22CS( 15) / +.2589294422527919749308600123070D-12 / DATA LN22CS( 16) / -.3619568316141588674466025382172D-13 / DATA LN22CS( 17) / +.5074037398016623088006858917396D-14 / DATA LN22CS( 18) / -.7131012977031127302700938748927D-15 / DATA LN22CS( 19) / +.1004490328554567481853386784126D-15 / DATA LN22CS( 20) / -.1417906532184025791904405075285D-16 / DATA LN22CS( 21) / +.2005297034743326117891086396074D-17 / DATA LN22CS( 22) / -.2840996662339803305365396717567D-18 / DATA LN22CS( 23) / +.4031469883969079899599878662826D-19 / DATA LN22CS( 24) / -.5729325241832207320455498956799D-20 / DATA LN22CS( 25) / +.8153488253890010675848928733866D-21 / DATA LN22CS( 26) / -.1161825588549721787606027468799D-21 / DATA LN22CS( 27) / +.1657516611662538343659339775999D-22 / DATA LN22CS( 28) / -.2367336704710805190114017280000D-23 / DATA LN22CS( 29) / +.3384670367975521386076569599999D-24 / DATA LN22CS( 30) / -.4843940829215718204296396799999D-25 / DATA LN22CS( 31) / +.6938759162514273718676138666666D-26 / DATA LN22CS( 32) / -.9948142607031436571923797333333D-27 / DATA LN22CS( 33) / +.1427440611211698610634752000000D-27 / DATA LN22CS( 34) / -.2049794721898234911566506666666D-28 / DATA LN22CS( 35) / +.2945648756401362222885546666666D-29 / DATA LN22CS( 36) / -.4235973185184957027669333333333D-30 / DATA LN22CS( 37) / +.6095532614003832040106666666666D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9LN2R if (FIRST) THEN EPS = D1MACH(3) NTLN21 = INITDS (LN21CS, 50, 0.1*EPS) NTLN22 = INITDS (LN22CS, 37, 0.1*EPS) ! XMIN = -1.0D0 + SQRT(D1MACH(4)) SQEPS = SQRT (EPS) TXMAX = 8.0/SQEPS XMAX = TXMAX - (EPS*TXMAX**2 - 2.D0*LOG(TXMAX)) & / (2.D0*EPS*TXMAX) TXBIG = 6.0/SQRT(SQEPS) XBIG = TXBIG - (SQEPS*TXBIG**2 - 2.D0*LOG(TXBIG)) & / (2.D0*SQEPS*TXBIG) end if FIRST = .FALSE. ! if (X < (-.625D0) .OR. X > 0.8125D0) go to 20 ! if (X < 0.0D0) D9LN2R = 0.375D0 + DCSEVL (16.D0*X/5.D0+1.D0, & LN21CS, NTLN21) if (X >= 0.0D0) D9LN2R = 0.375D0 + DCSEVL (32.D0*X/13.D0-1.D0, & LN22CS, NTLN22) return ! 20 if (X < XMIN) call XERMSG ('SLATEC', 'D9LN2R', & 'ANSWER LT HALF PRECISION BECAUSE X IS TOO NEAR -1', 1, 1) if (X > XMAX) call XERMSG ('SLATEC', 'D9LN2R', & 'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 3, 2) if (X > XBIG) call XERMSG ('SLATEC', 'D9LN2R', & 'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 2, 1) ! D9LN2R = (LOG(1.D0+X) - X*(1.D0 - 0.5D0*X)) / X**3 return ! end DOUBLE PRECISION FUNCTION D9PAK (Y, N) ! !! D9PAK packs a base 2 exponent into a floating point number. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY A6B !***TYPE DOUBLE PRECISION (R9PAK-S, D9PAK-D) !***KEYWORDS FNLIB, PACK !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Pack a base 2 exponent into floating point number X. This routine is ! almost the inverse of D9UPAK. It is not exactly the inverse, because ! ABS(X) need not be between 0.5 and 1.0. If both D9PAK and 2.d0**N ! were known to be in range we could compute ! D9PAK = X *2.0d0**N ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9UPAK, I1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891009 Corrected error when XERROR called. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 901009 Routine used I1MACH(7) where it should use I1MACH(10), ! Corrected (RWC) !***END PROLOGUE D9PAK DOUBLE PRECISION Y, A1N2B,A1N210,D1MACH LOGICAL FIRST SAVE NMIN, NMAX, A1N210, FIRST DATA A1N210 / 3.321928094887362347870319429489D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT D9PAK if (FIRST) THEN A1N2B = 1.0D0 if ( I1MACH(10) /= 2) A1N2B=D1MACH(5)*A1N210 NMIN = A1N2B*I1MACH(15) NMAX = A1N2B*I1MACH(16) end if FIRST = .FALSE. ! call D9UPAK(Y,D9PAK,NY) ! NSUM=N+NY if ( NSUM < NMIN)go to 40 if (NSUM > NMAX) call XERMSG ('SLATEC', 'D9PAK', & 'PACKED NUMBER OVERFLOWS', 1, 2) ! if (NSUM == 0) RETURN if ( NSUM > 0) go to 30 ! 20 D9PAK = 0.5D0*D9PAK NSUM=NSUM+1 if ( NSUM /= 0) go to 20 return ! 30 D9PAK = 2.0D0*D9PAK NSUM=NSUM - 1 if (NSUM /= 0) go to 30 return ! 40 call XERMSG ('SLATEC', 'D9PAK', 'PACKED NUMBER UNDERFLOWS', 1, 1) D9PAK = 0.0D0 return ! end subroutine D9UPAK (X, Y, N) ! !! D9UPAK unpacks a floating point number X so that X = Y*2**N. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY A6B !***TYPE DOUBLE PRECISION (R9UPAK-S, D9UPAK-D) !***KEYWORDS FNLIB, UNPACK !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Unpack a floating point number X so that X = Y*2.0**N, where ! 0.5 <= ABS(Y) < 1.0. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900820 Corrected code to find Y between 0.5 and 1.0 rather than ! between 0.05 and 1.0. (WRB) !***END PROLOGUE D9UPAK DOUBLE PRECISION X,Y,ABSX !***FIRST EXECUTABLE STATEMENT D9UPAK ABSX = ABS(X) N = 0 if (X == 0.0D0) go to 30 ! 10 if (ABSX >= 0.5D0) go to 20 N = N-1 ABSX = ABSX*2.0D0 go to 10 ! 20 if (ABSX < 1.0D0) go to 30 N = N+1 ABSX = ABSX*0.5D0 go to 20 ! 30 Y = SIGN(ABSX,X) return ! end DOUBLE PRECISION FUNCTION DACOSH (X) ! !! DACOSH computes the arc hyperbolic cosine. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE DOUBLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C) !***KEYWORDS ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB, ! INVERSE HYPERBOLIC COSINE !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DACOSH(X) calculates the double precision arc hyperbolic cosine for ! double precision argument X. The result is returned on the ! positive branch. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DACOSH DOUBLE PRECISION X, DLN2, XMAX, D1MACH SAVE DLN2, XMAX DATA DLN2 / 0.69314718055994530941723212145818D0 / DATA XMAX / 0.D0 / !***FIRST EXECUTABLE STATEMENT DACOSH if (XMAX == 0.D0) XMAX = 1.0D0/SQRT(D1MACH(3)) ! if (X < 1.D0) call XERMSG ('SLATEC', 'DACOSH', & 'X LESS THAN 1', 1, 2) ! if (X < XMAX) DACOSH = LOG (X+SQRT(X*X-1.0D0)) if (X >= XMAX) DACOSH = DLN2 + LOG(X) ! return end function daie ( x ) !*****************************************************************************80 ! !! DAIE calculates the Airy function for a negative argument ... ! and an exponentially scaled Airy function for a non-negative argument. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10D !***TYPE DOUBLE PRECISION (AIE-S, DAIE-D) !***KEYWORDS EXPONENTIALLY SCALED AIRY FUNCTION, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DAIE(X) calculates the Airy function or the exponentially scaled ! Airy function depending on the value of the argument. The function ! and argument are both double precision. ! ! Evaluate AI(X) for X <= 0.0 and AI(X)*EXP(ZETA) where ! ZETA = 2/3 * X**(3/2) for X >= 0.0 ! ! Series for AIF on the interval -1.00000E+00 to 1.00000E+00 ! with weighted error 8.37E-33 ! log weighted error 32.08 ! significant figures required 30.87 ! decimal places required 32.63 ! ! Series for AIG on the interval -1.00000E+00 to 1.00000E+00 ! with weighted error 7.47E-34 ! log weighted error 33.13 ! significant figures required 31.50 ! decimal places required 33.68 ! ! Series for AIP1 on the interval 1.25000E-01 to 1.00000E+00 ! with weighted error 3.69E-32 ! log weighted error 31.43 ! significant figures required 29.55 ! decimal places required 32.31 ! ! Series for AIP2 on the interval 0. to 1.25000E-01 ! with weighted error 3.48E-32 ! log weighted error 31.46 ! significant figures required 28.74 ! decimal places required 32.24 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9AIMP, DCSEVL, INITDS !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE DAIE double precision daie DOUBLE PRECISION X, AIFCS(13), AIGCS(13), AIP1CS(57), AIP2CS(37), & SQRTX, THETA, XBIG, XM, X3SML, X32SML, Z, D1MACH, DCSEVL LOGICAL FIRST SAVE AIFCS, AIGCS, AIP1CS, AIP2CS, NAIF, NAIG, NAIP1, & NAIP2, X3SML, X32SML, XBIG, FIRST DATA AIFCS( 1) / -.37971358496669997496197089469414D-1 / DATA AIFCS( 2) / +.59191888537263638574319728013777D-1 / DATA AIFCS( 3) / +.98629280577279975365603891044060D-3 / DATA AIFCS( 4) / +.68488438190765667554854830182412D-5 / DATA AIFCS( 5) / +.25942025962194713019489279081403D-7 / DATA AIFCS( 6) / +.61766127740813750329445749697236D-10 / DATA AIFCS( 7) / +.10092454172466117901429556224601D-12 / DATA AIFCS( 8) / +.12014792511179938141288033225333D-15 / DATA AIFCS( 9) / +.10882945588716991878525295466666D-18 / DATA AIFCS( 10) / +.77513772196684887039238400000000D-22 / DATA AIFCS( 11) / +.44548112037175638391466666666666D-25 / DATA AIFCS( 12) / +.21092845231692343466666666666666D-28 / DATA AIFCS( 13) / +.83701735910741333333333333333333D-32 / DATA AIGCS( 1) / +.18152365581161273011556209957864D-1 / DATA AIGCS( 2) / +.21572563166010755534030638819968D-1 / DATA AIGCS( 3) / +.25678356987483249659052428090133D-3 / DATA AIGCS( 4) / +.14265214119792403898829496921721D-5 / DATA AIGCS( 5) / +.45721149200180426070434097558191D-8 / DATA AIGCS( 6) / +.95251708435647098607392278840592D-11 / DATA AIGCS( 7) / +.13925634605771399051150420686190D-13 / DATA AIGCS( 8) / +.15070999142762379592306991138666D-16 / DATA AIGCS( 9) / +.12559148312567778822703205333333D-19 / DATA AIGCS( 10) / +.83063073770821340343829333333333D-23 / DATA AIGCS( 11) / +.44657538493718567445333333333333D-26 / DATA AIGCS( 12) / +.19900855034518869333333333333333D-29 / DATA AIGCS( 13) / +.74702885256533333333333333333333D-33 / DATA AIP1CS( 1) / -.2146951858910538455460863467778D-1 / DATA AIP1CS( 2) / -.7535382535043301166219720865565D-2 / DATA AIP1CS( 3) / +.5971527949026380852035388881994D-3 / DATA AIP1CS( 4) / -.7283251254207610648502368291548D-4 / DATA AIP1CS( 5) / +.1110297130739299666517381821140D-4 / DATA AIP1CS( 6) / -.1950386152284405710346930314033D-5 / DATA AIP1CS( 7) / +.3786973885159515193885319670057D-6 / DATA AIP1CS( 8) / -.7929675297350978279039072879154D-7 / DATA AIP1CS( 9) / +.1762247638674256075568420122202D-7 / DATA AIP1CS( 10) / -.4110767539667195045029896593893D-8 / DATA AIP1CS( 11) / +.9984770057857892247183414107544D-9 / DATA AIP1CS( 12) / -.2510093251387122211349867730034D-9 / DATA AIP1CS( 13) / +.6500501929860695409272038601725D-10 / DATA AIP1CS( 14) / -.1727818405393616515478877107366D-10 / DATA AIP1CS( 15) / +.4699378842824512578362292872307D-11 / DATA AIP1CS( 16) / -.1304675656297743914491241246272D-11 / DATA AIP1CS( 17) / +.3689698478462678810473948382282D-12 / DATA AIP1CS( 18) / -.1061087206646806173650359679035D-12 / DATA AIP1CS( 19) / +.3098414384878187438660210070110D-13 / DATA AIP1CS( 20) / -.9174908079824139307833423547851D-14 / DATA AIP1CS( 21) / +.2752049140347210895693579062271D-14 / DATA AIP1CS( 22) / -.8353750115922046558091393301880D-15 / DATA AIP1CS( 23) / +.2563931129357934947568636168612D-15 / DATA AIP1CS( 24) / -.7950633762598854983273747289822D-16 / DATA AIP1CS( 25) / +.2489283634603069977437281175644D-16 / DATA AIP1CS( 26) / -.7864326933928735569664626221296D-17 / DATA AIP1CS( 27) / +.2505687311439975672324470645019D-17 / DATA AIP1CS( 28) / -.8047420364163909524537958682241D-18 / DATA AIP1CS( 29) / +.2604097118952053964443401104392D-18 / DATA AIP1CS( 30) / -.8486954164056412259482488834184D-19 / DATA AIP1CS( 31) / +.2784706882142337843359429186027D-19 / DATA AIP1CS( 32) / -.9195858953498612913687224151354D-20 / DATA AIP1CS( 33) / +.3055304318374238742247668225583D-20 / DATA AIP1CS( 34) / -.1021035455479477875902177048439D-20 / DATA AIP1CS( 35) / +.3431118190743757844000555680836D-21 / DATA AIP1CS( 36) / -.1159129341797749513376922463109D-21 / DATA AIP1CS( 37) / +.3935772844200255610836268229154D-22 / DATA AIP1CS( 38) / -.1342880980296717611956718989038D-22 / DATA AIP1CS( 39) / +.4603287883520002741659190305314D-23 / DATA AIP1CS( 40) / -.1585043927004064227810772499387D-23 / DATA AIP1CS( 41) / +.5481275667729675908925523755008D-24 / DATA AIP1CS( 42) / -.1903349371855047259064017948945D-24 / DATA AIP1CS( 43) / +.6635682302374008716777612115968D-25 / DATA AIP1CS( 44) / -.2322311650026314307975200986453D-25 / DATA AIP1CS( 45) / +.8157640113429179313142743695359D-26 / DATA AIP1CS( 46) / -.2875824240632900490057489929557D-26 / DATA AIP1CS( 47) / +.1017329450942901435079714319018D-26 / DATA AIP1CS( 48) / -.3610879108742216446575703490559D-27 / DATA AIP1CS( 49) / +.1285788540363993421256640342698D-27 / DATA AIP1CS( 50) / -.4592901037378547425160693022719D-28 / DATA AIP1CS( 51) / +.1645597033820713725812102485333D-28 / DATA AIP1CS( 52) / -.5913421299843501842087920271360D-29 / DATA AIP1CS( 53) / +.2131057006604993303479369509546D-29 / DATA AIP1CS( 54) / -.7701158157787598216982761745066D-30 / DATA AIP1CS( 55) / +.2790533307968930417581783777280D-30 / DATA AIP1CS( 56) / -.1013807715111284006452241367039D-30 / DATA AIP1CS( 57) / +.3692580158719624093658286216533D-31 / DATA AIP2CS( 1) / -.174314496929375513390355844011D-2 / DATA AIP2CS( 2) / -.167893854325541671632190613480D-2 / DATA AIP2CS( 3) / +.359653403352166035885983858114D-4 / DATA AIP2CS( 4) / -.138081860273922835457399383100D-5 / DATA AIP2CS( 5) / +.741122807731505298848699095233D-7 / DATA AIP2CS( 6) / -.500238203900133013130422866325D-8 / DATA AIP2CS( 7) / +.400693917417184240675446866355D-9 / DATA AIP2CS( 8) / -.367331242795905044199318496207D-10 / DATA AIP2CS( 9) / +.376034439592373852439592002918D-11 / DATA AIP2CS( 10) / -.422321332718747538026564938968D-12 / DATA AIP2CS( 11) / +.513509454033657070919618754120D-13 / DATA AIP2CS( 12) / -.669095850390477595651681356676D-14 / DATA AIP2CS( 13) / +.926667545641290648239550724382D-15 / DATA AIP2CS( 14) / -.135514382416070576333397356591D-15 / DATA AIP2CS( 15) / +.208115496312830995299006549335D-16 / DATA AIP2CS( 16) / -.334116499159176856871277570256D-17 / DATA AIP2CS( 17) / +.558578584585924316868032946585D-18 / DATA AIP2CS( 18) / -.969219040152365247518658209109D-19 / DATA AIP2CS( 19) / +.174045700128893206465696557738D-19 / DATA AIP2CS( 20) / -.322640979731130400247846333098D-20 / DATA AIP2CS( 21) / +.616074471106625258533259618986D-21 / DATA AIP2CS( 22) / -.120936347982490059076420676266D-21 / DATA AIP2CS( 23) / +.243632763310138108261570095786D-22 / DATA AIP2CS( 24) / -.502914221497457468943403144533D-23 / DATA AIP2CS( 25) / +.106224175543635689495470626133D-23 / DATA AIP2CS( 26) / -.229284284895989241509856324266D-24 / DATA AIP2CS( 27) / +.505181733929503744986884778666D-25 / DATA AIP2CS( 28) / -.113498123714412404979793920000D-25 / DATA AIP2CS( 29) / +.259765565985606980698374144000D-26 / DATA AIP2CS( 30) / -.605124621542939506172231679999D-27 / DATA AIP2CS( 31) / +.143359777966772800720295253333D-27 / DATA AIP2CS( 32) / -.345147757060899986280721066666D-28 / DATA AIP2CS( 33) / +.843875190213646740427025066666D-29 / DATA AIP2CS( 34) / -.209396142298188169434453333333D-29 / DATA AIP2CS( 35) / +.527008873478945503182848000000D-30 / DATA AIP2CS( 36) / -.134457433014553385789030399999D-30 / DATA AIP2CS( 37) / +.347570964526601147340117333333D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DAIE if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NAIF = INITDS (AIFCS, 13, ETA) NAIG = INITDS (AIGCS, 13, ETA) NAIP1 = INITDS (AIP1CS, 57, ETA) NAIP2 = INITDS (AIP2CS, 37, ETA) X3SML = ETA**0.3333E0 X32SML = 1.3104D0*X3SML**2 XBIG = D1MACH(2)**0.6666D0 FIRST = .FALSE. end if if (X >= (-1.0D0)) go to 20 call D9AIMP (X, XM, THETA) DAIE = XM * COS(THETA) return 20 if (X > 1.0D0) go to 30 Z = 0.0D0 if (ABS(X) > X3SML) Z = X**3 DAIE = 0.375D0 + (DCSEVL (Z, AIFCS, NAIF) - X*(0.25D0 + & DCSEVL (Z, AIGCS, NAIG)) ) if (X > X32SML) DAIE = DAIE * EXP (2.0D0*X*SQRT(X)/3.0D0) return 30 if (X > 4.0D0) go to 40 SQRTX = SQRT(X) Z = (16.D0/(X*SQRTX) - 9.D0)/7.D0 DAIE = (0.28125D0 + DCSEVL (Z, AIP1CS, NAIP1))/SQRT(SQRTX) return 40 SQRTX = SQRT(X) Z = -1.0D0 if (X < XBIG) Z = 16.0D0/(X*SQRTX) - 1.0D0 DAIE = (0.28125D0 + DCSEVL (Z, AIP2CS, NAIP2))/SQRT(SQRTX) return end function dai ( x ) !*****************************************************************************80 ! !! DAI evaluates the Airy function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10D !***TYPE DOUBLE PRECISION (AI-S, DAI-D) !***KEYWORDS AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DAI(X) calculates the double precision Airy function for double ! precision argument X. ! ! Series for AIF on the interval -1.00000E+00 to 1.00000E+00 ! with weighted error 8.37E-33 ! log weighted error 32.08 ! significant figures required 30.87 ! decimal places required 32.63 ! ! Series for AIG on the interval -1.00000E+00 to 1.00000E+00 ! with weighted error 7.47E-34 ! log weighted error 33.13 ! significant figures required 31.50 ! decimal places required 33.68 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9AIMP, DAIE, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE DAI implicit none double precision, save, dimension ( 13 ) :: aifcs = (/ & -0.37971358496669997496197089469414D-1, & +0.59191888537263638574319728013777D-1, & +0.98629280577279975365603891044060D-3, & +0.68488438190765667554854830182412D-5, & +0.25942025962194713019489279081403D-7, & +0.61766127740813750329445749697236D-10, & +0.10092454172466117901429556224601D-12, & +0.12014792511179938141288033225333D-15, & +0.10882945588716991878525295466666D-18, & +0.77513772196684887039238400000000D-22, & +0.44548112037175638391466666666666D-25, & +0.21092845231692343466666666666666D-28, & +0.83701735910741333333333333333333D-32 /) double precision, save, dimension ( 13 ) :: aigcs = (/ & +0.18152365581161273011556209957864D-1, & +0.21572563166010755534030638819968D-1, & +0.25678356987483249659052428090133D-3, & +0.14265214119792403898829496921721D-5, & +0.45721149200180426070434097558191D-8, & +0.95251708435647098607392278840592D-11, & +0.13925634605771399051150420686190D-13, & +0.15070999142762379592306991138666D-16, & +0.12559148312567778822703205333333D-19, & +0.83063073770821340343829333333333D-23, & +0.44657538493718567445333333333333D-26, & +0.19900855034518869333333333333333D-29, & +0.74702885256533333333333333333333D-33 /) double precision d1mach double precision dai double precision daie double precision dcsevl logical, save :: first = .true. integer initds integer, save :: naif integer, save :: naig double precision theta double precision x double precision, save :: x3sml double precision xm double precision, save :: xmax double precision xmaxt double precision z !***FIRST EXECUTABLE STATEMENT DAI if ( first ) then naif = initds ( aifcs, 13, 0.1 * real ( d1mach(3) ) ) naig = initds ( aigcs, 13, 0.1 * real ( d1mach(3) ) ) x3sml = d1mach(3)**0.3334d0 xmaxt = ( -1.5d0 * log ( d1mach(1) ) )**0.6667d0 xmax = xmaxt - xmaxt * log ( xmaxt ) & / ( 4.0d0 * sqrt ( xmaxt ) + 1.0d0 ) - 0.01d0 first = .false. end if if ( x < -1.0d0 ) then call d9aimp ( x, xm, theta ) dai = xm * cos ( theta ) else if ( x <= 1.0d0 ) then if ( abs ( x ) <= x3sml ) then z = 0.0d0 else z = x**3 end if dai = 0.375d0 + ( dcsevl ( z, aifcs, naif ) & - x * ( 0.25d0 + dcsevl ( z, aigcs, naig ) ) ) else if ( x <= xmax ) then dai = daie ( x ) * exp ( -2.0d0 * x * sqrt ( x ) / 3.0d0 ) else dai = 0.0d0 call xermsg ( 'SLATEC', 'DAI', 'X so big AI underflows', 1, 1 ) end if return end DOUBLE PRECISION FUNCTION DASINH (X) ! !! DASINH computes the arc hyperbolic sine. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE DOUBLE PRECISION (ASINH-S, DASINH-D, CASINH-C) !***KEYWORDS ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB, ! INVERSE HYPERBOLIC SINE !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DASINH(X) calculates the double precision arc hyperbolic ! sine for double precision argument X. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DASINH DOUBLE PRECISION X, ASNHCS(39), ALN2, SQEPS, XMAX, Y, & DCSEVL, D1MACH LOGICAL FIRST SAVE ASNHCS, ALN2, NTERMS, XMAX, SQEPS, FIRST DATA ASNHCS( 1) / -.12820039911738186343372127359268D+0 / DATA ASNHCS( 2) / -.58811761189951767565211757138362D-1 / DATA ASNHCS( 3) / +.47274654322124815640725249756029D-2 / DATA ASNHCS( 4) / -.49383631626536172101360174790273D-3 / DATA ASNHCS( 5) / +.58506207058557412287494835259321D-4 / DATA ASNHCS( 6) / -.74669983289313681354755069217188D-5 / DATA ASNHCS( 7) / +.10011693583558199265966192015812D-5 / DATA ASNHCS( 8) / -.13903543858708333608616472258886D-6 / DATA ASNHCS( 9) / +.19823169483172793547317360237148D-7 / DATA ASNHCS( 10) / -.28847468417848843612747272800317D-8 / DATA ASNHCS( 11) / +.42672965467159937953457514995907D-9 / DATA ASNHCS( 12) / -.63976084654366357868752632309681D-10 / DATA ASNHCS( 13) / +.96991686089064704147878293131179D-11 / DATA ASNHCS( 14) / -.14844276972043770830246658365696D-11 / DATA ASNHCS( 15) / +.22903737939027447988040184378983D-12 / DATA ASNHCS( 16) / -.35588395132732645159978942651310D-13 / DATA ASNHCS( 17) / +.55639694080056789953374539088554D-14 / DATA ASNHCS( 18) / -.87462509599624678045666593520162D-15 / DATA ASNHCS( 19) / +.13815248844526692155868802298129D-15 / DATA ASNHCS( 20) / -.21916688282900363984955142264149D-16 / DATA ASNHCS( 21) / +.34904658524827565638313923706880D-17 / DATA ASNHCS( 22) / -.55785788400895742439630157032106D-18 / DATA ASNHCS( 23) / +.89445146617134012551050882798933D-19 / DATA ASNHCS( 24) / -.14383426346571317305551845239466D-19 / DATA ASNHCS( 25) / +.23191811872169963036326144682666D-20 / DATA ASNHCS( 26) / -.37487007953314343674570604543999D-21 / DATA ASNHCS( 27) / +.60732109822064279404549242880000D-22 / DATA ASNHCS( 28) / -.98599402764633583177370173440000D-23 / DATA ASNHCS( 29) / +.16039217452788496315232638293333D-23 / DATA ASNHCS( 30) / -.26138847350287686596716134399999D-24 / DATA ASNHCS( 31) / +.42670849606857390833358165333333D-25 / DATA ASNHCS( 32) / -.69770217039185243299730773333333D-26 / DATA ASNHCS( 33) / +.11425088336806858659812693333333D-26 / DATA ASNHCS( 34) / -.18735292078860968933021013333333D-27 / DATA ASNHCS( 35) / +.30763584414464922794065920000000D-28 / DATA ASNHCS( 36) / -.50577364031639824787046399999999D-29 / DATA ASNHCS( 37) / +.83250754712689142224213333333333D-30 / DATA ASNHCS( 38) / -.13718457282501044163925333333333D-30 / DATA ASNHCS( 39) / +.22629868426552784104106666666666D-31 / DATA ALN2 / 0.69314718055994530941723212145818D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DASINH if (FIRST) THEN NTERMS = INITDS (ASNHCS, 39, 0.1*REAL(D1MACH(3)) ) SQEPS = SQRT(D1MACH(3)) XMAX = 1.0D0/SQEPS end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 1.0D0) go to 20 ! DASINH = X if (Y > SQEPS) DASINH = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, & ASNHCS, NTERMS) ) return 20 if (Y < XMAX) DASINH = LOG (Y+SQRT(Y*Y+1.D0)) if (Y >= XMAX) DASINH = ALN2 + LOG(Y) DASINH = SIGN (DASINH, X) return ! end DOUBLE PRECISION FUNCTION DASUM (N, DX, INCX) ! !! DASUM sums the magnitudes of the elements of a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A3A !***TYPE DOUBLE PRECISION (SASUM-S, DASUM-D, SCASUM-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, SUM OF MAGNITUDES OF A VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! ! --Output-- ! DASUM double precision result (zero if N <= 0) ! ! Returns sum of magnitudes of double precision DX. ! DASUM = sum from 0 to N-1 of ABS(DX(IX+I*INCX)), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900821 Modified to correct problem with a negative increment. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DASUM DOUBLE PRECISION DX(*) INTEGER I, INCX, IX, M, MP1, N !***FIRST EXECUTABLE STATEMENT DASUM DASUM = 0.0D0 if (N <= 0) RETURN ! if (INCX == 1) GOTO 20 ! ! Code for increment not equal to 1. ! IX = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N DASUM = DASUM + ABS(DX(IX)) IX = IX + INCX 10 CONTINUE return ! ! Code for increment equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 6. ! 20 M = MOD(N,6) if (M == 0) GOTO 40 DO 30 I = 1,M DASUM = DASUM + ABS(DX(I)) 30 CONTINUE if (N < 6) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,6 DASUM = DASUM + ABS(DX(I)) + ABS(DX(I+1)) + ABS(DX(I+2)) + & ABS(DX(I+3)) + ABS(DX(I+4)) + ABS(DX(I+5)) 50 CONTINUE return end subroutine DASYIK (X, FNU, KODE, FLGIK, RA, ARG, IN, Y) ! !! DASYIK is subsidiary to DBESI and DBESK. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (ASYIK-S, DASYIK-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! DASYIK computes Bessel functions I and K ! for arguments X > 0.0 and orders FNU >= 35 ! on FLGIK = 1 and FLGIK = -1 respectively. ! ! INPUT ! ! X - Argument, X > 0.0D0 ! FNU - Order of first Bessel function ! KODE - A parameter to indicate the scaling option ! KODE=1 returns Y(I)= I/SUB(FNU+I-1)/(X), I=1,IN ! or Y(I)= K/SUB(FNU+I-1)/(X), I=1,IN ! on FLGIK = 1.0D0 or FLGIK = -1.0D0 ! KODE=2 returns Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN ! or Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN ! on FLGIK = 1.0D0 or FLGIK = -1.0D0 ! FLGIK - Selection parameter for I or K FUNCTION ! FLGIK = 1.0D0 gives the I function ! FLGIK = -1.0D0 gives the K function ! RA - SQRT(1.+Z*Z), Z=X/FNU ! ARG - Argument of the leading exponential ! IN - Number of functions desired, IN=1 or 2 ! ! OUTPUT ! ! Y - A vector whose first IN components contain the sequence ! ! Abstract **** A double precision routine **** ! DASYIK implements the uniform asymptotic expansion of ! the I and K Bessel functions for FNU >= 35 and real ! X > 0.0D0. The forms are identical except for a change ! in sign of some of the terms. This change in sign is ! accomplished by means of the FLAG FLGIK = 1 or -1. ! !***SEE ALSO DBESI, DBESK !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE DASYIK ! INTEGER IN, J, JN, K, KK, KODE, L DOUBLE PRECISION AK,AP,ARG,C,COEF,CON,ETX,FLGIK,FN,FNU,GLN,RA, & S1, S2, T, TOL, T2, X, Y, Z DOUBLE PRECISION D1MACH DIMENSION Y(*), C(65), CON(2) SAVE CON, C DATA CON(1), CON(2) / & 3.98942280401432678D-01, 1.25331413731550025D+00/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), & C(19), C(20), C(21), C(22), C(23), C(24)/ & -2.08333333333333D-01, 1.25000000000000D-01, & 3.34201388888889D-01, -4.01041666666667D-01, & 7.03125000000000D-02, -1.02581259645062D+00, & 1.84646267361111D+00, -8.91210937500000D-01, & 7.32421875000000D-02, 4.66958442342625D+00, & -1.12070026162230D+01, 8.78912353515625D+00, & -2.36408691406250D+00, 1.12152099609375D-01, & -2.82120725582002D+01, 8.46362176746007D+01, & -9.18182415432400D+01, 4.25349987453885D+01, & -7.36879435947963D+00, 2.27108001708984D-01, & 2.12570130039217D+02, -7.65252468141182D+02, & 1.05999045252800D+03, -6.99579627376133D+02/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ & 2.18190511744212D+02, -2.64914304869516D+01, & 5.72501420974731D-01, -1.91945766231841D+03, & 8.06172218173731D+03, -1.35865500064341D+04, & 1.16553933368645D+04, -5.30564697861340D+03, & 1.20090291321635D+03, -1.08090919788395D+02, & 1.72772750258446D+00, 2.02042913309661D+04, & -9.69805983886375D+04, 1.92547001232532D+05, & -2.03400177280416D+05, 1.22200464983017D+05, & -4.11926549688976D+04, 7.10951430248936D+03, & -4.93915304773088D+02, 6.07404200127348D+00, & -2.42919187900551D+05, 1.31176361466298D+06, & -2.99801591853811D+06, 3.76327129765640D+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), & C(65)/ & -2.81356322658653D+06, 1.26836527332162D+06, & -3.31645172484564D+05, 4.52187689813627D+04, & -2.49983048181121D+03, 2.43805296995561D+01, & 3.28446985307204D+06, -1.97068191184322D+07, & 5.09526024926646D+07, -7.41051482115327D+07, & 6.63445122747290D+07, -3.75671766607634D+07, & 1.32887671664218D+07, -2.78561812808645D+06, & 3.08186404612662D+05, -1.38860897537170D+04, & 1.10017140269247D+02/ !***FIRST EXECUTABLE STATEMENT DASYIK TOL = D1MACH(3) TOL = MAX(TOL,1.0D-15) FN = FNU Z = (3.0D0-FLGIK)/2.0D0 KK = INT(Z) DO 50 JN=1,IN if (JN == 1) go to 10 FN = FN - FLGIK Z = X/FN RA = SQRT(1.0D0+Z*Z) GLN = LOG((1.0D0+RA)/Z) ETX = KODE - 1 T = RA*(1.0D0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN)*FLGIK 10 COEF = EXP(ARG) T = 1.0D0/RA T2 = T*T T = T/FN T = SIGN(T,FLGIK) S2 = 1.0D0 AP = 1.0D0 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 (MAX(ABS(AK),ABS(AP)) < TOL) go to 40 30 CONTINUE 40 CONTINUE T = ABS(T) Y(JN) = S2*COEF*SQRT(T)*CON(KK) 50 CONTINUE return end subroutine DASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW) ! !! DASYJY is subsidiary to DBESJ and DBESY. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (ASYJY-S, DASYJY-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! DASYJY computes Bessel functions J and Y ! for arguments X > 0.0 and orders FNU >= 35.0 ! on FLGJY = 1 and FLGJY = -1 respectively ! ! INPUT ! ! FUNJY - External subroutine JAIRY or YAIRY ! X - Argument, X > 0.0D0 ! FNU - Order of the first Bessel function ! FLGJY - Selection flag ! FLGJY = 1.0D0 gives the J function ! FLGJY = -1.0D0 gives the Y function ! IN - Number of functions desired, IN = 1 or 2 ! ! OUTPUT ! ! Y - A vector whose first IN components contain the sequence ! IFLW - A flag indicating underflow or overflow ! return variables for BESJ only ! WK(1) = 1 - (X/FNU)**2 = W**2 ! WK(2) = SQRT(ABS(WK(1))) ! WK(3) = ABS(WK(2) - ATAN(WK(2))) or ! ABS(LN((1 + WK(2))/(X/FNU)) - WK(2)) ! = ABS((2/3)*ZETA**(3/2)) ! WK(4) = FNU*WK(3) ! WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3) ! WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3) ! WK(7) = FNU**(1/3) ! ! Abstract **** A Double Precision Routine **** ! DASYJY implements the uniform asymptotic expansion of ! the J and Y Bessel functions for FNU >= 35 and real ! X > 0.0D0. The forms are identical except for a change ! in sign of some of the terms. This change in sign is ! accomplished by means of the flag FLGJY = 1 or -1. On ! FLGJY = 1 the Airy functions AI(X) and DAI(X) are ! supplied by the external function JAIRY, and on ! FLGJY = -1 the Airy functions BI(X) and DBI(X) are ! supplied by the external function YAIRY. ! !***SEE ALSO DBESJ, DBESY !***ROUTINES CALLED D1MACH, I1MACH !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891004 Correction computation of ELIM. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE DASYJY INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1, & KSTEMP, L, LR, LRP1, ISETA, ISETB INTEGER I1MACH DOUBLE PRECISION ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ, & BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2, & 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 DOUBLE PRECISION D1MACH 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)) SAVE TOLS, CON1, CON2, CON548, AR, BR, C, & ALFA1, ALFA2, BETA1, BETA2, BETA3, GAMA DATA TOLS /-6.90775527898214D+00/ DATA CON1,CON2,CON548/ & 6.66666666666667D-01, 3.33333333333333D-01, 1.04166666666667D-01/ DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), & AR(8) / 8.35503472222222D-02, 1.28226574556327D-01, & 2.91849026464140D-01, 8.81627267443758D-01, 3.32140828186277D+00, & 1.49957629868626D+01, 7.89230130115865D+01, 4.74451538868264D+02/ DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), & BR(9), BR(10) /-1.45833333333333D-01,-9.87413194444444D-02, & -1.43312053915895D-01,-3.17227202678414D-01,-9.42429147957120D-01, & -3.51120304082635D+00,-1.57272636203680D+01,-8.22814390971859D+01, & -4.92355370523671D+02,-3.31621856854797D+03/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), & C(19), C(20), C(21), C(22), C(23), C(24)/ & -2.08333333333333D-01, 1.25000000000000D-01, & 3.34201388888889D-01, -4.01041666666667D-01, & 7.03125000000000D-02, -1.02581259645062D+00, & 1.84646267361111D+00, -8.91210937500000D-01, & 7.32421875000000D-02, 4.66958442342625D+00, & -1.12070026162230D+01, 8.78912353515625D+00, & -2.36408691406250D+00, 1.12152099609375D-01, & -2.82120725582002D+01, 8.46362176746007D+01, & -9.18182415432400D+01, 4.25349987453885D+01, & -7.36879435947963D+00, 2.27108001708984D-01, & 2.12570130039217D+02, -7.65252468141182D+02, & 1.05999045252800D+03, -6.99579627376133D+02/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ & 2.18190511744212D+02, -2.64914304869516D+01, & 5.72501420974731D-01, -1.91945766231841D+03, & 8.06172218173731D+03, -1.35865500064341D+04, & 1.16553933368645D+04, -5.30564697861340D+03, & 1.20090291321635D+03, -1.08090919788395D+02, & 1.72772750258446D+00, 2.02042913309661D+04, & -9.69805983886375D+04, 1.92547001232532D+05, & -2.03400177280416D+05, 1.22200464983017D+05, & -4.11926549688976D+04, 7.10951430248936D+03, & -4.93915304773088D+02, 6.07404200127348D+00, & -2.42919187900551D+05, 1.31176361466298D+06, & -2.99801591853811D+06, 3.76327129765640D+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), & C(65)/ & -2.81356322658653D+06, 1.26836527332162D+06, & -3.31645172484564D+05, 4.52187689813627D+04, & -2.49983048181121D+03, 2.43805296995561D+01, & 3.28446985307204D+06, -1.97068191184322D+07, & 5.09526024926646D+07, -7.41051482115327D+07, & 6.63445122747290D+07, -3.75671766607634D+07, & 1.32887671664218D+07, -2.78561812808645D+06, & 3.08186404612662D+05, -1.38860897537170D+04, & 1.10017140269247D+02/ DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1), & ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1), & ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1), & ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1), & ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1), & ALFA1(26,1) /-4.44444444444444D-03,-9.22077922077922D-04, & -8.84892884892885D-05, 1.65927687832450D-04, 2.46691372741793D-04, & 2.65995589346255D-04, 2.61824297061501D-04, 2.48730437344656D-04, & 2.32721040083232D-04, 2.16362485712365D-04, 2.00738858762752D-04, & 1.86267636637545D-04, 1.73060775917876D-04, 1.61091705929016D-04, & 1.50274774160908D-04, 1.40503497391270D-04, 1.31668816545923D-04, & 1.23667445598253D-04, 1.16405271474738D-04, 1.09798298372713D-04, & 1.03772410422993D-04, 9.82626078369363D-05, 9.32120517249503D-05, & 8.85710852478712D-05, 8.42963105715700D-05, 8.03497548407791D-05/ DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2), & ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2), & ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2), & ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2), & ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2), & ALFA1(26,2) / 6.93735541354589D-04, 2.32241745182922D-04, & -1.41986273556691D-05,-1.16444931672049D-04,-1.50803558053049D-04, & -1.55121924918096D-04,-1.46809756646466D-04,-1.33815503867491D-04, & -1.19744975684254D-04,-1.06184319207974D-04,-9.37699549891194D-05, & -8.26923045588193D-05,-7.29374348155221D-05,-6.44042357721016D-05, & -5.69611566009369D-05,-5.04731044303562D-05,-4.48134868008883D-05, & -3.98688727717599D-05,-3.55400532972042D-05,-3.17414256609022D-05, & -2.83996793904175D-05,-2.54522720634871D-05,-2.28459297164725D-05, & -2.05352753106481D-05,-1.84816217627666D-05,-1.66519330021394D-05/ DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1), & ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1), & ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1), & ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1), & ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1), & ALFA2(26,1) /-3.54211971457744D-04,-1.56161263945159D-04, & 3.04465503594936D-05, 1.30198655773243D-04, 1.67471106699712D-04, & 1.70222587683593D-04, 1.56501427608595D-04, 1.36339170977445D-04, & 1.14886692029825D-04, 9.45869093034688D-05, 7.64498419250898D-05, & 6.07570334965197D-05, 4.74394299290509D-05, 3.62757512005344D-05, & 2.69939714979225D-05, 1.93210938247939D-05, 1.30056674793963D-05, & 7.82620866744497D-06, 3.59257485819352D-06, 1.44040049814252D-07, & -2.65396769697939D-06,-4.91346867098486D-06,-6.72739296091248D-06, & -8.17269379678658D-06,-9.31304715093561D-06,-1.02011418798016D-05/ DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2), & ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2), & ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2), & ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2), & ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2), & ALFA2(26,2) / 3.78194199201773D-04, 2.02471952761816D-04, & -6.37938506318862D-05,-2.38598230603006D-04,-3.10916256027362D-04, & -3.13680115247576D-04,-2.78950273791323D-04,-2.28564082619141D-04, & -1.75245280340847D-04,-1.25544063060690D-04,-8.22982872820208D-05, & -4.62860730588116D-05,-1.72334302366962D-05, 5.60690482304602D-06, & 2.31395443148287D-05, 3.62642745856794D-05, 4.58006124490189D-05, & 5.24595294959114D-05, 5.68396208545815D-05, 5.94349820393104D-05, & 6.06478527578422D-05, 6.08023907788436D-05, 6.01577894539460D-05, & 5.89199657344698D-05, 5.72515823777593D-05, 5.52804375585853D-05/ DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1), & BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1), & BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1), & BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1), & BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1), & BETA1(26,1) / 1.79988721413553D-02, 5.59964911064388D-03, & 2.88501402231133D-03, 1.80096606761054D-03, 1.24753110589199D-03, & 9.22878876572938D-04, 7.14430421727287D-04, 5.71787281789705D-04, & 4.69431007606482D-04, 3.93232835462917D-04, 3.34818889318298D-04, & 2.88952148495752D-04, 2.52211615549573D-04, 2.22280580798883D-04, & 1.97541838033063D-04, 1.76836855019718D-04, 1.59316899661821D-04, & 1.44347930197334D-04, 1.31448068119965D-04, 1.20245444949303D-04, & 1.10449144504599D-04, 1.01828770740567D-04, 9.41998224204238D-05, & 8.74130545753834D-05, 8.13466262162801D-05, 7.59002269646219D-05/ DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2), & BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2), & BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2), & BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2), & BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2), & BETA1(26,2) /-1.49282953213429D-03,-8.78204709546389D-04, & -5.02916549572035D-04,-2.94822138512746D-04,-1.75463996970783D-04, & -1.04008550460816D-04,-5.96141953046458D-05,-3.12038929076098D-05, & -1.26089735980230D-05,-2.42892608575730D-07, 8.05996165414274D-06, & 1.36507009262147D-05, 1.73964125472926D-05, 1.98672978842134D-05, & 2.14463263790823D-05, 2.23954659232457D-05, 2.28967783814713D-05, & 2.30785389811178D-05, 2.30321976080909D-05, 2.28236073720349D-05, & 2.25005881105292D-05, 2.20981015361991D-05, 2.16418427448104D-05, & 2.11507649256221D-05, 2.06388749782171D-05, 2.01165241997082D-05/ DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1), & BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1), & BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1), & BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1), & BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1), & BETA2(26,1) / 5.52213076721293D-04, 4.47932581552385D-04, & 2.79520653992021D-04, 1.52468156198447D-04, 6.93271105657044D-05, & 1.76258683069991D-05,-1.35744996343269D-05,-3.17972413350427D-05, & -4.18861861696693D-05,-4.69004889379141D-05,-4.87665447413787D-05, & -4.87010031186735D-05,-4.74755620890087D-05,-4.55813058138628D-05, & -4.33309644511266D-05,-4.09230193157750D-05,-3.84822638603221D-05, & -3.60857167535411D-05,-3.37793306123367D-05,-3.15888560772110D-05, & -2.95269561750807D-05,-2.75978914828336D-05,-2.58006174666884D-05, & -2.41308356761280D-05,-2.25823509518346D-05,-2.11479656768913D-05/ DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2), & BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2), & BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2), & BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2), & BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2), & BETA2(26,2) /-4.74617796559960D-04,-4.77864567147321D-04, & -3.20390228067038D-04,-1.61105016119962D-04,-4.25778101285435D-05, & 3.44571294294968D-05, 7.97092684075675D-05, 1.03138236708272D-04, & 1.12466775262204D-04, 1.13103642108481D-04, 1.08651634848774D-04, & 1.01437951597662D-04, 9.29298396593364D-05, 8.40293133016090D-05, & 7.52727991349134D-05, 6.69632521975731D-05, 5.92564547323195D-05, & 5.22169308826976D-05, 4.58539485165361D-05, 4.01445513891487D-05, & 3.50481730031328D-05, 3.05157995034347D-05, 2.64956119950516D-05, & 2.29363633690998D-05, 1.97893056664022D-05, 1.70091984636413D-05/ DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1), & BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1), & BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1), & BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1), & BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1), & BETA3(26,1) / 7.36465810572578D-04, 8.72790805146194D-04, & 6.22614862573135D-04, 2.85998154194304D-04, 3.84737672879366D-06, & -1.87906003636972D-04,-2.97603646594555D-04,-3.45998126832656D-04, & -3.53382470916038D-04,-3.35715635775049D-04,-3.04321124789040D-04, & -2.66722723047613D-04,-2.27654214122820D-04,-1.89922611854562D-04, & -1.55058918599094D-04,-1.23778240761874D-04,-9.62926147717644D-05, & -7.25178327714425D-05,-5.22070028895634D-05,-3.50347750511901D-05, & -2.06489761035552D-05,-8.70106096849767D-06, 1.13698686675100D-06, & 9.16426474122779D-06, 1.56477785428873D-05, 2.08223629482467D-05/ DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), & GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), & GAMA(11), GAMA(12), GAMA(13), GAMA(14), GAMA(15), & GAMA(16), GAMA(17), GAMA(18), GAMA(19), GAMA(20), & GAMA(21), GAMA(22), GAMA(23), GAMA(24), GAMA(25), & GAMA(26) / 6.29960524947437D-01, 2.51984209978975D-01, & 1.54790300415656D-01, 1.10713062416159D-01, 8.57309395527395D-02, & 6.97161316958684D-02, 5.86085671893714D-02, 5.04698873536311D-02, & 4.42600580689155D-02, 3.93720661543510D-02, 3.54283195924455D-02, & 3.21818857502098D-02, 2.94646240791158D-02, 2.71581677112934D-02, & 2.51768272973862D-02, 2.34570755306079D-02, 2.19508390134907D-02, & 2.06210828235646D-02, 1.94388240897881D-02, 1.83810633800683D-02, & 1.74293213231963D-02, 1.65685837786612D-02, 1.57865285987918D-02, & 1.50729501494096D-02, 1.44193250839955D-02, 1.38184805735342D-02/ !***FIRST EXECUTABLE STATEMENT DASYJY TA = D1MACH(3) TOL = MAX(TA,1.0D-15) TB = D1MACH(5) JU = I1MACH(15) if ( FLGJY == 1.0D0) go to 6 JR = I1MACH(14) ELIM = -2.303D0*TB*(JU+JR) go to 7 6 CONTINUE ELIM = -2.303D0*(TB*JU+3.0D0) 7 CONTINUE FN = FNU IFLW = 0 DO 170 JN=1,IN XX = X/FN WK(1) = 1.0D0 - XX*XX ABW2 = ABS(WK(1)) WK(2) = SQRT(ABW2) WK(7) = FN**CON2 if (ABW2 > 0.27750D0) go to 80 ! ! ASYMPTOTIC EXPANSION ! CASES NEAR X=FN, ABS(1.-(X/FN)**2) <= 0.2775 ! COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES ! ! ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES ! ! KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA) ! SA = 0.0D0 if (ABW2 == 0.0D0) go to 10 SA = TOLS/LOG(ABW2) 10 SB = SA DO 20 I=1,5 AKM = MAX(SA,2.0D0) 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 <= 0.0D0) go to 35 if ( WK(4) > ELIM) go to 75 WK(6) = -WK(6) 35 CONTINUE PHI = SQRT(SQRT(SA+SA+SA+SA)) ! ! B(ZETA) FOR S=0 ! 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.0D0/FN2 RDEN = 1.0D0 ASUM = 1.0D0 RELB = TOL*ABS(SB) BSUM = SB DO 60 KS=1,4 KSP1 = KSP1 + 1 RDEN = RDEN*RFN2 ! ! A(ZETA) AND B(ZETA) FOR S=1,2,3,4 ! 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) <= TOL .AND. ABS(TB) <= RELB) go to 70 60 CONTINUE 70 CONTINUE BSUM = BSUM/(FN*WK(7)) go to 160 ! 75 CONTINUE IFLW = 1 return ! 80 CONTINUE UPOL(1) = 1.0D0 TAU = 1.0D0/WK(2) T2 = 1.0D0/WK(1) if (WK(1) >= 0.0D0) go to 90 ! ! CASES FOR (X/FN) > SQRT(1.2775) ! WK(3) = ABS(WK(2)-ATAN(WK(2))) WK(4) = WK(3)*FN RCZ = -CON1/WK(4) Z32 = 1.5D0*WK(3) RTZ = Z32**CON2 WK(5) = RTZ*WK(7) WK(6) = -WK(5)*WK(5) go to 100 90 CONTINUE ! ! CASES FOR (X/FN) < SQRT(0.7225) ! WK(3) = ABS(LOG((1.0D0+WK(2))/XX)-WK(2)) WK(4) = WK(3)*FN RCZ = CON1/WK(4) if ( WK(4) > ELIM) go to 75 Z32 = 1.5D0*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.0D0 ASUM = 1.0D0 TFN = TAU/FN RDEN=1.0D0/FN RFN2=RDEN*RDEN RDEN=1.0D0 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 ISETA=0 ISETB=0 DO 140 LR=2,8,2 ! ! COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA) ! 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 RDEN=RDEN*RFN2 TB = -TB if (WK(1) > 0.0D0) TB = ABS(TB) if ( RDEN < TOL) go to 131 ASUM = ASUM + SUMA*TB BSUM = BSUM + SUMB*TB go to 140 131 if ( ISETA == 1) go to 132 if ( ABS(SUMA) < TOL) ISETA=1 ASUM=ASUM+SUMA*TB 132 if ( ISETB == 1) go to 133 if ( ABS(SUMB) < RELB) ISETB=1 BSUM=BSUM+SUMB*TB 133 if ( ISETA == 1 .AND. ISETB == 1) go to 150 140 CONTINUE 150 TB = WK(5) if (WK(1) > 0.0D0) TB = -TB BSUM = BSUM/TB ! 160 CONTINUE call FUNJY(WK(6), WK(5), WK(4), FI, DFI) TA=1.0D0/TOL TB=D1MACH(1)*TA*1.0D+3 if ( ABS(FI) > TB) go to 165 FI=FI*TA DFI=DFI*TA PHI=PHI*TOL 165 CONTINUE Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7) FN = FN - FLGJY 170 CONTINUE return end DOUBLE PRECISION FUNCTION DATANH (X) ! !! DATANH computes the arc hyperbolic tangent. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4C !***TYPE DOUBLE PRECISION (ATANH-S, DATANH-D, CATANH-C) !***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, ! FNLIB, INVERSE HYPERBOLIC TANGENT !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DATANH(X) calculates the double precision arc hyperbolic ! tangent for double precision argument X. ! ! Series for ATNH on the interval 0. to 2.50000E-01 ! with weighted error 6.86E-32 ! log weighted error 31.16 ! significant figures required 30.00 ! decimal places required 31.88 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DATANH DOUBLE PRECISION X, ATNHCS(27), DXREL, SQEPS, Y, DCSEVL, D1MACH LOGICAL FIRST SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST DATA ATNHCS( 1) / +.9439510239319549230842892218633D-1 / DATA ATNHCS( 2) / +.4919843705578615947200034576668D-1 / DATA ATNHCS( 3) / +.2102593522455432763479327331752D-2 / DATA ATNHCS( 4) / +.1073554449776116584640731045276D-3 / DATA ATNHCS( 5) / +.5978267249293031478642787517872D-5 / DATA ATNHCS( 6) / +.3505062030889134845966834886200D-6 / DATA ATNHCS( 7) / +.2126374343765340350896219314431D-7 / DATA ATNHCS( 8) / +.1321694535715527192129801723055D-8 / DATA ATNHCS( 9) / +.8365875501178070364623604052959D-10 / DATA ATNHCS( 10) / +.5370503749311002163881434587772D-11 / DATA ATNHCS( 11) / +.3486659470157107922971245784290D-12 / DATA ATNHCS( 12) / +.2284549509603433015524024119722D-13 / DATA ATNHCS( 13) / +.1508407105944793044874229067558D-14 / DATA ATNHCS( 14) / +.1002418816804109126136995722837D-15 / DATA ATNHCS( 15) / +.6698674738165069539715526882986D-17 / DATA ATNHCS( 16) / +.4497954546494931083083327624533D-18 / DATA ATNHCS( 17) / +.3032954474279453541682367146666D-19 / DATA ATNHCS( 18) / +.2052702064190936826463861418666D-20 / DATA ATNHCS( 19) / +.1393848977053837713193014613333D-21 / DATA ATNHCS( 20) / +.9492580637224576971958954666666D-23 / DATA ATNHCS( 21) / +.6481915448242307604982442666666D-24 / DATA ATNHCS( 22) / +.4436730205723615272632320000000D-25 / DATA ATNHCS( 23) / +.3043465618543161638912000000000D-26 / DATA ATNHCS( 24) / +.2091881298792393474047999999999D-27 / DATA ATNHCS( 25) / +.1440445411234050561365333333333D-28 / DATA ATNHCS( 26) / +.9935374683141640465066666666666D-30 / DATA ATNHCS( 27) / +.6863462444358260053333333333333D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DATANH if (FIRST) THEN NTERMS = INITDS (ATNHCS, 27, 0.1*REAL(D1MACH(3)) ) DXREL = SQRT(D1MACH(4)) SQEPS = SQRT(3.0D0*D1MACH(3)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y >= 1.D0) call XERMSG ('SLATEC', 'DATANH', 'ABS(X) GE 1', & 2, 2) ! if (1.D0-Y < DXREL) call XERMSG ('SLATEC', 'DATANH', & 'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1) ! DATANH = X if (Y > SQEPS .AND. Y <= 0.5D0) DATANH = X*(1.0D0 + & DCSEVL (8.D0*X*X-1.D0, ATNHCS, NTERMS) ) if (Y > 0.5D0) DATANH = 0.5D0*LOG ((1.0D0+X)/(1.0D0-X)) ! return end subroutine DAVINT (X, Y, N, XLO, XUP, ANS, IERR) ! !! DAVINT integrates a function tabulated at arbitrarily spaced abscissas... ! using overlapping parabolas. ! !***LIBRARY SLATEC !***CATEGORY H2A1B2 !***TYPE DOUBLE PRECISION (AVINT-S, DAVINT-D) !***KEYWORDS INTEGRATION, QUADRATURE, TABULATED DATA !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! DAVINT integrates a function tabulated at arbitrarily spaced ! abscissas. The limits of integration need not coincide ! with the tabulated abscissas. ! ! A method of overlapping parabolas fitted to the data is used ! provided that there are at least 3 abscissas between the ! limits of integration. DAVINT also handles two special cases. ! If the limits of integration are equal, DAVINT returns a ! result of zero regardless of the number of tabulated values. ! If there are only two function values, DAVINT uses the ! trapezoid rule. ! ! Description of Parameters ! The user must dimension all arrays appearing in the call list ! X(N), Y(N) ! ! Input-- ! X - DOUBLE PRECISION array of abscissas, which must be in ! increasing order. ! Y - DOUBLE PRECISION array of function values. i.e., ! Y(I)=FUNC(X(I)) ! N - The integer number of function values supplied. ! N >= 2 unless XLO = XUP. ! XLO - DOUBLE PRECISION lower limit of integration ! XUP - DOUBLE PRECISION upper limit of integration. Must have ! XLO <= XUP ! ! Output-- ! ANS - Double Precision computed approximate value of integral ! IERR - A status code ! --Normal Code ! =1 Means the requested integration was performed. ! --Abnormal Codes ! =2 Means XUP was less than XLO. ! =3 Means the number of X(I) between XLO and XUP ! (inclusive) was less than 3 and neither of the two ! special cases described in the abstract occurred. ! No integration was performed. ! =4 Means the restriction X(I+1) > X(I) was violated. ! =5 Means the number N of function values was .lt. 2. ! ANS is set to zero if IERR=2,3,4,or 5. ! ! DAVINT is documented completely in SC-M-69-335 ! Original program from *Numerical Integration* by Davis & Rabinowitz ! Adaptation and modifications by Rondall E Jones. ! !***REFERENCES R. E. Jones, Approximate integrator of functions ! tabulated at arbitrarily spaced abscissas, ! Report SC-M-69-335, Sandia Laboratories, 1969. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 690901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DAVINT ! INTEGER I, IERR, INLFT, INRT, ISTART, ISTOP, N DOUBLE PRECISION A, ANS, B, C, CA, CB, CC, FL, FR, R3, RP5, & SLOPE, SUM, SYL, SYL2, SYL3, SYU, SYU2, SYU3, TERM1, TERM2, & TERM3, X, X1, X12, X13, X2, X23, X3, XLO, XUP, Y DIMENSION X(*),Y(*) ! BEGIN BLOCK PERMITTING ...EXITS TO 190 ! BEGIN BLOCK PERMITTING ...EXITS TO 180 !***FIRST EXECUTABLE STATEMENT DAVINT IERR = 1 ANS = 0.0D0 if (XLO > XUP) go to 160 if (XLO == XUP) go to 150 if (N >= 2) go to 10 IERR = 5 call XERMSG ('SLATEC', 'DAVINT', & 'LESS THAN TWO FUNCTION VALUES WERE SUPPLIED.', & 4, 1) ! ...............EXIT go to 190 10 CONTINUE DO 20 I = 2, N ! ............EXIT if (X(I) <= X(I-1)) go to 180 ! ...EXIT if (X(I) > XUP) go to 30 20 CONTINUE 30 CONTINUE if (N >= 3) go to 40 ! ! SPECIAL N=2 CASE SLOPE = (Y(2) - Y(1))/(X(2) - X(1)) FL = Y(1) + SLOPE*(XLO - X(1)) FR = Y(2) + SLOPE*(XUP - X(2)) ANS = 0.5D0*(FL + FR)*(XUP - XLO) ! ...............EXIT go to 190 40 CONTINUE if (X(N-2) >= XLO) go to 50 IERR = 3 call XERMSG ('SLATEC', 'DAVINT', & 'THERE WERE LESS THAN THREE FUNCTION VALUES ' // & 'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1) ! ...............EXIT go to 190 50 CONTINUE if (X(3) <= XUP) go to 60 IERR = 3 call XERMSG ('SLATEC', 'DAVINT', & 'THERE WERE LESS THAN THREE FUNCTION VALUES ' // & 'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1) ! ...............EXIT go to 190 60 CONTINUE I = 1 70 if (X(I) >= XLO) go to 80 I = I + 1 go to 70 80 CONTINUE INLFT = I I = N 90 if (X(I) <= XUP) go to 100 I = I - 1 go to 90 100 CONTINUE INRT = I if ((INRT - INLFT) >= 2) go to 110 IERR = 3 call XERMSG ('SLATEC', 'DAVINT', & 'THERE WERE LESS THAN THREE FUNCTION VALUES ' // & 'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1) ! ...............EXIT go to 190 110 CONTINUE ISTART = INLFT if (INLFT == 1) ISTART = 2 ISTOP = INRT if (INRT == N) ISTOP = N - 1 ! R3 = 3.0D0 RP5 = 0.5D0 SUM = 0.0D0 SYL = XLO SYL2 = SYL*SYL SYL3 = SYL2*SYL ! DO 140 I = ISTART, ISTOP X1 = X(I-1) X2 = X(I) X3 = X(I+1) X12 = X1 - X2 X13 = X1 - X3 X23 = X2 - X3 TERM1 = Y(I-1)/(X12*X13) TERM2 = -Y(I)/(X12*X23) TERM3 = Y(I+1)/(X13*X23) A = TERM1 + TERM2 + TERM3 B = -(X2 + X3)*TERM1 - (X1 + X3)*TERM2 & - (X1 + X2)*TERM3 C = X2*X3*TERM1 + X1*X3*TERM2 + X1*X2*TERM3 if (I > ISTART) go to 120 CA = A CB = B CC = C go to 130 120 CONTINUE CA = 0.5D0*(A + CA) CB = 0.5D0*(B + CB) CC = 0.5D0*(C + CC) 130 CONTINUE SYU = X2 SYU2 = SYU*SYU SYU3 = SYU2*SYU SUM = SUM + CA*(SYU3 - SYL3)/R3 & + CB*RP5*(SYU2 - SYL2) + CC*(SYU - SYL) CA = A CB = B CC = C SYL = SYU SYL2 = SYU2 SYL3 = SYU3 140 CONTINUE SYU = XUP ANS = SUM + CA*(SYU**3 - SYL3)/R3 & + CB*RP5*(SYU**2 - SYL2) + CC*(SYU - SYL) 150 CONTINUE go to 170 160 CONTINUE IERR = 2 call XERMSG ('SLATEC', 'DAVINT', & 'THE UPPER LIMIT OF INTEGRATION WAS NOT GREATER ' // & 'THAN THE LOWER LIMIT.', 4, 1) 170 CONTINUE ! ......EXIT go to 190 180 CONTINUE IERR = 4 call XERMSG ('SLATEC', 'DAVINT', & 'THE ABSCISSAS WERE NOT STRICTLY INCREASING. MUST HAVE ' // & 'X(I-1) < X(I) FOR ALL I.', 4, 1) 190 CONTINUE return end function DAWS (X) ! !! DAWS computes Dawson's function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C8C !***TYPE SINGLE PRECISION (DAWS-S, DDAWS-D) !***KEYWORDS DAWSON'S FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DAWS(X) calculates Dawson's integral for real argument X. ! ! Series for DAW on the interval 0. to 1.00000D+00 ! with weighted error 3.83E-17 ! log weighted error 16.42 ! significant figures required 15.78 ! decimal places required 16.97 ! ! Series for DAW2 on the interval 0. to 1.60000D+01 ! with weighted error 5.17E-17 ! log weighted error 16.29 ! significant figures required 15.90 ! decimal places required 17.02 ! ! Series for DAWA on the interval 0. to 6.25000D-02 ! with weighted error 2.24E-17 ! log weighted error 16.65 ! significant figures required 14.73 ! decimal places required 17.36 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 780401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE DAWS DIMENSION DAWCS(13), DAW2CS(29), DAWACS(26) LOGICAL FIRST SAVE DAWCS, DAW2CS, DAWACS, NTDAW, NTDAW2, NTDAWA, & XSML, XBIG, XMAX, FIRST DATA DAWCS( 1) / -.006351734375145949E0 / DATA DAWCS( 2) / -.22940714796773869E0 / DATA DAWCS( 3) / .022130500939084764E0 / DATA DAWCS( 4) / -.001549265453892985E0 / DATA DAWCS( 5) / .000084973277156849E0 / DATA DAWCS( 6) / -.000003828266270972E0 / DATA DAWCS( 7) / .000000146285480625E0 / DATA DAWCS( 8) / -.000000004851982381E0 / DATA DAWCS( 9) / .000000000142146357E0 / DATA DAWCS(10) / -.000000000003728836E0 / DATA DAWCS(11) / .000000000000088549E0 / DATA DAWCS(12) / -.000000000000001920E0 / DATA DAWCS(13) / .000000000000000038E0 / DATA DAW2CS( 1) / -.056886544105215527E0 / DATA DAW2CS( 2) / -.31811346996168131E0 / DATA DAW2CS( 3) / .20873845413642237E0 / DATA DAW2CS( 4) / -.12475409913779131E0 / DATA DAW2CS( 5) / .067869305186676777E0 / DATA DAW2CS( 6) / -.033659144895270940E0 / DATA DAW2CS( 7) / .015260781271987972E0 / DATA DAW2CS( 8) / -.006348370962596214E0 / DATA DAW2CS( 9) / .002432674092074852E0 / DATA DAW2CS(10) / -.000862195414910650E0 / DATA DAW2CS(11) / .000283765733363216E0 / DATA DAW2CS(12) / -.000087057549874170E0 / DATA DAW2CS(13) / .000024986849985481E0 / DATA DAW2CS(14) / -.000006731928676416E0 / DATA DAW2CS(15) / .000001707857878557E0 / DATA DAW2CS(16) / -.000000409175512264E0 / DATA DAW2CS(17) / .000000092828292216E0 / DATA DAW2CS(18) / -.000000019991403610E0 / DATA DAW2CS(19) / .000000004096349064E0 / DATA DAW2CS(20) / -.000000000800324095E0 / DATA DAW2CS(21) / .000000000149385031E0 / DATA DAW2CS(22) / -.000000000026687999E0 / DATA DAW2CS(23) / .000000000004571221E0 / DATA DAW2CS(24) / -.000000000000751873E0 / DATA DAW2CS(25) / .000000000000118931E0 / DATA DAW2CS(26) / -.000000000000018116E0 / DATA DAW2CS(27) / .000000000000002661E0 / DATA DAW2CS(28) / -.000000000000000377E0 / DATA DAW2CS(29) / .000000000000000051E0 / DATA DAWACS( 1) / .01690485637765704E0 / DATA DAWACS( 2) / .00868325227840695E0 / DATA DAWACS( 3) / .00024248640424177E0 / DATA DAWACS( 4) / .00001261182399572E0 / DATA DAWACS( 5) / .00000106645331463E0 / DATA DAWACS( 6) / .00000013581597947E0 / DATA DAWACS( 7) / .00000002171042356E0 / DATA DAWACS( 8) / .00000000286701050E0 / DATA DAWACS( 9) / -.00000000019013363E0 / DATA DAWACS(10) / -.00000000030977804E0 / DATA DAWACS(11) / -.00000000010294148E0 / DATA DAWACS(12) / -.00000000000626035E0 / DATA DAWACS(13) / .00000000000856313E0 / DATA DAWACS(14) / .00000000000303304E0 / DATA DAWACS(15) / -.00000000000025236E0 / DATA DAWACS(16) / -.00000000000042106E0 / DATA DAWACS(17) / -.00000000000004431E0 / DATA DAWACS(18) / .00000000000004911E0 / DATA DAWACS(19) / .00000000000001235E0 / DATA DAWACS(20) / -.00000000000000578E0 / DATA DAWACS(21) / -.00000000000000228E0 / DATA DAWACS(22) / .00000000000000076E0 / DATA DAWACS(23) / .00000000000000038E0 / DATA DAWACS(24) / -.00000000000000011E0 / DATA DAWACS(25) / -.00000000000000006E0 / DATA DAWACS(26) / .00000000000000002E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DAWS if (FIRST) THEN EPS = R1MACH(3) NTDAW = INITS (DAWCS, 13, 0.1*EPS) NTDAW2 = INITS (DAW2CS, 29, 0.1*EPS) NTDAWA = INITS (DAWACS, 26, 0.1*EPS) ! XSML = SQRT (1.5*EPS) XBIG = SQRT (0.5/EPS) XMAX = EXP (MIN (-LOG(2.*R1MACH(1)), LOG(R1MACH(2))) - 1.0) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 1.0) go to 20 ! DAWS = X if (Y <= XSML) RETURN ! DAWS = X * (0.75 + CSEVL (2.0*Y*Y-1.0, DAWCS, NTDAW)) return ! 20 if (Y > 4.0) go to 30 DAWS = X * (0.25 + CSEVL (0.125*Y*Y-1.0, DAW2CS, NTDAW2)) return ! 30 if (Y > XMAX) go to 40 DAWS = 0.5/X if (Y > XBIG) RETURN ! DAWS = (0.5 + CSEVL (32.0/Y**2-1.0, DAWACS, NTDAWA)) / X return ! 40 call XERMSG ('SLATEC', 'DAWS', 'ABS(X) SO LARGE DAWS UNDERFLOWS', & 1, 1) DAWS = 0.0 return ! end subroutine DAXPY (N, DA, DX, INCX, DY, INCY) ! !! DAXPY computes a constant times a vector plus a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A7 !***TYPE DOUBLE PRECISION (SAXPY-S, DAXPY-D, CAXPY-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, TRIAD, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! DA double precision scalar multiplier ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! DY double precision vector with N elements ! INCY storage spacing between elements of DY ! ! --Output-- ! DY double precision result (unchanged if N <= 0) ! ! Overwrite double precision DY with double precision DA*DX + DY. ! For I = 0 to N-1, replace DY(LY+I*INCY) with DA*DX(LX+I*INCX) + ! DY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DAXPY DOUBLE PRECISION DX(*), DY(*), DA !***FIRST EXECUTABLE STATEMENT DAXPY if (N <= 0 .OR. DA == 0.0D0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IX = 1 IY = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 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 ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 4. ! 20 M = MOD(N,4) if (M == 0) go to 40 DO 30 I = 1,M DY(I) = DY(I) + DA*DX(I) 30 CONTINUE if (N < 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 ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX DY(I) = DA*DX(I) + DY(I) 70 CONTINUE return end subroutine DBCG (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, & MSOLVE, MTSOLV, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, & P, RR, ZZ, PP, DZ, RWORK, IWORK) ! !! DBCG: Preconditioned BiConjugate Gradient Sparse Ax = b Solver. ! Routine to solve a Non-Symmetric linear system Ax = b ! using the Preconditioned BiConjugate Gradient method. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SBCG-S, DBCG-D) !***KEYWORDS BICONJUGATE GRADIENT, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), P(N) ! DOUBLE PRECISION RR(N), ZZ(N), PP(N), DZ(N) ! DOUBLE PRECISION RWORK(USER DEFINED) ! EXTERNAL MATVEC, MTTVEC, MSOLVE, MTSOLV ! ! call DBCG(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, ! $ MSOLVE, MTSOLV, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, ! $ R, Z, P, RR, ZZ, PP, DZ, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, for more ! details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! operation Y = A*X given A and X. The name of the MATVEC ! routine must be declared external in the calling program. ! The calling sequence of MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X upon ! return, X is an input vector. NELT, IA, JA, A and ISYM ! define the SLAP matrix data structure: see Description,below. ! MTTVEC :EXT External. ! Name of a routine which performs the matrix transpose vector ! multiply y = A'*X given A and X (where ' denotes transpose). ! The name of the MTTVEC routine must be declared external in ! the calling program. The calling sequence to MTTVEC is the ! same as that for MTTVEC, viz.: ! call MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A'*X ! upon return, X is an input vector. NELT, IA, JA, A and ISYM ! define the SLAP matrix data structure: see Description,below. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for Z ! given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine ! must be declared external in the calling program. The ! calling sequence of MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector, and Z is the solution upon return. NELT, IA, JA, A ! and ISYM define the SLAP matrix data structure: see ! Description, below. RWORK is a double precision array that ! can be used to pass necessary preconditioning information and/ ! or workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! MTSOLV :EXT External. ! Name of a routine which solves a linear system M'ZZ = RR for ! ZZ given RR with the preconditioning matrix M (M is supplied ! via RWORK and IWORK arrays). The name of the MTSOLV routine ! must be declared external in the calling program. The call- ! ing sequence to MTSOLV is: ! call MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, RR is the right-hand side ! vector, and ZZ is the solution upon return. NELT, IA, JA, A ! and ISYM define the SLAP matrix data structure: see ! Description, below. RWORK is a double precision array that ! can be used to pass necessary preconditioning information and/ ! or workspace to MTSOLV. IWORK is an integer work array for ! the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Double Precision R(N). ! Z :WORK Double Precision Z(N). ! P :WORK Double Precision P(N). ! RR :WORK Double Precision RR(N). ! ZZ :WORK Double Precision ZZ(N). ! PP :WORK Double Precision PP(N). ! DZ :WORK Double Precision DZ(N). ! Double Precision arrays used for workspace. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used for workspace in ! MSOLVE and MTSOLV. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE ! and MTSOLV. ! ! *Description ! This routine does not care what matrix data structure is used ! for A and M. It simply calls MATVEC, MTTVEC, MSOLVE, MTSOLV ! routines, with arguments as above. The user could write any ! type of structure, and appropriate MATVEC, MSOLVE, MTTVEC, ! and MTSOLV routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK in some fashion. The SLAP ! routines DSDBCG and DSLUBC are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the double pre- ! cision array A. In other words, for each column in the ! matrix first put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- ! th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) ! are the last elements of the ICOL-th column. Note that we ! always have JA(N+1)=NELT+1, where N is the number of columns ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DSDBCG, DSLUBC !***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, ISDBCG !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC, MTTVEC, MSOLVE, MTSOLV from ROUTINES ! CALLED list. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DBCG ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), DZ(N), P(N), PP(N), R(N), RR(N), & RWORK(*), X(N), Z(N), ZZ(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE, MTSOLV, MTTVEC ! .. Local Scalars .. DOUBLE PRECISION AK, AKDEN, BK, BKDEN, BKNUM, BNRM, FUZZ, SOLNRM, & TOLMIN INTEGER I, K ! .. External Functions .. DOUBLE PRECISION D1MACH, DDOT INTEGER ISDBCG EXTERNAL D1MACH, DDOT, ISDBCG ! .. External Subroutines .. EXTERNAL DAXPY, DCOPY ! .. Intrinsic Functions .. INTRINSIC ABS !***FIRST EXECUTABLE STATEMENT DBCG ! ! Check some of the input data. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if FUZZ = D1MACH(3) TOLMIN = 500*FUZZ FUZZ = FUZZ*FUZZ if ( TOL < TOLMIN ) THEN TOL = TOLMIN IERR = 4 end if ! ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N R(I) = B(I) - R(I) RR(I) = R(I) 10 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) call MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! if ( ISDBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, & DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) & go to 200 if ( IERR /= 0 ) RETURN ! ! ***** iteration loop ***** ! DO 100 K=1,ITMAX ITER = K ! ! Calculate coefficient BK and direction vectors P and PP. BKNUM = DDOT(N, Z, 1, RR, 1) if ( ABS(BKNUM) <= FUZZ ) THEN IERR = 6 return ENDIF if ( ITER == 1) THEN call DCOPY(N, Z, 1, P, 1) call DCOPY(N, ZZ, 1, PP, 1) ELSE BK = BKNUM/BKDEN DO 20 I = 1, N P(I) = Z(I) + BK*P(I) PP(I) = ZZ(I) + BK*PP(I) 20 CONTINUE ENDIF BKDEN = BKNUM ! ! Calculate coefficient AK, new iterate X, new residuals R and ! RR, and new pseudo-residuals Z and ZZ. call MATVEC(N, P, Z, NELT, IA, JA, A, ISYM) AKDEN = DDOT(N, PP, 1, Z, 1) AK = BKNUM/AKDEN if ( ABS(AKDEN) <= FUZZ ) THEN IERR = 6 return ENDIF call DAXPY(N, AK, P, 1, X, 1) call DAXPY(N, -AK, Z, 1, R, 1) call MTTVEC(N, PP, ZZ, NELT, IA, JA, A, ISYM) call DAXPY(N, -AK, ZZ, 1, RR, 1) call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) call MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! ! check stopping criterion. if ( ISDBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, & PP, DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) & go to 200 ! 100 CONTINUE ! ! ***** end of loop ***** ! ! stopping criterion not satisfied. ITER = ITMAX + 1 IERR = 2 ! 200 return end subroutine DBDIFF (L, V) ! !! DBDIFF is subsidiary to DBSKIN. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BDIFF-S, DBDIFF-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! DBDIFF computes the sum of B(L,K)*V(K)*(-1)**K where B(L,K) ! are the binomial coefficients. Truncated sums are computed by ! setting last part of the V vector to zero. On return, the binomial ! sum is in V(L). ! !***SEE ALSO DBSKIN !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DBDIFF ! INTEGER I, J, K, L DOUBLE PRECISION V DIMENSION V(*) !***FIRST EXECUTABLE STATEMENT DBDIFF if (L == 1) RETURN DO 20 J=2,L K = L DO 10 I=J,L V(K) = V(K-1) - V(K) K = K - 1 10 CONTINUE 20 CONTINUE return end DOUBLE PRECISION FUNCTION DBESI0 (X) ! !! DBESI0 computes the hyperbolic Bessel function of first kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE DOUBLE PRECISION (BESI0-S, DBESI0-D) !***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBESI0(X) calculates the double precision modified (hyperbolic) ! Bessel function of the first kind of order zero and double ! precision argument X. ! ! Series for BI0 on the interval 0. to 9.00000E+00 ! with weighted error 9.51E-34 ! log weighted error 33.02 ! significant figures required 33.31 ! decimal places required 33.65 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DBSI0E, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBESI0 DOUBLE PRECISION X, BI0CS(18), XMAX, XSML, Y, D1MACH, & DCSEVL, DBSI0E LOGICAL FIRST SAVE BI0CS, NTI0, XSML, XMAX, FIRST DATA BI0CS( 1) / -.7660547252839144951081894976243285D-1 / DATA BI0CS( 2) / +.1927337953993808269952408750881196D+1 / DATA BI0CS( 3) / +.2282644586920301338937029292330415D+0 / DATA BI0CS( 4) / +.1304891466707290428079334210691888D-1 / DATA BI0CS( 5) / +.4344270900816487451378682681026107D-3 / DATA BI0CS( 6) / +.9422657686001934663923171744118766D-5 / DATA BI0CS( 7) / +.1434006289510691079962091878179957D-6 / DATA BI0CS( 8) / +.1613849069661749069915419719994611D-8 / DATA BI0CS( 9) / +.1396650044535669699495092708142522D-10 / DATA BI0CS( 10) / +.9579451725505445344627523171893333D-13 / DATA BI0CS( 11) / +.5333981859862502131015107744000000D-15 / DATA BI0CS( 12) / +.2458716088437470774696785919999999D-17 / DATA BI0CS( 13) / +.9535680890248770026944341333333333D-20 / DATA BI0CS( 14) / +.3154382039721427336789333333333333D-22 / DATA BI0CS( 15) / +.9004564101094637431466666666666666D-25 / DATA BI0CS( 16) / +.2240647369123670016000000000000000D-27 / DATA BI0CS( 17) / +.4903034603242837333333333333333333D-30 / DATA BI0CS( 18) / +.9508172606122666666666666666666666D-33 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBESI0 if (FIRST) THEN NTI0 = INITDS (BI0CS, 18, 0.1*REAL(D1MACH(3))) XSML = SQRT(4.5D0*D1MACH(3)) XMAX = LOG (D1MACH(2)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 3.0D0) go to 20 ! DBESI0 = 1.0D0 if (Y > XSML) DBESI0 = 2.75D0 + DCSEVL (Y*Y/4.5D0-1.D0, BI0CS, & NTI0) return ! 20 if (Y > XMAX) call XERMSG ('SLATEC', 'DBESI0', & 'ABS(X) SO BIG I0 OVERFLOWS', 2, 2) ! DBESI0 = EXP(Y) * DBSI0E(X) ! return end DOUBLE PRECISION FUNCTION DBESI1 (X) ! !! DBESI1 computes the modified (hyperbolic) Bessel function of the first ... ! kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE DOUBLE PRECISION (BESI1-S, DBESI1-D) !***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBESI1(X) calculates the double precision modified (hyperbolic) ! Bessel function of the first kind of order one and double precision ! argument X. ! ! Series for BI1 on the interval 0. to 9.00000E+00 ! with weighted error 1.44E-32 ! log weighted error 31.84 ! significant figures required 31.45 ! decimal places required 32.46 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DBSI1E, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBESI1 DOUBLE PRECISION X, BI1CS(17), XMAX, XMIN, XSML, Y, D1MACH, & DCSEVL, DBSI1E LOGICAL FIRST SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST DATA BI1CS( 1) / -.19717132610998597316138503218149D-2 / DATA BI1CS( 2) / +.40734887667546480608155393652014D+0 / DATA BI1CS( 3) / +.34838994299959455866245037783787D-1 / DATA BI1CS( 4) / +.15453945563001236038598401058489D-2 / DATA BI1CS( 5) / +.41888521098377784129458832004120D-4 / DATA BI1CS( 6) / +.76490267648362114741959703966069D-6 / DATA BI1CS( 7) / +.10042493924741178689179808037238D-7 / DATA BI1CS( 8) / +.99322077919238106481371298054863D-10 / DATA BI1CS( 9) / +.76638017918447637275200171681349D-12 / DATA BI1CS( 10) / +.47414189238167394980388091948160D-14 / DATA BI1CS( 11) / +.24041144040745181799863172032000D-16 / DATA BI1CS( 12) / +.10171505007093713649121100799999D-18 / DATA BI1CS( 13) / +.36450935657866949458491733333333D-21 / DATA BI1CS( 14) / +.11205749502562039344810666666666D-23 / DATA BI1CS( 15) / +.29875441934468088832000000000000D-26 / DATA BI1CS( 16) / +.69732310939194709333333333333333D-29 / DATA BI1CS( 17) / +.14367948220620800000000000000000D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBESI1 if (FIRST) THEN NTI1 = INITDS (BI1CS, 17, 0.1*REAL(D1MACH(3))) XMIN = 2.0D0*D1MACH(1) XSML = SQRT(4.5D0*D1MACH(3)) XMAX = LOG (D1MACH(2)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 3.0D0) go to 20 ! DBESI1 = 0.D0 if (Y == 0.D0) return ! if (Y <= XMIN) call XERMSG ('SLATEC', 'DBESI1', & 'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1) if (Y > XMIN) DBESI1 = 0.5D0*X if (Y > XSML) DBESI1 = X*(0.875D0 + DCSEVL (Y*Y/4.5D0-1.D0, & BI1CS, NTI1)) return ! 20 if (Y > XMAX) call XERMSG ('SLATEC', 'DBESI1', & 'ABS(X) SO BIG I1 OVERFLOWS', 2, 2) ! DBESI1 = EXP(Y) * DBSI1E(X) ! return end subroutine DBESI (X, ALPHA, KODE, N, Y, NZ) ! !! DBESI computes an N member sequence of I Bessel functions ... ! I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions ! EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for nonnegative ! ALPHA and X. ! !***LIBRARY SLATEC !***CATEGORY C10B3 !***TYPE DOUBLE PRECISION (BESI-S, DBESI-D) !***KEYWORDS I BESSEL FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Amos, D. E., (SNLA) ! Daniel, S. L., (SNLA) !***DESCRIPTION ! ! Abstract **** a double precision routine **** ! DBESI computes an N member sequence of I Bessel functions ! I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions ! EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for nonnegative ALPHA ! and X. A combination of the power series, the asymptotic ! expansion for X to infinity, and the uniform asymptotic ! expansion for NU to infinity are applied over subdivisions of ! the (NU,X) plane. For values not covered by one of these ! formulae, the order is incremented by an integer so that one ! of these formulae apply. Backward recursion is used to reduce ! orders by integer values. The asymptotic expansion for X to ! infinity is used only when the entire sequence (specifically ! the last member) lies within the region covered by the ! expansion. Leading terms of these expansions are used to test ! for over or underflow where appropriate. If a sequence is ! requested and the last member would underflow, the result is ! set to zero and the next lower order tried, etc., until a ! member comes on scale or all are set to zero. An overflow ! cannot occur with scaling. ! ! The maximum number of significant digits obtainable ! is the smaller of 14 and the number of digits carried in ! double precision arithmetic. ! ! Description of Arguments ! ! Input X,ALPHA are double precision ! X - X >= 0.0D0 ! ALPHA - order of first member of the sequence, ! ALPHA >= 0.0D0 ! KODE - a parameter to indicate the scaling option ! KODE=1 returns ! Y(K)= I/sub(ALPHA+K-1)/(X), ! K=1,...,N ! KODE=2 returns ! Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X), ! K=1,...,N ! N - number of members in the sequence, N >= 1 ! ! Output Y is double precision ! Y - a vector whose first N components contain ! values for I/sub(ALPHA+K-1)/(X) or scaled ! values for EXP(-X)*I/sub(ALPHA+K-1)/(X), ! K=1,...,N depending on KODE ! NZ - number of components of Y set to zero due to ! underflow, ! NZ=0 , normal return, computation completed ! NZ /= 0, last NZ components of Y set to zero, ! Y(K)=0.0D0, K=N-NZ+1,...,N. ! ! Error Conditions ! Improper input arguments - a fatal error ! Overflow with KODE=1 - a fatal error ! Underflow - a non-fatal error(NZ /= 0) ! !***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 ! subroutines IBESS and JBESS for Bessel functions ! I(NU,X) and J(NU,X), X >= 0, NU >= 0, ACM ! Transactions on Mathematical Software 3, (1977), ! pp. 76-92. ! F. W. J. Olver, Tables of Bessel Functions of Moderate ! or Large Orders, NPL Mathematical Tables 6, Her ! Majesty's Stationery Office, London, 1962. !***ROUTINES CALLED D1MACH, DASYIK, DLNGAM, I1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBESI ! INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT, & N, NN, NS, NZ INTEGER I1MACH DOUBLE PRECISION 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 DOUBLE PRECISION D1MACH, DLNGAM DIMENSION Y(*), TEMP(3) SAVE RTTPI, INLIM DATA RTTPI / 3.98942280401433D-01/ DATA INLIM / 80 / !***FIRST EXECUTABLE STATEMENT DBESI NZ = 0 KT = 1 ! I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE ! I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE RA = D1MACH(3) TOL = MAX(RA,1.0D-15) I1 = -I1MACH(15) GLN = D1MACH(5) ELIM = 2.303D0*(I1*GLN-3.0D0) ! TOLLN = -LN(TOL) I1 = I1MACH(14)+1 TOLLN = 2.303D0*GLN*I1 TOLLN = MIN(TOLLN,34.5388D0) if (N-1) 590, 10, 20 10 KT = 2 20 NN = N if (KODE < 1 .OR. KODE > 2) go to 570 if (X) 600, 30, 80 30 if (ALPHA) 580, 40, 50 40 Y(1) = 1.0D0 if (N == 1) RETURN I1 = 2 go to 60 50 I1 = 1 60 DO 70 I=I1,N Y(I) = 0.0D0 70 CONTINUE return 80 CONTINUE if (ALPHA < 0.0D0) go to 580 ! IALP = INT(ALPHA) FNI = IALP + N - 1 FNF = ALPHA - IALP DFN = FNI + FNF FNU = DFN IN = 0 XO2 = X*0.5D0 SXO2 = XO2*XO2 ETX = KODE - 1 SX = ETX*X ! ! DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X ! TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE ! APPLIED. ! if (SXO2 <= (FNU+1.0D0)) go to 90 if (X <= 12.0D0) go to 110 FN = 0.55D0*FNU*FNU FN = MAX(17.0D0,FN) if (X >= FN) go to 430 ANS = MAX(36.0D0-FNU,0.0D0) NS = INT(ANS) FNI = FNI + NS DFN = FNI + FNF FN = DFN IS = KT KM = N - 1 + NS if (KM > 0) IS = 3 go to 120 90 FN = FNU FNP1 = FN + 1.0D0 XO2L = LOG(XO2) IS = KT if (X <= 0.5D0) go to 230 NS = 0 100 FNI = FNI + NS DFN = FNI + FNF FN = DFN FNP1 = FN + 1.0D0 IS = KT if (N-1+NS > 0) IS = 3 go to 230 110 XO2L = LOG(XO2) NS = INT(SXO2-FNU) go to 100 120 CONTINUE ! ! OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION ! if (KODE == 2) go to 130 if (ALPHA < 1.0D0) go to 150 Z = X/ALPHA RA = SQRT(1.0D0+Z*Z) GLN = LOG((1.0D0+RA)/Z) T = RA*(1.0D0-ETX) + ETX/(Z+RA) ARG = ALPHA*(T-GLN) if (ARG > ELIM) go to 610 if (KM == 0) go to 140 130 CONTINUE ! ! UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION ! Z = X/FN RA = SQRT(1.0D0+Z*Z) GLN = LOG((1.0D0+RA)/Z) T = RA*(1.0D0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN) 140 if (ARG < (-ELIM)) go to 280 go to 190 150 if (X > ELIM) go to 610 go to 130 ! ! UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY ! 160 if (KM /= 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.0D0 DFN = FNI + FNF FN = DFN if ( I1 == 2) go to 350 Z = X/FN RA = SQRT(1.0D0+Z*Z) GLN = LOG((1.0D0+RA)/Z) T = RA*(1.0D0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN) 190 CONTINUE I1 = ABS(3-IS) I1 = MAX(I1,1) FLGIK = 1.0D0 call DASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS)) go to (180, 350, 510), IS ! ! SERIES FOR (X/2)**2 <= NU+1 ! 230 CONTINUE GLN = DLNGAM(FNP1) ARG = FN*XO2L - GLN - SX if (ARG < (-ELIM)) go to 300 EARG = EXP(ARG) 240 CONTINUE S = 1.0D0 if (X < TOL) go to 260 AK = 3.0D0 T2 = 1.0D0 T = 1.0D0 S1 = FN DO 250 K=1,17 S2 = T2 + S1 T = T*SXO2/S2 S = S + T if (ABS(T) < TOL) go to 260 T2 = T2 + AK AK = AK + 2.0D0 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.0D0 DFN = FNI + FNF FN = DFN IS = 2 go to 240 ! ! SET UNDERFLOW VALUE AND UPDATE PARAMETERS ! 280 Y(NN) = 0.0D0 NN = NN - 1 FNI = FNI - 1.0D0 DFN = FNI + FNF FN = DFN if (NN-1) 340, 290, 130 290 KT = 2 IS = 2 go to 130 300 Y(NN) = 0.0D0 NN = NN - 1 FNP1 = FN FNI = FNI - 1.0D0 DFN = FNI + FNF FN = DFN if (NN-1) 340, 310, 320 310 KT = 2 IS = 2 320 if (SXO2 <= FNP1) go to 330 go to 130 330 ARG = ARG - XO2L + LOG(FNP1) if (ARG < (-ELIM)) go to 300 go to 230 340 NZ = N - NN return ! ! BACKWARD RECURSION SECTION ! 350 CONTINUE NZ = N - NN 360 CONTINUE if ( KT == 2) go to 420 S1 = TEMP(1) S2 = TEMP(2) TRX = 2.0D0/X DTM = FNI TM = (DTM+FNF)*TRX if (IN == 0) go to 390 ! BACKWARD RECUR TO INDEX ALPHA+NN-1 DO 380 I=1,IN S = S2 S2 = TM*S2 + S1 S1 = S DTM = DTM - 1.0D0 TM = (DTM+FNF)*TRX 380 CONTINUE Y(NN) = S1 if (NN == 1) RETURN Y(NN-1) = S2 if (NN == 2) RETURN go to 400 390 CONTINUE ! BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA Y(NN) = S1 Y(NN-1) = S2 if (NN == 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.0D0 TM = (DTM+FNF)*TRX 410 CONTINUE return 420 Y(1) = TEMP(2) return ! ! ASYMPTOTIC EXPANSION FOR X TO INFINITY ! 430 CONTINUE EARG = RTTPI/SQRT(X) if (KODE == 2) go to 440 if (X > ELIM) go to 610 EARG = EARG*EXP(X) 440 ETX = 8.0D0*X IS = KT IN = 0 FN = FNU 450 DX = FNI + FNI TM = 0.0D0 if (FNI == 0.0D0 .AND. ABS(FNF) < TOL) go to 460 TM = 4.0D0*FNF*(FNI+FNI+FNF) 460 CONTINUE DTM = DX*DX S1 = ETX TRX = DTM - 1.0D0 DX = -(TRX+TM)/ETX T = DX S = 1.0D0 + DX ATOL = TOL*ABS(S) S2 = 1.0D0 AK = 8.0D0 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) <= ATOL) go to 480 AK = AK + 8.0D0 470 CONTINUE 480 TEMP(IS) = S*EARG if ( IS == 2) go to 360 IS = 2 FNI = FNI - 1.0D0 DFN = FNI + FNF FN = DFN go to 450 ! ! BACKWARD RECURSION WITH NORMALIZATION BY ! ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. ! 500 CONTINUE ! COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION AKM = MAX(3.0D0-FN,0.0D0) KM = INT(AKM) TFN = FN + KM TA = (GLN+TFN-0.9189385332D0-0.0833333333D0/TFN)/(TFN+0.5D0) TA = XO2L - TA TB = -(1.0D0-1.0D0/TFN)/TFN AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5D0 IN = INT(AIN) IN = IN + KM go to 520 510 CONTINUE ! COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION T = 1.0D0/(FN*RA) AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5D0 IN = INT(AIN) if (IN > INLIM) go to 160 520 CONTINUE TRX = 2.0D0/X DTM = FNI + IN TM = (DTM+FNF)*TRX TA = 0.0D0 TB = TOL KK = 1 530 CONTINUE ! ! BACKWARD RECUR UNINDEXED ! DO 540 I=1,IN S = TB TB = TM*TB + TA TA = S DTM = DTM - 1.0D0 TM = (DTM+FNF)*TRX 540 CONTINUE ! NORMALIZATION if (KK /= 1) go to 550 TA = (TA/TB)*TEMP(3) TB = TEMP(3) KK = 2 IN = NS if (NS /= 0) go to 530 550 Y(NN) = TB NZ = N - NN if (NN == 1) RETURN TB = TM*TB + TA K = NN - 1 Y(K) = TB if (NN == 2) RETURN DTM = DTM - 1.0D0 TM = (DTM+FNF)*TRX KM = K - 1 ! ! BACKWARD RECUR INDEXED ! DO 560 I=1,KM Y(K-1) = TM*Y(K) + Y(K+1) DTM = DTM - 1.0D0 TM = (DTM+FNF)*TRX K = K - 1 560 CONTINUE return ! ! ! 570 CONTINUE call XERMSG ('SLATEC', 'DBESI', & 'SCALING OPTION, KODE, NOT 1 OR 2.', 2, 1) return 580 CONTINUE call XERMSG ('SLATEC', 'DBESI', 'ORDER, ALPHA, LESS THAN ZERO.', & 2, 1) return 590 CONTINUE call XERMSG ('SLATEC', 'DBESI', 'N LESS THAN ONE.', 2, 1) return 600 CONTINUE call XERMSG ('SLATEC', 'DBESI', 'X LESS THAN ZERO.', 2, 1) return 610 CONTINUE call XERMSG ('SLATEC', 'DBESI', & 'OVERFLOW, X TOO LARGE FOR KODE = 1.', 6, 1) return end DOUBLE PRECISION FUNCTION DBESJ0 (X) ! !! DBESJ0 computes the Bessel function of the first kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10A1 !***TYPE DOUBLE PRECISION (BESJ0-S, DBESJ0-D) !***KEYWORDS BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ZERO, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBESJ0(X) calculates the double precision Bessel function of ! the first kind of order zero for double precision argument X. ! ! Series for BJ0 on the interval 0. to 1.60000E+01 ! with weighted error 4.39E-32 ! log weighted error 31.36 ! significant figures required 31.21 ! decimal places required 32.00 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9B0MP, DCSEVL, INITDS !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DBESJ0 DOUBLE PRECISION X, BJ0CS(19), AMPL, THETA, XSML, Y, D1MACH, & DCSEVL LOGICAL FIRST SAVE BJ0CS, NTJ0, XSML, FIRST DATA BJ0CS( 1) / +.10025416196893913701073127264074D+0 / DATA BJ0CS( 2) / -.66522300776440513177678757831124D+0 / DATA BJ0CS( 3) / +.24898370349828131370460468726680D+0 / DATA BJ0CS( 4) / -.33252723170035769653884341503854D-1 / DATA BJ0CS( 5) / +.23114179304694015462904924117729D-2 / DATA BJ0CS( 6) / -.99112774199508092339048519336549D-4 / DATA BJ0CS( 7) / +.28916708643998808884733903747078D-5 / DATA BJ0CS( 8) / -.61210858663032635057818407481516D-7 / DATA BJ0CS( 9) / +.98386507938567841324768748636415D-9 / DATA BJ0CS( 10) / -.12423551597301765145515897006836D-10 / DATA BJ0CS( 11) / +.12654336302559045797915827210363D-12 / DATA BJ0CS( 12) / -.10619456495287244546914817512959D-14 / DATA BJ0CS( 13) / +.74706210758024567437098915584000D-17 / DATA BJ0CS( 14) / -.44697032274412780547627007999999D-19 / DATA BJ0CS( 15) / +.23024281584337436200523093333333D-21 / DATA BJ0CS( 16) / -.10319144794166698148522666666666D-23 / DATA BJ0CS( 17) / +.40608178274873322700800000000000D-26 / DATA BJ0CS( 18) / -.14143836005240913919999999999999D-28 / DATA BJ0CS( 19) / +.43910905496698880000000000000000D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBESJ0 if (FIRST) THEN NTJ0 = INITDS (BJ0CS, 19, 0.1*REAL(D1MACH(3))) XSML = SQRT(8.0D0*D1MACH(3)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 4.0D0) go to 20 ! DBESJ0 = 1.0D0 if (Y > XSML) DBESJ0 = DCSEVL (.125D0*Y*Y-1.D0, BJ0CS, NTJ0) return ! 20 call D9B0MP (Y, AMPL, THETA) DBESJ0 = AMPL * COS(THETA) ! return end DOUBLE PRECISION FUNCTION DBESJ1 (X) ! !! DBESJ1 computes the Bessel function of the first kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10A1 !***TYPE DOUBLE PRECISION (BESJ1-S, DBESJ1-D) !***KEYWORDS BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBESJ1(X) calculates the double precision Bessel function of the ! first kind of order one for double precision argument X. ! ! Series for BJ1 on the interval 0. to 1.60000E+01 ! with weighted error 1.16E-33 ! log weighted error 32.93 ! significant figures required 32.36 ! decimal places required 33.57 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9B1MP, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 780601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 910401 Corrected error in code which caused values to have the ! wrong sign for arguments less than 4.0. (WRB) !***END PROLOGUE DBESJ1 DOUBLE PRECISION X, BJ1CS(19), AMPL, THETA, XSML, XMIN, Y, & D1MACH, DCSEVL LOGICAL FIRST SAVE BJ1CS, NTJ1, XSML, XMIN, FIRST DATA BJ1CS( 1) / -.117261415133327865606240574524003D+0 / DATA BJ1CS( 2) / -.253615218307906395623030884554698D+0 / DATA BJ1CS( 3) / +.501270809844695685053656363203743D-1 / DATA BJ1CS( 4) / -.463151480962508191842619728789772D-2 / DATA BJ1CS( 5) / +.247996229415914024539124064592364D-3 / DATA BJ1CS( 6) / -.867894868627882584521246435176416D-5 / DATA BJ1CS( 7) / +.214293917143793691502766250991292D-6 / DATA BJ1CS( 8) / -.393609307918317979229322764073061D-8 / DATA BJ1CS( 9) / +.559118231794688004018248059864032D-10 / DATA BJ1CS( 10) / -.632761640466139302477695274014880D-12 / DATA BJ1CS( 11) / +.584099161085724700326945563268266D-14 / DATA BJ1CS( 12) / -.448253381870125819039135059199999D-16 / DATA BJ1CS( 13) / +.290538449262502466306018688000000D-18 / DATA BJ1CS( 14) / -.161173219784144165412118186666666D-20 / DATA BJ1CS( 15) / +.773947881939274637298346666666666D-23 / DATA BJ1CS( 16) / -.324869378211199841143466666666666D-25 / DATA BJ1CS( 17) / +.120223767722741022720000000000000D-27 / DATA BJ1CS( 18) / -.395201221265134933333333333333333D-30 / DATA BJ1CS( 19) / +.116167808226645333333333333333333D-32 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBESJ1 if (FIRST) THEN NTJ1 = INITDS (BJ1CS, 19, 0.1*REAL(D1MACH(3))) ! XSML = SQRT(8.0D0*D1MACH(3)) XMIN = 2.0D0*D1MACH(1) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 4.0D0) go to 20 ! DBESJ1 = 0.0D0 if (Y == 0.0D0) RETURN if (Y <= XMIN) call XERMSG ('SLATEC', 'DBESJ1', & 'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1) if (Y > XMIN) DBESJ1 = 0.5D0*X if (Y > XSML) DBESJ1 = X*(.25D0 + DCSEVL (.125D0*Y*Y-1.D0, & BJ1CS, NTJ1) ) return ! 20 call D9B1MP (Y, AMPL, THETA) DBESJ1 = SIGN (AMPL, X) * COS(THETA) ! return end subroutine DBESJ ( X, ALPHA, N, Y, NZ ) ! !! DBESJ computes an N member sequence of J Bessel functions ... ! J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA ! and X. ! !***LIBRARY SLATEC !***CATEGORY C10A3 !***TYPE DOUBLE PRECISION (BESJ-S, DBESJ-D) !***KEYWORDS J BESSEL FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Amos, D. E., (SNLA) ! Daniel, S. L., (SNLA) ! Weston, M. K., (SNLA) !***DESCRIPTION ! ! Abstract **** a double precision routine **** ! DBESJ computes an N member sequence of J Bessel functions ! J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. ! A combination of the power series, the asymptotic expansion ! for X to infinity and the uniform asymptotic expansion for ! NU to infinity are applied over subdivisions of the (NU,X) ! plane. For values of (NU,X) not covered by one of these ! formulae, the order is incremented or decremented by integer ! values into a region where one of the formulae apply. Backward ! recursion is applied to reduce orders by integer values except ! where the entire sequence lies in the oscillatory region. In ! this case forward recursion is stable and values from the ! asymptotic expansion for X to infinity start the recursion ! when it is efficient to do so. Leading terms of the series and ! uniform expansion are tested for underflow. If a sequence is ! requested and the last member would underflow, the result is ! set to zero and the next lower order tried, etc., until a ! member comes on scale or all members are set to zero. ! Overflow cannot occur. ! ! The maximum number of significant digits obtainable ! is the smaller of 14 and the number of digits carried in ! double precision arithmetic. ! ! Description of Arguments ! ! Input X,ALPHA are double precision ! X - X >= 0.0D0 ! ALPHA - order of first member of the sequence, ! ALPHA >= 0.0D0 ! N - number of members in the sequence, N >= 1 ! ! Output Y is double precision ! Y - a vector whose first N components contain ! values for J/sub(ALPHA+K-1)/(X), K=1,...,N ! NZ - number of components of Y set to zero due to ! underflow, ! NZ=0 , normal return, computation completed ! NZ /= 0, last NZ components of Y set to zero, ! Y(K)=0.0D0, K=N-NZ+1,...,N. ! ! Error Conditions ! Improper input arguments - a fatal error ! Underflow - a non-fatal error (NZ /= 0) ! !***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 ! subroutines IBESS and JBESS for Bessel functions ! I(NU,X) and J(NU,X), X >= 0, NU >= 0, ACM ! Transactions on Mathematical Software 3, (1977), ! pp. 76-92. ! F. W. J. Olver, Tables of Bessel Functions of Moderate ! or Large Orders, NPL Mathematical Tables 6, Her ! Majesty's Stationery Office, London, 1962. !***ROUTINES CALLED D1MACH, DASYJY, DJAIRY, DLNGAM, I1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBESJ EXTERNAL DJAIRY INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN, & NS,NZ INTEGER I1MACH DOUBLE PRECISION AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM, & EARG,ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU, & FNULIM,GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN, & S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL, & TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,SLIM,RTOL SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM DOUBLE PRECISION D1MACH, DLNGAM DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7) DATA RTWO,PDF,RTTP,PIDT / 1.34839972492648D+00, & 7.85398163397448D-01, 7.97884560802865D-01, 1.57079632679490D+00/ DATA PP(1), PP(2), PP(3), PP(4) / 8.72909153935547D+00, & 2.65693932265030D-01, 1.24578576865586D-01, 7.70133747430388D-04/ DATA INLIM / 150 / DATA FNULIM(1), FNULIM(2) / 100.0D0, 60.0D0 / !***FIRST EXECUTABLE STATEMENT DBESJ NZ = 0 KT = 1 NS=0 ! I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE ! I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE TA = D1MACH(3) TOL = MAX(TA,1.0D-15) I1 = I1MACH(14) + 1 I2 = I1MACH(15) TB = D1MACH(5) ELIM1 = -2.303D0*(I2*TB+3.0D0) RTOL=1.0D0/TOL SLIM=D1MACH(1)*RTOL*1.0D+3 ! TOLLN = -LN(TOL) TOLLN = 2.303D0*TB*I1 TOLLN = MIN(TOLLN,34.5388D0) 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.0D0 if (N == 1) RETURN I1 = 2 go to 60 50 I1 = 1 60 DO 70 I=I1,N Y(I) = 0.0D0 70 CONTINUE return 80 CONTINUE if (ALPHA < 0.0D0) go to 710 ! IALP = INT(ALPHA) FNI = IALP + N - 1 FNF = ALPHA - IALP DFN = FNI + FNF FNU = DFN XO2 = X*0.5D0 SXO2 = XO2*XO2 ! ! DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X ! TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE ! APPLIED. ! if (SXO2 <= (FNU+1.0D0)) go to 90 TA = MAX(20.0D0,FNU) if (X > TA) go to 120 if (X > 12.0D0) go to 110 XO2L = LOG(XO2) NS = INT(SXO2-FNU) + 1 go to 100 90 FN = FNU FNP1 = FN + 1.0D0 XO2L = LOG(XO2) IS = KT if (X <= 0.50D0) go to 330 NS = 0 100 FNI = FNI + NS DFN = FNI + FNF FN = DFN FNP1 = FN + 1.0D0 IS = KT if (N-1+NS > 0) IS = 3 go to 330 110 ANS = MAX(36.0D0-FNU,0.0D0) NS = INT(ANS) FNI = FNI + NS DFN = FNI + FNF FN = DFN IS = KT if (N-1+NS > 0) IS = 3 go to 130 120 CONTINUE RTX = SQRT(X) TAU = RTWO*RTX TA = TAU + FNULIM(KT) if (FNU <= TA) go to 480 FN = FNU IS = KT ! ! UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY ! 130 CONTINUE I1 = ABS(3-IS) I1 = MAX(I1,1) FLGJY = 1.0D0 call DASYJY(DJAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW) if ( IFLW /= 0) go to 380 go to (320, 450, 620), IS 310 TEMP(1) = TEMP(3) KT = 1 320 IS = 2 FNI = FNI - 1.0D0 DFN = FNI + FNF FN = DFN if ( I1 == 2) go to 450 go to 130 ! ! SERIES FOR (X/2)**2 <= NU+1 ! 330 CONTINUE GLN = DLNGAM(FNP1) ARG = FN*XO2L - GLN if (ARG < (-ELIM1)) go to 400 EARG = EXP(ARG) 340 CONTINUE S = 1.0D0 if (X < TOL) go to 360 AK = 3.0D0 T2 = 1.0D0 T = 1.0D0 S1 = FN DO 350 K=1,17 S2 = T2 + S1 T = -T*SXO2/S2 S = S + T if (ABS(T) < TOL) go to 360 T2 = T2 + AK AK = AK + 2.0D0 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.0D0 DFN = FNI + FNF FN = DFN IS = 2 go to 340 ! ! SET UNDERFLOW VALUE AND UPDATE PARAMETERS ! UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE LARGER ! THAN 36. THEREFORE, NS NEE NOT BE TESTED. ! 380 Y(NN) = 0.0D0 NN = NN - 1 FNI = FNI - 1.0D0 DFN = FNI + FNF FN = DFN if (NN-1) 440, 390, 130 390 KT = 2 IS = 2 go to 130 400 Y(NN) = 0.0D0 NN = NN - 1 FNP1 = FN FNI = FNI - 1.0D0 DFN = FNI + FNF FN = DFN if (NN-1) 440, 410, 420 410 KT = 2 IS = 2 420 if (SXO2 <= FNP1) go to 430 go to 130 430 ARG = ARG - XO2L + LOG(FNP1) if (ARG < (-ELIM1)) go to 400 go to 330 440 NZ = N - NN return ! ! BACKWARD RECURSION SECTION ! 450 CONTINUE if ( NS /= 0) go to 451 NZ = N - NN if (KT == 2) go to 470 ! BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA Y(NN) = TEMP(1) Y(NN-1) = TEMP(2) if (NN == 2) RETURN 451 CONTINUE TRX = 2.0D0/X DTM = FNI TM = (DTM+FNF)*TRX AK=1.0D0 TA=TEMP(1) TB=TEMP(2) if ( ABS(TA) > SLIM) go to 455 TA=TA*RTOL TB=TB*RTOL AK=TOL 455 CONTINUE KK=2 IN=NS-1 if ( IN == 0) go to 690 if ( NS /= 0) go to 670 K=NN-2 DO 460 I=3,NN S=TB TB = TM*TB - TA TA=S Y(K)=TB*AK DTM = DTM - 1.0D0 TM = (DTM+FNF)*TRX K = K - 1 460 CONTINUE return 470 Y(1) = TEMP(2) return ! ! ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN ! OSCILLATORY REGION X > MAX(20, NU), PROVIDED THE LAST MEMBER ! OF THE SEQUENCE IS ALSO IN THE REGION. ! 480 CONTINUE IN = INT(ALPHA-TAU+2.0D0) if (IN <= 0) go to 490 IDALP = IALP - IN - 1 KT = 1 go to 500 490 CONTINUE IDALP = IALP IN = 0 500 IS = KT FIDAL = IDALP DALPHA = FIDAL + FNF ARG = X - PIDT*DALPHA - PDF SA = SIN(ARG) SB = COS(ARG) COEF = RTTP/RTX ETX = 8.0D0*X 510 CONTINUE DTM = FIDAL + FIDAL DTM = DTM*DTM TM = 0.0D0 if (FIDAL == 0.0D0 .AND. ABS(FNF) < TOL) go to 520 TM = 4.0D0*FNF*(FIDAL+FIDAL+FNF) 520 CONTINUE TRX = DTM - 1.0D0 T2 = (TRX+TM)/ETX S2 = T2 RELB = TOL*ABS(T2) T1 = ETX S1 = 1.0D0 FN = 1.0D0 AK = 8.0D0 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.0D0 FN = FN + AK TRX = DTM - FN AP = TRX + TM T2 = T2*AP/T1 S2 = S2 + T2 if (ABS(T2) <= RELB) go to 540 AK = AK + 8.0D0 530 CONTINUE 540 TEMP(IS) = COEF*(S1*SB-S2*SA) if ( IS == 2) go to 560 FIDAL = FIDAL + 1.0D0 DALPHA = FIDAL + FNF IS = 2 TB = SA SA = -SB SB = TB go to 510 ! ! FORWARD RECURSION SECTION ! 560 if (KT == 2) go to 470 S1 = TEMP(1) S2 = TEMP(2) TX = 2.0D0/X TM = DALPHA*TX if (IN == 0) go to 580 ! ! FORWARD RECUR TO INDEX ALPHA ! DO 570 I=1,IN S = S2 S2 = TM*S2 - S1 TM = TM + TX S1 = S 570 CONTINUE if (NN == 1) go to 600 S = S2 S2 = TM*S2 - S1 TM = TM + TX S1 = S 580 CONTINUE ! ! FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 ! Y(1) = S1 Y(2) = S2 if (NN == 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 ! ! BACKWARD RECURSION WITH NORMALIZATION BY ! ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. ! 610 CONTINUE ! COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION AKM = MAX(3.0D0-FN,0.0D0) KM = INT(AKM) TFN = FN + KM TA = (GLN+TFN-0.9189385332D0-0.0833333333D0/TFN)/(TFN+0.5D0) TA = XO2L - TA TB = -(1.0D0-1.5D0/TFN)/TFN AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5D0 IN = KM + INT(AKM) go to 660 620 CONTINUE ! COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION GLN = WK(3) + WK(2) if (WK(6) > 30.0D0) go to 640 RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0D0 RZDEN = PP(1) + PP(2)*WK(6) TA = RZDEN/RDEN if (WK(1) < 0.10D0) go to 630 TB = GLN/WK(5) go to 650 630 TB=(1.259921049D0+(0.1679894730D0+0.0887944358D0*WK(1))*WK(1)) & /WK(7) go to 650 640 CONTINUE TA = 0.5D0*TOLLN/WK(4) TA=((0.0493827160D0*TA-0.1111111111D0)*TA+0.6666666667D0)*TA*WK(6) if (WK(1) < 0.10D0) go to 630 TB = GLN/WK(5) 650 IN = INT(TA/TB+1.5D0) if (IN > INLIM) go to 310 660 CONTINUE DTM = FNI + IN TRX = 2.0D0/X TM = (DTM+FNF)*TRX TA = 0.0D0 TB = TOL KK = 1 AK=1.0D0 670 CONTINUE ! ! BACKWARD RECUR UNINDEXED ! DO 680 I=1,IN S = TB TB = TM*TB - TA TA = S DTM = DTM - 1.0D0 TM = (DTM+FNF)*TRX 680 CONTINUE ! NORMALIZATION if (KK /= 1) go to 690 S=TEMP(3) SA=TA/TB TA=S TB=S if ( ABS(S) > SLIM) go to 685 TA=TA*RTOL TB=TB*RTOL AK=TOL 685 CONTINUE TA=TA*SA KK = 2 IN = NS if (NS /= 0) go to 670 690 Y(NN) = TB*AK NZ = N - NN if (NN == 1) RETURN K = NN - 1 S=TB TB = TM*TB - TA TA=S Y(K)=TB*AK if (NN == 2) RETURN DTM = DTM - 1.0D0 TM = (DTM+FNF)*TRX K=NN-2 ! ! BACKWARD RECUR INDEXED ! DO 700 I=3,NN S=TB TB = TM*TB - TA TA=S Y(K)=TB*AK DTM = DTM - 1.0D0 TM = (DTM+FNF)*TRX K = K - 1 700 CONTINUE return ! ! ! 710 CONTINUE call XERMSG ('SLATEC', 'DBESJ', 'ORDER, ALPHA, LESS THAN ZERO.', & 2, 1) return 720 CONTINUE call XERMSG ('SLATEC', 'DBESJ', 'N LESS THAN ONE.', 2, 1) return 730 CONTINUE call XERMSG ('SLATEC', 'DBESJ', 'X LESS THAN ZERO.', 2, 1) return end DOUBLE PRECISION FUNCTION DBESK0 (X) ! !! DBESK0 computes the modified (hyperbolic) Bessel function of the ... ! third kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE DOUBLE PRECISION (BESK0-S, DBESK0-D) !***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, ! THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBESK0(X) calculates the double precision modified (hyperbolic) ! Bessel function of the third kind of order zero for double ! precision argument X. The argument must be greater than zero ! but not so large that the result underflows. ! ! Series for BK0 on the interval 0. to 4.00000E+00 ! with weighted error 3.08E-33 ! log weighted error 32.51 ! significant figures required 32.05 ! decimal places required 33.11 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DBESI0, DBSK0E, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBESK0 DOUBLE PRECISION X, BK0CS(16), XMAX, XMAXT, XSML, Y, & D1MACH, DCSEVL, DBESI0, DBSK0E LOGICAL FIRST SAVE BK0CS, NTK0, XSML, XMAX, FIRST DATA BK0CS( 1) / -.353273932339027687201140060063153D-1 / DATA BK0CS( 2) / +.344289899924628486886344927529213D+0 / DATA BK0CS( 3) / +.359799365153615016265721303687231D-1 / DATA BK0CS( 4) / +.126461541144692592338479508673447D-2 / DATA BK0CS( 5) / +.228621210311945178608269830297585D-4 / DATA BK0CS( 6) / +.253479107902614945730790013428354D-6 / DATA BK0CS( 7) / +.190451637722020885897214059381366D-8 / DATA BK0CS( 8) / +.103496952576336245851008317853089D-10 / DATA BK0CS( 9) / +.425981614279108257652445327170133D-13 / DATA BK0CS( 10) / +.137446543588075089694238325440000D-15 / DATA BK0CS( 11) / +.357089652850837359099688597333333D-18 / DATA BK0CS( 12) / +.763164366011643737667498666666666D-21 / DATA BK0CS( 13) / +.136542498844078185908053333333333D-23 / DATA BK0CS( 14) / +.207527526690666808319999999999999D-26 / DATA BK0CS( 15) / +.271281421807298560000000000000000D-29 / DATA BK0CS( 16) / +.308259388791466666666666666666666D-32 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBESK0 if (FIRST) THEN NTK0 = INITDS (BK0CS, 16, 0.1*REAL(D1MACH(3))) XSML = SQRT(4.0D0*D1MACH(3)) XMAXT = -LOG(D1MACH(1)) XMAX = XMAXT - 0.5D0*XMAXT*LOG(XMAXT)/(XMAXT+0.5D0) end if FIRST = .FALSE. ! if (X <= 0.D0) call XERMSG ('SLATEC', 'DBESK0', & 'X IS ZERO OR NEGATIVE', 2, 2) if (X > 2.0D0) go to 20 ! Y = 0.D0 if (X > XSML) Y = X*X DBESK0 = -LOG(0.5D0*X)*DBESI0(X) - 0.25D0 + DCSEVL (.5D0*Y-1.D0, & BK0CS, NTK0) return ! 20 DBESK0 = 0.D0 if (X > XMAX) call XERMSG ('SLATEC', 'DBESK0', & 'X SO BIG K0 UNDERFLOWS', 1, 1) if (X > XMAX) RETURN ! DBESK0 = EXP(-X) * DBSK0E(X) ! return end DOUBLE PRECISION FUNCTION DBESK1 (X) ! !! DBESK1 computes the modified (hyperbolic) Bessel function of the ... ! third kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE DOUBLE PRECISION (BESK1-S, DBESK1-D) !***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, ! THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBESK1(X) calculates the double precision modified (hyperbolic) ! Bessel function of the third kind of order one for double precision ! argument X. The argument must be large enough that the result does ! not overflow and small enough that the result does not underflow. ! ! Series for BK1 on the interval 0. to 4.00000E+00 ! with weighted error 9.16E-32 ! log weighted error 31.04 ! significant figures required 30.61 ! decimal places required 31.64 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DBESI1, DBSK1E, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBESK1 DOUBLE PRECISION X, BK1CS(16), XMAX, XMAXT, XMIN, XSML, Y, & D1MACH, DCSEVL, DBESI1, DBSK1E LOGICAL FIRST SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST DATA BK1CS( 1) / +.25300227338947770532531120868533D-1 / DATA BK1CS( 2) / -.35315596077654487566723831691801D+0 / DATA BK1CS( 3) / -.12261118082265714823479067930042D+0 / DATA BK1CS( 4) / -.69757238596398643501812920296083D-2 / DATA BK1CS( 5) / -.17302889575130520630176507368979D-3 / DATA BK1CS( 6) / -.24334061415659682349600735030164D-5 / DATA BK1CS( 7) / -.22133876307347258558315252545126D-7 / DATA BK1CS( 8) / -.14114883926335277610958330212608D-9 / DATA BK1CS( 9) / -.66669016941993290060853751264373D-12 / DATA BK1CS( 10) / -.24274498505193659339263196864853D-14 / DATA BK1CS( 11) / -.70238634793862875971783797120000D-17 / DATA BK1CS( 12) / -.16543275155100994675491029333333D-19 / DATA BK1CS( 13) / -.32338347459944491991893333333333D-22 / DATA BK1CS( 14) / -.53312750529265274999466666666666D-25 / DATA BK1CS( 15) / -.75130407162157226666666666666666D-28 / DATA BK1CS( 16) / -.91550857176541866666666666666666D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBESK1 if (FIRST) THEN NTK1 = INITDS (BK1CS, 16, 0.1*REAL(D1MACH(3))) XMIN = EXP(MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0) XSML = SQRT(4.0D0*D1MACH(3)) XMAXT = -LOG(D1MACH(1)) XMAX = XMAXT - 0.5D0*XMAXT*LOG(XMAXT)/(XMAXT+0.5D0) end if FIRST = .FALSE. ! if (X <= 0.D0) call XERMSG ('SLATEC', 'DBESK1', & 'X IS ZERO OR NEGATIVE', 2, 2) if (X > 2.0D0) go to 20 ! if (X < XMIN) call XERMSG ('SLATEC', 'DBESK1', & 'X SO SMALL K1 OVERFLOWS', 3, 2) Y = 0.D0 if (X > XSML) Y = X*X DBESK1 = LOG(0.5D0*X)*DBESI1(X) + (0.75D0 + DCSEVL (.5D0*Y-1.D0, & BK1CS, NTK1))/X return ! 20 DBESK1 = 0.D0 if (X > XMAX) call XERMSG ('SLATEC', 'DBESK1', & 'X SO BIG K1 UNDERFLOWS', 1, 1) if (X > XMAX) RETURN ! DBESK1 = EXP(-X) * DBSK1E(X) ! return end subroutine DBESK (X, FNU, KODE, N, Y, NZ) ! !! DBESK implements forward recursion on the three term recursion ... ! relation for a sequence of non-negative order Bessel ! functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions ! EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive ! X and non-negative orders FNU. ! !***LIBRARY SLATEC !***CATEGORY C10B3 !***TYPE DOUBLE PRECISION (BESK-S, DBESK-D) !***KEYWORDS K BESSEL FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract **** a double precision routine **** ! DBESK implements forward recursion on the three term ! recursion relation for a sequence of non-negative order Bessel ! functions K/sub(FNU+I-1)/(X), or scaled Bessel functions ! EXP(X)*K/sub(FNU+I-1)/(X), I=1,..,N for real X > 0.0D0 and ! non-negative orders FNU. If FNU < NULIM, orders FNU and ! FNU+1 are obtained from DBSKNU to start the recursion. If ! FNU >= NULIM, the uniform asymptotic expansion is used for ! orders FNU and FNU+1 to start the recursion. NULIM is 35 or ! 70 depending on whether N=1 or N >= 2. Under and overflow ! tests are made on the leading term of the asymptotic expansion ! before any extensive computation is done. ! ! The maximum number of significant digits obtainable ! is the smaller of 14 and the number of digits carried in ! double precision arithmetic. ! ! Description of Arguments ! ! Input X,FNU are double precision ! X - X > 0.0D0 ! FNU - order of the initial K function, FNU >= 0.0D0 ! KODE - a parameter to indicate the scaling option ! KODE=1 returns Y(I)= K/sub(FNU+I-1)/(X), ! I=1,...,N ! KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), ! I=1,...,N ! N - number of members in the sequence, N >= 1 ! ! Output Y is double precision ! Y - a vector whose first N components contain values ! for the sequence ! Y(I)= k/sub(FNU+I-1)/(X), I=1,...,N or ! Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N ! depending on KODE ! NZ - number of components of Y set to zero due to ! underflow with KODE=1, ! NZ=0 , normal return, computation completed ! NZ /= 0, first NZ components of Y set to zero ! due to underflow, Y(I)=0.0D0, I=1,...,NZ ! ! Error Conditions ! Improper input arguments - a fatal error ! Overflow - a fatal error ! Underflow with KODE=1 - a non-fatal error (NZ /= 0) ! !***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate ! or Large Orders, NPL Mathematical Tables 6, Her ! Majesty's Stationery Office, London, 1962. ! N. M. Temme, On the numerical evaluation of the modified ! Bessel function of the third kind, Journal of ! Computational Physics 19, (1975), pp. 324-337. !***ROUTINES CALLED D1MACH, DASYIK, DBESK0, DBESK1, DBSK0E, DBSK1E, ! DBSKNU, I1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790201 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBESK ! INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ INTEGER I1MACH DOUBLE PRECISION CN,DNU,ELIM,ETX,FLGIK,FN,FNN,FNU,GLN,GNU,RTZ, & S, S1, S2, T, TM, TRX, W, X, XLIM, Y, ZN DOUBLE PRECISION DBESK0, DBESK1, DBSK1E, DBSK0E, D1MACH DIMENSION W(2), NULIM(2), Y(*) SAVE NULIM DATA NULIM(1),NULIM(2) / 35 , 70 / !***FIRST EXECUTABLE STATEMENT DBESK NN = -I1MACH(15) ELIM = 2.303D0*(NN*D1MACH(5)-3.0D0) XLIM = D1MACH(1)*1.0D+3 if (KODE < 1 .OR. KODE > 2) go to 280 if (FNU < 0.0D0) go to 290 if (X <= 0.0D0) go to 300 if (X < XLIM) go to 320 if (N < 1) go to 310 ETX = KODE - 1 ! ! ND IS A DUMMY VARIABLE FOR N ! GNU IS A DUMMY VARIABLE FOR FNU ! NZ = NUMBER OF UNDERFLOWS ON KODE=1 ! ND = N NZ = 0 NUD = INT(FNU) DNU = FNU - NUD GNU = FNU NN = MIN(2,ND) FN = FNU + N - 1 FNN = FN if (FN < 2.0D0) go to 150 ! ! OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) ! FOR THE LAST ORDER, FNU+N-1 >= NULIM ! ZN = X/FN if (ZN == 0.0D0) go to 320 RTZ = SQRT(1.0D0+ZN*ZN) GLN = LOG((1.0D0+RTZ)/ZN) T = RTZ*(1.0D0-ETX) + ETX/(ZN+RTZ) CN = -FN*(T-GLN) if (CN > ELIM) go to 320 if (NUD < NULIM(NN)) go to 30 if (NN == 1) go to 20 10 CONTINUE ! ! UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) ! FOR THE FIRST ORDER, FNU >= NULIM ! FN = GNU ZN = X/FN RTZ = SQRT(1.0D0+ZN*ZN) GLN = LOG((1.0D0+RTZ)/ZN) T = RTZ*(1.0D0-ETX) + ETX/(ZN+RTZ) CN = -FN*(T-GLN) 20 CONTINUE if (CN < -ELIM) go to 230 ! ! ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1 >= NULIM ! FLGIK = -1.0D0 call DASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y) if (NN == 1) go to 240 TRX = 2.0D0/X TM = (GNU+GNU+2.0D0)/X go to 130 ! 30 CONTINUE if (KODE == 2) go to 40 ! ! UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X) ! FOR ORDER DNU ! if (X > ELIM) go to 230 40 CONTINUE if (DNU /= 0.0D0) go to 80 if (KODE == 2) go to 50 S1 = DBESK0(X) go to 60 50 S1 = DBSK0E(X) 60 CONTINUE if (NUD == 0 .AND. ND == 1) go to 120 if (KODE == 2) go to 70 S2 = DBESK1(X) go to 90 70 S2 = DBSK1E(X) go to 90 80 CONTINUE NB = 2 if (NUD == 0 .AND. ND == 1) NB = 1 call DBSKNU(X, DNU, KODE, NB, W, NZ) S1 = W(1) if (NB == 1) go to 120 S2 = W(2) 90 CONTINUE TRX = 2.0D0/X TM = (DNU+DNU+2.0D0)/X ! FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) if (ND == 1) NUD = NUD - 1 if (NUD > 0) go to 100 if (ND > 1) go to 120 S1 = S2 go to 120 100 CONTINUE DO 110 I=1,NUD S = S2 S2 = TM*S2 + S1 S1 = S TM = TM + TRX 110 CONTINUE if (ND == 1) S1 = S2 120 CONTINUE Y(1) = S1 if (ND == 1) go to 240 Y(2) = S2 130 CONTINUE if (ND == 2) go to 240 ! FORWARD RECUR FROM FNU+2 TO FNU+N-1 DO 140 I=3,ND Y(I) = TM*Y(I-1) + Y(I-2) TM = TM + TRX 140 CONTINUE go to 240 ! 150 CONTINUE ! UNDERFLOW TEST FOR KODE=1 if (KODE == 2) go to 160 if (X > ELIM) go to 230 160 CONTINUE ! OVERFLOW TEST if (FN <= 1.0D0) go to 170 if (-FN*(LOG(X)-0.693D0) > ELIM) go to 320 170 CONTINUE if (DNU == 0.0D0) go to 180 call DBSKNU(X, FNU, KODE, ND, Y, MZ) go to 240 180 CONTINUE J = NUD if (J == 1) go to 210 J = J + 1 if (KODE == 2) go to 190 Y(J) = DBESK0(X) go to 200 190 Y(J) = DBSK0E(X) 200 if (ND == 1) go to 240 J = J + 1 210 if (KODE == 2) go to 220 Y(J) = DBESK1(X) go to 240 220 Y(J) = DBSK1E(X) go to 240 ! ! UPDATE PARAMETERS ON UNDERFLOW ! 230 CONTINUE NUD = NUD + 1 ND = ND - 1 if (ND == 0) go to 240 NN = MIN(2,ND) GNU = GNU + 1.0D0 if (FNN < 2.0D0) go to 230 if (NUD < NULIM(NN)) go to 230 go to 10 240 CONTINUE NZ = N - ND if (NZ == 0) RETURN if (ND == 0) go to 260 DO 250 I=1,ND J = N - I + 1 K = ND - I + 1 Y(J) = Y(K) 250 CONTINUE 260 CONTINUE DO 270 I=1,NZ Y(I) = 0.0D0 270 CONTINUE return ! ! ! 280 CONTINUE call XERMSG ('SLATEC', 'DBESK', & 'SCALING OPTION, KODE, NOT 1 OR 2', 2, 1) return 290 CONTINUE call XERMSG ('SLATEC', 'DBESK', 'ORDER, FNU, LESS THAN ZERO', 2, & 1) return 300 CONTINUE call XERMSG ('SLATEC', 'DBESK', 'X LESS THAN OR EQUAL TO ZERO', & 2, 1) return 310 CONTINUE call XERMSG ('SLATEC', 'DBESK', 'N LESS THAN ONE', 2, 1) return 320 CONTINUE call XERMSG ('SLATEC', 'DBESK', & 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) return end subroutine DBESKS (XNU, X, NIN, BK) ! !! DBESKS computes a sequence of modified Bessel functions of the ... ! third kind of fractional order. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B3 !***TYPE DOUBLE PRECISION (BESKS-S, DBESKS-D) !***KEYWORDS FNLIB, FRACTIONAL ORDER, MODIFIED BESSEL FUNCTION, ! SEQUENCE OF BESSEL FUNCTIONS, SPECIAL FUNCTIONS, ! THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBESKS computes a sequence of modified Bessel functions of the third ! kind of order XNU + I at X, where X > 0, XNU lies in (-1,1), ! and I = 0, 1, ... , NIN - 1, if NIN is positive and I = 0, 1, ... , ! NIN + 1, if NIN is negative. On return, the vector BK(.) contains ! the results at X for order starting at XNU. XNU, X, and BK are ! double precision. NIN is an integer. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DBSKES, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBESKS DOUBLE PRECISION XNU, X, BK(*), EXPXI, XMAX, D1MACH SAVE XMAX DATA XMAX / 0.D0 / !***FIRST EXECUTABLE STATEMENT DBESKS if (XMAX == 0.D0) XMAX = -LOG (D1MACH(1)) ! if (X > XMAX) call XERMSG ('SLATEC', 'DBESKS', & 'X SO BIG BESSEL K UNDERFLOWS', 1, 2) ! call DBSKES (XNU, X, NIN, BK) ! EXPXI = EXP (-X) N = ABS (NIN) DO 20 I=1,N BK(I) = EXPXI * BK(I) 20 CONTINUE ! return end DOUBLE PRECISION FUNCTION DBESY0 (X) ! !! DBESY0 computes the Bessel function of the second kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10A1 !***TYPE DOUBLE PRECISION (BESY0-S, DBESY0-D) !***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ZERO, SECOND KIND, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBESY0(X) calculates the double precision Bessel function of the ! second kind of order zero for double precision argument X. ! ! Series for BY0 on the interval 0. to 1.60000E+01 ! with weighted error 8.14E-32 ! log weighted error 31.09 ! significant figures required 30.31 ! decimal places required 31.73 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9B0MP, DBESJ0, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBESY0 DOUBLE PRECISION X, BY0CS(19), AMPL, THETA, TWODPI, XSML, & Y, D1MACH, DCSEVL, DBESJ0 LOGICAL FIRST SAVE BY0CS, TWODPI, NTY0, XSML, FIRST DATA BY0CS( 1) / -.1127783939286557321793980546028D-1 / DATA BY0CS( 2) / -.1283452375604203460480884531838D+0 / DATA BY0CS( 3) / -.1043788479979424936581762276618D+0 / DATA BY0CS( 4) / +.2366274918396969540924159264613D-1 / DATA BY0CS( 5) / -.2090391647700486239196223950342D-2 / DATA BY0CS( 6) / +.1039754539390572520999246576381D-3 / DATA BY0CS( 7) / -.3369747162423972096718775345037D-5 / DATA BY0CS( 8) / +.7729384267670667158521367216371D-7 / DATA BY0CS( 9) / -.1324976772664259591443476068964D-8 / DATA BY0CS( 10) / +.1764823261540452792100389363158D-10 / DATA BY0CS( 11) / -.1881055071580196200602823012069D-12 / DATA BY0CS( 12) / +.1641865485366149502792237185749D-14 / DATA BY0CS( 13) / -.1195659438604606085745991006720D-16 / DATA BY0CS( 14) / +.7377296297440185842494112426666D-19 / DATA BY0CS( 15) / -.3906843476710437330740906666666D-21 / DATA BY0CS( 16) / +.1795503664436157949829120000000D-23 / DATA BY0CS( 17) / -.7229627125448010478933333333333D-26 / DATA BY0CS( 18) / +.2571727931635168597333333333333D-28 / DATA BY0CS( 19) / -.8141268814163694933333333333333D-31 / DATA TWODPI / 0.636619772367581343075535053490057D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBESY0 if (FIRST) THEN NTY0 = INITDS (BY0CS, 19, 0.1*REAL(D1MACH(3))) XSML = SQRT(4.0D0*D1MACH(3)) end if FIRST = .FALSE. ! if (X <= 0.D0) call XERMSG ('SLATEC', 'DBESY0', & 'X IS ZERO OR NEGATIVE', 1, 2) if (X > 4.0D0) go to 20 ! Y = 0.D0 if (X > XSML) Y = X*X DBESY0 = TWODPI*LOG(0.5D0*X)*DBESJ0(X) + .375D0 + DCSEVL ( & .125D0*Y-1.D0, BY0CS, NTY0) return ! 20 call D9B0MP (X, AMPL, THETA) DBESY0 = AMPL * SIN(THETA) return ! end DOUBLE PRECISION FUNCTION DBESY1 (X) ! !! DBESY1 computes the Bessel function of the second kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10A1 !***TYPE DOUBLE PRECISION (BESY1-S, DBESY1-D) !***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBESY1(X) calculates the double precision Bessel function of the ! second kind of order for double precision argument X. ! ! Series for BY1 on the interval 0. to 1.60000E+01 ! with weighted error 8.65E-33 ! log weighted error 32.06 ! significant figures required 32.17 ! decimal places required 32.71 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9B1MP, DBESJ1, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBESY1 DOUBLE PRECISION X, BY1CS(20), AMPL, THETA, TWODPI, XMIN, XSML, & Y, D1MACH, DCSEVL, DBESJ1 LOGICAL FIRST SAVE BY1CS, TWODPI, NTY1, XMIN, XSML, FIRST DATA BY1CS( 1) / +.320804710061190862932352018628015D-1 / DATA BY1CS( 2) / +.126270789743350044953431725999727D+1 / DATA BY1CS( 3) / +.649996189992317500097490637314144D-2 / DATA BY1CS( 4) / -.893616452886050411653144160009712D-1 / DATA BY1CS( 5) / +.132508812217570954512375510370043D-1 / DATA BY1CS( 6) / -.897905911964835237753039508298105D-3 / DATA BY1CS( 7) / +.364736148795830678242287368165349D-4 / DATA BY1CS( 8) / -.100137438166600055549075523845295D-5 / DATA BY1CS( 9) / +.199453965739017397031159372421243D-7 / DATA BY1CS( 10) / -.302306560180338167284799332520743D-9 / DATA BY1CS( 11) / +.360987815694781196116252914242474D-11 / DATA BY1CS( 12) / -.348748829728758242414552947409066D-13 / DATA BY1CS( 13) / +.278387897155917665813507698517333D-15 / DATA BY1CS( 14) / -.186787096861948768766825352533333D-17 / DATA BY1CS( 15) / +.106853153391168259757070336000000D-19 / DATA BY1CS( 16) / -.527472195668448228943872000000000D-22 / DATA BY1CS( 17) / +.227019940315566414370133333333333D-24 / DATA BY1CS( 18) / -.859539035394523108693333333333333D-27 / DATA BY1CS( 19) / +.288540437983379456000000000000000D-29 / DATA BY1CS( 20) / -.864754113893717333333333333333333D-32 / DATA TWODPI / 0.636619772367581343075535053490057D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBESY1 if (FIRST) THEN NTY1 = INITDS (BY1CS, 20, 0.1*REAL(D1MACH(3))) ! XMIN = 1.571D0 * EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + & 0.01D0) XSML = SQRT(4.0D0*D1MACH(3)) end if FIRST = .FALSE. ! if (X <= 0.D0) call XERMSG ('SLATEC', 'DBESY1', & 'X IS ZERO OR NEGATIVE', 1, 2) if (X > 4.0D0) go to 20 ! if (X < XMIN) call XERMSG ('SLATEC', 'DBESY1', & 'X SO SMALL Y1 OVERFLOWS', 3, 2) Y = 0.D0 if (X > XSML) Y = X*X DBESY1 = TWODPI * LOG(0.5D0*X)*DBESJ1(X) + (0.5D0 + & DCSEVL (.125D0*Y-1.D0, BY1CS, NTY1))/X return ! 20 call D9B1MP (X, AMPL, THETA) DBESY1 = AMPL * SIN(THETA) return ! end subroutine DBESY (X, FNU, N, Y) ! !! DBESY implements forward recursion on the three term recursion ... ! relation for a sequence of non-negative order Bessel ... ! functions Y/SUB(FNU+I-1)/(X), I=1,...,N for real, positive ... ! X and non-negative orders FNU. ! !***LIBRARY SLATEC !***CATEGORY C10A3 !***TYPE DOUBLE PRECISION (BESY-S, DBESY-D) !***KEYWORDS SPECIAL FUNCTIONS, Y BESSEL FUNCTION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract **** a double precision routine **** ! DBESY implements forward recursion on the three term ! recursion relation for a sequence of non-negative order Bessel ! functions Y/sub(FNU+I-1)/(X), I=1,N for real X > 0.0D0 and ! non-negative orders FNU. If FNU < NULIM, orders FNU and ! FNU+1 are obtained from DBSYNU which computes by a power ! series for X <= 2, the K Bessel function of an imaginary ! argument for 2 < X <= 20 and the asymptotic expansion for ! X > 20. ! ! If FNU >= NULIM, the uniform asymptotic expansion is coded ! in DASYJY for orders FNU and FNU+1 to start the recursion. ! NULIM is 70 or 100 depending on whether N=1 or N >= 2. An ! overflow test is made on the leading term of the asymptotic ! expansion before any extensive computation is done. ! ! The maximum number of significant digits obtainable ! is the smaller of 14 and the number of digits carried in ! double precision arithmetic. ! ! Description of Arguments ! ! Input ! X - X > 0.0D0 ! FNU - order of the initial Y function, FNU >= 0.0D0 ! N - number of members in the sequence, N >= 1 ! ! Output ! Y - a vector whose first N components contain values ! for the sequence Y(I)=Y/sub(FNU+I-1)/(X), I=1,N. ! ! Error Conditions ! Improper input arguments - a fatal error ! Overflow - a fatal error ! !***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate ! or Large Orders, NPL Mathematical Tables 6, Her ! Majesty's Stationery Office, London, 1962. ! N. M. Temme, On the numerical evaluation of the modified ! Bessel function of the third kind, Journal of ! Computational Physics 19, (1975), pp. 324-337. ! N. M. Temme, On the numerical evaluation of the ordinary ! Bessel function of the second kind, Journal of ! Computational Physics 21, (1976), pp. 343-350. !***ROUTINES CALLED D1MACH, DASYJY, DBESY0, DBESY1, DBSYNU, DYAIRY, ! I1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBESY ! EXTERNAL DYAIRY INTEGER I, IFLW, J, N, NB, ND, NN, NUD, NULIM INTEGER I1MACH DOUBLE PRECISION AZN,CN,DNU,ELIM,FLGJY,FN,FNU,RAN,S,S1,S2,TM,TRX, & W,WK,W2N,X,XLIM,XXN,Y DOUBLE PRECISION DBESY0, DBESY1, D1MACH DIMENSION W(2), NULIM(2), Y(*), WK(7) SAVE NULIM DATA NULIM(1),NULIM(2) / 70 , 100 / !***FIRST EXECUTABLE STATEMENT DBESY NN = -I1MACH(15) ELIM = 2.303D0*(NN*D1MACH(5)-3.0D0) XLIM = D1MACH(1)*1.0D+3 if (FNU < 0.0D0) go to 140 if (X <= 0.0D0) go to 150 if (X < XLIM) go to 170 if (N < 1) go to 160 ! ! ND IS A DUMMY VARIABLE FOR N ! ND = N NUD = INT(FNU) DNU = FNU - NUD NN = MIN(2,ND) FN = FNU + N - 1 if (FN < 2.0D0) go to 100 ! ! OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) ! FOR THE LAST ORDER, FNU+N-1 >= NULIM ! XXN = X/FN W2N = 1.0D0-XXN*XXN if ( W2N <= 0.0D0) go to 10 RAN = SQRT(W2N) AZN = LOG((1.0D0+RAN)/XXN) - RAN CN = FN*AZN if ( CN > ELIM) go to 170 10 CONTINUE if (NUD < NULIM(NN)) go to 20 ! ! ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1 >= NULIM ! FLGJY = -1.0D0 call DASYJY(DYAIRY,X,FNU,FLGJY,NN,Y,WK,IFLW) if ( IFLW /= 0) go to 170 if (NN == 1) RETURN TRX = 2.0D0/X TM = (FNU+FNU+2.0D0)/X go to 80 ! 20 CONTINUE if (DNU /= 0.0D0) go to 30 S1 = DBESY0(X) if (NUD == 0 .AND. ND == 1) go to 70 S2 = DBESY1(X) go to 40 30 CONTINUE NB = 2 if (NUD == 0 .AND. ND == 1) NB = 1 call DBSYNU(X, DNU, NB, W) S1 = W(1) if (NB == 1) go to 70 S2 = W(2) 40 CONTINUE TRX = 2.0D0/X TM = (DNU+DNU+2.0D0)/X ! FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) if (ND == 1) NUD = NUD - 1 if (NUD > 0) go to 50 if (ND > 1) go to 70 S1 = S2 go to 70 50 CONTINUE DO 60 I=1,NUD S = S2 S2 = TM*S2 - S1 S1 = S TM = TM + TRX 60 CONTINUE if (ND == 1) S1 = S2 70 CONTINUE Y(1) = S1 if (ND == 1) RETURN Y(2) = S2 80 CONTINUE if (ND == 2) RETURN ! FORWARD RECUR FROM FNU+2 TO FNU+N-1 DO 90 I=3,ND Y(I) = TM*Y(I-1) - Y(I-2) TM = TM + TRX 90 CONTINUE return ! 100 CONTINUE ! OVERFLOW TEST if (FN <= 1.0D0) go to 110 if (-FN*(LOG(X)-0.693D0) > ELIM) go to 170 110 CONTINUE if (DNU == 0.0D0) go to 120 call DBSYNU(X, FNU, ND, Y) return 120 CONTINUE J = NUD if (J == 1) go to 130 J = J + 1 Y(J) = DBESY0(X) if (ND == 1) RETURN J = J + 1 130 CONTINUE Y(J) = DBESY1(X) if (ND == 1) RETURN TRX = 2.0D0/X TM = TRX go to 80 ! ! ! 140 CONTINUE call XERMSG ('SLATEC', 'DBESY', 'ORDER, FNU, LESS THAN ZERO', 2, & 1) return 150 CONTINUE call XERMSG ('SLATEC', 'DBESY', 'X LESS THAN OR EQUAL TO ZERO', & 2, 1) return 160 CONTINUE call XERMSG ('SLATEC', 'DBESY', 'N LESS THAN ONE', 2, 1) return 170 CONTINUE call XERMSG ('SLATEC', 'DBESY', & 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) return end DOUBLE PRECISION FUNCTION DBETA (A, B) ! !! DBETA computes the complete Beta function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7B !***TYPE DOUBLE PRECISION (BETA-S, DBETA-D, CBETA-C) !***KEYWORDS COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBETA(A,B) calculates the double precision complete beta function ! for double precision arguments A and B. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DGAMLM, DGAMMA, DLBETA, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE DBETA DOUBLE PRECISION A, B, ALNSML, XMAX, XMIN, DLBETA, DGAMMA, D1MACH LOGICAL FIRST EXTERNAL DGAMMA SAVE XMAX, ALNSML, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBETA if (FIRST) THEN call DGAMLM (XMIN, XMAX) ALNSML = LOG (D1MACH(1)) end if FIRST = .FALSE. ! if (A <= 0.D0 .OR. B <= 0.D0) call XERMSG ('SLATEC', 'DBETA', & 'BOTH ARGUMENTS MUST BE GT 0', 2, 2) ! if (A+B < XMAX) DBETA = DGAMMA(A)*DGAMMA(B)/DGAMMA(A+B) if (A+B < XMAX) RETURN ! DBETA = DLBETA (A, B) if (DBETA < ALNSML) go to 20 DBETA = EXP (DBETA) return ! 20 DBETA = 0.D0 call XERMSG ('SLATEC', 'DBETA', & 'A AND/OR B SO BIG BETA UNDERFLOWS', 1, 1) return ! end FUNCTION DBETAI (X, PIN, QIN) ! !! DBETAI calculates the incomplete Beta function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7F !***TYPE DOUBLE PRECISION (BETAI-S, DBETAI-D) !***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBETAI calculates the DOUBLE PRECISION incomplete beta function. ! ! The incomplete beta function ratio is the probability that a ! random variable from a beta distribution having parameters PIN and ! QIN will be less than or equal to X. ! ! -- Input Arguments -- All arguments are DOUBLE PRECISION. ! X upper limit of integration. X must be in (0,1) inclusive. ! PIN first beta distribution parameter. PIN must be > 0.0. ! QIN second beta distribution parameter. QIN must be > 0.0. ! !***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm ! 179, Communications of the ACM 17, 3 (March 1974), ! pp. 156. !***ROUTINES CALLED D1MACH, DLBETA, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920528 DESCRIPTION and REFERENCES sections revised. (WRB) !***END PROLOGUE DBETAI DOUBLE PRECISION DBETAI DOUBLE PRECISION X, PIN, QIN, ALNEPS, ALNSML, C, EPS, FINSUM, P, & PS, Q, SML, TERM, XB, XI, Y, D1MACH, DLBETA, P1 LOGICAL FIRST SAVE EPS, ALNEPS, SML, ALNSML, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBETAI if (FIRST) THEN EPS = D1MACH(3) ALNEPS = LOG (EPS) SML = D1MACH(1) ALNSML = LOG (SML) end if FIRST = .FALSE. ! if (X < 0.D0 .OR. X > 1.D0) call XERMSG ('SLATEC', 'DBETAI', & 'X IS NOT IN THE RANGE (0,1)', 1, 2) if (PIN <= 0.D0 .OR. QIN <= 0.D0) call XERMSG ('SLATEC', & 'DBETAI', 'P AND/OR Q IS LE ZERO', 2, 2) ! Y = X P = PIN Q = QIN if (Q <= P .AND. X < 0.8D0) go to 20 if (X < 0.2D0) go to 20 Y = 1.0D0 - Y P = QIN Q = PIN ! 20 if ((P+Q)*Y/(P+1.D0) < EPS) go to 80 ! ! EVALUATE THE INFINITE SUM FIRST. TERM WILL EQUAL ! Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) . ! PS = Q - AINT(Q) if (PS == 0.D0) PS = 1.0D0 XB = P*LOG(Y) - DLBETA(PS,P) - LOG(P) DBETAI = 0.0D0 if (XB < ALNSML) go to 40 ! DBETAI = EXP (XB) TERM = DBETAI*P if (PS == 1.0D0) go to 40 N = MAX (ALNEPS/LOG(Y), 4.0D0) DO 30 I=1,N XI = I TERM = TERM * (XI-PS)*Y/XI DBETAI = DBETAI + TERM/(P+XI) 30 CONTINUE ! ! NOW EVALUATE THE FINITE SUM, MAYBE. ! 40 if (Q <= 1.0D0) go to 70 ! XB = P*LOG(Y) + Q*LOG(1.0D0-Y) - DLBETA(P,Q) - LOG(Q) IB = MAX (XB/ALNSML, 0.0D0) TERM = EXP(XB - IB*ALNSML) C = 1.0D0/(1.D0-Y) P1 = Q*C/(P+Q-1.D0) ! FINSUM = 0.0D0 N = Q if (Q == DBLE(N)) N = N - 1 DO 50 I=1,N if (P1 <= 1.0D0 .AND. TERM/EPS <= FINSUM) go to 60 XI = I TERM = (Q-XI+1.0D0)*C*TERM/(P+Q-XI) ! if (TERM > 1.0D0) IB = IB - 1 if (TERM > 1.0D0) TERM = TERM*SML ! if (IB == 0) FINSUM = FINSUM + TERM 50 CONTINUE ! 60 DBETAI = DBETAI + FINSUM 70 if (Y /= X .OR. P /= PIN) DBETAI = 1.0D0 - DBETAI DBETAI = MAX (MIN (DBETAI, 1.0D0), 0.0D0) return ! 80 DBETAI = 0.0D0 XB = P*LOG(MAX(Y,SML)) - LOG(P) - DLBETA(P,Q) if (XB > ALNSML .AND. Y /= 0.0D0) DBETAI = EXP(XB) if (Y /= X .OR. P /= PIN) DBETAI = 1.0D0 - DBETAI ! return end subroutine DBFQAD (F, T, BCOEF, N, K, ID, X1, X2, TOL, QUAD, IERR, & WORK) ! !! DBFQAD computes the integral of a product of a function and a... ! derivative of a K-th order B-spline. ! !***LIBRARY SLATEC !***CATEGORY H2A2A1, E3, K6 !***TYPE DOUBLE PRECISION (BFQAD-S, DBFQAD-D) !***KEYWORDS INTEGRAL OF B-SPLINE, QUADRATURE !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract **** a double precision routine **** ! ! DBFQAD computes the integral on (X1,X2) of a product of a ! function F and the ID-th derivative of a K-th order B-spline, ! using the B-representation (T,BCOEF,N,K). (X1,X2) must be a ! subinterval of T(K) <= X <= T(N+1). An integration rou- ! tine, DBSGQ8 (a modification of GAUS8), integrates the product ! on subintervals of (X1,X2) formed by included (distinct) knots ! ! The maximum number of significant digits obtainable in ! DBSQAD is the smaller of 18 and the number of digits ! carried in double precision arithmetic. ! ! Description of Arguments ! Input F,T,BCOEF,X1,X2,TOL are double precision ! F - external function of one argument for the ! integrand BF(X)=F(X)*DBVALU(T,BCOEF,N,K,ID,X,INBV, ! WORK) ! T - knot array of length N+K ! BCOEF - coefficient array of length N ! N - length of coefficient array ! K - order of B-spline, K >= 1 ! ID - order of the spline derivative, 0 <= ID <= K-1 ! ID=0 gives the spline function ! X1,X2 - end points of quadrature interval in ! T(K) <= X <= T(N+1) ! TOL - desired accuracy for the quadrature, suggest ! 10.*DTOL < TOL <= .1 where DTOL is the maximum ! of 1.0D-18 and double precision unit roundoff for ! the machine = D1MACH(4) ! ! Output QUAD,WORK are double precision ! QUAD - integral of BF(X) on (X1,X2) ! IERR - a status code ! IERR=1 normal return ! 2 some quadrature on (X1,X2) does not meet ! the requested tolerance. ! WORK - work vector of length 3*K ! ! Error Conditions ! Improper input is a fatal error ! Some quadrature fails to meet the requested tolerance ! !***REFERENCES D. E. Amos, Quadrature subroutines for splines and ! B-splines, Report SAND79-1825, Sandia Laboratories, ! December 1979. !***ROUTINES CALLED D1MACH, DBSGQ8, DINTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBFQAD ! ! INTEGER ID, IERR, IFLG, ILO, IL1, IL2, K, LEFT, MFLAG, N, NPK, NP1 DOUBLE PRECISION A,AA,ANS,B,BB,BCOEF,Q,QUAD,T,TA,TB,TOL,WORK,WTOL, & X1, X2 DOUBLE PRECISION D1MACH, F DIMENSION T(*), BCOEF(*), WORK(*) EXTERNAL F !***FIRST EXECUTABLE STATEMENT DBFQAD IERR = 1 QUAD = 0.0D0 if ( K < 1) go to 100 if ( N < K) go to 105 if ( ID < 0 .OR. ID >= K) go to 110 WTOL = D1MACH(4) WTOL = MAX(WTOL,1.D-18) if (TOL < WTOL .OR. TOL > 0.1D0) go to 30 AA = MIN(X1,X2) BB = MAX(X1,X2) if (AA < T(K)) go to 20 NP1 = N + 1 if (BB > T(NP1)) go to 20 if (AA == BB) RETURN NPK = N + K ! ILO = 1 call DINTRV(T, NPK, AA, ILO, IL1, MFLAG) call DINTRV(T, NPK, BB, ILO, IL2, MFLAG) if (IL2 >= NP1) IL2 = N INBV = 1 Q = 0.0D0 DO 10 LEFT=IL1,IL2 TA = T(LEFT) TB = T(LEFT+1) if (TA == TB) go to 10 A = MAX(AA,TA) B = MIN(BB,TB) call DBSGQ8(F,T,BCOEF,N,K,ID,A,B,INBV,TOL,ANS,IFLG,WORK) if (IFLG > 1) IERR = 2 Q = Q + ANS 10 CONTINUE if (X1 > X2) Q = -Q QUAD = Q return ! ! 20 CONTINUE call XERMSG ('SLATEC', 'DBFQAD', & 'X1 OR X2 OR BOTH DO NOT SATISFY T(K) <= X <= T(N+1)', 2, 1) return 30 CONTINUE call XERMSG ('SLATEC', 'DBFQAD', & 'TOL IS LESS DTOL OR GREATER THAN 0.1', 2, 1) return 100 CONTINUE call XERMSG ('SLATEC', 'DBFQAD', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'DBFQAD', 'N DOES NOT SATISFY N >= K', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'DBFQAD', & 'ID DOES NOT SATISFY 0 <= ID < K', 2, 1) return end subroutine DBHIN (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) ! !! DBHIN reads a Sparse Linear System in the Boeing/Harwell Format. ! ! The matrix is read in and if the right hand side is also ! present in the input file then it too is read in. The ! matrix is then modified to be in the SLAP Column format. !***LIBRARY SLATEC (SLAP) !***CATEGORY N1 !***TYPE DOUBLE PRECISION (SBHIN-S, DBHIN-D) !***KEYWORDS LINEAR SYSTEM, MATRIX READ, SLAP SPARSE !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB ! DOUBLE PRECISION A(NELT), SOLN(N), RHS(N) ! ! call DBHIN( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) ! ! *Arguments: ! N :OUT Integer ! Order of the Matrix. ! NELT :INOUT Integer. ! On input NELT is the maximum number of non-zeros that ! can be stored in the IA, JA, A arrays. ! On output NELT is the number of non-zeros stored in A. ! IA :OUT Integer IA(NELT). ! JA :OUT Integer JA(NELT). ! A :OUT Double Precision A(NELT). ! On output these arrays hold the matrix A in the SLAP ! Triad format. See "Description", below. ! ISYM :OUT Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! SOLN :OUT Double Precision SOLN(N). ! The solution to the linear system, if present. This array ! is accessed if and only if JOB is set to read it in, see ! below. If the user requests that SOLN be read in, but it is ! not in the file, then it is simply zeroed out. ! RHS :OUT Double Precision RHS(N). ! The right hand side vector. This array is accessed if and ! only if JOB is set to read it in, see below. ! If the user requests that RHS be read in, but it is not in ! the file, then it is simply zeroed out. ! IUNIT :IN Integer. ! Fortran logical I/O device unit number to read the matrix ! from. This unit must be connected in a system dependent ! fashion to a file, or you will get a nasty message ! from the Fortran I/O libraries. ! JOB :INOUT Integer. ! Flag indicating what I/O operations to perform. ! On input JOB indicates what Input operations to try to ! perform. ! JOB = 0 => Read only the matrix. ! JOB = 1 => Read matrix and RHS (if present). ! JOB = 2 => Read matrix and SOLN (if present). ! JOB = 3 => Read matrix, RHS and SOLN (if present). ! On output JOB indicates what operations were actually ! performed. ! JOB = -3 => Unable to parse matrix "CODE" from input file ! to determine if only the lower triangle of matrix ! is stored. ! JOB = -2 => Number of non-zeros (NELT) too large. ! JOB = -1 => System size (N) too large. ! JOB = 0 => Read in only the matrix. ! JOB = 1 => Read in the matrix and RHS. ! JOB = 2 => Read in the matrix and SOLN. ! JOB = 3 => Read in the matrix, RHS and SOLN. ! JOB = 10 => Read in only the matrix *STRUCTURE*, but no ! non-zero entries. Hence, A(*) is not referenced ! and has the return values the same as the input. ! JOB = 11 => Read in the matrix *STRUCTURE* and RHS. ! JOB = 12 => Read in the matrix *STRUCTURE* and SOLN. ! JOB = 13 => Read in the matrix *STRUCTURE*, RHS and SOLN. ! ! *Description: ! The format for the input is as follows. The first line contains ! a title to identify the data file. On the second line (5I4) are ! counters: NLINE, NPLS, NRILS, NNVLS, NRHSLS. ! NLINE Number of data lines (after the header) in the file. ! NPLS Number of lines for the Column Pointer data in the file. ! NRILS Number of lines for the Row indices in the file. ! NNVLS Number of lines for the Matrix elements in the file. ! NRHSLS Number of lines for the RHS in the file. ! The third line (A3,11X,4I4) contains a symmetry code and some ! additional counters: CODE, NROW, NCOL, NIND, NELE. ! On the fourth line (2A16,2A20) are formats to be used to read ! the following data: PNTFNT, RINFMT, NVLFMT, RHSFMT. ! Following that are the blocks of data in the order indicated. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! *Portability: ! You must make sure that IUNIT is a valid Fortran logical ! I/O device unit number and that the unit number has been ! associated with a file or the console. This is a system ! dependent function. ! ! *Implementation note: ! SOLN is not read by this version. It will simply be ! zeroed out if JOB = 2 or 3 and the returned value of ! JOB will indicate SOLN has not been read. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 881107 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 911122 Added loop to zero out RHS if user wants to read RHS, but ! it's not in the input file. (MKS) ! 911125 Minor improvements to prologue. (FNF) ! 920511 Added complete declaration section. (WRB) ! 921007 Corrected description of input format. (FNF) ! 921208 Added Implementation Note and code to zero out SOLN. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DBHIN ! .. Scalar Arguments .. INTEGER ISYM, IUNIT, JOB, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), RHS(N), SOLN(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, IBGN, ICOL, IEND, ITEMP, J, JOBRET, NCOL, NELE, NIND, & NLINE, NNVLS, NPLS, NRHSLS, NRILS, NROW CHARACTER CODE*3, PNTFMT*16, RINFMT*16, NVLFMT*20, RHSFMT*20, & TITLE*80 ! .. Intrinsic Functions .. INTRINSIC MOD !***FIRST EXECUTABLE STATEMENT DBHIN ! ! Read Matrices In BOEING-HARWELL format. ! ! TITLE Header line to identify data file. ! NLINE Number of data lines (after the header) in the file. ! NPLS Number of lines for the Column Pointer data in the file. ! NRILS Number of lines for the Row indices in the data file. ! NNVLS Number of lines for the Matrix elements in the data file. ! NRHSLS Number of lines for the RHS in the data file. ! ---- Only those variables needed by SLAP are referenced. ---- ! READ(IUNIT,9000) TITLE READ(IUNIT,9010) NLINE, NPLS, NRILS, NNVLS, NRHSLS READ(IUNIT,9020) CODE, NROW, NCOL, NIND, NELE READ(IUNIT,9030) PNTFMT, RINFMT, NVLFMT, RHSFMT ! if ( NROW > N ) THEN N = NROW JOBRET = -1 GOTO 999 end if if ( NIND > NELT ) THEN NELT = NIND JOBRET = -2 GOTO 999 end if ! ! Set the parameters. ! N = NROW NELT = NIND if ( CODE == 'RUA' ) THEN ISYM = 0 ELSE if ( CODE == 'RSA' ) THEN ISYM = 1 ELSE JOBRET = -3 GOTO 999 end if READ(IUNIT,PNTFMT) (JA(I), I = 1, N+1) READ(IUNIT,RINFMT) (IA(I), I = 1, NELT) JOBRET = 10 if ( NNVLS > 0 ) THEN READ(IUNIT,NVLFMT) (A(I), I = 1, NELT) JOBRET = 0 end if if ( MOD(JOB,2) == 1 ) THEN ! ! User requests that the RHS be read in. If it is in the input ! file, read it in; otherwise just zero it out. ! if ( NRHSLS > 0 ) THEN READ(5,RHSFMT) (RHS(I), I = 1, N) JOBRET = JOBRET + 1 ELSE DO 10 I = 1, N RHS(I) = 0 10 CONTINUE ENDIF end if if ( (JOB == 2).OR.(JOB == 3) ) THEN ! ! User requests that the SOLN be read in. ! Just zero out the array. ! DO 20 I = 1, N SOLN(I) = 0 20 CONTINUE end if ! ! Now loop through the IA array making sure that the diagonal ! matrix element appears first in the column. Then sort the ! rest of the column in ascending order. ! !VD$R NOCONCUR !VD$R NOVECTOR DO 70 ICOL = 1, N IBGN = JA(ICOL) IEND = JA(ICOL+1)-1 DO 30 I = IBGN, IEND if ( IA(I) == ICOL ) THEN ! ! Swap the diagonal element with the first element in the ! column. ! ITEMP = IA(I) IA(I) = IA(IBGN) IA(IBGN) = ITEMP TEMP = A(I) A(I) = A(IBGN) A(IBGN) = TEMP GOTO 40 ENDIF 30 CONTINUE 40 IBGN = IBGN + 1 if ( IBGN < IEND ) THEN DO 60 I = IBGN, IEND DO 50 J = I+1, IEND if ( IA(I) > IA(J) ) THEN ITEMP = IA(I) IA(I) = IA(J) IA(J) = ITEMP TEMP = A(I) A(I) = A(J) A(J) = TEMP ENDIF 50 CONTINUE 60 CONTINUE ENDIF 70 CONTINUE ! ! Set return flag. 999 JOB = JOBRET return 9000 FORMAT( A80 ) 9010 FORMAT( 5I14 ) 9020 FORMAT( A3, 11X, 4I14 ) 9030 FORMAT( 2A16, 2A20 ) end DOUBLE PRECISION FUNCTION DBIE (X) ! !! DBIE calculates the Bairy function for a negative argument and an ... ! exponentially scaled Bairy function for a non-negative argument. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10D !***TYPE DOUBLE PRECISION (BIE-S, DBIE-D) !***KEYWORDS BAIRY FUNCTION, EXPONENTIALLY SCALED, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBIE(X) calculates the double precision Airy function of the ! second kind or the double precision exponentially scaled Airy ! function of the second kind, depending on the value of the ! double precision argument X. ! ! Evaluate BI(X) for X <= 0.0 and BI(X)*EXP(-ZETA) where ! ZETA = 2/3 * X**(3/2) for X >= 0.0 ! ! ! Series for BIF on the interval -1.00000E+00 to 1.00000E+00 ! with weighted error 1.45E-32 ! log weighted error 31.84 ! significant figures required 30.85 ! decimal places required 32.40 ! ! ! Series for BIG on the interval -1.00000E+00 to 1.00000E+00 ! with weighted error 1.29E-33 ! log weighted error 32.89 ! significant figures required 31.48 ! decimal places required 33.45 ! ! ! Series for BIF2 on the interval 1.00000E+00 to 8.00000E+00 ! with weighted error 6.08E-32 ! log weighted error 31.22 ! approx significant figures required 30.8 ! decimal places required 31.80 ! ! ! Series for BIG2 on the interval 1.00000E+00 to 8.00000E+00 ! with weighted error 4.91E-33 ! log weighted error 32.31 ! approx significant figures required 31.6 ! decimal places required 32.90 ! ! ! Series for BIP1 on the interval 1.25000E-01 to 3.53553E-01 ! with weighted error 1.06E-32 ! log weighted error 31.98 ! significant figures required 30.61 ! decimal places required 32.81 ! ! ! Series for BIP2 on the interval 0. to 1.25000E-01 ! with weighted error 4.04E-33 ! log weighted error 32.39 ! significant figures required 31.15 ! decimal places required 33.37 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9AIMP, DCSEVL, INITDS !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DBIE DOUBLE PRECISION X, BIFCS(13), BIGCS(13), BIF2CS(15), BIG2CS(15), & BIP1CS(47), BIP2CS(88), ATR, BTR, SQRTX, THETA, XBIG, XM, X3SML, & X32SML, Z, D1MACH, DCSEVL LOGICAL FIRST SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, BIP1CS, BIP2CS, ATR, BTR, & NBIF, NBIG, NBIF2, NBIG2, NBIP1, NBIP2, X3SML, X32SML, XBIG, & FIRST DATA BIFCS( 1) / -.16730216471986649483537423928176D-1 / DATA BIFCS( 2) / +.10252335834249445611426362777757D+0 / DATA BIFCS( 3) / +.17083092507381516539429650242013D-2 / DATA BIFCS( 4) / +.11862545467744681179216459210040D-4 / DATA BIFCS( 5) / +.44932907017792133694531887927242D-7 / DATA BIFCS( 6) / +.10698207143387889067567767663628D-9 / DATA BIFCS( 7) / +.17480643399771824706010517628573D-12 / DATA BIFCS( 8) / +.20810231071761711025881891834399D-15 / DATA BIFCS( 9) / +.18849814695665416509927971733333D-18 / DATA BIFCS( 10) / +.13425779173097804625882666666666D-21 / DATA BIFCS( 11) / +.77159593429658887893333333333333D-25 / DATA BIFCS( 12) / +.36533879617478566399999999999999D-28 / DATA BIFCS( 13) / +.14497565927953066666666666666666D-31 / DATA BIGCS( 1) / +.22466223248574522283468220139024D-1 / DATA BIGCS( 2) / +.37364775453019545441727561666752D-1 / DATA BIGCS( 3) / +.44476218957212285696215294326639D-3 / DATA BIGCS( 4) / +.24708075636329384245494591948882D-5 / DATA BIGCS( 5) / +.79191353395149635134862426285596D-8 / DATA BIGCS( 6) / +.16498079851827779880887872402706D-10 / DATA BIGCS( 7) / +.24119906664835455909247501122841D-13 / DATA BIGCS( 8) / +.26103736236091436985184781269333D-16 / DATA BIGCS( 9) / +.21753082977160323853123792000000D-19 / DATA BIGCS( 10) / +.14386946400390433219483733333333D-22 / DATA BIGCS( 11) / +.77349125612083468629333333333333D-26 / DATA BIGCS( 12) / +.34469292033849002666666666666666D-29 / DATA BIGCS( 13) / +.12938919273216000000000000000000D-32 / DATA BIF2CS( 1) / +.0998457269381604104468284257993D+0 / DATA BIF2CS( 2) / +.47862497786300553772211467318231D+0 / DATA BIF2CS( 3) / +.25155211960433011771324415436675D-1 / DATA BIF2CS( 4) / +.58206938852326456396515697872216D-3 / DATA BIF2CS( 5) / +.74997659644377865943861457378217D-5 / DATA BIF2CS( 6) / +.61346028703493836681403010356474D-7 / DATA BIF2CS( 7) / +.34627538851480632900434268733359D-9 / DATA BIF2CS( 8) / +.14288910080270254287770846748931D-11 / DATA BIF2CS( 9) / +.44962704298334641895056472179200D-14 / DATA BIF2CS( 10) / +.11142323065833011708428300106666D-16 / DATA BIF2CS( 11) / +.22304791066175002081517866666666D-19 / DATA BIF2CS( 12) / +.36815778736393142842922666666666D-22 / DATA BIF2CS( 13) / +.50960868449338261333333333333333D-25 / DATA BIF2CS( 14) / +.60003386926288554666666666666666D-28 / DATA BIF2CS( 15) / +.60827497446570666666666666666666D-31 / DATA BIG2CS( 1) / +.033305662145514340465176188111647D+0 / DATA BIG2CS( 2) / +.161309215123197067613287532084943D+0 / DATA BIG2CS( 3) / +.631900730961342869121615634921173D-2 / DATA BIG2CS( 4) / +.118790456816251736389780192304567D-3 / DATA BIG2CS( 5) / +.130453458862002656147116485012843D-5 / DATA BIG2CS( 6) / +.937412599553521729546809615508936D-8 / DATA BIG2CS( 7) / +.474580188674725153788510169834595D-10 / DATA BIG2CS( 8) / +.178310726509481399800065667560946D-12 / DATA BIG2CS( 9) / +.516759192784958180374276356640000D-15 / DATA BIG2CS( 10) / +.119004508386827125129496251733333D-17 / DATA BIG2CS( 11) / +.222982880666403517277063466666666D-20 / DATA BIG2CS( 12) / +.346551923027689419722666666666666D-23 / DATA BIG2CS( 13) / +.453926336320504514133333333333333D-26 / DATA BIG2CS( 14) / +.507884996513522346666666666666666D-29 / DATA BIG2CS( 15) / +.491020674696533333333333333333333D-32 / DATA BIP1CS( 1) / -.83220474779434474687471864707973D-1 / DATA BIP1CS( 2) / +.11461189273711742889920226128031D-1 / DATA BIP1CS( 3) / +.42896440718911509494134472566635D-3 / DATA BIP1CS( 4) / -.14906639379950514017847677732954D-3 / DATA BIP1CS( 5) / -.13076597267876290663136340998881D-4 / DATA BIP1CS( 6) / +.63275983961030344754535716032494D-5 / DATA BIP1CS( 7) / -.42226696982681924884778515889433D-6 / DATA BIP1CS( 8) / -.19147186298654689632835494181277D-6 / DATA BIP1CS( 9) / +.64531062845583173611038157880934D-7 / DATA BIP1CS( 10) / -.78448546771397719289748310448628D-8 / DATA BIP1CS( 11) / -.96077216623785085879198533565432D-9 / DATA BIP1CS( 12) / +.70004713316443966339006074402068D-9 / DATA BIP1CS( 13) / -.17731789132814932022083128056698D-9 / DATA BIP1CS( 14) / +.22720894783465236347282126389311D-10 / DATA BIP1CS( 15) / +.16540456313972049847032860681891D-11 / DATA BIP1CS( 16) / -.18517125559292316390755369896693D-11 / DATA BIP1CS( 17) / +.59576312477117290165680715534277D-12 / DATA BIP1CS( 18) / -.12194348147346564781055769498986D-12 / DATA BIP1CS( 19) / +.13347869253513048815386347813597D-13 / DATA BIP1CS( 20) / +.17278311524339746664384792889731D-14 / DATA BIP1CS( 21) / -.14590732013016720735268871713166D-14 / DATA BIP1CS( 22) / +.49010319927115819978994989520104D-15 / DATA BIP1CS( 23) / -.11556545519261548129262972762521D-15 / DATA BIP1CS( 24) / +.19098807367072411430671732441524D-16 / DATA BIP1CS( 25) / -.11768966854492179886913995957862D-17 / DATA BIP1CS( 26) / -.63271925149530064474537459677047D-18 / DATA BIP1CS( 27) / +.33861838880715361614130191322316D-18 / DATA BIP1CS( 28) / -.10725825321758625254992162219622D-18 / DATA BIP1CS( 29) / +.25995709605617169284786933115562D-19 / DATA BIP1CS( 30) / -.48477583571081193660962309494101D-20 / DATA BIP1CS( 31) / +.55298913982121625361505513198933D-21 / DATA BIP1CS( 32) / +.49421660826069471371748197444266D-22 / DATA BIP1CS( 33) / -.55162121924145707458069720814933D-22 / DATA BIP1CS( 34) / +.21437560417632550086631884499626D-22 / DATA BIP1CS( 35) / -.61910313387655605798785061137066D-23 / DATA BIP1CS( 36) / +.14629362707391245659830967336959D-23 / DATA BIP1CS( 37) / -.27918484471059005576177866069333D-24 / DATA BIP1CS( 38) / +.36455703168570246150906795349333D-25 / DATA BIP1CS( 39) / +.58511821906188711839382459733333D-27 / DATA BIP1CS( 40) / -.24946950487566510969745047551999D-26 / DATA BIP1CS( 41) / +.10979323980338380977919579477333D-26 / DATA BIP1CS( 42) / -.34743388345961115015034088106666D-27 / DATA BIP1CS( 43) / +.91373402635349697363171082240000D-28 / DATA BIP1CS( 44) / -.20510352728210629186247720959999D-28 / DATA BIP1CS( 45) / +.37976985698546461748651622399999D-29 / DATA BIP1CS( 46) / -.48479458497755565887848448000000D-30 / DATA BIP1CS( 47) / -.10558306941230714314205866666666D-31 / DATA BIP2CS( 1) / -.11359673758598867913797310895527D+0 / DATA BIP2CS( 2) / +.41381473947881595760052081171444D-2 / DATA BIP2CS( 3) / +.13534706221193329857696921727508D-3 / DATA BIP2CS( 4) / +.10427316653015353405887183456780D-4 / DATA BIP2CS( 5) / +.13474954767849907889589911958925D-5 / DATA BIP2CS( 6) / +.16965374054383983356062511163756D-6 / DATA BIP2CS( 7) / -.10096500865641624301366228396373D-7 / DATA BIP2CS( 8) / -.16729119493778475127836973095943D-7 / DATA BIP2CS( 9) / -.45815364485068383217152795613391D-8 / DATA BIP2CS( 10) / +.37366813665655477274064749384284D-9 / DATA BIP2CS( 11) / +.57669303201452448119584643502111D-9 / DATA BIP2CS( 12) / +.62181265087850324095393408792371D-10 / DATA BIP2CS( 13) / -.63294120282743068241589177281354D-10 / DATA BIP2CS( 14) / -.14915047908598767633999091989487D-10 / DATA BIP2CS( 15) / +.78896213942486771938172394294891D-11 / DATA BIP2CS( 16) / +.24960513721857797984888064000127D-11 / DATA BIP2CS( 17) / -.12130075287291659477746664734814D-11 / DATA BIP2CS( 18) / -.37404939108727277887343460402716D-12 / DATA BIP2CS( 19) / +.22377278140321476798783446931091D-12 / DATA BIP2CS( 20) / +.47490296312192466341986077472514D-13 / DATA BIP2CS( 21) / -.45261607991821224810605655831294D-13 / DATA BIP2CS( 22) / -.30172271841986072645112245876020D-14 / DATA BIP2CS( 23) / +.91058603558754058327592683478908D-14 / DATA BIP2CS( 24) / -.98149238033807062926643864207709D-15 / DATA BIP2CS( 25) / -.16429400647889465253601245251589D-14 / DATA BIP2CS( 26) / +.55334834214274215451182114635164D-15 / DATA BIP2CS( 27) / +.21750479864482655984374381998156D-15 / DATA BIP2CS( 28) / -.17379236200220656971287029558087D-15 / DATA BIP2CS( 29) / -.10470023471443714959283909313604D-17 / DATA BIP2CS( 30) / +.39219145986056386925441403311462D-16 / DATA BIP2CS( 31) / -.11621293686345196925824005665910D-16 / DATA BIP2CS( 32) / -.54027474491754245533735411307773D-17 / DATA BIP2CS( 33) / +.45441582123884610882675428553304D-17 / DATA BIP2CS( 34) / -.28775599625221075729427585480086D-18 / DATA BIP2CS( 35) / -.10017340927225341243596162960440D-17 / DATA BIP2CS( 36) / +.44823931215068369856332561906313D-18 / DATA BIP2CS( 37) / +.76135968654908942328948982366775D-19 / DATA BIP2CS( 38) / -.14448324094881347238956060145422D-18 / DATA BIP2CS( 39) / +.40460859449205362251624847392112D-19 / DATA BIP2CS( 40) / +.20321085700338446891325190707277D-19 / DATA BIP2CS( 41) / -.19602795471446798718272758041962D-19 / DATA BIP2CS( 42) / +.34273038443944824263518958211738D-20 / DATA BIP2CS( 43) / +.37023705853905135480024651593154D-20 / DATA BIP2CS( 44) / -.26879595172041591131400332966712D-20 / DATA BIP2CS( 45) / +.28121678463531712209714454683364D-21 / DATA BIP2CS( 46) / +.60933963636177797173271119680329D-21 / DATA BIP2CS( 47) / -.38666621897150844994172977893413D-21 / DATA BIP2CS( 48) / +.25989331253566943450895651927228D-22 / DATA BIP2CS( 49) / +.97194393622938503767281175216084D-22 / DATA BIP2CS( 50) / -.59392817834375098415630478204591D-22 / DATA BIP2CS( 51) / +.38864949977113015409591960439444D-23 / DATA BIP2CS( 52) / +.15334307393617272869721512868769D-22 / DATA BIP2CS( 53) / -.97513555209762624036336521409724D-23 / DATA BIP2CS( 54) / +.96340644440489471424741339383726D-24 / DATA BIP2CS( 55) / +.23841999400208880109946748792454D-23 / DATA BIP2CS( 56) / -.16896986315019706184848044205207D-23 / DATA BIP2CS( 57) / +.27352715888928361222578444801478D-24 / DATA BIP2CS( 58) / +.35660016185409578960111685025730D-24 / DATA BIP2CS( 59) / -.30234026608258827249534280666954D-24 / DATA BIP2CS( 60) / +.75002041605973930653144204823232D-25 / DATA BIP2CS( 61) / +.48403287575851388827455319838748D-25 / DATA BIP2CS( 62) / -.54364137654447888432698010297766D-25 / DATA BIP2CS( 63) / +.19281214470820962653345978809756D-25 / DATA BIP2CS( 64) / +.50116355020532656659611814172172D-26 / DATA BIP2CS( 65) / -.95040744582693253786034620869972D-26 / DATA BIP2CS( 66) / +.46372646157101975948696332245611D-26 / DATA BIP2CS( 67) / +.21177170704466954163768170577046D-28 / DATA BIP2CS( 68) / -.15404850268168594303692204548726D-26 / DATA BIP2CS( 69) / +.10387944293201213662047889194441D-26 / DATA BIP2CS( 70) / -.19890078156915416751316728235153D-27 / DATA BIP2CS( 71) / -.21022173878658495471177044522532D-27 / DATA BIP2CS( 72) / +.21353099724525793150633356670491D-27 / DATA BIP2CS( 73) / -.79040810747961342319023537632627D-28 / DATA BIP2CS( 74) / -.16575359960435585049973741763592D-28 / DATA BIP2CS( 75) / +.38868342850124112587625586496537D-28 / DATA BIP2CS( 76) / -.22309237330896866182621562424717D-28 / DATA BIP2CS( 77) / +.27777244420176260265625977404382D-29 / DATA BIP2CS( 78) / +.57078543472657725368712433782772D-29 / DATA BIP2CS( 79) / -.51743084445303852800173371555280D-29 / DATA BIP2CS( 80) / +.18413280751095837198450927071569D-29 / DATA BIP2CS( 81) / +.44422562390957094598544071068647D-30 / DATA BIP2CS( 82) / -.98504142639629801547464958226943D-30 / DATA BIP2CS( 83) / +.58857201353585104884754198881995D-30 / DATA BIP2CS( 84) / -.97636075440429787961402312628595D-31 / DATA BIP2CS( 85) / -.13581011996074695047063597884122D-30 / DATA BIP2CS( 86) / +.13999743518492413270568048380345D-30 / DATA BIP2CS( 87) / -.59754904545248477620884562981118D-31 / DATA BIP2CS( 88) / -.40391653875428313641045327529856D-32 / DATA ATR / 8.75069057084843450880771988210148D0 / DATA BTR / -2.09383632135605431360096498526268D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBIE if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NBIF = INITDS (BIFCS, 13, ETA) NBIG = INITDS (BIGCS, 13, ETA) NBIF2 = INITDS (BIF2CS, 15, ETA) NBIG2 = INITDS (BIG2CS, 15, ETA) NBIP1 = INITDS (BIP1CS, 47, ETA) NBIP2 = INITDS (BIP2CS, 88, ETA) ! X3SML = ETA**0.3333 X32SML = 1.3104D0*X3SML**2 XBIG = D1MACH(2)**0.6666D0 FIRST = .FALSE. end if if (X >= (-1.0D0)) go to 20 call D9AIMP (X, XM, THETA) DBIE = XM * SIN(THETA) return ! 20 if (X > 1.0D0) go to 30 Z = 0.D0 if (ABS(X) > X3SML) Z = X**3 DBIE = 0.625D0 + DCSEVL (Z, BIFCS, NBIF) + X*(0.4375D0 + & DCSEVL (Z, BIGCS, NBIG) ) if (X > X32SML) DBIE = DBIE * EXP(-2.0D0*X*SQRT(X)/3.0D0) return ! 30 if (X > 2.0D0) go to 40 Z = (2.0D0*X**3 - 9.0D0)/7.0D0 DBIE = EXP(-2.0D0*X*SQRT(X)/3.0D0) * (1.125D0 + & DCSEVL (Z, BIF2CS, NBIF2) + X*(0.625D0 + DCSEVL (Z, BIG2CS, & NBIG2)) ) return ! 40 if (X > 4.0D0) go to 50 SQRTX = SQRT(X) Z = ATR/(X*SQRTX) + BTR DBIE = (0.625D0 + DCSEVL (Z, BIP1CS, NBIP1))/SQRT(SQRTX) return ! 50 SQRTX = SQRT(X) Z = -1.0D0 if (X < XBIG) Z = 16.D0/(X*SQRTX) - 1.0D0 DBIE = (0.625D0 + DCSEVL (Z, BIP2CS, NBIP2))/SQRT(SQRTX) return ! end DOUBLE PRECISION FUNCTION DBI (X) ! !! DBI evaluates the Bairy function (the Airy function of the second kind). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10D !***TYPE DOUBLE PRECISION (BI-S, DBI-D) !***KEYWORDS BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBI(X) calculates the double precision Airy function of the ! second kind for double precision argument X. ! ! Series for BIF on the interval -1.00000E+00 to 1.00000E+00 ! with weighted error 1.45E-32 ! log weighted error 31.84 ! significant figures required 30.85 ! decimal places required 32.40 ! ! Series for BIG on the interval -1.00000E+00 to 1.00000E+00 ! with weighted error 1.29E-33 ! log weighted error 32.89 ! significant figures required 31.48 ! decimal places required 33.45 ! ! Series for BIF2 on the interval 1.00000E+00 to 8.00000E+00 ! with weighted error 6.08E-32 ! log weighted error 31.22 ! approx significant figures required 30.8 ! decimal places required 31.80 ! ! Series for BIG2 on the interval 1.00000E+00 to 8.00000E+00 ! with weighted error 4.91E-33 ! log weighted error 32.31 ! approx significant figures required 31.6 ! decimal places required 32.90 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9AIMP, DBIE, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBI DOUBLE PRECISION X, BIFCS(13), BIGCS(13), BIF2CS(15), BIG2CS(15), & THETA, XM, XMAX, X3SML, Z, D1MACH, DCSEVL, DBIE LOGICAL FIRST SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, NBIF, NBIG, & NBIF2, NBIG2, X3SML, XMAX, FIRST DATA BIFCS( 1) / -.16730216471986649483537423928176D-1 / DATA BIFCS( 2) / +.10252335834249445611426362777757D+0 / DATA BIFCS( 3) / +.17083092507381516539429650242013D-2 / DATA BIFCS( 4) / +.11862545467744681179216459210040D-4 / DATA BIFCS( 5) / +.44932907017792133694531887927242D-7 / DATA BIFCS( 6) / +.10698207143387889067567767663628D-9 / DATA BIFCS( 7) / +.17480643399771824706010517628573D-12 / DATA BIFCS( 8) / +.20810231071761711025881891834399D-15 / DATA BIFCS( 9) / +.18849814695665416509927971733333D-18 / DATA BIFCS( 10) / +.13425779173097804625882666666666D-21 / DATA BIFCS( 11) / +.77159593429658887893333333333333D-25 / DATA BIFCS( 12) / +.36533879617478566399999999999999D-28 / DATA BIFCS( 13) / +.14497565927953066666666666666666D-31 / DATA BIGCS( 1) / +.22466223248574522283468220139024D-1 / DATA BIGCS( 2) / +.37364775453019545441727561666752D-1 / DATA BIGCS( 3) / +.44476218957212285696215294326639D-3 / DATA BIGCS( 4) / +.24708075636329384245494591948882D-5 / DATA BIGCS( 5) / +.79191353395149635134862426285596D-8 / DATA BIGCS( 6) / +.16498079851827779880887872402706D-10 / DATA BIGCS( 7) / +.24119906664835455909247501122841D-13 / DATA BIGCS( 8) / +.26103736236091436985184781269333D-16 / DATA BIGCS( 9) / +.21753082977160323853123792000000D-19 / DATA BIGCS( 10) / +.14386946400390433219483733333333D-22 / DATA BIGCS( 11) / +.77349125612083468629333333333333D-26 / DATA BIGCS( 12) / +.34469292033849002666666666666666D-29 / DATA BIGCS( 13) / +.12938919273216000000000000000000D-32 / DATA BIF2CS( 1) / +.0998457269381604104468284257993D+0 / DATA BIF2CS( 2) / +.47862497786300553772211467318231D+0 / DATA BIF2CS( 3) / +.25155211960433011771324415436675D-1 / DATA BIF2CS( 4) / +.58206938852326456396515697872216D-3 / DATA BIF2CS( 5) / +.74997659644377865943861457378217D-5 / DATA BIF2CS( 6) / +.61346028703493836681403010356474D-7 / DATA BIF2CS( 7) / +.34627538851480632900434268733359D-9 / DATA BIF2CS( 8) / +.14288910080270254287770846748931D-11 / DATA BIF2CS( 9) / +.44962704298334641895056472179200D-14 / DATA BIF2CS( 10) / +.11142323065833011708428300106666D-16 / DATA BIF2CS( 11) / +.22304791066175002081517866666666D-19 / DATA BIF2CS( 12) / +.36815778736393142842922666666666D-22 / DATA BIF2CS( 13) / +.50960868449338261333333333333333D-25 / DATA BIF2CS( 14) / +.60003386926288554666666666666666D-28 / DATA BIF2CS( 15) / +.60827497446570666666666666666666D-31 / DATA BIG2CS( 1) / +.033305662145514340465176188111647D+0 / DATA BIG2CS( 2) / +.161309215123197067613287532084943D+0 / DATA BIG2CS( 3) / +.631900730961342869121615634921173D-2 / DATA BIG2CS( 4) / +.118790456816251736389780192304567D-3 / DATA BIG2CS( 5) / +.130453458862002656147116485012843D-5 / DATA BIG2CS( 6) / +.937412599553521729546809615508936D-8 / DATA BIG2CS( 7) / +.474580188674725153788510169834595D-10 / DATA BIG2CS( 8) / +.178310726509481399800065667560946D-12 / DATA BIG2CS( 9) / +.516759192784958180374276356640000D-15 / DATA BIG2CS( 10) / +.119004508386827125129496251733333D-17 / DATA BIG2CS( 11) / +.222982880666403517277063466666666D-20 / DATA BIG2CS( 12) / +.346551923027689419722666666666666D-23 / DATA BIG2CS( 13) / +.453926336320504514133333333333333D-26 / DATA BIG2CS( 14) / +.507884996513522346666666666666666D-29 / DATA BIG2CS( 15) / +.491020674696533333333333333333333D-32 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBI if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NBIF = INITDS (BIFCS, 13, ETA) NBIG = INITDS (BIGCS, 13, ETA) NBIF2 = INITDS (BIF2CS, 15, ETA) NBIG2 = INITDS (BIG2CS, 15, ETA) ! X3SML = ETA**0.3333 XMAX = (1.5*LOG(D1MACH(2)))**0.6666D0 FIRST = .FALSE. end if ! if (X >= (-1.0D0)) go to 20 call D9AIMP (X, XM, THETA) DBI = XM * SIN(THETA) return ! 20 if (X > 1.0D0) go to 30 Z = 0.D0 if (ABS(X) > X3SML) Z = X**3 DBI = 0.625 + DCSEVL (Z, BIFCS, NBIF) + X*(0.4375D0 + & DCSEVL (Z, BIGCS, NBIG)) return ! 30 if (X > 2.0D0) go to 40 Z = (2.0D0*X**3 - 9.0D0)/7.D0 DBI = 1.125D0 + DCSEVL (Z, BIF2CS, NBIF2) + X*(0.625D0 + & DCSEVL (Z, BIG2CS, NBIG2)) return ! 40 if (X > XMAX) call XERMSG ('SLATEC', 'DBI', & 'X SO BIG THAT BI OVERFLOWS', 1, 2) ! DBI = DBIE(X) * EXP(2.0D0*X*SQRT(X)/3.0D0) return ! end DOUBLE PRECISION FUNCTION DBINOM (N, M) ! !! DBINOM computes the binomial coefficients. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C1 !***TYPE DOUBLE PRECISION (BINOM-S, DBINOM-D) !***KEYWORDS BINOMIAL COEFFICIENTS, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBINOM(N,M) calculates the double precision binomial coefficient ! for integer arguments N and M. The result is (N!)/((M!)(N-M)!). ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9LGMC, DLNREL, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBINOM DOUBLE PRECISION CORR, FINTMX, SQ2PIL, XK, XN, XNK, D9LGMC, & DLNREL, D1MACH, BILNMX LOGICAL FIRST SAVE SQ2PIL, BILNMX, FINTMX, FIRST DATA SQ2PIL / 0.91893853320467274178032973640562D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBINOM if (FIRST) THEN BILNMX = LOG(D1MACH(2)) - 0.0001D0 FINTMX = 0.9D0/D1MACH(3) end if FIRST = .FALSE. ! if (N < 0 .OR. M < 0) call XERMSG ('SLATEC', 'DBINOM', & 'N OR M LT ZERO', 1, 2) if (N < M) call XERMSG ('SLATEC', 'DBINOM', 'N LT M', 2, 2) ! K = MIN (M, N-M) if (K > 20) go to 30 if (K*LOG(AMAX0(N,1)) > BILNMX) go to 30 ! DBINOM = 1.0D0 if (K == 0) RETURN DO 20 I=1,K XN = N - I + 1 XK = I DBINOM = DBINOM * (XN/XK) 20 CONTINUE ! if (DBINOM < FINTMX) DBINOM = AINT (DBINOM+0.5D0) return ! ! if K < 9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM 30 if (K < 9) call XERMSG ('SLATEC', 'DBINOM', & 'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2) ! XN = N + 1 XK = K + 1 XNK = N - K + 1 ! CORR = D9LGMC(XN) - D9LGMC(XK) - D9LGMC(XNK) DBINOM = XK*LOG(XNK/XK) - XN*DLNREL(-(XK-1.0D0)/XN) & -0.5D0*LOG(XN*XNK/XK) + 1.0D0 - SQ2PIL + CORR ! if (DBINOM > BILNMX) call XERMSG ('SLATEC', 'DBINOM', & 'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2) ! DBINOM = EXP (DBINOM) if (DBINOM < FINTMX) DBINOM = AINT (DBINOM+0.5D0) ! return end subroutine DBINT4 (X, Y, NDATA, IBCL, IBCR, FBCL, FBCR, KNTOPT, T, & BCOEF, N, K, W) ! !! DBINT4 computes the B-representation of a cubic spline ... ! which interpolates given data. ! !***LIBRARY SLATEC !***CATEGORY E1A !***TYPE DOUBLE PRECISION (BINT4-S, DBINT4-D) !***KEYWORDS B-SPLINE, CUBIC SPLINES, DATA FITTING, INTERPOLATION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract **** a double precision routine **** ! ! DBINT4 computes the B representation (T,BCOEF,N,K) of a ! cubic spline (K=4) which interpolates data (X(I),Y(I)), ! I=1,NDATA. Parameters IBCL, IBCR, FBCL, FBCR allow the ! specification of the spline first or second derivative at ! both X(1) and X(NDATA). When this data is not specified ! by the problem, it is common practice to use a natural ! spline by setting second derivatives at X(1) and X(NDATA) ! to zero (IBCL=IBCR=2,FBCL=FBCR=0.0). The spline is defined ! on T(4) <= X <= T(N+1) with (ordered) interior knots at ! X(I) values where N=NDATA+2. The knots T(1),T(2),T(3) lie to ! the left of T(4)=X(1) and the knots T(N+2), T(N+3), T(N+4) ! lie to the right of T(N+1)=X(NDATA) in increasing order. If ! no extrapolation outside (X(1),X(NDATA)) is anticipated, the ! knots T(1)=T(2)=T(3)=T(4)=X(1) and T(N+2)=T(N+3)=T(N+4)= ! T(N+1)=X(NDATA) can be specified by KNTOPT=1. KNTOPT=2 ! selects a knot placement for T(1), T(2), T(3) to make the ! first 7 knots symmetric about T(4)=X(1) and similarly for ! T(N+2), T(N+3), T(N+4) about T(N+1)=X(NDATA). KNTOPT=3 ! allows the user to make his own selection, in increasing ! order, for T(1), T(2), T(3) to the left of X(1) and T(N+2), ! T(N+3), T(N+4) to the right of X(NDATA) in the work array ! W(1) through W(6). In any case, the interpolation on ! T(4) <= X <= T(N+1) by using function DBVALU is unique ! for given boundary conditions. ! ! Description of Arguments ! ! Input X,Y,FBCL,FBCR,W are double precision ! X - X vector of abscissae of length NDATA, distinct ! and in increasing order ! Y - Y vector of ordinates of length NDATA ! NDATA - number of data points, NDATA >= 2 ! IBCL - selection parameter for left boundary condition ! IBCL = 1 constrain the first derivative at ! X(1) to FBCL ! = 2 constrain the second derivative at ! X(1) to FBCL ! IBCR - selection parameter for right boundary condition ! IBCR = 1 constrain first derivative at ! X(NDATA) to FBCR ! IBCR = 2 constrain second derivative at ! X(NDATA) to FBCR ! FBCL - left boundary values governed by IBCL ! FBCR - right boundary values governed by IBCR ! KNTOPT - knot selection parameter ! KNTOPT = 1 sets knot multiplicity at T(4) and ! T(N+1) to 4 ! = 2 sets a symmetric placement of knots ! about T(4) and T(N+1) ! = 3 sets T(I)=W(I) and T(N+1+I)=W(3+I),I=1,3 ! where W(I),I=1,6 is supplied by the user ! W - work array of dimension at least 5*(NDATA+2) ! If KNTOPT=3, then W(1),W(2),W(3) are knot values to ! the left of X(1) and W(4),W(5),W(6) are knot ! values to the right of X(NDATA) in increasing ! order to be supplied by the user ! ! Output T,BCOEF are double precision ! T - knot array of length N+4 ! BCOEF - B spline coefficient array of length N ! N - number of coefficients, N=NDATA+2 ! K - order of spline, K=4 ! ! Error Conditions ! Improper input is a fatal error ! Singular system of equations is a fatal error ! !***REFERENCES D. E. Amos, Computation with splines and B-splines, ! Report SAND78-1968, Sandia Laboratories, March 1979. ! Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. ! Carl de Boor, A Practical Guide to Splines, Applied ! Mathematics Series 27, Springer-Verlag, New York, ! 1978. !***ROUTINES CALLED D1MACH, DBNFAC, DBNSLV, DBSPVD, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBINT4 ! INTEGER I, IBCL, IBCR, IFLAG, ILB, ILEFT, IT, IUB, IW, IWP, J, & JW, K, KNTOPT, N, NDATA, NDM, NP, NWROW DOUBLE PRECISION BCOEF,FBCL,FBCR,T,TOL,TXN,TX1,VNIKX,W,WDTOL, & WORK,X,XL,Y DOUBLE PRECISION D1MACH DIMENSION X(*), Y(*), T(*), BCOEF(*), W(5,*), VNIKX(4,4), WORK(15) !***FIRST EXECUTABLE STATEMENT DBINT4 WDTOL = D1MACH(4) TOL = SQRT(WDTOL) if (NDATA < 2) go to 200 NDM = NDATA - 1 DO 10 I=1,NDM if (X(I) >= X(I+1)) go to 210 10 CONTINUE if (IBCL < 1 .OR. IBCL > 2) go to 220 if (IBCR < 1 .OR. IBCR > 2) go to 230 if (KNTOPT < 1 .OR. KNTOPT > 3) go to 240 K = 4 N = NDATA + 2 NP = N + 1 DO 20 I=1,NDATA T(I+3) = X(I) 20 CONTINUE go to (30, 50, 90), KNTOPT ! SET UP KNOT ARRAY WITH MULTIPLICITY 4 AT X(1) AND X(NDATA) 30 CONTINUE DO 40 I=1,3 T(4-I) = X(1) T(NP+I) = X(NDATA) 40 CONTINUE go to 110 ! SET UP KNOT ARRAY WITH SYMMETRIC PLACEMENT ABOUT END POINTS 50 CONTINUE if (NDATA > 3) go to 70 XL = (X(NDATA)-X(1))/3.0D0 DO 60 I=1,3 T(4-I) = T(5-I) - XL T(NP+I) = T(NP+I-1) + XL 60 CONTINUE go to 110 70 CONTINUE TX1 = X(1) + X(1) TXN = X(NDATA) + X(NDATA) DO 80 I=1,3 T(4-I) = TX1 - X(I+1) T(NP+I) = TXN - X(NDATA-I) 80 CONTINUE go to 110 ! SET UP KNOT ARRAY LESS THAN X(1) AND GREATER THAN X(NDATA) TO BE ! SUPPLIED BY USER IN WORK LOCATIONS W(1) THROUGH W(6) WHEN KNTOPT=3 90 CONTINUE DO 100 I=1,3 T(4-I) = W(4-I,1) JW = MAX(1,I-1) IW = MOD(I+2,5)+1 T(NP+I) = W(IW,JW) if (T(4-I) > T(5-I)) go to 250 if (T(NP+I) < T(NP+I-1)) go to 250 100 CONTINUE 110 CONTINUE ! DO 130 I=1,5 DO 120 J=1,N W(I,J) = 0.0D0 120 CONTINUE 130 CONTINUE ! SET UP LEFT INTERPOLATION POINT AND LEFT BOUNDARY CONDITION FOR ! RIGHT LIMITS IT = IBCL + 1 call DBSPVD(T, K, IT, X(1), K, 4, VNIKX, WORK) IW = 0 if (ABS(VNIKX(3,1)) < TOL) IW = 1 DO 140 J=1,3 W(J+1,4-J) = VNIKX(4-J,IT) W(J,4-J) = VNIKX(4-J,1) 140 CONTINUE BCOEF(1) = Y(1) BCOEF(2) = FBCL ! SET UP INTERPOLATION EQUATIONS FOR POINTS I=2 TO I=NDATA-1 ILEFT = 4 if (NDM < 2) go to 170 DO 160 I=2,NDM ILEFT = ILEFT + 1 call DBSPVD(T, K, 1, X(I), ILEFT, 4, VNIKX, WORK) DO 150 J=1,3 W(J+1,3+I-J) = VNIKX(4-J,1) 150 CONTINUE BCOEF(I+1) = Y(I) 160 CONTINUE ! SET UP RIGHT INTERPOLATION POINT AND RIGHT BOUNDARY CONDITION FOR ! LEFT LIMITS(ILEFT IS ASSOCIATED WITH T(N)=X(NDATA-1)) 170 CONTINUE IT = IBCR + 1 call DBSPVD(T, K, IT, X(NDATA), ILEFT, 4, VNIKX, WORK) JW = 0 if (ABS(VNIKX(2,1)) < TOL) JW = 1 DO 180 J=1,3 W(J+1,3+NDATA-J) = VNIKX(5-J,IT) W(J+2,3+NDATA-J) = VNIKX(5-J,1) 180 CONTINUE BCOEF(N-1) = FBCR BCOEF(N) = Y(NDATA) ! SOLVE SYSTEM OF EQUATIONS ILB = 2 - JW IUB = 2 - IW NWROW = 5 IWP = IW + 1 call DBNFAC(W(IWP,1), NWROW, N, ILB, IUB, IFLAG) if (IFLAG == 2) go to 190 call DBNSLV(W(IWP,1), NWROW, N, ILB, IUB, BCOEF) return ! ! 190 CONTINUE call XERMSG ('SLATEC', 'DBINT4', & 'THE SYSTEM OF EQUATIONS IS SINGULAR', 2, 1) return 200 CONTINUE call XERMSG ('SLATEC', 'DBINT4', 'NDATA IS LESS THAN 2', 2, 1) return 210 CONTINUE call XERMSG ('SLATEC', 'DBINT4', & 'X VALUES ARE NOT DISTINCT OR NOT ORDERED', 2, 1) return 220 CONTINUE call XERMSG ('SLATEC', 'DBINT4', 'IBCL IS NOT 1 OR 2', 2, 1) return 230 CONTINUE call XERMSG ('SLATEC', 'DBINT4', 'IBCR IS NOT 1 OR 2', 2, 1) return 240 CONTINUE call XERMSG ('SLATEC', 'DBINT4', 'KNTOPT IS NOT 1, 2, OR 3', 2, & 1) return 250 CONTINUE call XERMSG ('SLATEC', 'DBINT4', & 'KNOT INPUT THROUGH W ARRAY IS NOT ORDERED PROPERLY', 2, 1) return end subroutine DBINTK (X, Y, T, N, K, BCOEF, Q, WORK) ! !! DBINTK computes the B-representation of a spline which interpolates ... ! given data. ! !***LIBRARY SLATEC !***CATEGORY E1A !***TYPE DOUBLE PRECISION (BINTK-S, DBINTK-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract **** a double precision routine **** ! ! DBINTK is the SPLINT routine of the reference. ! ! DBINTK produces the B-spline coefficients, BCOEF, of the ! B-spline of order K with knots T(I), I=1,...,N+K, which ! takes on the value Y(I) at X(I), I=1,...,N. The spline or ! any of its derivatives can be evaluated by calls to DBVALU. ! ! The I-th equation of the linear system A*BCOEF = B for the ! coefficients of the interpolant enforces interpolation at ! X(I), I=1,...,N. Hence, B(I) = Y(I), for all I, and A is ! a band matrix with 2K-1 bands if A is invertible. The matrix ! A is generated row by row and stored, diagonal by diagonal, ! in the rows of Q, with the main diagonal going into row K. ! The banded system is then solved by a call to DBNFAC (which ! constructs the triangular factorization for A and stores it ! again in Q), followed by a call to DBNSLV (which then ! obtains the solution BCOEF by substitution). DBNFAC does no ! pivoting, since the total positivity of the matrix A makes ! this unnecessary. The linear system to be solved is ! (theoretically) invertible if and only if ! T(I) < X(I) < T(I+K), for all I. ! Equality is permitted on the left for I=1 and on the right ! for I=N when K knots are used at X(1) or X(N). Otherwise, ! violation of this condition is certain to lead to an error. ! ! Description of Arguments ! ! Input X,Y,T are double precision ! X - vector of length N containing data point abscissa ! in strictly increasing order. ! Y - corresponding vector of length N containing data ! point ordinates. ! T - knot vector of length N+K ! Since T(1),..,T(K) <= X(1) and T(N+1),..,T(N+K) ! >= X(N), this leaves only N-K knots (not nec- ! essarily X(I) values) interior to (X(1),X(N)) ! N - number of data points, N >= K ! K - order of the spline, K >= 1 ! ! Output BCOEF,Q,WORK are double precision ! BCOEF - a vector of length N containing the B-spline ! coefficients ! Q - a work vector of length (2*K-1)*N, containing ! the triangular factorization of the coefficient ! matrix of the linear system being solved. The ! coefficients for the interpolant of an ! additional data set (X(I),YY(I)), I=1,...,N ! with the same abscissa can be obtained by loading ! YY into BCOEF and then executing ! call DBNSLV (Q,2K-1,N,K-1,K-1,BCOEF) ! WORK - work vector of length 2*K ! ! Error Conditions ! Improper input is a fatal error ! Singular system of equations is a fatal error ! !***REFERENCES D. E. Amos, Computation with splines and B-splines, ! Report SAND78-1968, Sandia Laboratories, March 1979. ! Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. ! Carl de Boor, A Practical Guide to Splines, Applied ! Mathematics Series 27, Springer-Verlag, New York, ! 1978. !***ROUTINES CALLED DBNFAC, DBNSLV, DBSPVN, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBINTK ! INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT, & LENQ, NP1 DOUBLE PRECISION BCOEF(*), Y(*), Q(*), T(*), X(*), XI, WORK(*) ! DIMENSION Q(2*K-1,N), T(N+K) !***FIRST EXECUTABLE STATEMENT DBINTK if ( K < 1) go to 100 if ( N < K) go to 105 JJ = N - 1 if ( JJ == 0) go to 6 DO 5 I=1,JJ if ( X(I) >= X(I+1)) go to 110 5 CONTINUE 6 CONTINUE NP1 = N + 1 KM1 = K - 1 KPKM2 = 2*KM1 LEFT = K ! ZERO OUT ALL ENTRIES OF Q LENQ = N*(K+KM1) DO 10 I=1,LENQ Q(I) = 0.0D0 10 CONTINUE ! ! *** LOOP OVER I TO CONSTRUCT THE N INTERPOLATION EQUATIONS DO 50 I=1,N XI = X(I) ILP1MX = MIN(I+K,NP1) ! *** FIND LEFT IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT ! T(LEFT) <= X(I) < T(LEFT+1) ! MATRIX IS SINGULAR if THIS IS NOT POSSIBLE LEFT = MAX(LEFT,I) if (XI < T(LEFT)) go to 80 20 if (XI < T(LEFT+1)) go to 30 LEFT = LEFT + 1 if (LEFT < ILP1MX) go to 20 LEFT = LEFT - 1 if (XI > T(LEFT+1)) go to 80 ! *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE ! A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE K ENTRIES WITH J = ! LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE K NUMBERS ! ARE RETURNED, IN BCOEF (USED FOR TEMP. STORAGE HERE), BY THE ! FOLLOWING 30 call DBSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK) ! WE THEREFORE WANT BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO ! A(I,LEFT-K+J), I.E., INTO Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE ! A(I+J,J) IS TO GO INTO Q(I+K,J), ALL I,J, if WE CONSIDER Q ! AS A TWO-DIM. ARRAY , WITH 2*K-1 ROWS (SEE COMMENTS IN ! DBNFAC). IN THE PRESENT PROGRAM, WE TREAT Q AS AN EQUIVALENT ! ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON ! DIMENSION STATEMENTS) . WE THEREFORE WANT BCOEF(J) TO GO INTO ! ENTRY ! I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1) ! = I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J ! OF Q . JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1) DO 40 J=1,K JJ = JJ + KPKM2 Q(JJ) = BCOEF(J) 40 CONTINUE 50 CONTINUE ! ! ***OBTAIN FACTORIZATION OF A , STORED AGAIN IN Q. call DBNFAC(Q, K+KM1, N, KM1, KM1, IFLAG) go to (60, 90), IFLAG ! *** SOLVE A*BCOEF = Y BY BACKSUBSTITUTION 60 DO 70 I=1,N BCOEF(I) = Y(I) 70 CONTINUE call DBNSLV(Q, K+KM1, N, KM1, KM1, BCOEF) return ! ! 80 CONTINUE call XERMSG ('SLATEC', 'DBINTK', & 'SOME ABSCISSA WAS NOT IN THE SUPPORT OF THE CORRESPONDING ' // & 'BASIS FUNCTION AND THE SYSTEM IS SINGULAR.', 2, 1) return 90 CONTINUE call XERMSG ('SLATEC', 'DBINTK', & 'THE SYSTEM OF SOLVER DETECTS A SINGULAR SYSTEM ALTHOUGH ' // & 'THE THEORETICAL CONDITIONS FOR A SOLUTION WERE SATISFIED.', & 8, 1) return 100 CONTINUE call XERMSG ('SLATEC', 'DBINTK', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'DBINTK', 'N DOES NOT SATISFY N >= K', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'DBINTK', & 'X(I) DOES NOT SATISFY X(I) < X(I+1) FOR SOME I', 2, 1) return end subroutine DBKIAS (X, N, KTRMS, T, ANS, IND, MS, GMRN, H, IERR) ! !! DBKIAS is subsidiary to DBSKIN. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BKIAS-S, DBKIAS-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! DBKIAS computes repeated integrals of the K0 Bessel function ! by the asymptotic expansion ! !***SEE ALSO DBSKIN !***ROUTINES CALLED D1MACH, DBDIFF, DGAMRN, DHKSEQ !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DBKIAS INTEGER I, II, IND, J, JMI, JN, K, KK, KM, KTRMS, MM, MP, MS, N, & IERR DOUBLE PRECISION ANS, B, BND, DEN1, DEN2, DEN3, ER, ERR, FJ, FK, & FLN, FM1, GMRN, G1, GS, H, HN, HRTPI, RAT, RG1, RXP, RZ, RZX, S, & SS, SUMI, SUMJ, T, TOL, V, W, X, XP, Z DOUBLE PRECISION DGAMRN, D1MACH DIMENSION B(120), XP(16), S(31), H(*), V(52), W(52), T(50), & BND(15) SAVE B, BND, HRTPI !----------------------------------------------------------------------- ! COEFFICIENTS OF POLYNOMIAL P(J-1,X), J=1,15 !----------------------------------------------------------------------- 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), B(23), B(24) /1.00000000000000000D+00, & 1.00000000000000000D+00,-2.00000000000000000D+00, & 1.00000000000000000D+00,-8.00000000000000000D+00, & 6.00000000000000000D+00,1.00000000000000000D+00, & -2.20000000000000000D+01,5.80000000000000000D+01, & -2.40000000000000000D+01,1.00000000000000000D+00, & -5.20000000000000000D+01,3.28000000000000000D+02, & -4.44000000000000000D+02,1.20000000000000000D+02, & 1.00000000000000000D+00,-1.14000000000000000D+02, & 1.45200000000000000D+03,-4.40000000000000000D+03, & 3.70800000000000000D+03,-7.20000000000000000D+02, & 1.00000000000000000D+00,-2.40000000000000000D+02, & 5.61000000000000000D+03/ DATA B(25), B(26), B(27), B(28), B(29), B(30), B(31), B(32), & B(33), B(34), B(35), B(36), B(37), B(38), B(39), B(40), B(41), & B(42), B(43), B(44), B(45), B(46), B(47), B(48) & /-3.21200000000000000D+04,5.81400000000000000D+04, & -3.39840000000000000D+04,5.04000000000000000D+03, & 1.00000000000000000D+00,-4.94000000000000000D+02, & 1.99500000000000000D+04,-1.95800000000000000D+05, & 6.44020000000000000D+05,-7.85304000000000000D+05, & 3.41136000000000000D+05,-4.03200000000000000D+04, & 1.00000000000000000D+00,-1.00400000000000000D+03, & 6.72600000000000000D+04,-1.06250000000000000D+06, & 5.76550000000000000D+06,-1.24400640000000000D+07, & 1.10262960000000000D+07,-3.73392000000000000D+06, & 3.62880000000000000D+05,1.00000000000000000D+00, & -2.02600000000000000D+03,2.18848000000000000D+05/ DATA B(49), B(50), B(51), B(52), B(53), B(54), B(55), B(56), & B(57), B(58), B(59), B(60), B(61), B(62), B(63), B(64), B(65), & B(66), B(67), B(68), B(69), B(70), B(71), B(72) & /-5.32616000000000000D+06,4.47650000000000000D+07, & -1.55357384000000000D+08,2.38904904000000000D+08, & -1.62186912000000000D+08,4.43390400000000000D+07, & -3.62880000000000000D+06,1.00000000000000000D+00, & -4.07200000000000000D+03,6.95038000000000000D+05, & -2.52439040000000000D+07,3.14369720000000000D+08, & -1.64838430400000000D+09,4.00269508800000000D+09, & -4.64216395200000000D+09,2.50748121600000000D+09, & -5.68356480000000000D+08,3.99168000000000000D+07, & 1.00000000000000000D+00,-8.16600000000000000D+03, & 2.17062600000000000D+06,-1.14876376000000000D+08, & 2.05148277600000000D+09,-1.55489607840000000D+10/ DATA B(73), B(74), B(75), B(76), B(77), B(78), B(79), B(80), & B(81), B(82), B(83), B(84), B(85), B(86), B(87), B(88), B(89), & B(90), B(91), B(92), B(93), B(94), B(95), B(96) & /5.60413987840000000D+10,-1.01180433024000000D+11, & 9.21997902240000000D+10,-4.07883018240000000D+10, & 7.82771904000000000D+09,-4.79001600000000000D+08, & 1.00000000000000000D+00,-1.63560000000000000D+04, & 6.69969600000000000D+06,-5.07259276000000000D+08, & 1.26698177760000000D+10,-1.34323420224000000D+11, & 6.87720046384000000D+11,-1.81818864230400000D+12, & 2.54986547342400000D+12,-1.88307966182400000D+12, & 6.97929436800000000D+11,-1.15336085760000000D+11, & 6.22702080000000000D+09,1.00000000000000000D+00, & -3.27380000000000000D+04,2.05079880000000000D+07, & -2.18982980800000000D+09,7.50160522280000000D+10/ DATA B(97), B(98), B(99), B(100), B(101), B(102), B(103), B(104), & B(105), B(106), B(107), B(108), B(109), B(110), B(111), B(112), & B(113), B(114), B(115), B(116), B(117), B(118) & /-1.08467651241600000D+12,7.63483214939200000D+12, & -2.82999100661120000D+13,5.74943734645920000D+13, & -6.47283751398720000D+13,3.96895780558080000D+13, & -1.25509040179200000D+13,1.81099255680000000D+12, & -8.71782912000000000D+10,1.00000000000000000D+00, & -6.55040000000000000D+04,6.24078900000000000D+07, & -9.29252692000000000D+09,4.29826006340000000D+11, & -8.30844432796800000D+12,7.83913848313120000D+13, & -3.94365587815520000D+14,1.11174747256968000D+15, & -1.79717122069056000D+15,1.66642448627145600D+15, & -8.65023253219584000D+14,2.36908271543040000D+14/ DATA B(119), B(120) /-3.01963769856000000D+13, & 1.30767436800000000D+12/ !----------------------------------------------------------------------- ! BOUNDS B(M,K) , K=M-3 !----------------------------------------------------------------------- DATA BND(1), BND(2), BND(3), BND(4), BND(5), BND(6), BND(7), & BND(8), BND(9), BND(10), BND(11), BND(12), BND(13), BND(14), & BND(15) /1.0D0,1.0D0,1.0D0,1.0D0,3.10D0,5.18D0,11.7D0,29.8D0, & 90.4D0,297.0D0,1070.0D0,4290.0D0,18100.0D0,84700.0D0,408000.0D0/ DATA HRTPI /8.86226925452758014D-01/ ! !***FIRST EXECUTABLE STATEMENT DBKIAS IERR=0 TOL = MAX(D1MACH(4),1.0D-18) FLN = N RZ = 1.0D0/(X+FLN) RZX = X*RZ Z = 0.5D0*(X+FLN) if (IND > 1) go to 10 GMRN = DGAMRN(Z) 10 CONTINUE GS = HRTPI*GMRN G1 = GS + GS RG1 = 1.0D0/G1 GMRN = (RZ+RZ)/GMRN if (IND > 1) go to 70 !----------------------------------------------------------------------- ! EVALUATE ERROR FOR M=MS !----------------------------------------------------------------------- HN = 0.5D0*FLN DEN2 = KTRMS + KTRMS + N DEN3 = DEN2 - 2.0D0 DEN1 = X + DEN2 ERR = RG1*(X+X)/(DEN1-1.0D0) if (N == 0) go to 20 RAT = 1.0D0/(FLN*FLN) 20 CONTINUE if (KTRMS == 0) go to 30 FJ = KTRMS RAT = 0.25D0/(HRTPI*DEN3*SQRT(FJ)) 30 CONTINUE ERR = ERR*RAT FJ = -3.0D0 DO 50 J=1,15 if (J <= 5) ERR = ERR/DEN1 FM1 = MAX(1.0D0,FJ) FJ = FJ + 1.0D0 ER = BND(J)*ERR if (KTRMS == 0) go to 40 ER = ER/FM1 if (ER < TOL) go to 60 if (J >= 5) ERR = ERR/DEN3 go to 50 40 CONTINUE ER = ER*(1.0D0+HN/FM1) if (ER < TOL) go to 60 if (J >= 5) ERR = ERR/FLN 50 CONTINUE go to 200 60 CONTINUE MS = J 70 CONTINUE MM = MS + MS MP = MM + 1 !----------------------------------------------------------------------- ! H(K)=(-Z)**(K)*(PSI(K-1,Z)-PSI(K-1,Z+0.5))/GAMMA(K) , K=1,2,...,MM !----------------------------------------------------------------------- if (IND > 1) go to 80 call DHKSEQ(Z, MM, H, IERR) go to 100 80 CONTINUE RAT = Z/(Z-0.5D0) RXP = RAT DO 90 I=1,MM H(I) = RXP*(1.0D0-H(I)) RXP = RXP*RAT 90 CONTINUE 100 CONTINUE !----------------------------------------------------------------------- ! SCALED S SEQUENCE !----------------------------------------------------------------------- S(1) = 1.0D0 FK = 1.0D0 DO 120 K=2,MP SS = 0.0D0 KM = K - 1 I = KM DO 110 J=1,KM SS = SS + S(J)*H(I) I = I - 1 110 CONTINUE S(K) = SS/FK FK = FK + 1.0D0 120 CONTINUE !----------------------------------------------------------------------- ! SCALED S-TILDA SEQUENCE !----------------------------------------------------------------------- if (KTRMS == 0) go to 160 FK = 0.0D0 SS = 0.0D0 RG1 = RG1/Z DO 130 K=1,KTRMS V(K) = Z/(Z+FK) W(K) = T(K)*V(K) SS = SS + W(K) FK = FK + 1.0D0 130 CONTINUE S(1) = S(1) - SS*RG1 DO 150 I=2,MP SS = 0.0D0 DO 140 K=1,KTRMS W(K) = W(K)*V(K) SS = SS + W(K) 140 CONTINUE S(I) = S(I) - SS*RG1 150 CONTINUE 160 CONTINUE !----------------------------------------------------------------------- ! SUM ON J !----------------------------------------------------------------------- SUMJ = 0.0D0 JN = 1 RXP = 1.0D0 XP(1) = 1.0D0 DO 190 J=1,MS JN = JN + J - 1 XP(J+1) = XP(J)*RZX RXP = RXP*RZ !----------------------------------------------------------------------- ! SUM ON I !----------------------------------------------------------------------- SUMI = 0.0D0 II = JN DO 180 I=1,J JMI = J - I + 1 KK = J + I + 1 DO 170 K=1,JMI V(K) = S(KK)*XP(K) KK = KK + 1 170 CONTINUE call DBDIFF(JMI, V) SUMI = SUMI + B(II)*V(JMI)*XP(I+1) II = II + 1 180 CONTINUE SUMJ = SUMJ + SUMI*RXP 190 CONTINUE ANS = GS*(S(1)-SUMJ) return 200 CONTINUE IERR=2 return end subroutine DBKISR (X, N, SUM, IERR) ! !! DBKISR is subsidiary to DBSKIN. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BKISR-S, DBKISR-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! DBKISR computes repeated integrals of the K0 Bessel function ! by the series for N=0,1, and 2. ! !***SEE ALSO DBSKIN !***ROUTINES CALLED D1MACH, DPSIXN !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DBKISR INTEGER I, IERR, K, KK, KKN, K1, N, NP DOUBLE PRECISION AK, ATOL, BK, C, FK, FN, HX, HXS, POL, PR, SUM, & TKP, TOL, TRM, X, XLN DOUBLE PRECISION DPSIXN, D1MACH DIMENSION C(2) SAVE C ! DATA C(1), C(2) /1.57079632679489662D+00,1.0D0/ !***FIRST EXECUTABLE STATEMENT DBKISR IERR=0 TOL = MAX(D1MACH(4),1.0D-18) if (X < TOL) go to 50 PR = 1.0D0 POL = 0.0D0 if (N == 0) go to 20 DO 10 I=1,N POL = -POL*X + C(I) PR = PR*X/I 10 CONTINUE 20 CONTINUE HX = X*0.5D0 HXS = HX*HX XLN = LOG(HX) NP = N + 1 TKP = 3.0D0 FK = 2.0D0 FN = N BK = 4.0D0 AK = 2.0D0/((FN+1.0D0)*(FN+2.0D0)) SUM = AK*(DPSIXN(N+3)-DPSIXN(3)+DPSIXN(2)-XLN) ATOL = SUM*TOL*0.75D0 DO 30 K=2,20 AK = AK*(HXS/BK)*((TKP+1.0D0)/(TKP+FN+1.0D0))*(TKP/(TKP+FN)) K1 = K + 1 KK = K1 + K KKN = KK + N TRM = (DPSIXN(K1)+DPSIXN(KKN)-DPSIXN(KK)-XLN)*AK SUM = SUM + TRM if (ABS(TRM) <= ATOL) go to 40 TKP = TKP + 2.0D0 BK = BK + TKP FK = FK + 1.0D0 30 CONTINUE go to 80 40 CONTINUE SUM = (SUM*HXS+DPSIXN(NP)-XLN)*PR if (N == 1) SUM = -SUM SUM = POL + SUM return !----------------------------------------------------------------------- ! SMALL X CASE, X < WORD TOLERANCE !----------------------------------------------------------------------- 50 CONTINUE if (N > 0) go to 60 HX = X*0.5D0 SUM = DPSIXN(1) - LOG(HX) return 60 CONTINUE SUM = C(N) return 80 CONTINUE IERR=2 return end subroutine DBKSOL (N, A, X) ! !! DBKSOL is subsidiary to DBVSUP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BKSOL-S, DBKSOL-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! Solution of an upper triangular linear system by ! back-substitution ! ! The matrix A is assumed to be stored in a linear ! array proceeding in a row-wise manner. The ! vector X contains the given constant vector on input ! and contains the solution on return. ! The actual diagonal of A is unity while a diagonal ! scaling matrix is stored there. ! ********************************************************************** ! !***SEE ALSO DBVSUP !***ROUTINES CALLED DDOT !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DBKSOL ! DOUBLE PRECISION DDOT INTEGER J, K, M, N, NM1 DOUBLE PRECISION A(*), X(*) ! !***FIRST EXECUTABLE STATEMENT DBKSOL M = (N*(N + 1))/2 X(N) = X(N)*A(M) NM1 = N - 1 if (NM1 < 1) go to 20 DO 10 K = 1, NM1 J = N - K M = M - K - 1 X(J) = X(J)*A(M) - DDOT(K,A(M+1),1,X(J+1),1) 10 CONTINUE 20 CONTINUE ! return end subroutine DBNDAC (G, MDG, NB, IP, IR, MT, JT) ! !! DBNDAC computes the LU factorization of banded matrices using ... ! sequential accumulation of rows of the data matrix. ! Exactly one right-hand side vector is permitted. ! !***LIBRARY SLATEC !***CATEGORY D9 !***TYPE DOUBLE PRECISION (BNDACC-S, DBNDAC-D) !***KEYWORDS BANDED MATRIX, CURVE FITTING, LEAST SQUARES !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! These subroutines solve the least squares problem Ax = b for ! banded matrices A using sequential accumulation of rows of the ! data matrix. Exactly one right-hand side vector is permitted. ! ! These subroutines are intended for the type of least squares ! systems that arise in applications such as curve or surface ! fitting of data. The least squares equations are accumulated and ! processed using only part of the data. This requires a certain ! user interaction during the solution of Ax = b. ! ! Specifically, suppose the data matrix (A B) is row partitioned ! into Q submatrices. Let (E F) be the T-th one of these ! submatrices where E = (0 C 0). Here the dimension of E is MT by N ! and the dimension of C is MT by NB. The value of NB is the ! bandwidth of A. The dimensions of the leading block of zeros in E ! are MT by JT-1. ! ! The user of the subroutine DBNDAC provides MT,JT,C and F for ! T=1,...,Q. Not all of this data must be supplied at once. ! ! Following the processing of the various blocks (E F), the matrix ! (A B) has been transformed to the form (R D) where R is upper ! triangular and banded with bandwidth NB. The least squares ! system Rx = d is then easily solved using back substitution by ! executing the statement call DBNDSL(1,...). The sequence of ! values for JT must be nondecreasing. This may require some ! preliminary interchanges of rows and columns of the matrix A. ! ! The primary reason for these subroutines is that the total ! processing can take place in a working array of dimension MU by ! NB+1. An acceptable value for MU is ! ! MU = MAX(MT + N + 1), ! ! where N is the number of unknowns. ! ! Here the maximum is taken over all values of MT for T=1,...,Q. ! Notice that MT can be taken to be a small as one, showing that ! MU can be as small as N+2. The subprogram DBNDAC processes the ! rows more efficiently if MU is large enough so that each new ! block (C F) has a distinct value of JT. ! ! The four principle parts of these algorithms are obtained by the ! following call statements ! ! call DBNDAC(...) Introduce new blocks of data. ! ! call DBNDSL(1,...)Compute solution vector and length of ! residual vector. ! ! call DBNDSL(2,...)Given any row vector H solve YR = H for the ! row vector Y. ! ! call DBNDSL(3,...)Given any column vector W solve RZ = W for ! the column vector Z. ! ! The dots in the above call statements indicate additional ! arguments that will be specified in the following paragraphs. ! ! The user must dimension the array appearing in the call list.. ! G(MDG,NB+1) ! ! Description of calling sequence for DBNDAC.. ! ! The entire set of parameters for DBNDAC are ! ! Input.. All Type REAL variables are DOUBLE PRECISION ! ! G(*,*) The working array into which the user will ! place the MT by NB+1 block (C F) in rows IR ! through IR+MT-1, columns 1 through NB+1. ! See descriptions of IR and MT below. ! ! MDG The number of rows in the working array ! G(*,*). The value of MDG should be >= MU. ! The value of MU is defined in the abstract ! of these subprograms. ! ! NB The bandwidth of the data matrix A. ! ! IP Set by the user to the value 1 before the ! first call to DBNDAC. Its subsequent value ! is controlled by DBNDAC to set up for the ! next call to DBNDAC. ! ! IR Index of the row of G(*,*) where the user is ! to place the new block of data (C F). Set by ! the user to the value 1 before the first call ! to DBNDAC. Its subsequent value is controlled ! by DBNDAC. A value of IR > MDG is considered ! an error. ! ! MT,JT Set by the user to indicate respectively the ! number of new rows of data in the block and ! the index of the first nonzero column in that ! set of rows (E F) = (0 C 0 F) being processed. ! ! Output.. All Type REAL variables are DOUBLE PRECISION ! ! G(*,*) The working array which will contain the ! processed rows of that part of the data ! matrix which has been passed to DBNDAC. ! ! IP,IR The values of these arguments are advanced by ! DBNDAC to be ready for storing and processing ! a new block of data in G(*,*). ! ! Description of calling sequence for DBNDSL.. ! ! The user must dimension the arrays appearing in the call list.. ! ! G(MDG,NB+1), X(N) ! ! The entire set of parameters for DBNDSL are ! ! Input.. All Type REAL variables are DOUBLE PRECISION ! ! MODE Set by the user to one of the values 1, 2, or ! 3. These values respectively indicate that ! the solution of AX = B, YR = H or RZ = W is ! required. ! ! G(*,*),MDG, These arguments all have the same meaning and ! NB,IP,IR contents as following the last call to DBNDAC. ! ! X(*) With mode=2 or 3 this array contains, ! respectively, the right-side vectors H or W of ! the systems YR = H or RZ = W. ! ! N The number of variables in the solution ! vector. If any of the N diagonal terms are ! zero the subroutine DBNDSL prints an ! appropriate message. This condition is ! considered an error. ! ! Output.. All Type REAL variables are DOUBLE PRECISION ! ! X(*) This array contains the solution vectors X, ! Y or Z of the systems AX = B, YR = H or ! RZ = W depending on the value of MODE=1, ! 2 or 3. ! ! RNORM If MODE=1 RNORM is the Euclidean length of the ! residual vector AX-B. When MODE=2 or 3 RNORM ! is set to zero. ! ! Remarks.. ! ! To obtain the upper triangular matrix and transformed right-hand ! side vector D so that the super diagonals of R form the columns ! of G(*,*), execute the following Fortran statements. ! ! NBP1=NB+1 ! ! DO 10 J=1, NBP1 ! ! 10 G(IR,J) = 0.E0 ! ! MT=1 ! ! JT=N+1 ! ! call DBNDAC(G,MDG,NB,IP,IR,MT,JT) ! !***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares ! Problems, Prentice-Hall, Inc., 1974, Chapter 27. !***ROUTINES CALLED DH12, XERMSG !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBNDAC IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(MDG,*) !***FIRST EXECUTABLE STATEMENT DBNDAC ZERO=0.D0 ! ! ALG. STEPS 1-4 ARE PERFORMED EXTERNAL TO THIS SUBROUTINE. ! NBP1=NB+1 if (MT <= 0.OR.NB <= 0) RETURN ! if ( .NOT.MDG < IR) go to 5 NERR=1 IOPT=2 call XERMSG ('SLATEC', 'DBNDAC', 'MDG < IR, PROBABLE ERROR.', & NERR, IOPT) return 5 CONTINUE ! ! ALG. STEP 5 if (JT == IP) go to 70 ! ALG. STEPS 6-7 if (JT <= IR) go to 30 ! ALG. STEPS 8-9 DO 10 I=1,MT IG1=JT+MT-I IG2=IR+MT-I DO 10 J=1,NBP1 G(IG1,J)=G(IG2,J) 10 CONTINUE ! ALG. STEP 10 IE=JT-IR DO 20 I=1,IE IG=IR+I-1 DO 20 J=1,NBP1 G(IG,J)=ZERO 20 CONTINUE ! ALG. STEP 11 IR=JT ! ALG. STEP 12 30 MU=MIN(NB-1,IR-IP-1) if (MU == 0) go to 60 ! ALG. STEP 13 DO 50 L=1,MU ! ALG. STEP 14 K=MIN(L,JT-IP) ! 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 ! ALG. STEP 16 DO 50 I=1,K JG=NBP1-I G(IG,JG)=ZERO 50 CONTINUE ! ALG. STEP 17 60 IP=JT ! ALG. STEPS 18-19 70 MH=IR+MT-IP KH=MIN(NBP1,MH) ! ALG. STEP 20 DO 80 I=1,KH call DH12 (1,I,MAX(I+1,IR-IP+1),MH,G(IP,I),1,RHO, & G(IP,I+1),1,MDG,NBP1-I) 80 CONTINUE ! ALG. STEP 21 IR=IP+KH ! ALG. STEP 22 if (KH < NBP1) go to 100 ! ALG. STEP 23 DO 90 I=1,NB G(IR-1,I)=ZERO 90 CONTINUE ! ALG. STEP 24 100 CONTINUE ! ALG. STEP 25 return end subroutine DBNDSL (MODE, G, MDG, NB, IP, IR, X, N, RNORM) ! !! DBNDSL solves the least squares problem for a banded matrix using ... ! sequential accumulation of rows of the data matrix. ! Exactly one right-hand side vector is permitted. ! !***LIBRARY SLATEC !***CATEGORY D9 !***TYPE DOUBLE PRECISION (BNDSOL-S, DBNDSL-D) !***KEYWORDS BANDED MATRIX, CURVE FITTING, LEAST SQUARES !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! These subroutines solve the least squares problem Ax = b for ! banded matrices A using sequential accumulation of rows of the ! data matrix. Exactly one right-hand side vector is permitted. ! ! These subroutines are intended for the type of least squares ! systems that arise in applications such as curve or surface ! fitting of data. The least squares equations are accumulated and ! processed using only part of the data. This requires a certain ! user interaction during the solution of Ax = b. ! ! Specifically, suppose the data matrix (A B) is row partitioned ! into Q submatrices. Let (E F) be the T-th one of these ! submatrices where E = (0 C 0). Here the dimension of E is MT by N ! and the dimension of C is MT by NB. The value of NB is the ! bandwidth of A. The dimensions of the leading block of zeros in E ! are MT by JT-1. ! ! The user of the subroutine DBNDAC provides MT,JT,C and F for ! T=1,...,Q. Not all of this data must be supplied at once. ! ! Following the processing of the various blocks (E F), the matrix ! (A B) has been transformed to the form (R D) where R is upper ! triangular and banded with bandwidth NB. The least squares ! system Rx = d is then easily solved using back substitution by ! executing the statement call DBNDSL(1,...). The sequence of ! values for JT must be nondecreasing. This may require some ! preliminary interchanges of rows and columns of the matrix A. ! ! The primary reason for these subroutines is that the total ! processing can take place in a working array of dimension MU by ! NB+1. An acceptable value for MU is ! ! MU = MAX(MT + N + 1), ! ! where N is the number of unknowns. ! ! Here the maximum is taken over all values of MT for T=1,...,Q. ! Notice that MT can be taken to be a small as one, showing that ! MU can be as small as N+2. The subprogram DBNDAC processes the ! rows more efficiently if MU is large enough so that each new ! block (C F) has a distinct value of JT. ! ! The four principle parts of these algorithms are obtained by the ! following call statements ! ! call DBNDAC(...) Introduce new blocks of data. ! ! call DBNDSL(1,...)Compute solution vector and length of ! residual vector. ! ! call DBNDSL(2,...)Given any row vector H solve YR = H for the ! row vector Y. ! ! call DBNDSL(3,...)Given any column vector W solve RZ = W for ! the column vector Z. ! ! The dots in the above call statements indicate additional ! arguments that will be specified in the following paragraphs. ! ! The user must dimension the array appearing in the call list.. ! G(MDG,NB+1) ! ! Description of calling sequence for DBNDAC.. ! ! The entire set of parameters for DBNDAC are ! ! Input.. All Type REAL variables are DOUBLE PRECISION ! ! G(*,*) The working array into which the user will ! place the MT by NB+1 block (C F) in rows IR ! through IR+MT-1, columns 1 through NB+1. ! See descriptions of IR and MT below. ! ! MDG The number of rows in the working array ! G(*,*). The value of MDG should be >= MU. ! The value of MU is defined in the abstract ! of these subprograms. ! ! NB The bandwidth of the data matrix A. ! ! IP Set by the user to the value 1 before the ! first call to DBNDAC. Its subsequent value ! is controlled by DBNDAC to set up for the ! next call to DBNDAC. ! ! IR Index of the row of G(*,*) where the user is ! the user to the value 1 before the first call ! to DBNDAC. Its subsequent value is controlled ! by DBNDAC. A value of IR > MDG is considered ! an error. ! ! MT,JT Set by the user to indicate respectively the ! number of new rows of data in the block and ! the index of the first nonzero column in that ! set of rows (E F) = (0 C 0 F) being processed. ! Output.. All Type REAL variables are DOUBLE PRECISION ! ! G(*,*) The working array which will contain the ! processed rows of that part of the data ! matrix which has been passed to DBNDAC. ! ! IP,IR The values of these arguments are advanced by ! DBNDAC to be ready for storing and processing ! a new block of data in G(*,*). ! ! Description of calling sequence for DBNDSL.. ! ! The user must dimension the arrays appearing in the call list.. ! ! G(MDG,NB+1), X(N) ! ! The entire set of parameters for DBNDSL are ! ! Input.. ! ! MODE Set by the user to one of the values 1, 2, or ! 3. These values respectively indicate that ! the solution of AX = B, YR = H or RZ = W is ! required. ! ! G(*,*),MDG, These arguments all have the same meaning and ! NB,IP,IR contents as following the last call to DBNDAC. ! ! X(*) With mode=2 or 3 this array contains, ! respectively, the right-side vectors H or W of ! the systems YR = H or RZ = W. ! ! N The number of variables in the solution ! vector. If any of the N diagonal terms are ! zero the subroutine DBNDSL prints an ! appropriate message. This condition is ! considered an error. ! ! Output.. ! ! X(*) This array contains the solution vectors X, ! Y or Z of the systems AX = B, YR = H or ! RZ = W depending on the value of MODE=1, ! 2 or 3. ! ! RNORM If MODE=1 RNORM is the Euclidean length of the ! residual vector AX-B. When MODE=2 or 3 RNORM ! is set to zero. ! ! Remarks.. ! ! To obtain the upper triangular matrix and transformed right-hand ! side vector D so that the super diagonals of R form the columns ! of G(*,*), execute the following Fortran statements. ! ! NBP1=NB+1 ! ! DO 10 J=1, NBP1 ! ! 10 G(IR,J) = 0.E0 ! ! MT=1 ! ! JT=N+1 ! ! call DBNDAC(G,MDG,NB,IP,IR,MT,JT) ! !***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares ! Problems, Prentice-Hall, Inc., 1974, Chapter 27. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBNDSL IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION G(MDG,*),X(*) !***FIRST EXECUTABLE STATEMENT DBNDSL ZERO=0.D0 ! RNORM=ZERO go to (10,90,50), MODE ! ********************* MODE = 1 ! ALG. STEP 26 10 DO 20 J=1,N X(J)=G(J,NB+1) 20 CONTINUE RSQ=ZERO NP1=N+1 IRM1=IR-1 if (NP1 > IRM1) go to 40 DO 30 J=NP1,IRM1 RSQ=RSQ+G(J,NB+1)**2 30 CONTINUE RNORM=SQRT(RSQ) 40 CONTINUE ! ********************* MODE = 3 ! ALG. STEP 27 50 DO 80 II=1,N I=N+1-II ! ALG. STEP 28 S=ZERO L=MAX(0,I-IP) ! ALG. STEP 29 if (I == N) go to 70 ! ALG. STEP 30 IE=MIN(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 ! ALG. STEP 31 70 if (G(I,L+1)) 80,130,80 80 X(I)=(X(I)-S)/G(I,L+1) ! ALG. STEP 32 return ! ********************* MODE = 2 90 DO 120 J=1,N S=ZERO if (J == 1) go to 110 I1=MAX(1,J-NB+1) I2=J-1 DO 100 I=I1,I2 L=J-I+1+MAX(0,I-IP) S=S+X(I)*G(I,L) 100 CONTINUE 110 L=MAX(0,J-IP) if (G(J,L+1)) 120,130,120 120 X(J)=(X(J)-S)/G(J,L+1) return ! 130 CONTINUE NERR=1 IOPT=2 call XERMSG ('SLATEC', 'DBNDSL', & 'A ZERO DIAGONAL TERM IS IN THE N BY N UPPER TRIANGULAR ' // & 'MATRIX.', NERR, IOPT) return end subroutine DBNFAC (W, NROWW, NROW, NBANDL, NBANDU, IFLAG) ! !! DBNFAC is subsidiary to DBINT4 and DBINTK. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BNFAC-S, DBNFAC-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DBNFAC is the BANFAC routine from ! * A Practical Guide to Splines * by C. de Boor ! ! DBNFAC is a double precision routine ! ! Returns in W the LU-factorization (without pivoting) of the banded ! matrix A of order NROW with (NBANDL + 1 + NBANDU) bands or diag- ! onals in the work array W . ! ! ***** I N P U T ****** W is double precision ! W.....Work array of size (NROWW,NROW) containing the interesting ! part of a banded matrix A , with the diagonals or bands of A ! stored in the rows of W , while columns of A correspond to ! columns of W . This is the storage mode used in LINPACK and ! results in efficient innermost loops. ! Explicitly, A has NBANDL bands below the diagonal ! + 1 (main) diagonal ! + NBANDU bands above the diagonal ! and thus, with MIDDLE = NBANDU + 1, ! A(I+J,J) is in W(I+MIDDLE,J) for I=-NBANDU,...,NBANDL ! J=1,...,NROW . ! For example, the interesting entries of A (1,2)-banded matrix ! of order 9 would appear in the first 1+1+2 = 4 rows of W ! as follows. ! 13243546576879 ! 1223344556677889 ! 112233445566778899 ! 2132435465768798 ! ! All other entries of W not identified in this way with an en- ! try of A are never referenced . ! NROWW.....Row dimension of the work array W . ! must be >= NBANDL + 1 + NBANDU . ! NBANDL.....Number of bands of A below the main diagonal ! NBANDU.....Number of bands of A above the main diagonal . ! ! ***** O U T P U T ****** W is double precision ! IFLAG.....Integer indicating success( = 1) or failure ( = 2) . ! If IFLAG = 1, then ! W.....contains the LU-factorization of A into a unit lower triangu- ! lar matrix L and an upper triangular matrix U (both banded) ! and stored in customary fashion over the corresponding entries ! of A . This makes it possible to solve any particular linear ! system A*X = B for X by a ! call DBNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B ) ! with the solution X contained in B on return . ! If IFLAG = 2, then ! one of NROW-1, NBANDL,NBANDU failed to be nonnegative, or else ! one of the potential pivots was found to be zero indicating ! that A does not have an LU-factorization. This implies that ! A is singular in case it is totally positive . ! ! ***** M E T H O D ****** ! Gauss elimination W I T H O U T pivoting is used. The routine is ! intended for use with matrices A which do not require row inter- ! changes during factorization, especially for the T O T A L L Y ! P O S I T I V E matrices which occur in spline calculations. ! The routine should NOT be used for an arbitrary banded matrix. ! !***SEE ALSO DBINT4, DBINTK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DBNFAC ! INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K, & KMAX, MIDDLE, MIDMK, NROWM1 DOUBLE PRECISION W(NROWW,*), FACTOR, PIVOT ! !***FIRST EXECUTABLE STATEMENT DBNFAC IFLAG = 1 MIDDLE = NBANDU + 1 ! W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF A . NROWM1 = NROW - 1 if (NROWM1) 120, 110, 10 10 if (NBANDL > 0) go to 30 ! A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO . DO 20 I=1,NROWM1 if (W(MIDDLE,I) == 0.0D0) go to 120 20 CONTINUE go to 110 30 if (NBANDU > 0) go to 60 ! A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND ! DIVIDE EACH COLUMN BY ITS DIAGONAL . DO 50 I=1,NROWM1 PIVOT = W(MIDDLE,I) if (PIVOT == 0.0D0) go to 120 JMAX = MIN(NBANDL,NROW-I) DO 40 J=1,JMAX W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT 40 CONTINUE 50 CONTINUE return ! ! A IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION 60 DO 100 I=1,NROWM1 ! W(MIDDLE,I) IS PIVOT FOR I-TH STEP . PIVOT = W(MIDDLE,I) if (PIVOT == 0.0D0) go to 120 ! JMAX IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN I ! BELOW THE DIAGONAL . JMAX = MIN(NBANDL,NROW-I) ! DIVIDE EACH ENTRY IN COLUMN I BELOW DIAGONAL BY PIVOT . DO 70 J=1,JMAX W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT 70 CONTINUE ! KMAX IS THE NUMBER OF (NONZERO) ENTRIES IN ROW I TO ! THE RIGHT OF THE DIAGONAL . KMAX = MIN(NBANDU,NROW-I) ! SUBTRACT A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN ! (BELOW ROW I ) . DO 90 K=1,KMAX IPK = I + K MIDMK = MIDDLE - K FACTOR = W(MIDMK,IPK) DO 80 J=1,JMAX W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR 80 CONTINUE 90 CONTINUE 100 CONTINUE ! CHECK THE LAST DIAGONAL ENTRY . 110 if (W(MIDDLE,NROW) /= 0.0D0) RETURN 120 IFLAG = 2 return end subroutine DBNSLV (W, NROWW, NROW, NBANDL, NBANDU, B) ! !! DBNSLV is subsidiary to DBINT4 and DBINTK. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BNSLV-S, DBNSLV-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DBNSLV is the BANSLV routine from ! * A Practical Guide to Splines * by C. de Boor ! ! DBNSLV is a double precision routine ! ! Companion routine to DBNFAC . It returns the solution X of the ! linear system A*X = B in place of B , given the LU-factorization ! for A in the work array W from DBNFAC. ! ! ***** I N P U T ****** W,B are DOUBLE PRECISION ! W, NROWW,NROW,NBANDL,NBANDU.....Describe the LU-factorization of a ! banded matrix A of order NROW as constructed in DBNFAC . ! For details, see DBNFAC . ! B.....Right side of the system to be solved . ! ! ***** O U T P U T ****** B is DOUBLE PRECISION ! B.....Contains the solution X , of order NROW . ! ! ***** M E T H O D ****** ! (With A = L*U, as stored in W,) the unit lower triangular system ! L(U*X) = B is solved for Y = U*X, and Y stored in B . Then the ! upper triangular system U*X = Y is solved for X . The calcul- ! ations are so arranged that the innermost loops stay within columns. ! !***SEE ALSO DBINT4, DBINTK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DBNSLV ! INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1 DOUBLE PRECISION W(NROWW,*), B(*) !***FIRST EXECUTABLE STATEMENT DBNSLV MIDDLE = NBANDU + 1 if (NROW == 1) go to 80 NROWM1 = NROW - 1 if (NBANDL == 0) go to 30 ! FORWARD PASS ! FOR I=1,2,...,NROW-1, SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN ! OF L ) FROM RIGHT SIDE (BELOW I-TH ROW) . DO 20 I=1,NROWM1 JMAX = MIN(NBANDL,NROW-I) DO 10 J=1,JMAX B(I+J) = B(I+J) - B(I)*W(MIDDLE+J,I) 10 CONTINUE 20 CONTINUE ! BACKWARD PASS ! FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG- ! ONAL ENTRY OF U, THEN SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN ! OF U) FROM RIGHT SIDE (ABOVE I-TH ROW). 30 if (NBANDU > 0) go to 50 ! A IS LOWER TRIANGULAR . DO 40 I=1,NROW B(I) = B(I)/W(1,I) 40 CONTINUE return 50 I = NROW 60 B(I) = B(I)/W(MIDDLE,I) JMAX = MIN(NBANDU,I-1) DO 70 J=1,JMAX B(I-J) = B(I-J) - B(I)*W(MIDDLE-J,I) 70 CONTINUE I = I - 1 if (I > 1) go to 60 80 B(1) = B(1)/W(MIDDLE,1) return end subroutine DBOCLS (W, MDW, MCON, MROWS, NCOLS, BL, BU, IND, IOPT, & X, RNORMC, RNORM, MODE, RW, IW) ! !! DBOCLS solves the bounded and constrained least squares problem ... ! consisting of solving the equation ! E*X = F (in the least squares sense) ! subject to the linear constraints ! C*X = Y. ! !***LIBRARY SLATEC !***CATEGORY K1A2A, G2E, G2H1, G2H2 !***TYPE DOUBLE PRECISION (SBOCLS-S, DBOCLS-D) !***KEYWORDS BOUNDS, CONSTRAINTS, INEQUALITY, LEAST SQUARES, LINEAR !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! **** All INPUT and OUTPUT real variables are DOUBLE PRECISION **** ! ! This subprogram solves the bounded and constrained least squares ! problem. The problem statement is: ! ! Solve E*X = F (least squares sense), subject to constraints ! C*X=Y. ! ! In this formulation both X and Y are unknowns, and both may ! have bounds on any of their components. This formulation ! of the problem allows the user to have equality and inequality ! constraints as well as simple bounds on the solution components. ! ! This constrained linear least squares subprogram solves E*X=F ! subject to C*X=Y, where E is MROWS by NCOLS, C is MCON by NCOLS. ! ! The user must have dimension statements of the form ! ! DIMENSION W(MDW,NCOLS+MCON+1), BL(NCOLS+MCON), BU(NCOLS+MCON), ! * X(2*(NCOLS+MCON)+2+NX), RW(6*NCOLS+5*MCON) ! INTEGER IND(NCOLS+MCON), IOPT(17+NI), IW(2*(NCOLS+MCON)) ! ! (here NX=number of extra locations required for the options; NX=0 ! if no options are in use. Also NI=number of extra locations ! for options 1-9.) ! ! INPUT ! ----- ! ! ------------------------- ! W(MDW,*),MCON,MROWS,NCOLS ! ------------------------- ! The array W contains the (possibly null) matrix [C:*] followed by ! [E:F]. This must be placed in W as follows: ! [C : *] ! W = [ ] ! [E : F] ! The (*) after C indicates that this data can be undefined. The ! matrix [E:F] has MROWS rows and NCOLS+1 columns. The matrix C is ! placed in the first MCON rows of W(*,*) while [E:F] ! follows in rows MCON+1 through MCON+MROWS of W(*,*). The vector F ! is placed in rows MCON+1 through MCON+MROWS, column NCOLS+1. The ! values of MDW and NCOLS must be positive; the value of MCON must ! be nonnegative. An exception to this occurs when using option 1 ! for accumulation of blocks of equations. In that case MROWS is an ! OUTPUT variable only, and the matrix data for [E:F] is placed in ! W(*,*), one block of rows at a time. See IOPT(*) contents, option ! number 1, for further details. The row dimension, MDW, of the ! array W(*,*) must satisfy the inequality: ! ! If using option 1, ! MDW .ge. MCON + max(max. number of ! rows accumulated, NCOLS) + 1. ! If using option 8, ! MDW .ge. MCON + MROWS. ! Else ! MDW .ge. MCON + max(MROWS, NCOLS). ! ! Other values are errors, but this is checked only when using ! option=2. The value of MROWS is an output parameter when ! using option number 1 for accumulating large blocks of least ! squares equations before solving the problem. ! See IOPT(*) contents for details about option 1. ! ! ------------------ ! BL(*),BU(*),IND(*) ! ------------------ ! These arrays contain the information about the bounds that the ! solution values are to satisfy. The value of IND(J) tells the ! type of bound and BL(J) and BU(J) give the explicit values for ! the respective upper and lower bounds on the unknowns X and Y. ! The first NVARS entries of IND(*), BL(*) and BU(*) specify ! bounds on X; the next MCON entries specify bounds on Y. ! ! 1. For IND(J)=1, require X(J) .ge. BL(J); ! if J.gt.NCOLS, Y(J-NCOLS) .ge. BL(J). ! (the value of BU(J) is not used.) ! 2. For IND(J)=2, require X(J) .le. BU(J); ! if J.gt.NCOLS, Y(J-NCOLS) .le. BU(J). ! (the value of BL(J) is not used.) ! 3. For IND(J)=3, require X(J) .ge. BL(J) and ! X(J) .le. BU(J); ! if J.gt.NCOLS, Y(J-NCOLS) .ge. BL(J) and ! Y(J-NCOLS) .le. BU(J). ! (to impose equality constraints have BL(J)=BU(J)= ! constraining value.) ! 4. For IND(J)=4, no bounds on X(J) or Y(J-NCOLS) are required. ! (the values of BL(J) and BU(J) are not used.) ! ! Values other than 1,2,3 or 4 for IND(J) are errors. In the case ! IND(J)=3 (upper and lower bounds) the condition BL(J) .gt. BU(J) ! is an error. The values BL(J), BU(J), J .gt. NCOLS, will be ! changed. Significant changes mean that the constraints are ! infeasible. (Users must make this decision themselves.) ! The new values for BL(J), BU(J), J .gt. NCOLS, define a ! region such that the perturbed problem is feasible. If users ! know that their problem is feasible, this step can be skipped ! by using option number 8 described below. ! See IOPT(*) description. ! ! ! ------- ! IOPT(*) ! ------- ! This is the array where the user can specify nonstandard options ! for DBOCLS( ). Most of the time this feature can be ignored by ! setting the input value IOPT(1)=99. Occasionally users may have ! needs that require use of the following subprogram options. For ! details about how to use the options see below: IOPT(*) CONTENTS. ! ! Option Number Brief Statement of Purpose ! ------ ------ ----- --------- -- ------- ! 1 Return to user for accumulation of blocks ! of least squares equations. The values ! of IOPT(*) are changed with this option. ! The changes are updates to pointers for ! placing the rows of equations into position ! for processing. ! 2 Check lengths of all arrays used in the ! subprogram. ! 3 Column scaling of the data matrix, [C]. ! [E] ! 4 User provides column scaling for matrix [C]. ! [E] ! 5 Provide option array to the low-level ! subprogram SBOLS( ). ! 6 Provide option array to the low-level ! subprogram SBOLSM( ). ! 7 Move the IOPT(*) processing pointer. ! 8 Do not preprocess the constraints to ! resolve infeasibilities. ! 9 Do not pretriangularize the least squares matrix. ! 99 No more options to change. ! ! ---- ! X(*) ! ---- ! This array is used to pass data associated with options 4,5 and ! 6. Ignore this parameter (on input) if no options are used. ! Otherwise see below: IOPT(*) CONTENTS. ! ! ! OUTPUT ! ------ ! ! ----------------- ! X(*),RNORMC,RNORM ! ----------------- ! The array X(*) contains a solution (if MODE .ge.0 or .eq.-22) for ! the constrained least squares problem. The value RNORMC is the ! minimum residual vector length for the constraints C*X - Y = 0. ! The value RNORM is the minimum residual vector length for the ! least squares equations. Normally RNORMC=0, but in the case of ! inconsistent constraints this value will be nonzero. ! The values of X are returned in the first NVARS entries of X(*). ! The values of Y are returned in the last MCON entries of X(*). ! ! ---- ! MODE ! ---- ! The sign of MODE determines whether the subprogram has completed ! normally, or encountered an error condition or abnormal status. A ! value of MODE .ge. 0 signifies that the subprogram has completed ! normally. The value of mode (.ge. 0) is the number of variables ! in an active status: not at a bound nor at the value zero, for ! the case of free variables. A negative value of MODE will be one ! of the cases (-57)-(-41), (-37)-(-22), (-19)-(-2). Values .lt. -1 ! correspond to an abnormal completion of the subprogram. These ! error messages are in groups for the subprograms DBOCLS(), ! SBOLSM(), and SBOLS(). An approximate solution will be returned ! to the user only when max. iterations is reached, MODE=-22. ! ! ----------- ! RW(*),IW(*) ! ----------- ! These are working arrays. (normally the user can ignore the ! contents of these arrays.) ! ! IOPT(*) CONTENTS ! ------- -------- ! The option array allows a user to modify some internal variables ! in the subprogram without recompiling the source code. A central ! goal of the initial software design was to do a good job for most ! people. Thus the use of options will be restricted to a select ! group of users. The processing of the option array proceeds as ! follows: a pointer, here called LP, is initially set to the value ! 1. At the pointer position the option number is extracted and ! used for locating other information that allows for options to be ! changed. The portion of the array IOPT(*) that is used for each ! option is fixed; the user and the subprogram both know how many ! locations are needed for each option. The value of LP is updated ! for each option based on the amount of storage in IOPT(*) that is ! required. A great deal of error checking is done by the ! subprogram on the contents of the option array. Nevertheless it ! is still possible to give the subprogram optional input that is ! meaningless. For example option 4 uses the locations ! X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) for passing scaling data. ! The user must manage the allocation of these locations. ! ! 1 ! - ! This option allows the user to solve problems with a large number ! of rows compared to the number of variables. The idea is that the ! subprogram returns to the user (perhaps many times) and receives ! new least squares equations from the calling program unit. ! Eventually the user signals "that's all" and a solution is then ! computed. The value of MROWS is an output variable when this ! option is used. Its value is always in the range 0 .le. MROWS ! .le. NCOLS+1. It is the number of rows after the ! triangularization of the entire set of equations. If LP is the ! processing pointer for IOPT(*), the usage for the sequential ! processing of blocks of equations is ! ! ! IOPT(LP)=1 ! Move block of equations to W(*,*) starting at ! the first row of W(*,*). ! IOPT(LP+3)=# of rows in the block; user defined ! ! The user now calls DBOCLS( ) in a loop. The value of IOPT(LP+1) ! directs the user's action. The value of IOPT(LP+2) points to ! where the subsequent rows are to be placed in W(*,*). Both of ! these values are first defined in the subprogram. The user ! changes the value of IOPT(LP+1) (to 2) as a signal that all of ! the rows have been processed. ! ! ! .= 0 ! . ELSE ! . ERROR CONDITION; SHOULD NOT HAPPEN. ! .= THE NUMBER ! OF EFFECTIVE ROWS=(I2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 41 ! ! WARNING IN... ! DBOCLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE >= NCOLS+ ! MCON+1=(I2). ! IN ABOVE MESSAGE, I1= 2 ! IN ABOVE MESSAGE, I2= 3 ! ERROR NUMBER = 42 ! ! WARNING IN... ! DBOCLS(). THE DIMENSIONS OF THE ARRAYS BL(),BU(), AND IND()=(I1) ! MUST BE >= NCOLS+MCON=(I2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 43 ! ! WARNING IN... ! DBOCLS(). THE DIMENSION OF X()=(I1) MUST BE ! >= THE REQD.LENGTH=(I2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 44 ! ! WARNING IN... ! DBOCLS(). THE . ! DBOCLS() THE DIMENSION OF IW()=(I1) MUST BE >= 2*NCOLS+2*MCON=(I2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 4 ! ERROR NUMBER = 46 ! ! WARNING IN... ! DBOCLS(). THE DIMENSION OF IOPT()=(I1) MUST BE >= THE REQD. ! LEN.=(I2). ! IN ABOVE MESSAGE, I1= 16 ! IN ABOVE MESSAGE, I2= 18 ! ERROR NUMBER = 47 ! ! WARNING IN... ! DBOCLS(). ISCALE OPTION=(I1) MUST BE 1-3. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 48 ! ! WARNING IN... ! DBOCLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PROVIDED COLUMN SCALING ! MUST BE POSITIVE. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 49 ! ! WARNING IN... ! DBOCLS(). EACH PROVIDED COL. SCALE FACTOR MUST BE POSITIVE. ! COMPONENT (I1) NOW = (R1). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, R1= 0. ! ERROR NUMBER = 50 ! ! WARNING IN... ! DBOCLS(). THE OPTION NUMBER=(I1) IS NOT DEFINED. ! IN ABOVE MESSAGE, I1= 1001 ! ERROR NUMBER = 51 ! ! WARNING IN... ! DBOCLS(). NO. OF ROWS=(I1) MUST BE >= 0 .AND. <= MDW-MCON=(I2). ! IN ABOVE MESSAGE, I1= 2 ! IN ABOVE MESSAGE, I2= 1 ! ERROR NUMBER = 52 ! ! WARNING IN... ! DBOCLS(). MDW=(I1) MUST BE POSITIVE. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 53 ! ! WARNING IN... ! DBOCLS(). MCON=(I1) MUST BE NONNEGATIVE. ! IN ABOVE MESSAGE, I1= -1 ! ERROR NUMBER = 54 ! ! WARNING IN... ! DBOCLS(). NCOLS=(I1) THE NO. OF VARIABLES MUST BE POSITIVE. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 55 ! ! WARNING IN... ! DBOCLS(). FOR J=(I1), IND(J)=(I2) MUST BE 1-4. ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 0 ! ERROR NUMBER = 56 ! ! WARNING IN... ! DBOCLS(). FOR J=(I1), BOUND BL(J)=(R1) IS > BU(J)=(R2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, R1= .1000000000E+01 ! IN ABOVE MESSAGE, R2= 0. ! ERROR NUMBER = 57 ! LINEAR CONSTRAINTS, SNLA REPT. SAND82-1517, AUG., (1982). ! !***REFERENCES R. J. Hanson, Linear least squares with bounds and ! linear constraints, Report SAND82-1517, Sandia ! Laboratories, August 1982. !***ROUTINES CALLED D1MACH, DASUM, DBOLS, DCOPY, DDOT, DNRM2, DSCAL, ! XERMSG !***REVISION HISTORY (YYMMDD) ! 821220 DATE WRITTEN ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 910819 Added variable M for MOUT+MCON in reference to DBOLS. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBOCLS ! REVISED 850604-0900 ! REVISED YYMMDD-HHMM ! ! PURPOSE ! ------- ! THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE LEAST SQUARES ! PROBLEM CONSISTING OF LINEAR CONSTRAINTS ! ! C*X = Y ! ! AND LEAST SQUARES EQUATIONS ! ! E*X = F ! ! IN THIS FORMULATION THE VECTORS X AND Y ARE BOTH UNKNOWNS. ! FURTHER, X AND Y MAY BOTH HAVE USER-SPECIFIED BOUNDS ON EACH ! COMPONENT. THE USER MUST HAVE DIMENSION STATEMENTS OF THE ! FORM ! ! DIMENSION W(MDW,NCOLS+MCON+1), BL(NCOLS+MCON),BU(NCOLS+MCON), ! X(2*(NCOLS+MCON)+2+NX), RW(6*NCOLS+5*MCON) ! ! INTEGER IND(NCOLS+MCON), IOPT(16+NI), IW(2*(NCOLS+MCON)) ! ! TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN ! EDITING AT THE CARD 'C++'. ! CHANGE THIS SUBPROGRAM TO DBOCLS AND THE STRINGS ! /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/, /SRELPR/ TO /DRELPR/, ! /R1MACH/ TO /D1MACH/, /E0/ TO /D0/, /SCOPY/ TO /DCOPY/, ! /SSCAL/ TO /DSCAL/, /SASUM/ TO /DASUM/, /SBOLS/ TO /DBOLS/, ! /REAL / TO /DOUBLE PRECISION/. ! ++ DOUBLE PRECISION W(MDW,*),BL(*),BU(*),X(*),RW(*) DOUBLE PRECISION ANORM, CNORM, ONE, RNORM, RNORMC, DRELPR DOUBLE PRECISION T, T1, T2, DDOT, DNRM2, WT, ZERO DOUBLE PRECISION DASUM, D1MACH ! THIS VARIABLE REMAINS TYPED REAL. INTEGER IND(*),IOPT(*),IW(*),JOPT(05) LOGICAL CHECKL,FILTER,ACCUM,PRETRI CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 SAVE IGO,ACCUM,CHECKL DATA IGO/0/ !***FIRST EXECUTABLE STATEMENT DBOCLS NERR = 0 MODE = 0 if (IGO == 0) THEN ! DO(CHECK VALIDITY OF INPUT DATA) ! PROCEDURE(CHECK VALIDITY OF INPUT DATA) ! ! SEE THAT MDW IS > 0. GROSS CHECK ONLY. if (MDW <= 0) THEN WRITE (XERN1, '(I8)') MDW call XERMSG ('SLATEC', 'DBOCLS', 'MDW = ' // XERN1 // & ' MUST BE POSITIVE.', 53, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ! ! SEE THAT NUMBER OF CONSTRAINTS IS NONNEGATIVE. if (MCON < 0) THEN WRITE (XERN1, '(I8)') MCON call XERMSG ('SLATEC', 'DBOCLS', 'MCON = ' // XERN1 // & ' MUST BE NON-NEGATIVE', 54, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ! ! SEE THAT NUMBER OF UNKNOWNS IS POSITIVE. if (NCOLS <= 0) THEN WRITE (XERN1, '(I8)') NCOLS call XERMSG ('SLATEC', 'DBOCLS', 'NCOLS = ' // XERN1 // & ' THE NO. OF VARIABLES, MUST BE POSITIVE.', 55, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ! ! SEE THAT CONSTRAINT INDICATORS ARE ALL WELL-DEFINED. DO 10 J = 1,NCOLS + MCON if (IND(J) < 1 .OR. IND(J) > 4) THEN WRITE (XERN1, '(I8)') J WRITE (XERN2, '(I8)') IND(J) call XERMSG ('SLATEC', 'DBOCLS', 'IND(' // XERN1 // & ') = ' // XERN2 // ' MUST BE 1-4.', 56, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF 10 CONTINUE ! ! SEE THAT BOUNDS ARE CONSISTENT. DO 20 J = 1,NCOLS + MCON if (IND(J) == 3) THEN if (BL(J) > BU(J)) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') BL(J) WRITE (XERN4, '(1PE15.6)') BU(J) call XERMSG ('SLATEC', 'DBOCLS', 'BOUND BL(' // & XERN1 // ') = ' // XERN3 // ' IS > BU(' // & XERN1 // ') = ' // XERN4, 57, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ENDIF 20 CONTINUE ! END PROCEDURE ! DO(PROCESS OPTION ARRAY) ! PROCEDURE(PROCESS OPTION ARRAY) ZERO = 0.D0 ONE = 1.D0 DRELPR = D1MACH(4) CHECKL = .FALSE. FILTER = .TRUE. LENX = 2* (NCOLS+MCON) + 2 ISCALE = 1 IGO = 1 ACCUM = .FALSE. PRETRI = .TRUE. LOPT = 0 MOPT = 0 LP = 0 LDS = 0 ! DO FOREVER 30 CONTINUE LP = LP + LDS IP = IOPT(LP+1) JP = ABS(IP) ! ! TEST FOR NO MORE OPTIONS TO CHANGE. if (IP == 99) THEN if (LOPT == 0) LOPT = - (LP+2) if (MOPT == 0) MOPT = - (ABS(LOPT)+7) if (LOPT < 0) THEN LBOU = ABS(LOPT) ELSE LBOU = LOPT - 15 ENDIF ! ! SEND COL. SCALING TO DBOLS(). IOPT(LBOU) = 4 IOPT(LBOU+1) = 1 ! ! PASS AN OPTION ARRAY FOR DBOLSM(). IOPT(LBOU+2) = 5 ! ! LOC. OF OPTION ARRAY FOR DBOLSM( ). IOPT(LBOU+3) = 8 ! ! SKIP TO START OF USER-GIVEN OPTION ARRAY FOR DBOLS(). IOPT(LBOU+4) = 6 IOPT(LBOU+6) = 99 if (LOPT > 0) THEN IOPT(LBOU+5) = LOPT - LBOU + 1 ELSE IOPT(LBOU+4) = -IOPT(LBOU+4) ENDIF if (MOPT < 0) THEN LBOUM = ABS(MOPT) ELSE LBOUM = MOPT - 8 ENDIF ! ! CHANGE PRETRIANGULARIZATION FACTOR IN DBOLSM(). IOPT(LBOUM) = 5 IOPT(LBOUM+1) = NCOLS + MCON + 1 ! ! PASS WEIGHT TO DBOLSM() FOR RANK TEST. IOPT(LBOUM+2) = 6 IOPT(LBOUM+3) = NCOLS + MCON + 2 IOPT(LBOUM+4) = MCON ! ! SKIP TO USER-GIVEN OPTION ARRAY FOR DBOLSM( ). IOPT(LBOUM+5) = 1 IOPT(LBOUM+7) = 99 if (MOPT > 0) THEN IOPT(LBOUM+6) = MOPT - LBOUM + 1 ELSE IOPT(LBOUM+5) = -IOPT(LBOUM+5) ENDIF ! EXIT FOREVER go to 50 ELSE if (JP == 99) THEN LDS = 1 ! CYCLE FOREVER go to 50 ELSE if (JP == 1) THEN if (IP > 0) THEN ! ! SET UP DIRECTION FLAG LOCATION, ROW STACKING POINTER ! LOCATION, AND LOCATION FOR NUMBER OF NEW ROWS. LOCACC = LP + 2 ! ! IOPT(LOCACC-1)=OPTION NUMBER FOR SEQ. ACCUMULATION. ! CONTENTS.. IOPT(LOCACC )=USER DIRECTION FLAG, 1 OR 2. ! IOPT(LOCACC+1)=ROW STACKING POINTER. ! IOPT(LOCACC+2)=NUMBER OF NEW ROWS TO PROCESS. ! USER ACTION WITH THIS OPTION.. ! (SET UP OPTION DATA FOR SEQ. ACCUMULATION IN IOPT(*).) ! (MOVE BLOCK OF EQUATIONS INTO W(*,*) STARTING AT FIRST ! ROW OF W(*,*) BELOW THE ROWS FOR THE CONSTRAINT MATRIX C. ! SET IOPT(LOCACC+2)=NO. OF LEAST SQUARES EQUATIONS IN BLOCK. ! LOOP ! call DBOCLS() ! ! if ( IOPT(LOCACC) == 1) THEN ! STACK EQUAS. INTO W(*,*), STARTING AT ! ROW IOPT(LOCACC+1). ! INTO W(*,*). ! SET IOPT(LOCACC+2)=NO. OF EQUAS. ! if LAST BLOCK OF EQUAS., SET IOPT(LOCACC)=2. ! ELSE if IOPT(LOCACC) == 2) THEN ! (PROCESS IS OVER. EXIT LOOP.) ! ELSE ! (ERROR CONDITION. SHOULD NOT HAPPEN.) ! end if ! END LOOP IOPT(LOCACC+1) = MCON + 1 ACCUM = .TRUE. IOPT(LOCACC) = IGO ENDIF LDS = 4 ! CYCLE FOREVER go to 30 ELSE if (JP == 2) THEN if (IP > 0) THEN ! ! GET ACTUAL LENGTHS OF ARRAYS FOR CHECKING AGAINST NEEDS. LOCDIM = LP + 2 ! ! LMDW >= MCON+MAX(MOUT,NCOLS), if MCON > 0 .AND FILTER ! LMDW >= MCON+MOUT, OTHERWISE ! ! LNDW >= NCOLS+MCON+1 ! LLB >= NCOLS+MCON ! LLX >= 2*(NCOLS+MCON)+2+EXTRA REQD. IN OPTIONS. ! LLRW >= 6*NCOLS+5*MCON ! LLIW >= 2*(NCOLS+MCON) ! LIOP >= AMOUNT REQD. FOR OPTION ARRAY. LMDW = IOPT(LOCDIM) LNDW = IOPT(LOCDIM+1) LLB = IOPT(LOCDIM+2) LLX = IOPT(LOCDIM+3) LLRW = IOPT(LOCDIM+4) LLIW = IOPT(LOCDIM+5) LIOPT = IOPT(LOCDIM+6) CHECKL = .TRUE. ENDIF LDS = 8 ! CYCLE FOREVER go to 30 ! ! OPTION TO MODIFY THE COLUMN SCALING. ELSE if (JP == 3) THEN if (IP > 0) THEN ISCALE = IOPT(LP+2) ! ! SEE THAT ISCALE IS 1 THRU 3. if (ISCALE < 1 .OR. ISCALE > 3) THEN WRITE (XERN1, '(I8)') ISCALE call XERMSG ('SLATEC', 'DBOCLS', & 'ISCALE OPTION = ' // XERN1 // ' MUST BE 1-3', & 48, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! IN THIS OPTION THE USER HAS PROVIDED SCALING. THE ! SCALE FACTORS FOR THE COLUMNS BEGIN IN X(NCOLS+IOPT(LP+2)). ELSE if (JP == 4) THEN if (IP > 0) THEN ISCALE = 4 if (IOPT(LP+2) <= 0) THEN WRITE (XERN1, '(I8)') IOPT(LP+2) call XERMSG ('SLATEC', 'DBOCLS', & 'OFFSET PAST X(NCOLS) (' // XERN1 // & ') FOR USER-PROVIDED COLUMN SCALING MUST BE POSITIVE.', & 49, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF call DCOPY(NCOLS,X(NCOLS+IOPT(LP+2)),1,RW,1) LENX = LENX + NCOLS DO 40 J = 1,NCOLS if (RW(J) <= ZERO) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') RW(J) call XERMSG ('SLATEC', 'DBOCLS', & 'EACH PROVIDED COLUMN SCALE FACTOR MUST BE ' // & 'POSITIVE.$$COMPONENT ' // XERN1 // ' NOW = ' // & XERN3, 50, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF 40 CONTINUE ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO DBOLS(). ELSE if (JP == 5) THEN if (IP > 0) THEN LOPT = IOPT(LP+2) ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO DBOLSM(). ELSE if (JP == 6) THEN if (IP > 0) THEN MOPT = IOPT(LP+2) ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! THIS OPTION USES THE NEXT LOC OF IOPT(*) AS A ! POINTER VALUE TO SKIP TO NEXT. ELSE if (JP == 7) THEN if (IP > 0) THEN LP = IOPT(LP+2) - 1 LDS = 0 ELSE LDS = 2 ENDIF ! CYCLE FOREVER go to 30 ! ! THIS OPTION AVOIDS THE CONSTRAINT RESOLVING PHASE FOR ! THE LINEAR CONSTRAINTS C*X=Y. ELSE if (JP == 8) THEN FILTER = .NOT. (IP > 0) LDS = 1 ! CYCLE FOREVER go to 30 ! ! THIS OPTION SUPPRESSES PRE-TRIANGULARIZATION OF THE LEAST ! SQUARES EQUATIONS. ELSE if (JP == 9) THEN PRETRI = .NOT. (IP > 0) LDS = 1 ! CYCLE FOREVER go to 30 ! ! NO VALID OPTION NUMBER WAS NOTED. THIS IS AN ERROR CONDITION. ELSE WRITE (XERN1, '(I8)') JP call XERMSG ('SLATEC', 'DBOCLS', 'OPTION NUMBER = ' // & XERN1 // ' IS NOT DEFINED.', 51, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ! END FOREVER ! END PROCEDURE 50 CONTINUE if (CHECKL) THEN ! DO(CHECK LENGTHS OF ARRAYS) ! PROCEDURE(CHECK LENGTHS OF ARRAYS) ! ! THIS FEATURE ALLOWS THE USER TO MAKE SURE THAT THE ! ARRAYS ARE LONG ENOUGH FOR THE INTENDED PROBLEM SIZE AND USE. if ( FILTER .AND. .NOT.ACCUM) THEN MDWL=MCON+MAX(MROWS,NCOLS) ELSE MDWL=MCON+NCOLS+1 ENDIF if (LMDW < MDWL) THEN WRITE (XERN1, '(I8)') LMDW WRITE (XERN2, '(I8)') MDWL call XERMSG ('SLATEC', 'DBOCLS', & 'THE ROW DIMENSION OF W(,) = ' // XERN1 // & ' MUST BE >= THE NUMBER OF EFFECTIVE ROWS = ' // & XERN2, 41, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LNDW < NCOLS+MCON+1) THEN WRITE (XERN1, '(I8)') LNDW WRITE (XERN2, '(I8)') NCOLS+MCON+1 call XERMSG ('SLATEC', 'DBOCLS', & 'THE COLUMN DIMENSION OF W(,) = ' // XERN1 // & ' MUST BE >= NCOLS+MCON+1 = ' // XERN2, 42, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LLB < NCOLS+MCON) THEN WRITE (XERN1, '(I8)') LLB WRITE (XERN2, '(I8)') NCOLS+MCON call XERMSG ('SLATEC', 'DBOCLS', & 'THE DIMENSIONS OF THE ARRAYS BS(), BU(), AND IND() = ' & // XERN1 // ' MUST BE >= NCOLS+MCON = ' // XERN2, & 43, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LLX < LENX) THEN WRITE (XERN1, '(I8)') LLX WRITE (XERN2, '(I8)') LENX call XERMSG ('SLATEC', 'DBOCLS', & 'THE DIMENSION OF X() = ' // XERN1 // & ' MUST BE >= THE REQUIRED LENGTH = ' // XERN2, & 44, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LLRW < 6*NCOLS+5*MCON) THEN WRITE (XERN1, '(I8)') LLRW WRITE (XERN2, '(I8)') 6*NCOLS+5*MCON call XERMSG ('SLATEC', 'DBOCLS', & 'THE DIMENSION OF RW() = ' // XERN1 // & ' MUST BE >= 6*NCOLS+5*MCON = ' // XERN2, 45, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LLIW < 2*NCOLS+2*MCON) THEN WRITE (XERN1, '(I8)') LLIW WRITE (XERN2, '(I8)') 2*NCOLS+2*MCON call XERMSG ('SLATEC', 'DBOCLS', & 'THE DIMENSION OF IW() = ' // XERN1 // & ' MUST BE >= 2*NCOLS+2*MCON = ' // XERN2, 46, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LIOPT < LP+17) THEN WRITE (XERN1, '(I8)') LIOPT WRITE (XERN2, '(I8)') LP+17 call XERMSG ('SLATEC', 'DBOCLS', & 'THE DIMENSION OF IOPT() = ' // XERN1 // & ' MUST BE >= THE REQUIRED LEN = ' // XERN2, 47,1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ! END PROCEDURE ENDIF end if ! ! OPTIONALLY GO BACK TO THE USER FOR ACCUMULATION OF LEAST SQUARES ! EQUATIONS AND DIRECTIONS FOR PROCESSING THESE EQUATIONS. ! DO(ACCUMULATE LEAST SQUARES EQUATIONS) ! PROCEDURE(ACCUMULATE LEAST SQUARES EQUATIONS) if (ACCUM) THEN MROWS = IOPT(LOCACC+1) - 1 - MCON INROWS = IOPT(LOCACC+2) MNEW = MROWS + INROWS if (MNEW < 0 .OR. MNEW+MCON > MDW) THEN WRITE (XERN1, '(I8)') MNEW WRITE (XERN2, '(I8)') MDW-MCON call XERMSG ('SLATEC', 'DBOCLS', 'NO. OF ROWS = ' // & XERN1 // ' MUST BE >= 0 .AND. <= MDW-MCON = ' // & XERN2, 52, 1) ! (RETURN TO USER PROGRAM UNIT) go to 260 ENDIF end if ! ! USE THE SOFTWARE OF DBOLS( ) FOR THE TRIANGULARIZATION OF THE ! LEAST SQUARES MATRIX. THIS MAY INVOLVE A SYSTALTIC INTERCHANGE ! OF PROCESSING POINTERS BETWEEN THE CALLING AND CALLED (DBOLS()) ! PROGRAM UNITS. JOPT(01) = 1 JOPT(02) = 2 JOPT(04) = MROWS JOPT(05) = 99 IRW = NCOLS + 1 IIW = 1 if (ACCUM .OR. PRETRI) THEN call DBOLS(W(MCON+1,1),MDW,MOUT,NCOLS,BL,BU,IND,JOPT,X,RNORM, & MODE,RW(IRW),IW(IIW)) ELSE MOUT = MROWS end if if (ACCUM) THEN ACCUM = IOPT(LOCACC) == 1 IOPT(LOCACC+1) = JOPT(03) + MCON MROWS = MIN(NCOLS+1,MNEW) end if ! END PROCEDURE if (ACCUM) RETURN ! DO(SOLVE CONSTRAINED AND BOUNDED LEAST SQUARES PROBLEM) ! PROCEDURE(SOLVE CONSTRAINED AND BOUNDED LEAST SQUARES PROBLEM) ! ! MOVE RIGHT HAND SIDE OF LEAST SQUARES EQUATIONS. call DCOPY(MOUT,W(MCON+1,NCOLS+1),1,W(MCON+1,NCOLS+MCON+1),1) if (MCON > 0 .AND. FILTER) THEN ! ! PROJECT THE LINEAR CONSTRAINTS INTO A REACHABLE SET. DO 60 I = 1,MCON call DCOPY(NCOLS,W(I,1),MDW,W(MCON+1,NCOLS+I),1) 60 CONTINUE ! ! PLACE (-)IDENTITY MATRIX AFTER CONSTRAINT DATA. DO 70 J = NCOLS + 1,NCOLS + MCON + 1 W(1,J) = ZERO call DCOPY(MCON,W(1,J),0,W(1,J),1) 70 CONTINUE W(1,NCOLS+1) = -ONE call DCOPY(MCON,W(1,NCOLS+1),0,W(1,NCOLS+1),MDW+1) ! ! OBTAIN A 'FEASIBLE POINT' FOR THE LINEAR CONSTRAINTS. JOPT(01) = 99 IRW = NCOLS + 1 IIW = 1 call DBOLS(W,MDW,MCON,NCOLS+MCON,BL,BU,IND,JOPT,X,RNORMC, & MODEC,RW(IRW),IW(IIW)) ! ! ENLARGE THE BOUNDS SET, if REQUIRED, TO INCLUDE POINTS THAT ! CAN BE REACHED. DO 130 J = NCOLS + 1,NCOLS + MCON ICASE = IND(J) if (ICASE < 4) THEN T = DDOT(NCOLS,W(MCON+1,J),1,X,1) ENDIF go to (80,90,100,110),ICASE go to 120 ! CASE 1 80 BL(J) = MIN(T,BL(J)) go to 120 ! CASE 2 90 BU(J) = MAX(T,BU(J)) go to 120 ! CASE 3 100 BL(J) = MIN(T,BL(J)) BU(J) = MAX(T,BU(J)) go to 120 ! CASE 4 110 CONTINUE 120 CONTINUE 130 CONTINUE ! ! MOVE CONSTRAINT DATA BACK TO THE ORIGINAL AREA. DO 140 J = NCOLS + 1,NCOLS + MCON call DCOPY(NCOLS,W(MCON+1,J),1,W(J-NCOLS,1),MDW) 140 CONTINUE end if if (MCON > 0) THEN DO 150 J = NCOLS + 1,NCOLS + MCON W(MCON+1,J) = ZERO call DCOPY(MOUT,W(MCON+1,J),0,W(MCON+1,J),1) 150 CONTINUE ! ! PUT IN (-)IDENTITY MATRIX (POSSIBLY) ONCE AGAIN. DO 160 J = NCOLS + 1,NCOLS + MCON + 1 W(1,J) = ZERO call DCOPY(MCON,W(1,J),0,W(1,J),1) 160 CONTINUE W(1,NCOLS+1) = -ONE call DCOPY(MCON,W(1,NCOLS+1),0,W(1,NCOLS+1),MDW+1) end if ! ! COMPUTE NOMINAL COLUMN SCALING FOR THE UNWEIGHTED MATRIX. CNORM = ZERO ANORM = ZERO DO 170 J = 1,NCOLS T1 = DASUM(MCON,W(1,J),1) T2 = DASUM(MOUT,W(MCON+1,1),1) T = T1 + T2 if (T == ZERO) T = ONE CNORM = MAX(CNORM,T1) ANORM = MAX(ANORM,T2) X(NCOLS+MCON+J) = ONE/T 170 CONTINUE go to (180,190,210,220),ISCALE go to 230 ! CASE 1 180 CONTINUE go to 230 ! CASE 2 ! ! SCALE COLS. (BEFORE WEIGHTING) TO HAVE LENGTH ONE. 190 DO 200 J = 1,NCOLS T = DNRM2(MCON+MOUT,W(1,J),1) if (T == ZERO) T = ONE X(NCOLS+MCON+J) = ONE/T 200 CONTINUE go to 230 ! CASE 3 ! ! SUPPRESS SCALING (USE UNIT MATRIX). 210 X(NCOLS+MCON+1) = ONE call DCOPY(NCOLS,X(NCOLS+MCON+1),0,X(NCOLS+MCON+1),1) go to 230 ! CASE 4 ! ! THE USER HAS PROVIDED SCALING. 220 call DCOPY(NCOLS,RW,1,X(NCOLS+MCON+1),1) 230 CONTINUE DO 240 J = NCOLS + 1,NCOLS + MCON X(NCOLS+MCON+J) = ONE 240 CONTINUE ! ! WEIGHT THE LEAST SQUARES EQUATIONS. WT = DRELPR if (ANORM > ZERO) WT = WT/ANORM if (CNORM > ZERO) WT = WT*CNORM DO 250 I = 1,MOUT call DSCAL(NCOLS,WT,W(I+MCON,1),MDW) 250 CONTINUE call DSCAL(MOUT,WT,W(MCON+1,MCON+NCOLS+1),1) LRW = 1 LIW = 1 ! ! SET THE NEW TRIANGULARIZATION FACTOR. X(2* (NCOLS+MCON)+1) = ZERO ! ! SET THE WEIGHT TO USE IN COMPONENTS > MCON, ! WHEN MAKING LINEAR INDEPENDENCE TEST. X(2* (NCOLS+MCON)+2) = ONE/WT M = MOUT+MCON call DBOLS(W,MDW,M,NCOLS+MCON,BL,BU,IND,IOPT(LBOU),X, & RNORM,MODE,RW(LRW),IW(LIW)) RNORM = RNORM/WT ! END PROCEDURE ! PROCEDURE(RETURN TO USER PROGRAM UNIT) 260 if (MODE >= 0) MODE = -NERR IGO = 0 return ! END PROGRAM end subroutine DBOLS (W, MDW, MROWS, NCOLS, BL, BU, IND, IOPT, X, & RNORM, MODE, RW, IW) ! !! DBOLS solves the problem E*X = F (in the least squares sense) ... ! with bounds on selected X values. ! !***LIBRARY SLATEC !***CATEGORY K1A2A, G2E, G2H1, G2H2 !***TYPE DOUBLE PRECISION (SBOLS-S, DBOLS-D) !***KEYWORDS BOUNDS, CONSTRAINTS, INEQUALITY, LEAST SQUARES, LINEAR !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! **** All INPUT and OUTPUT real variables are DOUBLE PRECISION **** ! ! The user must have dimension statements of the form: ! ! DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS), ! * X(NCOLS+NX), RW(5*NCOLS) ! INTEGER IND(NCOLS), IOPT(1+NI), IW(2*NCOLS) ! ! (Here NX=number of extra locations required for option 4; NX=0 ! for no options; NX=NCOLS if this option is in use. Here NI=number ! of extra locations required for options 1-6; NI=0 for no ! options.) ! ! INPUT ! ----- ! ! -------------------- ! W(MDW,*),MROWS,NCOLS ! -------------------- ! The array W(*,*) contains the matrix [E:F] on entry. The matrix ! [E:F] has MROWS rows and NCOLS+1 columns. This data is placed in ! the array W(*,*) with E occupying the first NCOLS columns and the ! right side vector F in column NCOLS+1. The row dimension, MDW, of ! the array W(*,*) must satisfy the inequality MDW .ge. MROWS. ! Other values of MDW are errors. The values of MROWS and NCOLS ! must be positive. Other values are errors. There is an exception ! to this when using option 1 for accumulation of blocks of ! equations. In that case MROWS is an OUTPUT variable ONLY, and the ! matrix data for [E:F] is placed in W(*,*), one block of rows at a ! time. MROWS contains the number of rows in the matrix after ! triangularizing several blocks of equations. This is an OUTPUT ! parameter ONLY when option 1 is used. See IOPT(*) CONTENTS ! for details about option 1. ! ! ------------------ ! BL(*),BU(*),IND(*) ! ------------------ ! These arrays contain the information about the bounds that the ! solution values are to satisfy. The value of IND(J) tells the ! type of bound and BL(J) and BU(J) give the explicit values for ! the respective upper and lower bounds. ! ! 1. For IND(J)=1, require X(J) .ge. BL(J). ! (the value of BU(J) is not used.) ! 2. For IND(J)=2, require X(J) .le. BU(J). ! (the value of BL(J) is not used.) ! 3. For IND(J)=3, require X(J) .ge. BL(J) and ! X(J) .le. BU(J). ! 4. For IND(J)=4, no bounds on X(J) are required. ! (the values of BL(J) and BU(J) are not used.) ! ! Values other than 1,2,3 or 4 for IND(J) are errors. In the case ! IND(J)=3 (upper and lower bounds) the condition BL(J) .gt. BU(J) ! is an error. ! ! ------- ! IOPT(*) ! ------- ! This is the array where the user can specify nonstandard options ! for DBOLSM( ). Most of the time this feature can be ignored by ! setting the input value IOPT(1)=99. Occasionally users may have ! needs that require use of the following subprogram options. For ! details about how to use the options see below: IOPT(*) CONTENTS. ! ! Option Number Brief Statement of Purpose ! ------ ------ ----- --------- -- ------- ! 1 Return to user for accumulation of blocks ! of least squares equations. ! 2 Check lengths of all arrays used in the ! subprogram. ! 3 Standard scaling of the data matrix, E. ! 4 User provides column scaling for matrix E. ! 5 Provide option array to the low-level ! subprogram DBOLSM( ). ! 6 Move the IOPT(*) processing pointer. ! 99 No more options to change. ! ! ---- ! X(*) ! ---- ! This array is used to pass data associated with option 4. Ignore ! this parameter if this option is not used. Otherwise see below: ! IOPT(*) CONTENTS. ! ! OUTPUT ! ------ ! ! ---------- ! X(*),RNORM ! ---------- ! The array X(*) contains a solution (if MODE .ge.0 or .eq.-22) for ! the constrained least squares problem. The value RNORM is the ! minimum residual vector length. ! ! ---- ! MODE ! ---- ! The sign of MODE determines whether the subprogram has completed ! normally, or encountered an error condition or abnormal status. A ! value of MODE .ge. 0 signifies that the subprogram has completed ! normally. The value of MODE ( >= 0) is the number of variables ! in an active status: not at a bound nor at the value ZERO, for ! the case of free variables. A negative value of MODE will be one ! of the cases -37,-36,...,-22, or -17,...,-2. Values .lt. -1 ! correspond to an abnormal completion of the subprogram. To ! understand the abnormal completion codes see below: ERROR ! MESSAGES for DBOLS( ). AN approximate solution will be returned ! to the user only when max. iterations is reached, MODE=-22. ! Values for MODE=-37,...,-22 come from the low-level subprogram ! DBOLSM(). See the section ERROR MESSAGES for DBOLSM() in the ! documentation for DBOLSM(). ! ! ----------- ! RW(*),IW(*) ! ----------- ! These are working arrays with 5*NCOLS and 2*NCOLS entries. ! (normally the user can ignore the contents of these arrays, ! but they must be dimensioned properly.) ! ! IOPT(*) CONTENTS ! ------- -------- ! The option array allows a user to modify internal variables in ! the subprogram without recompiling the source code. A central ! goal of the initial software design was to do a good job for most ! people. Thus the use of options will be restricted to a select ! group of users. The processing of the option array proceeds as ! follows: a pointer, here called LP, is initially set to the value ! 1. This value is updated as each option is processed. At the ! pointer position the option number is extracted and used for ! locating other information that allows for options to be changed. ! The portion of the array IOPT(*) that is used for each option is ! fixed; the user and the subprogram both know how many locations ! are needed for each option. A great deal of error checking is ! done by the subprogram on the contents of the option array. ! Nevertheless it is still possible to give the subprogram optional ! input that is meaningless. For example option 4 uses the ! locations X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) for passing ! scaling data. The user must manage the allocation of these ! locations. ! ! 1 ! - ! This option allows the user to solve problems with a large number ! of rows compared to the number of variables. The idea is that the ! subprogram returns to the user (perhaps many times) and receives ! new least squares equations from the calling program unit. ! Eventually the user signals "that's all" and then computes the ! solution with one final call to subprogram DBOLS( ). The value of ! MROWS is an OUTPUT variable when this option is used. Its value ! is always in the range 0 .le. MROWS .le. NCOLS+1. It is equal to ! the number of rows after the triangularization of the entire set ! of equations. If LP is the processing pointer for IOPT(*), the ! usage for the sequential processing of blocks of equations is ! ! IOPT(LP)=1 ! Move block of equations to W(*,*) starting at ! the first row of W(*,*). ! IOPT(LP+3)=# of rows in the block; user defined ! ! The user now calls DBOLS( ) in a loop. The value of IOPT(LP+1) ! directs the user's action. The value of IOPT(LP+2) points to ! where the subsequent rows are to be placed in W(*,*). ! ! .= 0 ! . ELSE ! . ERROR CONDITION; SHOULD NOT HAPPEN. ! . BU(J)=(R2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, R1= 0. ! IN ABOVE MESSAGE, R2= ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 6 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! DBOLS(). ISCALE OPTION=(I1) MUST BE 1-3. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 7 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! DBOLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PROVIDED COLUMN SCALING ! MUST BE POSITIVE. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 8 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! DBOLS(). EACH PROVIDED COL. SCALE FACTOR MUST BE POSITIVE. ! COMPONENT (I1) NOW = (R1). ! IN ABOVE MESSAGE, I1= ND. <= MDW=(I2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 0 ! ERROR NUMBER = 10 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! DBOLS().THE ROW DIMENSION OF W(,)=(I1) MUST BE >= THE NUMBER OF ROWS= ! (I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 1 ! ERROR NUMBER = 11 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! DBOLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE >= NCOLS+1=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 12 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! DBOLS().THE DIMENSIONS OF THE ARRAYS BL(),BU(), AND IND()=(I1) MUST BE ! >= NCOLS=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 1 ! ERROR NUMBER = 13 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! DBOLS(). THE DIMENSION OF X()=(I1) MUST BE >= THE REQD. LENGTH=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 14 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! DBOLS(). THE DIMENSION OF RW()=(I1) MUST BE >= 5*NCOLS=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 3 ! ERROR NUMBER = 15 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! DBOLS() THE DIMENSION OF IW()=(I1) MUST BE >= 2*NCOLS=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 16 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! DBOLS() THE DIMENSION OF IOPT()=(I1) MUST BE >= THE REQD. LEN.=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 1 ! ERROR NUMBER = 17 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! !***REFERENCES R. J. Hanson, Linear least squares with bounds and ! linear constraints, Report SAND82-1517, Sandia ! Laboratories, August 1982. !***ROUTINES CALLED DBOLSM, DCOPY, DNRM2, DROT, DROTG, IDAMAX, XERMSG !***REVISION HISTORY (YYMMDD) ! 821220 DATE WRITTEN ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBOLS ! ! SOLVE LINEAR LEAST SQUARES SYSTEM WITH BOUNDS ON ! SELECTED VARIABLES. ! REVISED 850329-1400 ! REVISED YYMMDD-HHMM ! TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN ! EDITING AT THE CARD 'C++'. ! CHANGE THIS SUBPROGRAM NAME TO DBOLS AND THE STRINGS ! /SCOPY/ TO /DCOPY/, /SBOL/ TO /DBOL/, ! /SNRM2/ TO /DNRM2/, /ISAMAX/ TO /IDAMAX/, ! /SROTG/ TO /DROTG/, /SROT/ TO /DROT/, /E0/ TO /D0/, ! /REAL / TO /DOUBLE PRECISION/. ! ++ DOUBLE PRECISION W(MDW,*),BL(*),BU(*),X(*),RW(*) DOUBLE PRECISION SC, SS, ONE, DNRM2, RNORM, ZERO ! ! THIS VARIABLE SHOULD REMAIN TYPE REAL. INTEGER IND(*),IOPT(*),IW(*) LOGICAL CHECKL CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 SAVE IGO,LOCACC,LOPT,ISCALE DATA IGO/0/ !***FIRST EXECUTABLE STATEMENT DBOLS NERR = 0 MODE = 0 if (IGO == 0) THEN ! DO(CHECK VALIDITY OF INPUT DATA) ! PROCEDURE(CHECK VALIDITY OF INPUT DATA) ! ! SEE THAT MDW IS > 0. GROSS CHECK ONLY. if (MDW <= 0) THEN WRITE (XERN1, '(I8)') MDW call XERMSG ('SLATEC', 'DBOLS', 'MDW = ' // XERN1 // & ' MUST BE POSITIVE.', 2, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF ! ! SEE THAT NUMBER OF UNKNOWNS IS POSITIVE. if (NCOLS <= 0) THEN WRITE (XERN1, '(I8)') NCOLS call XERMSG ('SLATEC', 'DBOLS', 'NCOLS = ' // XERN1 // & ' THE NO. OF VARIABLES MUST BE POSITIVE.', 3, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF ! ! SEE THAT CONSTRAINT INDICATORS ARE ALL WELL-DEFINED. DO 10 J = 1,NCOLS if (IND(J) < 1 .OR. IND(J) > 4) THEN WRITE (XERN1, '(I8)') J WRITE (XERN2, '(I8)') IND(J) call XERMSG ('SLATEC', 'DBOLS', 'IND(' // XERN1 // & ') = ' // XERN2 // ' MUST BE 1-4.', 4, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF 10 CONTINUE ! ! SEE THAT BOUNDS ARE CONSISTENT. DO 20 J = 1,NCOLS if (IND(J) == 3) THEN if (BL(J) > BU(J)) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') BL(J) WRITE (XERN4, '(1PE15.6)') BU(J) call XERMSG ('SLATEC', 'DBOLS', 'BOUND BL(' // & XERN1 // ') = ' // XERN3 // ' IS > BU(' // & XERN1 // ') = ' // XERN4, 5, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF ENDIF 20 CONTINUE ! END PROCEDURE ! DO(PROCESS OPTION ARRAY) ! PROCEDURE(PROCESS OPTION ARRAY) ZERO = 0.D0 ONE = 1.D0 CHECKL = .FALSE. LENX = NCOLS ISCALE = 1 IGO = 2 LOPT = 0 LP = 0 LDS = 0 30 CONTINUE LP = LP + LDS IP = IOPT(LP+1) JP = ABS(IP) ! ! TEST FOR NO MORE OPTIONS. if (IP == 99) THEN if (LOPT == 0) LOPT = LP + 1 go to 50 ELSE if (JP == 99) THEN LDS = 1 go to 30 ELSE if (JP == 1) THEN if (IP > 0) THEN ! ! SET UP DIRECTION FLAG, ROW STACKING POINTER ! LOCATION, AND LOCATION FOR NUMBER OF NEW ROWS. LOCACC = LP + 2 ! ! IOPT(LOCACC-1)=OPTION NUMBER FOR SEQ. ACCUMULATION. ! CONTENTS.. IOPT(LOCACC )=USER DIRECTION FLAG, 1 OR 2. ! IOPT(LOCACC+1)=ROW STACKING POINTER. ! IOPT(LOCACC+2)=NUMBER OF NEW ROWS TO PROCESS. ! USER ACTION WITH THIS OPTION.. ! (SET UP OPTION DATA FOR SEQ. ACCUMULATION IN IOPT(*). ! MUST ALSO START PROCESS WITH IOPT(LOCACC)=1.) ! (MOVE BLOCK OF EQUATIONS INTO W(*,*) STARTING AT FIRST ! ROW OF W(*,*). SET IOPT(LOCACC+2)=NO. OF ROWS IN BLOCK.) ! LOOP ! call DBOLS() ! ! if ( IOPT(LOCACC) == 1) THEN ! STACK EQUAS., STARTING AT ROW IOPT(LOCACC+1), ! INTO W(*,*). ! SET IOPT(LOCACC+2)=NO. OF EQUAS. ! if LAST BLOCK OF EQUAS., SET IOPT(LOCACC)=2. ! ELSE if IOPT(LOCACC) == 2) THEN ! (PROCESS IS OVER. EXIT LOOP.) ! ELSE ! (ERROR CONDITION. SHOULD NOT HAPPEN.) ! end if ! END LOOP ! SET IOPT(LOCACC-1)=-OPTION NUMBER FOR SEQ. ACCUMULATION. ! call DBOLS( ) IOPT(LOCACC+1) = 1 IGO = 1 ENDIF LDS = 4 go to 30 ELSE if (JP == 2) THEN if (IP > 0) THEN ! ! GET ACTUAL LENGTHS OF ARRAYS FOR CHECKING AGAINST NEEDS. LOCDIM = LP + 2 ! ! LMDW >= MROWS ! LNDW >= NCOLS+1 ! LLB >= NCOLS ! LLX >= NCOLS+EXTRA REQD. IN OPTIONS. ! LLRW >= 5*NCOLS ! LLIW >= 2*NCOLS ! LIOP >= AMOUNT REQD. FOR IOPTION ARRAY. LMDW = IOPT(LOCDIM) LNDW = IOPT(LOCDIM+1) LLB = IOPT(LOCDIM+2) LLX = IOPT(LOCDIM+3) LLRW = IOPT(LOCDIM+4) LLIW = IOPT(LOCDIM+5) LIOPT = IOPT(LOCDIM+6) CHECKL = .TRUE. ENDIF LDS = 8 go to 30 ! ! OPTION TO MODIFY THE COLUMN SCALING. ELSE if (JP == 3) THEN if (IP > 0) THEN ISCALE = IOPT(LP+2) ! ! SEE THAT ISCALE IS 1 THRU 3. if (ISCALE < 1 .OR. ISCALE > 3) THEN WRITE (XERN1, '(I8)') ISCALE call XERMSG ('SLATEC', 'DBOLS', 'ISCALE OPTION = ' & // XERN1 // ' MUST BE 1-3', 7, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! IN THIS OPTION THE USER HAS PROVIDED SCALING. THE ! SCALE FACTORS FOR THE COLUMNS BEGIN IN X(NCOLS+IOPT(LP+2)). ELSE if (JP == 4) THEN if (IP > 0) THEN ISCALE = 4 if (IOPT(LP+2) <= 0) THEN WRITE (XERN1, '(I8)') IOPT(LP+2) call XERMSG ('SLATEC', 'DBOLS', & 'OFFSET PAST X(NCOLS) (' // XERN1 // & ') FOR USER-PROVIDED COLUMN SCALING MUST ' // & 'BE POSITIVE.', 8, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF call DCOPY(NCOLS,X(NCOLS+IOPT(LP+2)),1,RW,1) LENX = LENX + NCOLS DO 40 J = 1,NCOLS if (RW(J) <= ZERO) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') RW(J) call XERMSG ('SLATEC', 'DBOLS', & 'EACH PROVIDED COLUMN SCALE FACTOR ' // & 'MUST BE POSITIVE.$$COMPONENT ' // XERN1 // & ' NOW = ' // XERN3, 9, 1) go to 190 ENDIF 40 CONTINUE ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO DBOLSM(). ELSE if (JP == 5) THEN if (IP > 0) THEN LOPT = IOPT(LP+2) ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! THIS OPTION USES THE NEXT LOC OF IOPT(*) AS AN ! INCREMENT TO SKIP. ELSE if (JP == 6) THEN if (IP > 0) THEN LP = IOPT(LP+2) - 1 LDS = 0 ELSE LDS = 2 ENDIF ! CYCLE FOREVER go to 30 ! ! NO VALID OPTION NUMBER WAS NOTED. THIS IS AN ERROR CONDITION. ELSE WRITE (XERN1, '(I8)') JP call XERMSG ('SLATEC', 'DBOLS', 'THE OPTION NUMBER = ' // & XERN1 // ' IS NOT DEFINED.', 6, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF 50 CONTINUE ! END PROCEDURE if (CHECKL) THEN ! DO(CHECK LENGTHS OF ARRAYS) ! PROCEDURE(CHECK LENGTHS OF ARRAYS) ! ! THIS FEATURE ALLOWS THE USER TO MAKE SURE THAT THE ! ARRAYS ARE LONG ENOUGH FOR THE INTENDED PROBLEM SIZE AND USE. if (LMDW < MROWS) THEN WRITE (XERN1, '(I8)') LMDW WRITE (XERN2, '(I8)') MROWS call XERMSG ('SLATEC', 'DBOLS', & 'THE ROW DIMENSION OF W(,) = ' // XERN1 // & ' MUST BE >= THE NUMBER OF ROWS = ' // XERN2, & 11, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF if (LNDW < NCOLS+1) THEN WRITE (XERN1, '(I8)') LNDW WRITE (XERN2, '(I8)') NCOLS+1 call XERMSG ('SLATEC', 'DBOLS', & 'THE COLUMN DIMENSION OF W(,) = ' // XERN1 // & ' MUST BE >= NCOLS+1 = ' // XERN2, 12, 1) go to 190 ENDIF if (LLB < NCOLS) THEN WRITE (XERN1, '(I8)') LLB WRITE (XERN2, '(I8)') NCOLS call XERMSG ('SLATEC', 'DBOLS', & 'THE DIMENSIONS OF THE ARRAYS BL(), BU(), AND IND() = ' & // XERN1 // ' MUST BE >= NCOLS = ' // XERN2, & 13, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF if (LLX < LENX) THEN WRITE (XERN1, '(I8)') LLX WRITE (XERN2, '(I8)') LENX call XERMSG ('SLATEC', 'DBOLS', & 'THE DIMENSION OF X() = ' // XERN1 // & ' MUST BE >= THE REQUIRED LENGTH = ' // XERN2, & 14, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF if (LLRW < 5*NCOLS) THEN WRITE (XERN1, '(I8)') LLRW WRITE (XERN2, '(I8)') 5*NCOLS call XERMSG ('SLATEC', 'DBOLS', & 'THE DIMENSION OF RW() = ' // XERN1 // & ' MUST BE >= 5*NCOLS = ' // XERN2, 15, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF if (LLIW < 2*NCOLS) THEN WRITE (XERN1, '(I8)') LLIW WRITE (XERN2, '(I8)') 2*NCOLS call XERMSG ('SLATEC', 'DBOLS', & 'THE DIMENSION OF IW() = ' // XERN1 // & ' MUST BE >= 2*NCOLS = ' // XERN2, 16, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF if (LIOPT < LP+1) THEN WRITE (XERN1, '(I8)') LIOPT WRITE (XERN2, '(I8)') LP+1 call XERMSG ('SLATEC', 'DBOLS', & 'THE DIMENSION OF IOPT() = ' // XERN1 // & ' MUST BE >= THE REQUIRED LEN = ' // XERN2, 17,1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF ! END PROCEDURE ENDIF end if go to (60,90),IGO go to 180 ! ! GO BACK TO THE USER FOR ACCUMULATION OF LEAST SQUARES ! EQUATIONS AND DIRECTIONS TO QUIT PROCESSING. ! CASE 1 60 CONTINUE ! DO(ACCUMULATE LEAST SQUARES EQUATIONS) ! PROCEDURE(ACCUMULATE LEAST SQUARES EQUATIONS) MROWS = IOPT(LOCACC+1) - 1 INROWS = IOPT(LOCACC+2) MNEW = MROWS + INROWS if (MNEW < 0 .OR. MNEW > MDW) THEN WRITE (XERN1, '(I8)') MNEW WRITE (XERN2, '(I8)') MDW call XERMSG ('SLATEC', 'DBOLS', 'NO. OF ROWS = ' // XERN1 // & ' MUST BE >= 0 .AND. <= MDW = ' // XERN2, 10, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 end if DO 80 J = 1,MIN(NCOLS+1,MNEW) DO 70 I = MNEW,MAX(MROWS,J) + 1,-1 IBIG = IDAMAX(I-J,W(J,J),1) + J - 1 ! ! PIVOT FOR INCREASED STABILITY. call DROTG(W(IBIG,J),W(I,J),SC,SS) call DROT(NCOLS+1-J,W(IBIG,J+1),MDW,W(I,J+1),MDW,SC,SS) W(I,J) = ZERO 70 CONTINUE 80 CONTINUE MROWS = MIN(NCOLS+1,MNEW) IOPT(LOCACC+1) = MROWS + 1 IGO = IOPT(LOCACC) ! END PROCEDURE if (IGO == 2) THEN IGO = 0 end if go to 180 ! CASE 2 90 CONTINUE ! DO(INITIALIZE VARIABLES AND DATA VALUES) ! PROCEDURE(INITIALIZE VARIABLES AND DATA VALUES) DO 150 J = 1,NCOLS go to (100,110,120,130),ISCALE go to 140 100 CONTINUE ! CASE 1 ! ! THIS IS THE NOMINAL SCALING. EACH NONZERO ! COL. HAS MAX. NORM EQUAL TO ONE. IBIG = IDAMAX(MROWS,W(1,J),1) RW(J) = ABS(W(IBIG,J)) if (RW(J) == ZERO) THEN RW(J) = ONE ELSE RW(J) = ONE/RW(J) ENDIF go to 140 110 CONTINUE ! CASE 2 ! ! THIS CHOICE OF SCALING MAKES EACH NONZERO COLUMN ! HAVE EUCLIDEAN LENGTH EQUAL TO ONE. RW(J) = DNRM2(MROWS,W(1,J),1) if (RW(J) == ZERO) THEN RW(J) = ONE ELSE RW(J) = ONE/RW(J) ENDIF go to 140 120 CONTINUE ! CASE 3 ! ! THIS CASE EFFECTIVELY SUPPRESSES SCALING BY SETTING ! THE SCALING MATRIX TO THE IDENTITY MATRIX. RW(1) = ONE call DCOPY(NCOLS,RW,0,RW,1) go to 160 130 CONTINUE ! CASE 4 go to 160 140 CONTINUE 150 CONTINUE 160 CONTINUE ! END PROCEDURE ! DO(SOLVE BOUNDED LEAST SQUARES PROBLEM) ! PROCEDURE(SOLVE BOUNDED LEAST SQUARES PROBLEM) ! ! INITIALIZE IBASIS(*), J=1,NCOLS, AND IBB(*), J=1,NCOLS, ! TO =J,AND =1, FOR USE IN DBOLSM( ). DO 170 J = 1,NCOLS IW(J) = J IW(J+NCOLS) = 1 RW(3*NCOLS+J) = BL(J) RW(4*NCOLS+J) = BU(J) 170 CONTINUE call DBOLSM(W,MDW,MROWS,NCOLS,RW(3*NCOLS+1),RW(4*NCOLS+1),IND, & IOPT(LOPT),X,RNORM,MODE,RW(NCOLS+1),RW(2*NCOLS+1),RW, & IW,IW(NCOLS+1)) ! END PROCEDURE IGO = 0 180 CONTINUE return ! PROCEDURE(RETURN TO USER PROGRAM UNIT) 190 if ( MODE >= 0)MODE = -NERR IGO = 0 return ! END PROCEDURE end subroutine DBOLSM (W, MDW, MINPUT, NCOLS, BL, BU, IND, IOPT, X, & RNORM, MODE, RW, WW, SCL, IBASIS, IBB) ! !! DBOLSM is subsidiary to DBOCLS and DBOLS. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SBOLSM-S, DBOLSM-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! **** Double Precision Version of SBOLSM **** ! **** All INPUT and OUTPUT real variables are DOUBLE PRECISION **** ! ! Solve E*X = F (least squares sense) with bounds on ! selected X values. ! The user must have DIMENSION statements of the form: ! ! DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS), ! * X(NCOLS+NX), RW(NCOLS), WW(NCOLS), SCL(NCOLS) ! INTEGER IND(NCOLS), IOPT(1+NI), IBASIS(NCOLS), IBB(NCOLS) ! ! (Here NX=number of extra locations required for options 1,...,7; ! NX=0 for no options; here NI=number of extra locations possibly ! required for options 1-7; NI=0 for no options; NI=14 if all the ! options are simultaneously in use.) ! ! INPUT ! ----- ! ! -------------------- ! W(MDW,*),MINPUT,NCOLS ! -------------------- ! The array W(*,*) contains the matrix [E:F] on entry. The matrix ! [E:F] has MINPUT rows and NCOLS+1 columns. This data is placed in ! the array W(*,*) with E occupying the first NCOLS columns and the ! right side vector F in column NCOLS+1. The row dimension, MDW, of ! the array W(*,*) must satisfy the inequality MDW .ge. MINPUT. ! Other values of MDW are errors. The values of MINPUT and NCOLS ! must be positive. Other values are errors. ! ! ------------------ ! BL(*),BU(*),IND(*) ! ------------------ ! These arrays contain the information about the bounds that the ! solution values are to satisfy. The value of IND(J) tells the ! type of bound and BL(J) and BU(J) give the explicit values for ! the respective upper and lower bounds. ! ! 1. For IND(J)=1, require X(J) .ge. BL(J). ! 2. For IND(J)=2, require X(J) .le. BU(J). ! 3. For IND(J)=3, require X(J) .ge. BL(J) and ! X(J) .le. BU(J). ! 4. For IND(J)=4, no bounds on X(J) are required. ! The values of BL(*),BL(*) are modified by the subprogram. Values ! other than 1,2,3 or 4 for IND(J) are errors. In the case IND(J)=3 ! (upper and lower bounds) the condition BL(J) .gt. BU(J) is an ! error. ! ! ------- ! IOPT(*) ! ------- ! This is the array where the user can specify nonstandard options ! for DBOLSM. Most of the time this feature can be ignored by ! setting the input value IOPT(1)=99. Occasionally users may have ! needs that require use of the following subprogram options. For ! details about how to use the options see below: IOPT(*) CONTENTS. ! ! Option Number Brief Statement of Purpose ! ----- ------ ----- --------- -- ------- ! 1 Move the IOPT(*) processing pointer. ! 2 Change rank determination tolerance. ! 3 Change blow-up factor that determines the ! size of variables being dropped from active ! status. ! 4 Reset the maximum number of iterations to use ! in solving the problem. ! 5 The data matrix is triangularized before the ! problem is solved whenever (NCOLS/MINPUT) .lt. ! FAC. Change the value of FAC. ! 6 Redefine the weighting matrix used for ! linear independence checking. ! 7 Debug output is desired. ! 99 No more options to change. ! ! ---- ! X(*) ! ---- ! This array is used to pass data associated with options 1,2,3 and ! 5. Ignore this input parameter if none of these options are used. ! Otherwise see below: IOPT(*) CONTENTS. ! ! ---------------- ! IBASIS(*),IBB(*) ! ---------------- ! These arrays must be initialized by the user. The values ! IBASIS(J)=J, J=1,...,NCOLS ! IBB(J) =1, J=1,...,NCOLS ! are appropriate except when using nonstandard features. ! ! ------ ! SCL(*) ! ------ ! This is the array of scaling factors to use on the columns of the ! matrix E. These values must be defined by the user. To suppress ! any column scaling set SCL(J)=1.0, J=1,...,NCOLS. ! ! OUTPUT ! ------ ! ! ---------- ! X(*),RNORM ! ---------- ! The array X(*) contains a solution (if MODE .ge. 0 or .eq. -22) ! for the constrained least squares problem. The value RNORM is the ! minimum residual vector length. ! ! ---- ! MODE ! ---- ! The sign of mode determines whether the subprogram has completed ! normally, or encountered an error condition or abnormal status. ! A value of MODE .ge. 0 signifies that the subprogram has completed ! normally. The value of MODE (.ge. 0) is the number of variables ! in an active status: not at a bound nor at the value ZERO, for ! the case of free variables. A negative value of MODE will be one ! of the 18 cases -38,-37,...,-22, or -1. Values .lt. -1 correspond ! to an abnormal completion of the subprogram. To understand the ! abnormal completion codes see below: ERROR MESSAGES for DBOLSM ! An approximate solution will be returned to the user only when ! maximum iterations is reached, MODE=-22. ! ! ----------- ! RW(*),WW(*) ! ----------- ! These are working arrays each with NCOLS entries. The array RW(*) ! contains the working (scaled, nonactive) solution values. The ! array WW(*) contains the working (scaled, active) gradient vector ! values. ! ! ---------------- ! IBASIS(*),IBB(*) ! ---------------- ! These arrays contain information about the status of the solution ! when MODE .ge. 0. The indices IBASIS(K), K=1,...,MODE, show the ! nonactive variables; indices IBASIS(K), K=MODE+1,..., NCOLS are ! the active variables. The value (IBB(J)-1) is the number of times ! variable J was reflected from its upper bound. (Normally the user ! can ignore these parameters.) ! ! IOPT(*) CONTENTS ! ------- -------- ! The option array allows a user to modify internal variables in ! the subprogram without recompiling the source code. A central ! goal of the initial software design was to do a good job for most ! people. Thus the use of options will be restricted to a select ! group of users. The processing of the option array proceeds as ! follows: a pointer, here called LP, is initially set to the value ! 1. The value is updated as the options are processed. At the ! pointer position the option number is extracted and used for ! locating other information that allows for options to be changed. ! The portion of the array IOPT(*) that is used for each option is ! fixed; the user and the subprogram both know how many locations ! are needed for each option. A great deal of error checking is ! done by the subprogram on the contents of the option array. ! Nevertheless it is still possible to give the subprogram optional ! input that is meaningless. For example, some of the options use ! the location X(NCOLS+IOFF) for passing data. The user must manage ! the allocation of these locations when more than one piece of ! option data is being passed to the subprogram. ! ! 1 ! - ! Move the processing pointer (either forward or backward) to the ! location IOPT(LP+1). The processing pointer is moved to location ! LP+2 of IOPT(*) in case IOPT(LP)=-1. For example to skip over ! locations 3,...,NCOLS+2 of IOPT(*), ! ! IOPT(1)=1 ! IOPT(2)=NCOLS+3 ! (IOPT(I), I=3,...,NCOLS+2 are not defined here.) ! IOPT(NCOLS+3)=99 ! call DBOLSM ! ! CAUTION: Misuse of this option can yield some very hard-to-find ! bugs. Use it with care. ! ! 2 ! - ! The algorithm that solves the bounded least squares problem ! iteratively drops columns from the active set. This has the ! effect of joining a new column vector to the QR factorization of ! the rectangular matrix consisting of the partially triangularized ! nonactive columns. After triangularizing this matrix a test is ! made on the size of the pivot element. The column vector is ! rejected as dependent if the magnitude of the pivot element is ! .le. TOL* magnitude of the column in components strictly above ! the pivot element. Nominally the value of this (rank) tolerance ! is TOL = SQRT(R1MACH(4)). To change only the value of TOL, for ! example, ! ! X(NCOLS+1)=TOL ! IOPT(1)=2 ! IOPT(2)=1 ! IOPT(3)=99 ! call DBOLSM ! ! Generally, if LP is the processing pointer for IOPT(*), ! ! X(NCOLS+IOFF)=TOL ! IOPT(LP)=2 ! IOPT(LP+1)=IOFF ! . ! call DBOLSM ! ! The required length of IOPT(*) is increased by 2 if option 2 is ! used; The required length of X(*) is increased by 1. A value of ! IOFF .le. 0 is an error. A value of TOL .le. R1MACH(4) gives a ! warning message; it is not considered an error. ! ! 3 ! - ! A solution component is left active (not used) if, roughly ! speaking, it seems too large. Mathematically the new component is ! left active if the magnitude is .ge.((vector norm of F)/(matrix ! norm of E))/BLOWUP. Nominally the factor BLOWUP = SQRT(R1MACH(4)). ! To change only the value of BLOWUP, for example, ! ! X(NCOLS+2)=BLOWUP ! IOPT(1)=3 ! IOPT(2)=2 ! IOPT(3)=99 ! call DBOLSM ! ! Generally, if LP is the processing pointer for IOPT(*), ! ! X(NCOLS+IOFF)=BLOWUP ! IOPT(LP)=3 ! IOPT(LP+1)=IOFF ! . ! call DBOLSM ! ! The required length of IOPT(*) is increased by 2 if option 3 is ! used; the required length of X(*) is increased by 1. A value of ! IOFF .le. 0 is an error. A value of BLOWUP .le. 0.0 is an error. ! ! 4 ! - ! Normally the algorithm for solving the bounded least squares ! problem requires between NCOLS/3 and NCOLS drop-add steps to ! converge. (this remark is based on examining a small number of ! test cases.) The amount of arithmetic for such problems is ! typically about twice that required for linear least squares if ! there are no bounds and if plane rotations are used in the ! solution method. Convergence of the algorithm, while ! mathematically certain, can be much slower than indicated. To ! avoid this potential but unlikely event ITMAX drop-add steps are ! permitted. Nominally ITMAX=5*(MAX(MINPUT,NCOLS)). To change the ! value of ITMAX, for example, ! ! IOPT(1)=4 ! IOPT(2)=ITMAX ! IOPT(3)=99 ! call DBOLSM ! ! Generally, if LP is the processing pointer for IOPT(*), ! ! IOPT(LP)=4 ! IOPT(LP+1)=ITMAX ! . ! call DBOLSM ! ! The value of ITMAX must be .gt. 0. Other values are errors. Use ! of this option increases the required length of IOPT(*) by 2. ! ! 5 ! - ! For purposes of increased efficiency the MINPUT by NCOLS+1 data ! matrix [E:F] is triangularized as a first step whenever MINPUT ! satisfies FAC*MINPUT .gt. NCOLS. Nominally FAC=0.75. To change the ! value of FAC, ! ! X(NCOLS+3)=FAC ! IOPT(1)=5 ! IOPT(2)=3 ! IOPT(3)=99 ! call DBOLSM ! ! Generally, if LP is the processing pointer for IOPT(*), ! ! X(NCOLS+IOFF)=FAC ! IOPT(LP)=5 ! IOPT(LP+1)=IOFF ! . ! call DBOLSM ! ! The value of FAC must be nonnegative. Other values are errors. ! Resetting FAC=0.0 suppresses the initial triangularization step. ! Use of this option increases the required length of IOPT(*) by 2; ! The required length of of X(*) is increased by 1. ! ! 6 ! - ! The norm used in testing the magnitudes of the pivot element ! compared to the mass of the column above the pivot line can be ! changed. The type of change that this option allows is to weight ! the components with an index larger than MVAL by the parameter ! WT. Normally MVAL=0 and WT=1. To change both the values MVAL and ! WT, where LP is the processing pointer for IOPT(*), ! ! X(NCOLS+IOFF)=WT ! IOPT(LP)=6 ! IOPT(LP+1)=IOFF ! IOPT(LP+2)=MVAL ! ! Use of this option increases the required length of IOPT(*) by 3. ! The length of X(*) is increased by 1. Values of MVAL must be ! nonnegative and not greater than MINPUT. Other values are errors. ! The value of WT must be positive. Any other value is an error. If ! either error condition is present a message will be printed. ! ! 7 ! - ! Debug output, showing the detailed add-drop steps for the ! constrained least squares problem, is desired. This option is ! intended to be used to locate suspected bugs. ! ! 99 ! -- ! There are no more options to change. ! ! The values for options are 1,...,7,99, and are the only ones ! permitted. Other values are errors. Options -99,-1,...,-7 mean ! that the repective options 99,1,...,7 are left at their default ! values. An example is the option to modify the (rank) tolerance: ! ! X(NCOLS+1)=TOL ! IOPT(1)=-2 ! IOPT(2)=1 ! IOPT(3)=99 ! ! Error Messages for DBOLSM ! ----- -------- --- --------- ! -22 MORE THAN ITMAX = ... ITERATIONS SOLVING BOUNDED LEAST ! SQUARES PROBLEM. ! ! -23 THE OPTION NUMBER = ... IS NOT DEFINED. ! ! -24 THE OFFSET = ... BEYOND POSTION NCOLS = ... MUST BE POSITIVE ! FOR OPTION NUMBER 2. ! ! -25 THE TOLERANCE FOR RANK DETERMINATION = ... IS LESS THAN ! MACHINE PRECISION = .... ! ! -26 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE ! FOR OPTION NUMBER 3. ! ! -27 THE RECIPROCAL OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES ! MUST BE POSITIVE. NOW = .... ! ! -28 THE MAXIMUM NUMBER OF ITERATIONS = ... MUST BE POSITIVE. ! ! -29 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE ! FOR OPTION NUMBER 5. ! ! -30 THE FACTOR (NCOLS/MINPUT) WHERE PRETRIANGULARIZING IS ! PERFORMED MUST BE NONNEGATIVE. NOW = .... ! ! -31 THE NUMBER OF ROWS = ... MUST BE POSITIVE. ! ! -32 THE NUMBER OF COLUMNS = ... MUST BE POSTIVE. ! ! -33 THE ROW DIMENSION OF W(,) = ... MUST BE >= THE NUMBER OF ! ROWS = .... ! ! -34 FOR J = ... THE CONSTRAINT INDICATOR MUST BE 1-4. ! ! -35 FOR J = ... THE LOWER BOUND = ... IS > THE UPPER BOUND = ! .... ! ! -36 THE INPUT ORDER OF COLUMNS = ... IS NOT BETWEEN 1 AND NCOLS ! = .... ! ! -37 THE BOUND POLARITY FLAG IN COMPONENT J = ... MUST BE ! POSITIVE. NOW = .... ! ! -38 THE ROW SEPARATOR TO APPLY WEIGHTING (...) MUST LIE BETWEEN ! 0 AND MINPUT = .... WEIGHT = ... MUST BE POSITIVE. ! !***SEE ALSO DBOCLS, DBOLS !***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, DMOUT, DNRM2, DROT, ! DROTG, DSWAP, DVOUT, IVOUT, XERMSG !***REVISION HISTORY (YYMMDD) ! 821220 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920422 Fixed usage of MINPUT. (WRB) ! 901009 Editorial changes, code now reads from top to bottom. (RWC) !***END PROLOGUE DBOLSM ! ! PURPOSE ! ------- ! THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE BOUNDED ! LEAST SQUARES PROBLEM. THE PROBLEM SOLVED HERE IS: ! ! SOLVE E*X = F (LEAST SQUARES SENSE) ! WITH BOUNDS ON SELECTED X VALUES. ! ! TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN ! EDITING AT THE CARD 'C++'. ! CHANGE THE SUBPROGRAM NAME TO DBOLSM AND THE STRINGS ! /SAXPY/ TO /DAXPY/, /SCOPY/ TO /DCOPY/, ! /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/, ! /SROT/ TO /DROT/, /SROTG/ TO /DROTG/, /R1MACH/ TO /D1MACH/, ! /SVOUT/ TO /DVOUT/, /SMOUT/ TO /DMOUT/, ! /SSWAP/ TO /DSWAP/, /E0/ TO /D0/, ! /REAL / TO /DOUBLE PRECISION/. !++ ! DOUBLE PRECISION W(MDW,*),BL(*),BU(*) DOUBLE PRECISION X(*),RW(*),WW(*),SCL(*) DOUBLE PRECISION ALPHA,BETA,BOU,COLABV,COLBLO DOUBLE PRECISION CL1,CL2,CL3,ONE,BIG DOUBLE PRECISION FAC,RNORM,SC,SS,T,TOLIND,WT DOUBLE PRECISION TWO,T1,T2,WBIG,WLARGE,WMAG,XNEW DOUBLE PRECISION ZERO,DDOT,DNRM2 DOUBLE PRECISION D1MACH,TOLSZE INTEGER IBASIS(*),IBB(*),IND(*),IOPT(*) LOGICAL FOUND,CONSTR CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 ! PARAMETER (ZERO=0.0D0, ONE=1.0D0, TWO=2.0D0) ! INEXT(IDUM) = MIN(IDUM+1,MROWS) !***FIRST EXECUTABLE STATEMENT DBOLSM ! ! Verify that the problem dimensions are defined properly. ! if (MINPUT <= 0) THEN WRITE (XERN1, '(I8)') MINPUT call XERMSG ('SLATEC', 'DBOLSM', 'THE NUMBER OF ROWS = ' // & XERN1 // ' MUST BE POSITIVE.', 31, 1) MODE = -31 return end if ! if (NCOLS <= 0) THEN WRITE (XERN1, '(I8)') NCOLS call XERMSG ('SLATEC', 'DBOLSM', 'THE NUMBER OF COLUMNS = ' // & XERN1 // ' MUST BE POSITIVE.', 32, 1) MODE = -32 return end if ! if (MDW < MINPUT) THEN WRITE (XERN1, '(I8)') MDW WRITE (XERN2, '(I8)') MINPUT call XERMSG ('SLATEC', 'DBOLSM', & 'THE ROW DIMENSION OF W(,) = ' // XERN1 // & ' MUST BE >= THE NUMBER OF ROWS = ' // XERN2, 33, 1) MODE = -33 return end if ! ! Verify that bound information is correct. ! DO 10 J = 1,NCOLS if (IND(J) < 1 .OR. IND(J) > 4) THEN WRITE (XERN1, '(I8)') J WRITE (XERN2, '(I8)') IND(J) call XERMSG ('SLATEC', 'DBOLSM', 'FOR J = ' // XERN1 // & ' THE CONSTRAINT INDICATOR MUST BE 1-4', 34, 1) MODE = -34 return ENDIF 10 CONTINUE ! DO 20 J = 1,NCOLS if (IND(J) == 3) THEN if (BU(J) < BL(J)) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PD15.6)') BL(J) WRITE (XERN4, '(1PD15.6)') BU(J) call XERMSG ('SLATEC', 'DBOLSM', 'FOR J = ' // XERN1 & // ' THE LOWER BOUND = ' // XERN3 // & ' IS > THE UPPER BOUND = ' // XERN4, 35, 1) MODE = -35 return ENDIF ENDIF 20 CONTINUE ! ! Check that permutation and polarity arrays have been set. ! DO 30 J = 1,NCOLS if (IBASIS(J) < 1 .OR. IBASIS(J) > NCOLS) THEN WRITE (XERN1, '(I8)') IBASIS(J) WRITE (XERN2, '(I8)') NCOLS call XERMSG ('SLATEC', 'DBOLSM', & 'THE INPUT ORDER OF COLUMNS = ' // XERN1 // & ' IS NOT BETWEEN 1 AND NCOLS = ' // XERN2, 36, 1) MODE = -36 return ENDIF ! if (IBB(J) <= 0) THEN WRITE (XERN1, '(I8)') J WRITE (XERN2, '(I8)') IBB(J) call XERMSG ('SLATEC', 'DBOLSM', & 'THE BOUND POLARITY FLAG IN COMPONENT J = ' // XERN1 // & ' MUST BE POSITIVE.$$NOW = ' // XERN2, 37, 1) MODE = -37 return ENDIF 30 CONTINUE ! ! Process the option array. ! FAC = 0.75D0 TOLIND = SQRT(D1MACH(4)) TOLSZE = SQRT(D1MACH(4)) ITMAX = 5*MAX(MINPUT,NCOLS) WT = ONE MVAL = 0 IPRINT = 0 ! ! Changes to some parameters can occur through the option array, ! IOPT(*). Process this array looking carefully for input data ! errors. ! LP = 0 LDS = 0 ! ! Test for no more options. ! 590 LP = LP + LDS IP = IOPT(LP+1) JP = ABS(IP) if (IP == 99) THEN go to 470 ELSE if (JP == 99) THEN LDS = 1 ELSE if (JP == 1) THEN ! ! Move the IOPT(*) processing pointer. ! if (IP > 0) THEN LP = IOPT(LP+2) - 1 LDS = 0 ELSE LDS = 2 ENDIF ELSE if (JP == 2) THEN ! ! Change tolerance for rank determination. ! if (IP > 0) THEN IOFF = IOPT(LP+2) if (IOFF <= 0) THEN WRITE (XERN1, '(I8)') IOFF WRITE (XERN2, '(I8)') NCOLS call XERMSG ('SLATEC', 'DBOLSM', 'THE OFFSET = ' // & XERN1 // ' BEYOND POSITION NCOLS = ' // XERN2 // & ' MUST BE POSITIVE FOR OPTION NUMBER 2.', 24, 1) MODE = -24 return ENDIF ! TOLIND = X(NCOLS+IOFF) if (TOLIND < D1MACH(4)) THEN WRITE (XERN3, '(1PD15.6)') TOLIND WRITE (XERN4, '(1PD15.6)') D1MACH(4) call XERMSG ('SLATEC', 'DBOLSM', & 'THE TOLERANCE FOR RANK DETERMINATION = ' // XERN3 & // ' IS LESS THAN MACHINE PRECISION = ' // XERN4, & 25, 0) MODE = -25 ENDIF ENDIF LDS = 2 ELSE if (JP == 3) THEN ! ! Change blowup factor for allowing variables to become ! inactive. ! if (IP > 0) THEN IOFF = IOPT(LP+2) if (IOFF <= 0) THEN WRITE (XERN1, '(I8)') IOFF WRITE (XERN2, '(I8)') NCOLS call XERMSG ('SLATEC', 'DBOLSM', 'THE OFFSET = ' // & XERN1 // ' BEYOND POSITION NCOLS = ' // XERN2 // & ' MUST BE POSITIVE FOR OPTION NUMBER 3.', 26, 1) MODE = -26 return ENDIF ! TOLSZE = X(NCOLS+IOFF) if (TOLSZE <= ZERO) THEN WRITE (XERN3, '(1PD15.6)') TOLSZE call XERMSG ('SLATEC', 'DBOLSM', 'THE RECIPROCAL ' // & 'OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES ' // & 'MUST BE POSITIVE.$$NOW = ' // XERN3, 27, 1) MODE = -27 return ENDIF ENDIF LDS = 2 ELSE if (JP == 4) THEN ! ! Change the maximum number of iterations allowed. ! if (IP > 0) THEN ITMAX = IOPT(LP+2) if (ITMAX <= 0) THEN WRITE (XERN1, '(I8)') ITMAX call XERMSG ('SLATEC', 'DBOLSM', & 'THE MAXIMUM NUMBER OF ITERATIONS = ' // XERN1 // & ' MUST BE POSITIVE.', 28, 1) MODE = -28 return ENDIF ENDIF LDS = 2 ELSE if (JP == 5) THEN ! ! Change the factor for pretriangularizing the data matrix. ! if (IP > 0) THEN IOFF = IOPT(LP+2) if (IOFF <= 0) THEN WRITE (XERN1, '(I8)') IOFF WRITE (XERN2, '(I8)') NCOLS call XERMSG ('SLATEC', 'DBOLSM', 'THE OFFSET = ' // & XERN1 // ' BEYOND POSITION NCOLS = ' // XERN2 // & ' MUST BE POSITIVE FOR OPTION NUMBER 5.', 29, 1) MODE = -29 return ENDIF ! FAC = X(NCOLS+IOFF) if (FAC < ZERO) THEN WRITE (XERN3, '(1PD15.6)') FAC call XERMSG ('SLATEC', 'DBOLSM', & 'THE FACTOR (NCOLS/MINPUT) WHERE PRE-' // & 'TRIANGULARIZING IS PERFORMED MUST BE NON-' // & 'NEGATIVE.$$NOW = ' // XERN3, 30, 0) MODE = -30 return ENDIF ENDIF LDS = 2 ELSE if (JP == 6) THEN ! ! Change the weighting factor (from 1.0) to apply to components ! numbered .gt. MVAL (initially set to 1.) This trick is needed ! for applications of this subprogram to the heavily weighted ! least squares problem that come from equality constraints. ! if (IP > 0) THEN IOFF = IOPT(LP+2) MVAL = IOPT(LP+3) WT = X(NCOLS+IOFF) ENDIF ! if (MVAL < 0 .OR. MVAL > MINPUT .OR. WT <= ZERO) THEN WRITE (XERN1, '(I8)') MVAL WRITE (XERN2, '(I8)') MINPUT WRITE (XERN3, '(1PD15.6)') WT call XERMSG ('SLATEC', 'DBOLSM', & 'THE ROW SEPARATOR TO APPLY WEIGHTING (' // XERN1 // & ') MUST LIE BETWEEN 0 AND MINPUT = ' // XERN2 // & '.$$WEIGHT = ' // XERN3 // ' MUST BE POSITIVE.', 38, 0) MODE = -38 return ENDIF LDS = 3 ELSE if (JP == 7) THEN ! ! Turn on debug output. ! if (IP > 0) IPRINT = 1 LDS = 2 ELSE WRITE (XERN1, '(I8)') IP call XERMSG ('SLATEC', 'DBOLSM', 'THE OPTION NUMBER = ' // & XERN1 // ' IS NOT DEFINED.', 23, 1) MODE = -23 return end if go to 590 ! ! Pretriangularize rectangular arrays of certain sizes for ! increased efficiency. ! 470 if (FAC*MINPUT > NCOLS) THEN DO 490 J = 1,NCOLS+1 DO 480 I = MINPUT,J+MVAL+1,-1 call DROTG(W(I-1,J),W(I,J),SC,SS) W(I,J) = ZERO call DROT(NCOLS-J+1,W(I-1,J+1),MDW,W(I,J+1),MDW,SC,SS) 480 CONTINUE 490 CONTINUE MROWS = NCOLS + MVAL + 1 ELSE MROWS = MINPUT end if ! ! Set the X(*) array to zero so all components are defined. ! call DCOPY(NCOLS,ZERO,0,X,1) ! ! The arrays IBASIS(*) and IBB(*) are initialized by the calling ! program and the column scaling is defined in the calling program. ! 'BIG' is plus infinity on this machine. ! BIG = D1MACH(2) DO 550 J = 1,NCOLS if (IND(J) == 1) THEN BU(J) = BIG ELSE if (IND(J) == 2) THEN BL(J) = -BIG ELSE if (IND(J) == 4) THEN BL(J) = -BIG BU(J) = BIG ENDIF 550 CONTINUE ! DO 570 J = 1,NCOLS if ((BL(J) <= ZERO.AND.ZERO <= BU(J).AND.ABS(BU(J)) < & ABS(BL(J))) .OR. BU(J) < ZERO) THEN T = BU(J) BU(J) = -BL(J) BL(J) = -T SCL(J) = -SCL(J) DO 560 I = 1,MROWS W(I,J) = -W(I,J) 560 CONTINUE ENDIF ! ! Indices in set T(=TIGHT) are denoted by negative values ! of IBASIS(*). ! if (BL(J) >= ZERO) THEN IBASIS(J) = -IBASIS(J) T = -BL(J) BU(J) = BU(J) + T call DAXPY(MROWS,T,W(1,J),1,W(1,NCOLS+1),1) ENDIF 570 CONTINUE ! NSETB = 0 ITER = 0 ! if (IPRINT > 0) THEN call DMOUT(MROWS,NCOLS+1,MDW,W,'('' PRETRI. INPUT MATRIX'')', & -4) call DVOUT(NCOLS,BL,'('' LOWER BOUNDS'')',-4) call DVOUT(NCOLS,BU,'('' UPPER BOUNDS'')',-4) end if ! 580 ITER = ITER + 1 if (ITER > ITMAX) THEN WRITE (XERN1, '(I8)') ITMAX call XERMSG ('SLATEC', 'DBOLSM', 'MORE THAN ITMAX = ' // XERN1 & // ' ITERATIONS SOLVING BOUNDED LEAST SQUARES PROBLEM.', & 22, 1) MODE = -22 ! ! Rescale and translate variables. ! IGOPR = 1 go to 130 end if ! ! Find a variable to become non-active. ! T ! Compute (negative) of gradient vector, W = E *(F-E*X). ! call DCOPY(NCOLS,ZERO,0,WW,1) DO 200 J = NSETB+1,NCOLS JCOL = ABS(IBASIS(J)) WW(J) = DDOT(MROWS-NSETB,W(INEXT(NSETB),J),1, & W(INEXT(NSETB),NCOLS+1),1)*ABS(SCL(JCOL)) 200 CONTINUE ! if (IPRINT > 0) THEN call DVOUT(NCOLS,WW,'('' GRADIENT VALUES'')',-4) call IVOUT(NCOLS,IBASIS,'('' INTERNAL VARIABLE ORDER'')',-4) call IVOUT(NCOLS,IBB,'('' BOUND POLARITY'')',-4) end if ! ! If active set = number of total rows, quit. ! 210 if (NSETB == MROWS) THEN FOUND = .FALSE. go to 120 end if ! ! Choose an extremal component of gradient vector for a candidate ! to become non-active. ! WLARGE = -BIG WMAG = -BIG DO 220 J = NSETB+1,NCOLS T = WW(J) if (T == BIG) go to 220 ITEMP = IBASIS(J) JCOL = ABS(ITEMP) T1 = DNRM2(MVAL-NSETB,W(INEXT(NSETB),J),1) if (ITEMP < 0) THEN if (MOD(IBB(JCOL),2) == 0) T = -T if (T < ZERO) go to 220 if (MVAL > NSETB) T = T1 if (T > WLARGE) THEN WLARGE = T JLARGE = J ENDIF ELSE if (MVAL > NSETB) T = T1 if (ABS(T) > WMAG) THEN WMAG = ABS(T) JMAG = J ENDIF ENDIF 220 CONTINUE ! ! Choose magnitude of largest component of gradient for candidate. ! JBIG = 0 WBIG = ZERO if (WLARGE > ZERO) THEN JBIG = JLARGE WBIG = WLARGE end if ! if (WMAG >= WBIG) THEN JBIG = JMAG WBIG = WMAG end if ! if (JBIG == 0) THEN FOUND = .FALSE. if (IPRINT > 0) THEN call IVOUT(0,I,'('' FOUND NO VARIABLE TO ENTER'')',-4) ENDIF go to 120 end if ! ! See if the incoming column is sufficiently independent. This ! test is made before an elimination is performed. ! if (IPRINT > 0) & call IVOUT(1,JBIG,'('' TRY TO BRING IN THIS COL.'')',-4) ! if (MVAL <= NSETB) THEN CL1 = DNRM2(MVAL,W(1,JBIG),1) CL2 = ABS(WT)*DNRM2(NSETB-MVAL,W(INEXT(MVAL),JBIG),1) CL3 = ABS(WT)*DNRM2(MROWS-NSETB,W(INEXT(NSETB),JBIG),1) call DROTG(CL1,CL2,SC,SS) COLABV = ABS(CL1) COLBLO = CL3 ELSE CL1 = DNRM2(NSETB,W(1,JBIG),1) CL2 = DNRM2(MVAL-NSETB,W(INEXT(NSETB),JBIG),1) CL3 = ABS(WT)*DNRM2(MROWS-MVAL,W(INEXT(MVAL),JBIG),1) COLABV = CL1 call DROTG(CL2,CL3,SC,SS) COLBLO = ABS(CL2) end if ! if (COLBLO <= TOLIND*COLABV) THEN WW(JBIG) = BIG if (IPRINT > 0) & call IVOUT(0,I,'('' VARIABLE IS DEPENDENT, NOT USED.'')', & -4) go to 210 end if ! ! Swap matrix columns NSETB+1 and JBIG, plus pointer information, ! and gradient values. ! NSETB = NSETB + 1 if (NSETB /= JBIG) THEN call DSWAP(MROWS,W(1,NSETB),1,W(1,JBIG),1) call DSWAP(1,WW(NSETB),1,WW(JBIG),1) ITEMP = IBASIS(NSETB) IBASIS(NSETB) = IBASIS(JBIG) IBASIS(JBIG) = ITEMP end if ! ! Eliminate entries below the pivot line in column NSETB. ! if (MROWS > NSETB) THEN DO 230 I = MROWS,NSETB+1,-1 if (I == MVAL+1) go to 230 call DROTG(W(I-1,NSETB),W(I,NSETB),SC,SS) W(I,NSETB) = ZERO call DROT(NCOLS-NSETB+1,W(I-1,NSETB+1),MDW,W(I,NSETB+1), & MDW,SC,SS) 230 CONTINUE ! if (MVAL >= NSETB .AND. MVAL < MROWS) THEN call DROTG(W(NSETB,NSETB),W(MVAL+1,NSETB),SC,SS) W(MVAL+1,NSETB) = ZERO call DROT(NCOLS-NSETB+1,W(NSETB,NSETB+1),MDW, & W(MVAL+1,NSETB+1),MDW,SC,SS) ENDIF end if ! if (W(NSETB,NSETB) == ZERO) THEN WW(NSETB) = BIG NSETB = NSETB - 1 if (IPRINT > 0) THEN call IVOUT(0,I,'('' PIVOT IS ZERO, NOT USED.'')',-4) ENDIF go to 210 end if ! ! Check that new variable is moving in the right direction. ! ITEMP = IBASIS(NSETB) JCOL = ABS(ITEMP) XNEW = (W(NSETB,NCOLS+1)/W(NSETB,NSETB))/ABS(SCL(JCOL)) if (ITEMP < 0) THEN ! ! if ( WW(NSETB) >= ZERO.AND.XNEW <= ZERO) exit(quit) ! if ( WW(NSETB) <= ZERO.AND.XNEW >= ZERO) exit(quit) ! if ((WW(NSETB) >= ZERO.AND.XNEW <= ZERO) .OR. & (WW(NSETB) <= ZERO.AND.XNEW >= ZERO)) go to 240 end if FOUND = .TRUE. go to 120 ! 240 WW(NSETB) = BIG NSETB = NSETB - 1 if (IPRINT > 0) & call IVOUT(0,I,'('' VARIABLE HAS BAD DIRECTION, NOT USED.'')', & -4) go to 210 ! ! Solve the triangular system. ! 270 call DCOPY(NSETB,W(1,NCOLS+1),1,RW,1) DO 280 J = NSETB,1,-1 RW(J) = RW(J)/W(J,J) JCOL = ABS(IBASIS(J)) T = RW(J) if (MOD(IBB(JCOL),2) == 0) RW(J) = -RW(J) call DAXPY(J-1,-T,W(1,J),1,RW,1) RW(J) = RW(J)/ABS(SCL(JCOL)) 280 CONTINUE ! if (IPRINT > 0) THEN call DVOUT(NSETB,RW,'('' SOLN. VALUES'')',-4) call IVOUT(NSETB,IBASIS,'('' COLS. USED'')',-4) end if ! if (LGOPR == 2) THEN call DCOPY(NSETB,RW,1,X,1) DO 450 J = 1,NSETB ITEMP = IBASIS(J) JCOL = ABS(ITEMP) if (ITEMP < 0) THEN BOU = ZERO ELSE BOU = BL(JCOL) ENDIF ! if ((-BOU) /= BIG) BOU = BOU/ABS(SCL(JCOL)) if (X(J) <= BOU) THEN JDROP1 = J go to 340 ENDIF ! BOU = BU(JCOL) if (BOU /= BIG) BOU = BOU/ABS(SCL(JCOL)) if (X(J) >= BOU) THEN JDROP2 = J go to 340 ENDIF 450 CONTINUE go to 340 end if ! ! See if the unconstrained solution (obtained by solving the ! triangular system) satisfies the problem bounds. ! ALPHA = TWO BETA = TWO X(NSETB) = ZERO DO 310 J = 1,NSETB ITEMP = IBASIS(J) JCOL = ABS(ITEMP) T1 = TWO T2 = TWO if (ITEMP < 0) THEN BOU = ZERO ELSE BOU = BL(JCOL) ENDIF if ((-BOU) /= BIG) BOU = BOU/ABS(SCL(JCOL)) if (RW(J) <= BOU) T1 = (X(J)-BOU)/ (X(J)-RW(J)) BOU = BU(JCOL) if (BOU /= BIG) BOU = BOU/ABS(SCL(JCOL)) if (RW(J) >= BOU) T2 = (BOU-X(J))/ (RW(J)-X(J)) ! ! If not, then compute a step length so that the variables remain ! feasible. ! if (T1 < ALPHA) THEN ALPHA = T1 JDROP1 = J ENDIF ! if (T2 < BETA) THEN BETA = T2 JDROP2 = J ENDIF 310 CONTINUE ! CONSTR = ALPHA < TWO .OR. BETA < TWO if (.NOT.CONSTR) THEN ! ! Accept the candidate because it satisfies the stated bounds ! on the variables. ! call DCOPY(NSETB,RW,1,X,1) go to 580 end if ! ! Take a step that is as large as possible with all variables ! remaining feasible. ! DO 330 J = 1,NSETB X(J) = X(J) + MIN(ALPHA,BETA)* (RW(J)-X(J)) 330 CONTINUE ! if (ALPHA <= BETA) THEN JDROP2 = 0 ELSE JDROP1 = 0 end if ! 340 if (JDROP1+JDROP2 <= 0 .OR. NSETB <= 0) go to 580 350 JDROP = JDROP1 + JDROP2 ITEMP = IBASIS(JDROP) JCOL = ABS(ITEMP) if (JDROP2 > 0) THEN ! ! Variable is at an upper bound. Subtract multiple of this ! column from right hand side. ! T = BU(JCOL) if (ITEMP > 0) THEN BU(JCOL) = T - BL(JCOL) BL(JCOL) = -T ITEMP = -ITEMP SCL(JCOL) = -SCL(JCOL) DO 360 I = 1,JDROP W(I,JDROP) = -W(I,JDROP) 360 CONTINUE ELSE IBB(JCOL) = IBB(JCOL) + 1 if (MOD(IBB(JCOL),2) == 0) T = -T ENDIF ! ! Variable is at a lower bound. ! ELSE if (ITEMP < ZERO) THEN T = ZERO ELSE T = -BL(JCOL) BU(JCOL) = BU(JCOL) + T ITEMP = -ITEMP ENDIF end if ! call DAXPY(JDROP,T,W(1,JDROP),1,W(1,NCOLS+1),1) ! ! Move certain columns left to achieve upper Hessenberg form. ! call DCOPY(JDROP,W(1,JDROP),1,RW,1) DO 370 J = JDROP+1,NSETB IBASIS(J-1) = IBASIS(J) X(J-1) = X(J) call DCOPY(J,W(1,J),1,W(1,J-1),1) 370 CONTINUE ! IBASIS(NSETB) = ITEMP W(1,NSETB) = ZERO call DCOPY(MROWS-JDROP,W(1,NSETB),0,W(JDROP+1,NSETB),1) call DCOPY(JDROP,RW,1,W(1,NSETB),1) ! ! Transform the matrix from upper Hessenberg form to upper ! triangular form. ! NSETB = NSETB - 1 DO 390 I = JDROP,NSETB ! ! Look for small pivots and avoid mixing weighted and ! nonweighted rows. ! if (I == MVAL) THEN T = ZERO DO 380 J = I,NSETB JCOL = ABS(IBASIS(J)) T1 = ABS(W(I,J)*SCL(JCOL)) if (T1 > T) THEN JBIG = J T = T1 ENDIF 380 CONTINUE go to 400 ENDIF call DROTG(W(I,I),W(I+1,I),SC,SS) W(I+1,I) = ZERO call DROT(NCOLS-I+1,W(I,I+1),MDW,W(I+1,I+1),MDW,SC,SS) 390 CONTINUE go to 430 ! ! The triangularization is completed by giving up the Hessenberg ! form and triangularizing a rectangular matrix. ! 400 call DSWAP(MROWS,W(1,I),1,W(1,JBIG),1) call DSWAP(1,WW(I),1,WW(JBIG),1) call DSWAP(1,X(I),1,X(JBIG),1) ITEMP = IBASIS(I) IBASIS(I) = IBASIS(JBIG) IBASIS(JBIG) = ITEMP JBIG = I DO 420 J = JBIG,NSETB DO 410 I = J+1,MROWS call DROTG(W(J,J),W(I,J),SC,SS) W(I,J) = ZERO call DROT(NCOLS-J+1,W(J,J+1),MDW,W(I,J+1),MDW,SC,SS) 410 CONTINUE 420 CONTINUE ! ! See if the remaining coefficients are feasible. They should be ! because of the way MIN(ALPHA,BETA) was chosen. Any that are not ! feasible will be set to their bounds and appropriately translated. ! 430 JDROP1 = 0 JDROP2 = 0 LGOPR = 2 go to 270 ! ! Find a variable to become non-active. ! 120 if (FOUND) THEN LGOPR = 1 go to 270 end if ! ! Rescale and translate variables. ! IGOPR = 2 130 call DCOPY(NSETB,X,1,RW,1) call DCOPY(NCOLS,ZERO,0,X,1) DO 140 J = 1,NSETB JCOL = ABS(IBASIS(J)) X(JCOL) = RW(J)*ABS(SCL(JCOL)) 140 CONTINUE ! DO 150 J = 1,NCOLS if (MOD(IBB(J),2) == 0) X(J) = BU(J) - X(J) 150 CONTINUE ! DO 160 J = 1,NCOLS JCOL = IBASIS(J) if (JCOL < 0) X(-JCOL) = BL(-JCOL) + X(-JCOL) 160 CONTINUE ! DO 170 J = 1,NCOLS if (SCL(J) < ZERO) X(J) = -X(J) 170 CONTINUE ! I = MAX(NSETB,MVAL) RNORM = DNRM2(MROWS-I,W(INEXT(I),NCOLS+1),1) ! if (IGOPR == 2) MODE = NSETB return end subroutine DBSGQ8 (FUN, XT, BC, N, KK, ID, A, B, INBV, ERR, ANS, & IERR, WORK) ! !! DBSGQ8 is subsidiary to DBFQAD. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BSGQ8-S, DBSGQ8-D) !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract **** A DOUBLE PRECISION routine **** ! ! DBSGQ8, a modification of GAUS8, integrates the ! product of FUN(X) by the ID-th derivative of a spline ! DBVALU(XT,BC,N,KK,ID,X,INBV,WORK) between limits A and B. ! ! Description of Arguments ! ! INPUT-- FUN,XT,BC,A,B,ERR are DOUBLE PRECISION ! FUN - Name of external function of one argument which ! multiplies DBVALU. ! XT - Knot array for DBVALU ! BC - B-coefficient array for DBVALU ! N - Number of B-coefficients for DBVALU ! KK - Order of the spline, KK >= 1 ! ID - Order of the spline derivative, 0 <= ID <= KK-1 ! A - Lower limit of integral ! B - Upper limit of integral (may be less than A) ! INBV- Initialization parameter for DBVALU ! ERR - Is a requested pseudorelative error tolerance. Normally ! pick a value of ABS(ERR) < 1D-3. ANS will normally ! have no more error than ABS(ERR) times the integral of ! the absolute value of FUN(X)*DBVALU(XT,BC,N,KK,X,ID, ! INBV,WORK). ! ! ! OUTPUT-- ERR,ANS,WORK are DOUBLE PRECISION ! ERR - Will be an estimate of the absolute error in ANS if the ! input value of ERR was negative. (ERR is unchanged if ! the input value of ERR was nonnegative.) The estimated ! error is solely for information to the user and should ! not be used as a correction to the computed integral. ! ANS - Computed value of integral ! IERR- A status code ! --Normal Codes ! 1 ANS most likely meets requested error tolerance, ! or A=B. ! -1 A and B are too nearly equal to allow normal ! integration. ANS is set to zero. ! --Abnormal Code ! 2 ANS probably does not meet requested error tolerance. ! WORK- Work vector of length 3*K for DBVALU ! !***SEE ALSO DBFQAD !***ROUTINES CALLED D1MACH, DBVALU, I1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE DBSGQ8 ! INTEGER ID, IERR, INBV, K, KK, KML, KMX, L, LMN, LMX, LR, MXL, & N, NBITS, NIB, NLMN, NLMX INTEGER I1MACH DOUBLE PRECISION A,AA,AE,ANIB,ANS,AREA,B,BC,C,CE,EE,EF,EPS,ERR, & EST,GL,GLR,GR,HH,SQ2,TOL,VL,VR,WORK,W1, W2, W3, W4, XT, X1, & X2, X3, X4, X, H DOUBLE PRECISION D1MACH, DBVALU, G8, FUN DIMENSION XT(*), BC(*), WORK(*) DIMENSION AA(60), HH(60), LR(60), VL(60), GR(60) SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, NLMN, KMX, KML DATA X1, X2, X3, X4/ & 1.83434642495649805D-01, 5.25532409916328986D-01, & 7.96666477413626740D-01, 9.60289856497536232D-01/ DATA W1, W2, W3, W4/ & 3.62683783378361983D-01, 3.13706645877887287D-01, & 2.22381034453374471D-01, 1.01228536290376259D-01/ DATA SQ2/1.41421356D0/ DATA NLMN/1/,KMX/5000/,KML/6/ G8(X,H)=H*((W1*(FUN(X-X1*H)*DBVALU(XT,BC,N,KK,ID,X-X1*H,INBV,WORK) & + FUN(X+X1*H)*DBVALU(XT,BC,N,KK,ID,X+X1*H,INBV,WORK)) & +W2*(FUN(X-X2*H)*DBVALU(XT,BC,N,KK,ID,X-X2*H,INBV,WORK)+ & FUN(X+X2*H)*DBVALU(XT,BC,N,KK,ID,X+X2*H,INBV,WORK))) & +(W3*(FUN(X-X3*H)*DBVALU(XT,BC,N,KK,ID,X-X3*H,INBV,WORK)+ & FUN(X+X3*H)*DBVALU(XT,BC,N,KK,ID,X+X3*H,INBV,WORK)) & +W4*(FUN(X-X4*H)*DBVALU(XT,BC,N,KK,ID,X-X4*H,INBV,WORK)+ & FUN(X+X4*H)*DBVALU(XT,BC,N,KK,ID,X+X4*H,INBV,WORK)))) ! ! INITIALIZE ! !***FIRST EXECUTABLE STATEMENT DBSGQ8 K = I1MACH(14) ANIB = D1MACH(5)*K/0.30102000D0 NBITS = INT(ANIB) NLMX = MIN((NBITS*5)/8,60) ANS = 0.0D0 IERR = 1 CE = 0.0D0 if (A == B) go to 140 LMX = NLMX LMN = NLMN if (B == 0.0D0) go to 10 if (SIGN(1.0D0,B)*A <= 0.0D0) go to 10 C = ABS(1.0D0-A/B) if (C > 0.1D0) go to 10 if (C <= 0.0D0) go to 140 ANIB = 0.5D0 - LOG(C)/0.69314718D0 NIB = INT(ANIB) LMX = MIN(NLMX,NBITS-NIB-7) if (LMX < 1) go to 130 LMN = MIN(LMN,LMX) 10 TOL = MAX(ABS(ERR),2.0D0**(5-NBITS))/2.0D0 if (ERR == 0.0D0) TOL = SQRT(D1MACH(4)) EPS = TOL HH(1) = (B-A)/4.0D0 AA(1) = A LR(1) = 1 L = 1 EST = G8(AA(L)+2.0D0*HH(L),2.0D0*HH(L)) K = 8 AREA = ABS(EST) EF = 0.5D0 MXL = 0 ! ! COMPUTE REFINED ESTIMATES, ESTIMATE THE ERROR, ETC. ! 20 GL = G8(AA(L)+HH(L),HH(L)) GR(L) = G8(AA(L)+3.0D0*HH(L),HH(L)) K = K + 16 AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) GLR = GL + GR(L) EE = ABS(EST-GLR)*EF AE = MAX(EPS*AREA,TOL*ABS(GLR)) if (EE-AE) 40, 40, 50 30 MXL = 1 40 CE = CE + (EST-GLR) if (LR(L)) 60, 60, 80 ! ! CONSIDER THE LEFT HALF OF THIS LEVEL ! 50 if (K > KMX) LMX = KML if (L >= LMX) go to 30 L = L + 1 EPS = EPS*0.5D0 EF = EF/SQ2 HH(L) = HH(L-1)*0.5D0 LR(L) = -1 AA(L) = AA(L-1) EST = GL go to 20 ! ! PROCEED TO RIGHT HALF AT THIS LEVEL ! 60 VL(L) = GLR 70 EST = GR(L-1) LR(L) = 1 AA(L) = AA(L) + 4.0D0*HH(L) go to 20 ! ! return ONE LEVEL ! 80 VR = GLR 90 if (L <= 1) go to 120 L = L - 1 EPS = EPS*2.0D0 EF = EF*SQ2 if (LR(L)) 100, 100, 110 100 VL(L) = VL(L+1) + VR go to 70 110 VR = VL(L+1) + VR go to 90 ! ! EXIT ! 120 ANS = VR if ((MXL == 0) .OR. (ABS(CE) <= 2.0D0*TOL*AREA)) go to 140 IERR = 2 call XERMSG ('SLATEC', 'DBSGQ8', & 'ANS IS PROBABLY INSUFFICIENTLY ACCURATE.', 3, 1) go to 140 130 IERR = -1 call XERMSG ('SLATEC', 'DBSGQ8', & 'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL INTEGRATION. ' // & ' ANS IS SET TO ZERO AND IERR TO -1.', 1, -1) 140 CONTINUE if (ERR < 0.0D0) ERR = CE return end DOUBLE PRECISION FUNCTION DBSI0E (X) ! !! DBSI0E computes the exponentially scaled modified (hyperbolic) Bessel... ! function of the first kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE DOUBLE PRECISION (BESI0E-S, DBSI0E-D) !***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, ! HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, ! ORDER ZERO, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBSI0E(X) calculates the double precision exponentially scaled ! modified (hyperbolic) Bessel function of the first kind of order ! zero for double precision argument X. The result is the Bessel ! function I0(X) multiplied by EXP(-ABS(X)). ! ! Series for BI0 on the interval 0. to 9.00000E+00 ! with weighted error 9.51E-34 ! log weighted error 33.02 ! significant figures required 33.31 ! decimal places required 33.65 ! ! Series for AI0 on the interval 1.25000E-01 to 3.33333E-01 ! with weighted error 2.74E-32 ! log weighted error 31.56 ! significant figures required 30.15 ! decimal places required 32.39 ! ! Series for AI02 on the interval 0. to 1.25000E-01 ! with weighted error 1.97E-32 ! log weighted error 31.71 ! significant figures required 30.15 ! decimal places required 32.63 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DBSI0E DOUBLE PRECISION X, BI0CS(18), AI0CS(46), AI02CS(69), & XSML, Y, D1MACH, DCSEVL LOGICAL FIRST SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02, XSML, FIRST DATA BI0CS( 1) / -.7660547252839144951081894976243285D-1 / DATA BI0CS( 2) / +.1927337953993808269952408750881196D+1 / DATA BI0CS( 3) / +.2282644586920301338937029292330415D+0 / DATA BI0CS( 4) / +.1304891466707290428079334210691888D-1 / DATA BI0CS( 5) / +.4344270900816487451378682681026107D-3 / DATA BI0CS( 6) / +.9422657686001934663923171744118766D-5 / DATA BI0CS( 7) / +.1434006289510691079962091878179957D-6 / DATA BI0CS( 8) / +.1613849069661749069915419719994611D-8 / DATA BI0CS( 9) / +.1396650044535669699495092708142522D-10 / DATA BI0CS( 10) / +.9579451725505445344627523171893333D-13 / DATA BI0CS( 11) / +.5333981859862502131015107744000000D-15 / DATA BI0CS( 12) / +.2458716088437470774696785919999999D-17 / DATA BI0CS( 13) / +.9535680890248770026944341333333333D-20 / DATA BI0CS( 14) / +.3154382039721427336789333333333333D-22 / DATA BI0CS( 15) / +.9004564101094637431466666666666666D-25 / DATA BI0CS( 16) / +.2240647369123670016000000000000000D-27 / DATA BI0CS( 17) / +.4903034603242837333333333333333333D-30 / DATA BI0CS( 18) / +.9508172606122666666666666666666666D-33 / DATA AI0CS( 1) / +.7575994494023795942729872037438D-1 / DATA AI0CS( 2) / +.7591380810823345507292978733204D-2 / DATA AI0CS( 3) / +.4153131338923750501863197491382D-3 / DATA AI0CS( 4) / +.1070076463439073073582429702170D-4 / DATA AI0CS( 5) / -.7901179979212894660750319485730D-5 / DATA AI0CS( 6) / -.7826143501438752269788989806909D-6 / DATA AI0CS( 7) / +.2783849942948870806381185389857D-6 / DATA AI0CS( 8) / +.8252472600612027191966829133198D-8 / DATA AI0CS( 9) / -.1204463945520199179054960891103D-7 / DATA AI0CS( 10) / +.1559648598506076443612287527928D-8 / DATA AI0CS( 11) / +.2292556367103316543477254802857D-9 / DATA AI0CS( 12) / -.1191622884279064603677774234478D-9 / DATA AI0CS( 13) / +.1757854916032409830218331247743D-10 / DATA AI0CS( 14) / +.1128224463218900517144411356824D-11 / DATA AI0CS( 15) / -.1146848625927298877729633876982D-11 / DATA AI0CS( 16) / +.2715592054803662872643651921606D-12 / DATA AI0CS( 17) / -.2415874666562687838442475720281D-13 / DATA AI0CS( 18) / -.6084469888255125064606099639224D-14 / DATA AI0CS( 19) / +.3145705077175477293708360267303D-14 / DATA AI0CS( 20) / -.7172212924871187717962175059176D-15 / DATA AI0CS( 21) / +.7874493403454103396083909603327D-16 / DATA AI0CS( 22) / +.1004802753009462402345244571839D-16 / DATA AI0CS( 23) / -.7566895365350534853428435888810D-17 / DATA AI0CS( 24) / +.2150380106876119887812051287845D-17 / DATA AI0CS( 25) / -.3754858341830874429151584452608D-18 / DATA AI0CS( 26) / +.2354065842226992576900757105322D-19 / DATA AI0CS( 27) / +.1114667612047928530226373355110D-19 / DATA AI0CS( 28) / -.5398891884396990378696779322709D-20 / DATA AI0CS( 29) / +.1439598792240752677042858404522D-20 / DATA AI0CS( 30) / -.2591916360111093406460818401962D-21 / DATA AI0CS( 31) / +.2238133183998583907434092298240D-22 / DATA AI0CS( 32) / +.5250672575364771172772216831999D-23 / DATA AI0CS( 33) / -.3249904138533230784173432285866D-23 / DATA AI0CS( 34) / +.9924214103205037927857284710400D-24 / DATA AI0CS( 35) / -.2164992254244669523146554299733D-24 / DATA AI0CS( 36) / +.3233609471943594083973332991999D-25 / DATA AI0CS( 37) / -.1184620207396742489824733866666D-26 / DATA AI0CS( 38) / -.1281671853950498650548338687999D-26 / DATA AI0CS( 39) / +.5827015182279390511605568853333D-27 / DATA AI0CS( 40) / -.1668222326026109719364501503999D-27 / DATA AI0CS( 41) / +.3625309510541569975700684800000D-28 / DATA AI0CS( 42) / -.5733627999055713589945958399999D-29 / DATA AI0CS( 43) / +.3736796722063098229642581333333D-30 / DATA AI0CS( 44) / +.1602073983156851963365512533333D-30 / DATA AI0CS( 45) / -.8700424864057229884522495999999D-31 / DATA AI0CS( 46) / +.2741320937937481145603413333333D-31 / DATA AI02CS( 1) / +.5449041101410883160789609622680D-1 / DATA AI02CS( 2) / +.3369116478255694089897856629799D-2 / DATA AI02CS( 3) / +.6889758346916823984262639143011D-4 / DATA AI02CS( 4) / +.2891370520834756482966924023232D-5 / DATA AI02CS( 5) / +.2048918589469063741827605340931D-6 / DATA AI02CS( 6) / +.2266668990498178064593277431361D-7 / DATA AI02CS( 7) / +.3396232025708386345150843969523D-8 / DATA AI02CS( 8) / +.4940602388224969589104824497835D-9 / DATA AI02CS( 9) / +.1188914710784643834240845251963D-10 / DATA AI02CS( 10) / -.3149916527963241364538648629619D-10 / DATA AI02CS( 11) / -.1321581184044771311875407399267D-10 / DATA AI02CS( 12) / -.1794178531506806117779435740269D-11 / DATA AI02CS( 13) / +.7180124451383666233671064293469D-12 / DATA AI02CS( 14) / +.3852778382742142701140898017776D-12 / DATA AI02CS( 15) / +.1540086217521409826913258233397D-13 / DATA AI02CS( 16) / -.4150569347287222086626899720156D-13 / DATA AI02CS( 17) / -.9554846698828307648702144943125D-14 / DATA AI02CS( 18) / +.3811680669352622420746055355118D-14 / DATA AI02CS( 19) / +.1772560133056526383604932666758D-14 / DATA AI02CS( 20) / -.3425485619677219134619247903282D-15 / DATA AI02CS( 21) / -.2827623980516583484942055937594D-15 / DATA AI02CS( 22) / +.3461222867697461093097062508134D-16 / DATA AI02CS( 23) / +.4465621420296759999010420542843D-16 / DATA AI02CS( 24) / -.4830504485944182071255254037954D-17 / DATA AI02CS( 25) / -.7233180487874753954562272409245D-17 / DATA AI02CS( 26) / +.9921475412173698598880460939810D-18 / DATA AI02CS( 27) / +.1193650890845982085504399499242D-17 / DATA AI02CS( 28) / -.2488709837150807235720544916602D-18 / DATA AI02CS( 29) / -.1938426454160905928984697811326D-18 / DATA AI02CS( 30) / +.6444656697373443868783019493949D-19 / DATA AI02CS( 31) / +.2886051596289224326481713830734D-19 / DATA AI02CS( 32) / -.1601954907174971807061671562007D-19 / DATA AI02CS( 33) / -.3270815010592314720891935674859D-20 / DATA AI02CS( 34) / +.3686932283826409181146007239393D-20 / DATA AI02CS( 35) / +.1268297648030950153013595297109D-22 / DATA AI02CS( 36) / -.7549825019377273907696366644101D-21 / DATA AI02CS( 37) / +.1502133571377835349637127890534D-21 / DATA AI02CS( 38) / +.1265195883509648534932087992483D-21 / DATA AI02CS( 39) / -.6100998370083680708629408916002D-22 / DATA AI02CS( 40) / -.1268809629260128264368720959242D-22 / DATA AI02CS( 41) / +.1661016099890741457840384874905D-22 / DATA AI02CS( 42) / -.1585194335765885579379705048814D-23 / DATA AI02CS( 43) / -.3302645405968217800953817667556D-23 / DATA AI02CS( 44) / +.1313580902839239781740396231174D-23 / DATA AI02CS( 45) / +.3689040246671156793314256372804D-24 / DATA AI02CS( 46) / -.4210141910461689149219782472499D-24 / DATA AI02CS( 47) / +.4791954591082865780631714013730D-25 / DATA AI02CS( 48) / +.8459470390221821795299717074124D-25 / DATA AI02CS( 49) / -.4039800940872832493146079371810D-25 / DATA AI02CS( 50) / -.6434714653650431347301008504695D-26 / DATA AI02CS( 51) / +.1225743398875665990344647369905D-25 / DATA AI02CS( 52) / -.2934391316025708923198798211754D-26 / DATA AI02CS( 53) / -.1961311309194982926203712057289D-26 / DATA AI02CS( 54) / +.1503520374822193424162299003098D-26 / DATA AI02CS( 55) / -.9588720515744826552033863882069D-28 / DATA AI02CS( 56) / -.3483339380817045486394411085114D-27 / DATA AI02CS( 57) / +.1690903610263043673062449607256D-27 / DATA AI02CS( 58) / +.1982866538735603043894001157188D-28 / DATA AI02CS( 59) / -.5317498081491816214575830025284D-28 / DATA AI02CS( 60) / +.1803306629888392946235014503901D-28 / DATA AI02CS( 61) / +.6213093341454893175884053112422D-29 / DATA AI02CS( 62) / -.7692189292772161863200728066730D-29 / DATA AI02CS( 63) / +.1858252826111702542625560165963D-29 / DATA AI02CS( 64) / +.1237585142281395724899271545541D-29 / DATA AI02CS( 65) / -.1102259120409223803217794787792D-29 / DATA AI02CS( 66) / +.1886287118039704490077874479431D-30 / DATA AI02CS( 67) / +.2160196872243658913149031414060D-30 / DATA AI02CS( 68) / -.1605454124919743200584465949655D-30 / DATA AI02CS( 69) / +.1965352984594290603938848073318D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBSI0E if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NTI0 = INITDS (BI0CS, 18, ETA) NTAI0 = INITDS (AI0CS, 46, ETA) NTAI02 = INITDS (AI02CS, 69, ETA) XSML = SQRT(4.5D0*D1MACH(3)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 3.0D0) go to 20 ! DBSI0E = 1.0D0 - X if (Y > XSML) DBSI0E = EXP(-Y) * (2.75D0 + & DCSEVL (Y*Y/4.5D0-1.D0, BI0CS, NTI0) ) return ! 20 if (Y <= 8.D0) DBSI0E = (0.375D0 + DCSEVL ((48.D0/Y-11.D0)/5.D0, & AI0CS, NTAI0))/SQRT(Y) if (Y > 8.D0) DBSI0E = (0.375D0 + DCSEVL (16.D0/Y-1.D0, AI02CS, & NTAI02))/SQRT(Y) ! return end DOUBLE PRECISION FUNCTION DBSI1E (X) ! !! DBSI1E computes the exponentially scaled modified (hyperbolic) Bessel... ! function of the first kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE DOUBLE PRECISION (BESI1E-S, DBSI1E-D) !***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, ! HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, ! ORDER ONE, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBSI1E(X) calculates the double precision exponentially scaled ! modified (hyperbolic) Bessel function of the first kind of order ! one for double precision argument X. The result is I1(X) ! multiplied by EXP(-ABS(X)). ! ! Series for BI1 on the interval 0. to 9.00000E+00 ! with weighted error 1.44E-32 ! log weighted error 31.84 ! significant figures required 31.45 ! decimal places required 32.46 ! ! Series for AI1 on the interval 1.25000E-01 to 3.33333E-01 ! with weighted error 2.81E-32 ! log weighted error 31.55 ! significant figures required 29.93 ! decimal places required 32.38 ! ! Series for AI12 on the interval 0. to 1.25000E-01 ! with weighted error 1.83E-32 ! log weighted error 31.74 ! significant figures required 29.97 ! decimal places required 32.66 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBSI1E DOUBLE PRECISION X, BI1CS(17), AI1CS(46), AI12CS(69), XMIN, & XSML, Y, D1MACH, DCSEVL LOGICAL FIRST SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML, & FIRST DATA BI1CS( 1) / -.19717132610998597316138503218149D-2 / DATA BI1CS( 2) / +.40734887667546480608155393652014D+0 / DATA BI1CS( 3) / +.34838994299959455866245037783787D-1 / DATA BI1CS( 4) / +.15453945563001236038598401058489D-2 / DATA BI1CS( 5) / +.41888521098377784129458832004120D-4 / DATA BI1CS( 6) / +.76490267648362114741959703966069D-6 / DATA BI1CS( 7) / +.10042493924741178689179808037238D-7 / DATA BI1CS( 8) / +.99322077919238106481371298054863D-10 / DATA BI1CS( 9) / +.76638017918447637275200171681349D-12 / DATA BI1CS( 10) / +.47414189238167394980388091948160D-14 / DATA BI1CS( 11) / +.24041144040745181799863172032000D-16 / DATA BI1CS( 12) / +.10171505007093713649121100799999D-18 / DATA BI1CS( 13) / +.36450935657866949458491733333333D-21 / DATA BI1CS( 14) / +.11205749502562039344810666666666D-23 / DATA BI1CS( 15) / +.29875441934468088832000000000000D-26 / DATA BI1CS( 16) / +.69732310939194709333333333333333D-29 / DATA BI1CS( 17) / +.14367948220620800000000000000000D-31 / DATA AI1CS( 1) / -.2846744181881478674100372468307D-1 / DATA AI1CS( 2) / -.1922953231443220651044448774979D-1 / DATA AI1CS( 3) / -.6115185857943788982256249917785D-3 / DATA AI1CS( 4) / -.2069971253350227708882823777979D-4 / DATA AI1CS( 5) / +.8585619145810725565536944673138D-5 / DATA AI1CS( 6) / +.1049498246711590862517453997860D-5 / DATA AI1CS( 7) / -.2918338918447902202093432326697D-6 / DATA AI1CS( 8) / -.1559378146631739000160680969077D-7 / DATA AI1CS( 9) / +.1318012367144944705525302873909D-7 / DATA AI1CS( 10) / -.1448423418183078317639134467815D-8 / DATA AI1CS( 11) / -.2908512243993142094825040993010D-9 / DATA AI1CS( 12) / +.1266388917875382387311159690403D-9 / DATA AI1CS( 13) / -.1664947772919220670624178398580D-10 / DATA AI1CS( 14) / -.1666653644609432976095937154999D-11 / DATA AI1CS( 15) / +.1242602414290768265232168472017D-11 / DATA AI1CS( 16) / -.2731549379672432397251461428633D-12 / DATA AI1CS( 17) / +.2023947881645803780700262688981D-13 / DATA AI1CS( 18) / +.7307950018116883636198698126123D-14 / DATA AI1CS( 19) / -.3332905634404674943813778617133D-14 / DATA AI1CS( 20) / +.7175346558512953743542254665670D-15 / DATA AI1CS( 21) / -.6982530324796256355850629223656D-16 / DATA AI1CS( 22) / -.1299944201562760760060446080587D-16 / DATA AI1CS( 23) / +.8120942864242798892054678342860D-17 / DATA AI1CS( 24) / -.2194016207410736898156266643783D-17 / DATA AI1CS( 25) / +.3630516170029654848279860932334D-18 / DATA AI1CS( 26) / -.1695139772439104166306866790399D-19 / DATA AI1CS( 27) / -.1288184829897907807116882538222D-19 / DATA AI1CS( 28) / +.5694428604967052780109991073109D-20 / DATA AI1CS( 29) / -.1459597009090480056545509900287D-20 / DATA AI1CS( 30) / +.2514546010675717314084691334485D-21 / DATA AI1CS( 31) / -.1844758883139124818160400029013D-22 / DATA AI1CS( 32) / -.6339760596227948641928609791999D-23 / DATA AI1CS( 33) / +.3461441102031011111108146626560D-23 / DATA AI1CS( 34) / -.1017062335371393547596541023573D-23 / DATA AI1CS( 35) / +.2149877147090431445962500778666D-24 / DATA AI1CS( 36) / -.3045252425238676401746206173866D-25 / DATA AI1CS( 37) / +.5238082144721285982177634986666D-27 / DATA AI1CS( 38) / +.1443583107089382446416789503999D-26 / DATA AI1CS( 39) / -.6121302074890042733200670719999D-27 / DATA AI1CS( 40) / +.1700011117467818418349189802666D-27 / DATA AI1CS( 41) / -.3596589107984244158535215786666D-28 / DATA AI1CS( 42) / +.5448178578948418576650513066666D-29 / DATA AI1CS( 43) / -.2731831789689084989162564266666D-30 / DATA AI1CS( 44) / -.1858905021708600715771903999999D-30 / DATA AI1CS( 45) / +.9212682974513933441127765333333D-31 / DATA AI1CS( 46) / -.2813835155653561106370833066666D-31 / DATA AI12CS( 1) / +.2857623501828012047449845948469D-1 / DATA AI12CS( 2) / -.9761097491361468407765164457302D-2 / DATA AI12CS( 3) / -.1105889387626237162912569212775D-3 / DATA AI12CS( 4) / -.3882564808877690393456544776274D-5 / DATA AI12CS( 5) / -.2512236237870208925294520022121D-6 / DATA AI12CS( 6) / -.2631468846889519506837052365232D-7 / DATA AI12CS( 7) / -.3835380385964237022045006787968D-8 / DATA AI12CS( 8) / -.5589743462196583806868112522229D-9 / DATA AI12CS( 9) / -.1897495812350541234498925033238D-10 / DATA AI12CS( 10) / +.3252603583015488238555080679949D-10 / DATA AI12CS( 11) / +.1412580743661378133163366332846D-10 / DATA AI12CS( 12) / +.2035628544147089507224526136840D-11 / DATA AI12CS( 13) / -.7198551776245908512092589890446D-12 / DATA AI12CS( 14) / -.4083551111092197318228499639691D-12 / DATA AI12CS( 15) / -.2101541842772664313019845727462D-13 / DATA AI12CS( 16) / +.4272440016711951354297788336997D-13 / DATA AI12CS( 17) / +.1042027698412880276417414499948D-13 / DATA AI12CS( 18) / -.3814403072437007804767072535396D-14 / DATA AI12CS( 19) / -.1880354775510782448512734533963D-14 / DATA AI12CS( 20) / +.3308202310920928282731903352405D-15 / DATA AI12CS( 21) / +.2962628997645950139068546542052D-15 / DATA AI12CS( 22) / -.3209525921993423958778373532887D-16 / DATA AI12CS( 23) / -.4650305368489358325571282818979D-16 / DATA AI12CS( 24) / +.4414348323071707949946113759641D-17 / DATA AI12CS( 25) / +.7517296310842104805425458080295D-17 / DATA AI12CS( 26) / -.9314178867326883375684847845157D-18 / DATA AI12CS( 27) / -.1242193275194890956116784488697D-17 / DATA AI12CS( 28) / +.2414276719454848469005153902176D-18 / DATA AI12CS( 29) / +.2026944384053285178971922860692D-18 / DATA AI12CS( 30) / -.6394267188269097787043919886811D-19 / DATA AI12CS( 31) / -.3049812452373095896084884503571D-19 / DATA AI12CS( 32) / +.1612841851651480225134622307691D-19 / DATA AI12CS( 33) / +.3560913964309925054510270904620D-20 / DATA AI12CS( 34) / -.3752017947936439079666828003246D-20 / DATA AI12CS( 35) / -.5787037427074799345951982310741D-22 / DATA AI12CS( 36) / +.7759997511648161961982369632092D-21 / DATA AI12CS( 37) / -.1452790897202233394064459874085D-21 / DATA AI12CS( 38) / -.1318225286739036702121922753374D-21 / DATA AI12CS( 39) / +.6116654862903070701879991331717D-22 / DATA AI12CS( 40) / +.1376279762427126427730243383634D-22 / DATA AI12CS( 41) / -.1690837689959347884919839382306D-22 / DATA AI12CS( 42) / +.1430596088595433153987201085385D-23 / DATA AI12CS( 43) / +.3409557828090594020405367729902D-23 / DATA AI12CS( 44) / -.1309457666270760227845738726424D-23 / DATA AI12CS( 45) / -.3940706411240257436093521417557D-24 / DATA AI12CS( 46) / +.4277137426980876580806166797352D-24 / DATA AI12CS( 47) / -.4424634830982606881900283123029D-25 / DATA AI12CS( 48) / -.8734113196230714972115309788747D-25 / DATA AI12CS( 49) / +.4045401335683533392143404142428D-25 / DATA AI12CS( 50) / +.7067100658094689465651607717806D-26 / DATA AI12CS( 51) / -.1249463344565105223002864518605D-25 / DATA AI12CS( 52) / +.2867392244403437032979483391426D-26 / DATA AI12CS( 53) / +.2044292892504292670281779574210D-26 / DATA AI12CS( 54) / -.1518636633820462568371346802911D-26 / DATA AI12CS( 55) / +.8110181098187575886132279107037D-28 / DATA AI12CS( 56) / +.3580379354773586091127173703270D-27 / DATA AI12CS( 57) / -.1692929018927902509593057175448D-27 / DATA AI12CS( 58) / -.2222902499702427639067758527774D-28 / DATA AI12CS( 59) / +.5424535127145969655048600401128D-28 / DATA AI12CS( 60) / -.1787068401578018688764912993304D-28 / DATA AI12CS( 61) / -.6565479068722814938823929437880D-29 / DATA AI12CS( 62) / +.7807013165061145280922067706839D-29 / DATA AI12CS( 63) / -.1816595260668979717379333152221D-29 / DATA AI12CS( 64) / -.1287704952660084820376875598959D-29 / DATA AI12CS( 65) / +.1114548172988164547413709273694D-29 / DATA AI12CS( 66) / -.1808343145039336939159368876687D-30 / DATA AI12CS( 67) / -.2231677718203771952232448228939D-30 / DATA AI12CS( 68) / +.1619029596080341510617909803614D-30 / DATA AI12CS( 69) / -.1834079908804941413901308439210D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBSI1E if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NTI1 = INITDS (BI1CS, 17, ETA) NTAI1 = INITDS (AI1CS, 46, ETA) NTAI12 = INITDS (AI12CS, 69, ETA) ! XMIN = 2.0D0*D1MACH(1) XSML = SQRT(4.5D0*D1MACH(3)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 3.0D0) go to 20 ! DBSI1E = 0.0D0 if (Y == 0.D0) return ! if (Y <= XMIN) call XERMSG ('SLATEC', 'DBSI1E', & 'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1) if (Y > XMIN) DBSI1E = 0.5D0*X if (Y > XSML) DBSI1E = X*(0.875D0 + DCSEVL (Y*Y/4.5D0-1.D0, & BI1CS, NTI1) ) DBSI1E = EXP(-Y) * DBSI1E return ! 20 if (Y <= 8.D0) DBSI1E = (0.375D0 + DCSEVL ((48.D0/Y-11.D0)/5.D0, & AI1CS, NTAI1))/SQRT(Y) if (Y > 8.D0) DBSI1E = (0.375D0 + DCSEVL (16.D0/Y-1.D0, AI12CS, & NTAI12))/SQRT(Y) DBSI1E = SIGN (DBSI1E, X) ! return end DOUBLE PRECISION FUNCTION DBSK0E (X) ! !! DBSK0E computes the exponentially scaled modified (hyperbolic) Bessel ... ! function of the third kind of order zero. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE DOUBLE PRECISION (BESK0E-S, DBSK0E-D) !***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, ! THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBSK0E(X) computes the double precision exponentially scaled ! modified (hyperbolic) Bessel function of the third kind of ! order zero for positive double precision argument X. ! ! Series for BK0 on the interval 0. to 4.00000E+00 ! with weighted error 3.08E-33 ! log weighted error 32.51 ! significant figures required 32.05 ! decimal places required 33.11 ! ! Series for AK0 on the interval 1.25000E-01 to 5.00000E-01 ! with weighted error 2.85E-32 ! log weighted error 31.54 ! significant figures required 30.19 ! decimal places required 32.33 ! ! Series for AK02 on the interval 0. to 1.25000E-01 ! with weighted error 2.30E-32 ! log weighted error 31.64 ! significant figures required 29.68 ! decimal places required 32.40 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DBESI0, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBSK0E DOUBLE PRECISION X, BK0CS(16), AK0CS(38), AK02CS(33), & XSML, Y, D1MACH, DCSEVL, DBESI0 LOGICAL FIRST SAVE BK0CS, AK0CS, AK02CS, NTK0, NTAK0, NTAK02, XSML, FIRST DATA BK0CS( 1) / -.353273932339027687201140060063153D-1 / DATA BK0CS( 2) / +.344289899924628486886344927529213D+0 / DATA BK0CS( 3) / +.359799365153615016265721303687231D-1 / DATA BK0CS( 4) / +.126461541144692592338479508673447D-2 / DATA BK0CS( 5) / +.228621210311945178608269830297585D-4 / DATA BK0CS( 6) / +.253479107902614945730790013428354D-6 / DATA BK0CS( 7) / +.190451637722020885897214059381366D-8 / DATA BK0CS( 8) / +.103496952576336245851008317853089D-10 / DATA BK0CS( 9) / +.425981614279108257652445327170133D-13 / DATA BK0CS( 10) / +.137446543588075089694238325440000D-15 / DATA BK0CS( 11) / +.357089652850837359099688597333333D-18 / DATA BK0CS( 12) / +.763164366011643737667498666666666D-21 / DATA BK0CS( 13) / +.136542498844078185908053333333333D-23 / DATA BK0CS( 14) / +.207527526690666808319999999999999D-26 / DATA BK0CS( 15) / +.271281421807298560000000000000000D-29 / DATA BK0CS( 16) / +.308259388791466666666666666666666D-32 / DATA AK0CS( 1) / -.7643947903327941424082978270088D-1 / DATA AK0CS( 2) / -.2235652605699819052023095550791D-1 / DATA AK0CS( 3) / +.7734181154693858235300618174047D-3 / DATA AK0CS( 4) / -.4281006688886099464452146435416D-4 / DATA AK0CS( 5) / +.3081700173862974743650014826660D-5 / DATA AK0CS( 6) / -.2639367222009664974067448892723D-6 / DATA AK0CS( 7) / +.2563713036403469206294088265742D-7 / DATA AK0CS( 8) / -.2742705549900201263857211915244D-8 / DATA AK0CS( 9) / +.3169429658097499592080832873403D-9 / DATA AK0CS( 10) / -.3902353286962184141601065717962D-10 / DATA AK0CS( 11) / +.5068040698188575402050092127286D-11 / DATA AK0CS( 12) / -.6889574741007870679541713557984D-12 / DATA AK0CS( 13) / +.9744978497825917691388201336831D-13 / DATA AK0CS( 14) / -.1427332841884548505389855340122D-13 / DATA AK0CS( 15) / +.2156412571021463039558062976527D-14 / DATA AK0CS( 16) / -.3349654255149562772188782058530D-15 / DATA AK0CS( 17) / +.5335260216952911692145280392601D-16 / DATA AK0CS( 18) / -.8693669980890753807639622378837D-17 / DATA AK0CS( 19) / +.1446404347862212227887763442346D-17 / DATA AK0CS( 20) / -.2452889825500129682404678751573D-18 / DATA AK0CS( 21) / +.4233754526232171572821706342400D-19 / DATA AK0CS( 22) / -.7427946526454464195695341294933D-20 / DATA AK0CS( 23) / +.1323150529392666866277967462400D-20 / DATA AK0CS( 24) / -.2390587164739649451335981465599D-21 / DATA AK0CS( 25) / +.4376827585923226140165712554666D-22 / DATA AK0CS( 26) / -.8113700607345118059339011413333D-23 / DATA AK0CS( 27) / +.1521819913832172958310378154666D-23 / DATA AK0CS( 28) / -.2886041941483397770235958613333D-24 / DATA AK0CS( 29) / +.5530620667054717979992610133333D-25 / DATA AK0CS( 30) / -.1070377329249898728591633066666D-25 / DATA AK0CS( 31) / +.2091086893142384300296328533333D-26 / DATA AK0CS( 32) / -.4121713723646203827410261333333D-27 / DATA AK0CS( 33) / +.8193483971121307640135680000000D-28 / DATA AK0CS( 34) / -.1642000275459297726780757333333D-28 / DATA AK0CS( 35) / +.3316143281480227195890346666666D-29 / DATA AK0CS( 36) / -.6746863644145295941085866666666D-30 / DATA AK0CS( 37) / +.1382429146318424677635413333333D-30 / DATA AK0CS( 38) / -.2851874167359832570811733333333D-31 / DATA AK02CS( 1) / -.1201869826307592239839346212452D-1 / DATA AK02CS( 2) / -.9174852691025695310652561075713D-2 / DATA AK02CS( 3) / +.1444550931775005821048843878057D-3 / DATA AK02CS( 4) / -.4013614175435709728671021077879D-5 / DATA AK02CS( 5) / +.1567831810852310672590348990333D-6 / DATA AK02CS( 6) / -.7770110438521737710315799754460D-8 / DATA AK02CS( 7) / +.4611182576179717882533130529586D-9 / DATA AK02CS( 8) / -.3158592997860565770526665803309D-10 / DATA AK02CS( 9) / +.2435018039365041127835887814329D-11 / DATA AK02CS( 10) / -.2074331387398347897709853373506D-12 / DATA AK02CS( 11) / +.1925787280589917084742736504693D-13 / DATA AK02CS( 12) / -.1927554805838956103600347182218D-14 / DATA AK02CS( 13) / +.2062198029197818278285237869644D-15 / DATA AK02CS( 14) / -.2341685117579242402603640195071D-16 / DATA AK02CS( 15) / +.2805902810643042246815178828458D-17 / DATA AK02CS( 16) / -.3530507631161807945815482463573D-18 / DATA AK02CS( 17) / +.4645295422935108267424216337066D-19 / DATA AK02CS( 18) / -.6368625941344266473922053461333D-20 / DATA AK02CS( 19) / +.9069521310986515567622348800000D-21 / DATA AK02CS( 20) / -.1337974785423690739845005311999D-21 / DATA AK02CS( 21) / +.2039836021859952315522088960000D-22 / DATA AK02CS( 22) / -.3207027481367840500060869973333D-23 / DATA AK02CS( 23) / +.5189744413662309963626359466666D-24 / DATA AK02CS( 24) / -.8629501497540572192964607999999D-25 / DATA AK02CS( 25) / +.1472161183102559855208038400000D-25 / DATA AK02CS( 26) / -.2573069023867011283812351999999D-26 / DATA AK02CS( 27) / +.4601774086643516587376640000000D-27 / DATA AK02CS( 28) / -.8411555324201093737130666666666D-28 / DATA AK02CS( 29) / +.1569806306635368939301546666666D-28 / DATA AK02CS( 30) / -.2988226453005757788979199999999D-29 / DATA AK02CS( 31) / +.5796831375216836520618666666666D-30 / DATA AK02CS( 32) / -.1145035994347681332155733333333D-30 / DATA AK02CS( 33) / +.2301266594249682802005333333333D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBSK0E if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NTK0 = INITDS (BK0CS, 16, ETA) NTAK0 = INITDS (AK0CS, 38, ETA) NTAK02 = INITDS (AK02CS, 33, ETA) XSML = SQRT(4.0D0*D1MACH(3)) end if FIRST = .FALSE. ! if (X <= 0.D0) call XERMSG ('SLATEC', 'DBSK0E', & 'X IS ZERO OR NEGATIVE', 2, 2) if (X > 2.0D0) go to 20 ! Y = 0.D0 if (X > XSML) Y = X*X DBSK0E = EXP(X)*(-LOG(0.5D0*X)*DBESI0(X) - 0.25D0 + & DCSEVL (.5D0*Y-1.D0, BK0CS, NTK0)) return ! 20 if (X <= 8.D0) DBSK0E = (1.25D0 + DCSEVL ((16.D0/X-5.D0)/3.D0, & AK0CS, NTAK0))/SQRT(X) if (X > 8.D0) DBSK0E = (1.25D0 + & DCSEVL (16.D0/X-1.D0, AK02CS, NTAK02))/SQRT(X) ! return end DOUBLE PRECISION FUNCTION DBSK1E (X) ! !! DBSK1E computes the exponentially scaled modified (hyperbolic) Bessel ... ! function of the third kind of order one. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B1 !***TYPE DOUBLE PRECISION (BESK1E-S, DBSK1E-D) !***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, ! MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, ! THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBSK1E(S) computes the double precision exponentially scaled ! modified (hyperbolic) Bessel function of the third kind of order ! one for positive double precision argument X. ! ! Series for BK1 on the interval 0. to 4.00000E+00 ! with weighted error 9.16E-32 ! log weighted error 31.04 ! significant figures required 30.61 ! decimal places required 31.64 ! ! Series for AK1 on the interval 1.25000E-01 to 5.00000E-01 ! with weighted error 3.07E-32 ! log weighted error 31.51 ! significant figures required 30.71 ! decimal places required 32.30 ! ! Series for AK12 on the interval 0. to 1.25000E-01 ! with weighted error 2.41E-32 ! log weighted error 31.62 ! significant figures required 30.25 ! decimal places required 32.38 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DBESI1, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBSK1E DOUBLE PRECISION X, BK1CS(16), AK1CS(38), AK12CS(33), XMIN, & XSML, Y, D1MACH, DCSEVL, DBESI1 LOGICAL FIRST SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML, & FIRST DATA BK1CS( 1) / +.25300227338947770532531120868533D-1 / DATA BK1CS( 2) / -.35315596077654487566723831691801D+0 / DATA BK1CS( 3) / -.12261118082265714823479067930042D+0 / DATA BK1CS( 4) / -.69757238596398643501812920296083D-2 / DATA BK1CS( 5) / -.17302889575130520630176507368979D-3 / DATA BK1CS( 6) / -.24334061415659682349600735030164D-5 / DATA BK1CS( 7) / -.22133876307347258558315252545126D-7 / DATA BK1CS( 8) / -.14114883926335277610958330212608D-9 / DATA BK1CS( 9) / -.66669016941993290060853751264373D-12 / DATA BK1CS( 10) / -.24274498505193659339263196864853D-14 / DATA BK1CS( 11) / -.70238634793862875971783797120000D-17 / DATA BK1CS( 12) / -.16543275155100994675491029333333D-19 / DATA BK1CS( 13) / -.32338347459944491991893333333333D-22 / DATA BK1CS( 14) / -.53312750529265274999466666666666D-25 / DATA BK1CS( 15) / -.75130407162157226666666666666666D-28 / DATA BK1CS( 16) / -.91550857176541866666666666666666D-31 / DATA AK1CS( 1) / +.27443134069738829695257666227266D+0 / DATA AK1CS( 2) / +.75719899531993678170892378149290D-1 / DATA AK1CS( 3) / -.14410515564754061229853116175625D-2 / DATA AK1CS( 4) / +.66501169551257479394251385477036D-4 / DATA AK1CS( 5) / -.43699847095201407660580845089167D-5 / DATA AK1CS( 6) / +.35402774997630526799417139008534D-6 / DATA AK1CS( 7) / -.33111637792932920208982688245704D-7 / DATA AK1CS( 8) / +.34459775819010534532311499770992D-8 / DATA AK1CS( 9) / -.38989323474754271048981937492758D-9 / DATA AK1CS( 10) / +.47208197504658356400947449339005D-10 / DATA AK1CS( 11) / -.60478356628753562345373591562890D-11 / DATA AK1CS( 12) / +.81284948748658747888193837985663D-12 / DATA AK1CS( 13) / -.11386945747147891428923915951042D-12 / DATA AK1CS( 14) / +.16540358408462282325972948205090D-13 / DATA AK1CS( 15) / -.24809025677068848221516010440533D-14 / DATA AK1CS( 16) / +.38292378907024096948429227299157D-15 / DATA AK1CS( 17) / -.60647341040012418187768210377386D-16 / DATA AK1CS( 18) / +.98324256232648616038194004650666D-17 / DATA AK1CS( 19) / -.16284168738284380035666620115626D-17 / DATA AK1CS( 20) / +.27501536496752623718284120337066D-18 / DATA AK1CS( 21) / -.47289666463953250924281069568000D-19 / DATA AK1CS( 22) / +.82681500028109932722392050346666D-20 / DATA AK1CS( 23) / -.14681405136624956337193964885333D-20 / DATA AK1CS( 24) / +.26447639269208245978085894826666D-21 / DATA AK1CS( 25) / -.48290157564856387897969868800000D-22 / DATA AK1CS( 26) / +.89293020743610130180656332799999D-23 / DATA AK1CS( 27) / -.16708397168972517176997751466666D-23 / DATA AK1CS( 28) / +.31616456034040694931368618666666D-24 / DATA AK1CS( 29) / -.60462055312274989106506410666666D-25 / DATA AK1CS( 30) / +.11678798942042732700718421333333D-25 / DATA AK1CS( 31) / -.22773741582653996232867840000000D-26 / DATA AK1CS( 32) / +.44811097300773675795305813333333D-27 / DATA AK1CS( 33) / -.88932884769020194062336000000000D-28 / DATA AK1CS( 34) / +.17794680018850275131392000000000D-28 / DATA AK1CS( 35) / -.35884555967329095821994666666666D-29 / DATA AK1CS( 36) / +.72906290492694257991679999999999D-30 / DATA AK1CS( 37) / -.14918449845546227073024000000000D-30 / DATA AK1CS( 38) / +.30736573872934276300799999999999D-31 / DATA AK12CS( 1) / +.6379308343739001036600488534102D-1 / DATA AK12CS( 2) / +.2832887813049720935835030284708D-1 / DATA AK12CS( 3) / -.2475370673905250345414545566732D-3 / DATA AK12CS( 4) / +.5771972451607248820470976625763D-5 / DATA AK12CS( 5) / -.2068939219536548302745533196552D-6 / DATA AK12CS( 6) / +.9739983441381804180309213097887D-8 / DATA AK12CS( 7) / -.5585336140380624984688895511129D-9 / DATA AK12CS( 8) / +.3732996634046185240221212854731D-10 / DATA AK12CS( 9) / -.2825051961023225445135065754928D-11 / DATA AK12CS( 10) / +.2372019002484144173643496955486D-12 / DATA AK12CS( 11) / -.2176677387991753979268301667938D-13 / DATA AK12CS( 12) / +.2157914161616032453939562689706D-14 / DATA AK12CS( 13) / -.2290196930718269275991551338154D-15 / DATA AK12CS( 14) / +.2582885729823274961919939565226D-16 / DATA AK12CS( 15) / -.3076752641268463187621098173440D-17 / DATA AK12CS( 16) / +.3851487721280491597094896844799D-18 / DATA AK12CS( 17) / -.5044794897641528977117282508800D-19 / DATA AK12CS( 18) / +.6888673850418544237018292223999D-20 / DATA AK12CS( 19) / -.9775041541950118303002132480000D-21 / DATA AK12CS( 20) / +.1437416218523836461001659733333D-21 / DATA AK12CS( 21) / -.2185059497344347373499733333333D-22 / DATA AK12CS( 22) / +.3426245621809220631645388800000D-23 / DATA AK12CS( 23) / -.5531064394246408232501248000000D-24 / DATA AK12CS( 24) / +.9176601505685995403782826666666D-25 / DATA AK12CS( 25) / -.1562287203618024911448746666666D-25 / DATA AK12CS( 26) / +.2725419375484333132349439999999D-26 / DATA AK12CS( 27) / -.4865674910074827992378026666666D-27 / DATA AK12CS( 28) / +.8879388552723502587357866666666D-28 / DATA AK12CS( 29) / -.1654585918039257548936533333333D-28 / DATA AK12CS( 30) / +.3145111321357848674303999999999D-29 / DATA AK12CS( 31) / -.6092998312193127612416000000000D-30 / DATA AK12CS( 32) / +.1202021939369815834623999999999D-30 / DATA AK12CS( 33) / -.2412930801459408841386666666666D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DBSK1E if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NTK1 = INITDS (BK1CS, 16, ETA) NTAK1 = INITDS (AK1CS, 38, ETA) NTAK12 = INITDS (AK12CS, 33, ETA) ! XMIN = EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0) XSML = SQRT(4.0D0*D1MACH(3)) end if FIRST = .FALSE. ! if (X <= 0.D0) call XERMSG ('SLATEC', 'DBSK1E', & 'X IS ZERO OR NEGATIVE', 2, 2) if (X > 2.0D0) go to 20 ! if (X < XMIN) call XERMSG ('SLATEC', 'DBSK1E', & 'X SO SMALL K1 OVERFLOWS', 3, 2) Y = 0.D0 if (X > XSML) Y = X*X DBSK1E = EXP(X)*(LOG(0.5D0*X)*DBESI1(X) + (0.75D0 + & DCSEVL (0.5D0*Y-1.D0, BK1CS, NTK1))/X ) return ! 20 if (X <= 8.D0) DBSK1E = (1.25D0 + DCSEVL ((16.D0/X-5.D0)/3.D0, & AK1CS, NTAK1))/SQRT(X) if (X > 8.D0) DBSK1E = (1.25D0 + & DCSEVL (16.D0/X-1.D0, AK12CS, NTAK12))/SQRT(X) ! return end subroutine DBSKES (XNU, X, NIN, BKE) ! !! DBSKES computes a sequence of exponentially scaled modified Bessel ... ! functions of the third kind of fractional order. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B3 !***TYPE DOUBLE PRECISION (BESKES-S, DBSKES-D) !***KEYWORDS EXPONENTIALLY SCALED, FNLIB, FRACTIONAL ORDER, ! MODIFIED BESSEL FUNCTION, SEQUENCE OF BESSEL FUNCTIONS, ! SPECIAL FUNCTIONS, THIRD KIND !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DBSKES(XNU,X,NIN,BKE) computes a double precision sequence ! of exponentially scaled modified Bessel functions ! of the third kind of order XNU + I at X, where X > 0, ! XNU lies in (-1,1), and I = 0, 1, ... , NIN - 1, if NIN is positive ! and I = 0, -1, ... , NIN + 1, if NIN is negative. On return, the ! vector BKE(.) contains the results at X for order starting at XNU. ! XNU, X, and BKE are double precision. NIN is integer. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9KNUS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DBSKES DOUBLE PRECISION XNU, X, BKE(*), BKNU1, V, VINCR, VEND, ALNBIG, & D1MACH, DIRECT SAVE ALNBIG DATA ALNBIG / 0.D0 / !***FIRST EXECUTABLE STATEMENT DBSKES if (ALNBIG == 0.D0) ALNBIG = LOG (D1MACH(2)) ! V = ABS(XNU) N = ABS(NIN) ! if (V >= 1.D0) call XERMSG ('SLATEC', 'DBSKES', & 'ABS(XNU) MUST BE LT 1', 2, 2) if (X <= 0.D0) call XERMSG ('SLATEC', 'DBSKES', 'X IS LE 0', 3, & 2) if (N == 0) call XERMSG ('SLATEC', 'DBSKES', & 'N THE NUMBER IN THE SEQUENCE IS 0', 4, 2) ! call D9KNUS (V, X, BKE(1), BKNU1, ISWTCH) if (N == 1) RETURN ! VINCR = SIGN (1.0, REAL(NIN)) DIRECT = VINCR if (XNU /= 0.D0) DIRECT = VINCR*SIGN(1.D0, XNU) if (ISWTCH == 1 .AND. DIRECT > 0.) call XERMSG ('SLATEC', & 'DBSKES', 'X SO SMALL BESSEL K-SUB-XNU+1 OVERFLOWS', 5, 2) BKE(2) = BKNU1 ! if (DIRECT < 0.) call D9KNUS (ABS(XNU+VINCR), X, BKE(2), BKNU1, & ISWTCH) if (N == 2) RETURN ! VEND = ABS (XNU+NIN) - 1.0D0 if ((VEND-.5D0)*LOG(VEND)+0.27D0-VEND*(LOG(X)-.694D0) > & ALNBIG) call XERMSG ('SLATEC', 'DBSKES', & 'X SO SMALL OR ABS(NU) SO BIG THAT BESSEL K-SUB-NU ' // & 'OVERFLOWS', 5, 2) ! V = XNU DO 10 I=3,N V = V + VINCR BKE(I) = 2.0D0*V*BKE(I-1)/X + BKE(I-2) 10 CONTINUE ! return end subroutine DBSKIN (X, N, KODE, M, Y, NZ, IERR) ! !! DBSKIN computes repeated integrals of the K-zero Bessel function. ! !***LIBRARY SLATEC !***CATEGORY C10F !***TYPE DOUBLE PRECISION (BSKIN-S, DBSKIN-D) !***KEYWORDS BICKLEY FUNCTIONS, EXPONENTIAL INTEGRAL, ! INTEGRALS OF BESSEL FUNCTIONS, K-ZERO BESSEL FUNCTION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! The following definitions are used in DBSKIN: ! ! Definition 1 ! KI(0,X) = K-zero Bessel function. ! ! Definition 2 ! KI(N,X) = Bickley Function ! = integral from X to infinity of KI(N-1,t)dt ! for X .ge. 0 and N = 1,2,... ! _____________________________________________________________________ ! DBSKIN computes a sequence of Bickley functions (repeated integrals ! of the K0 Bessel function); i.e. for fixed X and N and for K=1,..., ! DBSKIN computes the sequence ! ! Y(K) = KI(N+K-1,X) for KODE=1 ! or ! Y(K) = EXP(X)*KI(N+K-1,X) for KODE=2, ! ! for N.ge.0 and X.ge.0 (N and X cannot be zero simultaneously). ! ! INPUT X is DOUBLE PRECISION ! X - Argument, X .ge. 0.0D0 ! N - Order of first member of the sequence N .ge. 0 ! KODE - Selection parameter ! KODE = 1 returns Y(K)= KI(N+K-1,X), K=1,M ! = 2 returns Y(K)=EXP(X)*KI(N+K-1,X), K=1,M ! M - Number of members in the sequence, M.ge.1 ! ! OUTPUT Y is a DOUBLE PRECISION VECTOR ! Y - A vector of dimension at least M containing the ! sequence selected by KODE. ! NZ - Underflow flag ! NZ = 0 means computation completed ! = 1 means an exponential underflow occurred on ! KODE=1. Y(K)=0.0D0, K=1,...,M is returned ! KODE=1 AND Y(K)=0.0E0, K=1,...,M IS RETURNED ! IERR - Error flag ! IERR=0, Normal return, computation completed ! IERR=1, Input error, no computation ! IERR=2, Error, no computation ! Algorithm termination condition not met ! ! The nominal computational accuracy is the maximum of unit ! roundoff (=D1MACH(4)) and 1.0D-18 since critical constants ! are given to only 18 digits. ! ! BSKIN is the single precision version of DBSKIN. ! ! *Long Description: ! ! Numerical recurrence on ! ! (L-1)*KI(L,X) = X(KI(L-3,X) - KI(L-1,X)) + (L-2)*KI(L-2,X) ! ! is stable where recurrence is carried forward or backward ! away from INT(X+0.5). The power series for indices 0,1 and 2 ! on 0.le.X.le.2 starts a stable recurrence for indices ! greater than 2. If N is sufficiently large (N.gt.NLIM), the ! uniform asymptotic expansion for N to INFINITY is more ! economical. On X.gt.2 the recursion is started by evaluating ! the uniform expansion for the three members whose indices are ! closest to INT(X+0.5) within the set N,...,N+M-1. Forward ! recurrence, backward recurrence or both complete the ! sequence depending on the relation of INT(X+0.5) to the ! indices N,...,N+M-1. ! !***REFERENCES D. E. Amos, Uniform asymptotic expansions for ! exponential integrals E(N,X) and Bickley functions ! KI(N,X), ACM Transactions on Mathematical Software, ! 1983. ! D. E. Amos, A portable Fortran subroutine for the ! Bickley functions KI(N,X), Algorithm 609, ACM ! Transactions on Mathematical Software, 1983. !***ROUTINES CALLED D1MACH, DBKIAS, DBKISR, DEXINT, DGAMRN, I1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891009 Removed unreferenced statement label. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBSKIN INTEGER I, ICASE, IERR, IL, I1M, K, KK, KODE, KTRMS, M, & M3, N, NE, NFLG, NL, NLIM, NN, NP, NS, NT, NZ INTEGER I1MACH DOUBLE PRECISION A, ENLIM, EXI, FN, GR, H, HN, HRTPI, SS, TOL, & T1, T2, W, X, XLIM, XNLIM, XP, Y, YS, YSS DOUBLE PRECISION DGAMRN, D1MACH DIMENSION EXI(102), A(50), YS(3), YSS(3), H(31), Y(*) SAVE A, HRTPI !----------------------------------------------------------------------- ! COEFFICIENTS IN SERIES OF EXPONENTIAL INTEGRALS !----------------------------------------------------------------------- DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), A(8), A(9), A(10), & A(11), A(12), A(13), A(14), A(15), A(16), A(17), A(18), A(19), & A(20), A(21), A(22), A(23), A(24) /1.00000000000000000D+00, & 5.00000000000000000D-01,3.75000000000000000D-01, & 3.12500000000000000D-01,2.73437500000000000D-01, & 2.46093750000000000D-01,2.25585937500000000D-01, & 2.09472656250000000D-01,1.96380615234375000D-01, & 1.85470581054687500D-01,1.76197052001953125D-01, & 1.68188095092773438D-01,1.61180257797241211D-01, & 1.54981017112731934D-01,1.49445980787277222D-01, & 1.44464448094367981D-01,1.39949934091418982D-01, & 1.35833759559318423D-01,1.32060599571559578D-01, & 1.28585320635465905D-01,1.25370687619579257D-01, & 1.22385671247684513D-01,1.19604178719328047D-01, & 1.17004087877603524D-01/ DATA A(25), A(26), A(27), A(28), A(29), A(30), A(31), A(32), & A(33), A(34), A(35), A(36), A(37), A(38), A(39), A(40), A(41), & A(42), A(43), A(44), A(45), A(46), A(47), A(48) & /1.14566502713486784D-01,1.12275172659217048D-01, & 1.10116034723462874D-01,1.08076848895250599D-01, & 1.06146905164978267D-01,1.04316786110409676D-01, & 1.02578173008569515D-01,1.00923686347140974D-01, & 9.93467537479668965D-02,9.78414999033007314D-02, & 9.64026543164874854D-02,9.50254735405376642D-02, & 9.37056752969190855D-02,9.24393823875012600D-02, & 9.12230747245078224D-02,9.00535481254756708D-02, & 8.89278787739072249D-02,8.78433924473961612D-02, & 8.67976377754033498D-02,8.57883629175498224D-02, & 8.48134951571231199D-02,8.38711229887106408D-02, & 8.29594803475290034D-02,8.20769326842574183D-02/ DATA A(49), A(50) /8.12219646354630702D-02,8.03931690779583449D-02 & / !----------------------------------------------------------------------- ! SQRT(PI)/2 !----------------------------------------------------------------------- DATA HRTPI /8.86226925452758014D-01/ ! !***FIRST EXECUTABLE STATEMENT DBSKIN IERR = 0 NZ=0 if (X < 0.0D0) IERR=1 if (N < 0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (M < 1) IERR=1 if (X == 0.0D0 .AND. N == 0) IERR=1 if (IERR /= 0) RETURN if (X == 0.0D0) go to 300 I1M = -I1MACH(15) T1 = 2.3026D0*D1MACH(5)*I1M XLIM = T1 - 3.228086D0 T2 = T1 + (N+M-1) if (T2 > 1000.0D0) XLIM = T1 - 0.5D0*(LOG(T2)-0.451583D0) if (X > XLIM .AND. KODE == 1) go to 320 TOL = MAX(D1MACH(4),1.0D-18) I1M = I1MACH(14) !----------------------------------------------------------------------- ! LN(NLIM) = 0.125*LN(EPS), NLIM = 2*KTRMS+N !----------------------------------------------------------------------- XNLIM = 0.287823D0*(I1M-1)*D1MACH(5) ENLIM = EXP(XNLIM) NLIM = INT(ENLIM) + 2 NLIM = MIN(100,NLIM) NLIM = MAX(20,NLIM) M3 = MIN(M,3) NL = N + M - 1 if (X > 2.0D0) go to 130 if (N > NLIM) go to 280 !----------------------------------------------------------------------- ! COMPUTATION BY SERIES FOR 0 <= X <= 2 !----------------------------------------------------------------------- NFLG = 0 NN = N if (NL <= 2) go to 60 M3 = 3 NN = 0 NFLG = 1 60 CONTINUE XP = 1.0D0 if (KODE == 2) XP = EXP(X) DO 80 I=1,M3 call DBKISR(X, NN, W, IERR) if ( IERR /= 0) RETURN W = W*XP if (NN < N) go to 70 KK = NN - N + 1 Y(KK) = W 70 CONTINUE YS(I) = W NN = NN + 1 80 CONTINUE if (NFLG == 0) RETURN NS = NN XP = 1.0D0 90 CONTINUE !----------------------------------------------------------------------- ! FORWARD RECURSION SCALED BY EXP(X) ON ICASE=0,1,2 !----------------------------------------------------------------------- FN = NS - 1 IL = NL - NS + 1 if (IL <= 0) RETURN DO 110 I=1,IL T1 = YS(2) T2 = YS(3) YS(3) = (X*(YS(1)-YS(3))+(FN-1.0D0)*YS(2))/FN YS(2) = T2 YS(1) = T1 FN = FN + 1.0D0 if (NS < N) go to 100 KK = NS - N + 1 Y(KK) = YS(3)*XP 100 CONTINUE NS = NS + 1 110 CONTINUE return !----------------------------------------------------------------------- ! COMPUTATION BY ASYMPTOTIC EXPANSION FOR X > 2 !----------------------------------------------------------------------- 130 CONTINUE W = X + 0.5D0 NT = INT(W) if (NL > NT) go to 270 !----------------------------------------------------------------------- ! CASE NL <= NT, ICASE=0 !----------------------------------------------------------------------- ICASE = 0 NN = NL NFLG = MIN(M-M3,1) 140 CONTINUE KK = (NLIM-NN)/2 KTRMS = MAX(0,KK) NS = NN + 1 NP = NN - M3 + 1 XP = 1.0D0 if (KODE == 1) XP = EXP(-X) DO 150 I=1,M3 KK = I call DBKIAS(X, NP, KTRMS, A, W, KK, NE, GR, H, IERR) if ( IERR /= 0) RETURN YS(I) = W NP = NP + 1 150 CONTINUE !----------------------------------------------------------------------- ! SUM SERIES OF EXPONENTIAL INTEGRALS BACKWARD !----------------------------------------------------------------------- if (KTRMS == 0) go to 160 NE = KTRMS + KTRMS + 1 NP = NN - M3 + 2 call DEXINT(X, NP, 2, NE, TOL, EXI, NZ, IERR) if (NZ /= 0) go to 320 160 CONTINUE DO 190 I=1,M3 SS = 0.0D0 if (KTRMS == 0) go to 180 KK = I + KTRMS + KTRMS - 2 IL = KTRMS DO 170 K=1,KTRMS SS = SS + A(IL)*EXI(KK) KK = KK - 2 IL = IL - 1 170 CONTINUE 180 CONTINUE YS(I) = YS(I) + SS 190 CONTINUE if (ICASE == 1) go to 200 if (NFLG /= 0) go to 220 200 CONTINUE DO 210 I=1,M3 Y(I) = YS(I)*XP 210 CONTINUE if (ICASE == 1 .AND. NFLG == 1) go to 90 return 220 CONTINUE !----------------------------------------------------------------------- ! BACKWARD RECURSION SCALED BY EXP(X) ICASE=0,2 !----------------------------------------------------------------------- KK = NN - N + 1 K = M3 DO 230 I=1,M3 Y(KK) = YS(K)*XP YSS(I) = YS(I) KK = KK - 1 K = K - 1 230 CONTINUE IL = KK if (IL <= 0) go to 250 FN = NN - 3 DO 240 I=1,IL T1 = YS(2) T2 = YS(1) YS(1) = YS(2) + ((FN+2.0D0)*YS(3)-(FN+1.0D0)*YS(1))/X YS(2) = T2 YS(3) = T1 Y(KK) = YS(1)*XP KK = KK - 1 FN = FN - 1.0D0 240 CONTINUE 250 CONTINUE if (ICASE /= 2) RETURN DO 260 I=1,M3 YS(I) = YSS(I) 260 CONTINUE go to 90 270 CONTINUE if (N < NT) go to 290 !----------------------------------------------------------------------- ! ICASE=1, NT <= N <= NL WITH FORWARD RECURSION !----------------------------------------------------------------------- 280 CONTINUE NN = N + M3 - 1 NFLG = MIN(M-M3,1) ICASE = 1 go to 140 !----------------------------------------------------------------------- ! ICASE=2, N < NT < NL WITH BOTH FORWARD AND BACKWARD RECURSION !----------------------------------------------------------------------- 290 CONTINUE NN = NT + 1 NFLG = MIN(M-M3,1) ICASE = 2 go to 140 !----------------------------------------------------------------------- ! X=0 CASE !----------------------------------------------------------------------- 300 CONTINUE FN = N HN = 0.5D0*FN GR = DGAMRN(HN) Y(1) = HRTPI*GR if (M == 1) RETURN Y(2) = HRTPI/(HN*GR) if (M == 2) RETURN DO 310 K=3,M Y(K) = FN*Y(K-2)/(FN+1.0D0) FN = FN + 1.0D0 310 CONTINUE return !----------------------------------------------------------------------- ! UNDERFLOW ON KODE=1, X > XLIM !----------------------------------------------------------------------- 320 CONTINUE NZ=M DO 330 I=1,M Y(I) = 0.0D0 330 CONTINUE return end subroutine DBSKNU (X, FNU, KODE, N, Y, NZ) ! !! DBSKNU is subsidiary to DBESK. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BESKNU-S, DBSKNU-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract **** A DOUBLE PRECISION routine **** ! DBSKNU computes N member sequences of K Bessel functions ! K/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and ! positive X. Equations of the references are implemented on ! small orders DNU for K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X). ! Forward recursion with the three term recursion relation ! generates higher orders FNU+I-1, I=1,...,N. The parameter ! KODE permits K/SUB(FNU+I-1)/(X) values or scaled values ! EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned. ! ! To start the recursion FNU is normalized to the interval ! -0.5 <= DNU < 0.5. A special form of the power series is ! implemented on 0 < X <= X1 while the Miller algorithm for the ! K Bessel function in terms of the confluent hypergeometric ! function U(FNU+0.5,2*FNU+1,X) is implemented on X1 < X <= X2. ! For X > X2, the asymptotic expansion for large X is used. ! When FNU is a half odd integer, a special formula for ! DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. ! ! The maximum number of significant digits obtainable ! is the smaller of 14 and the number of digits carried in ! DOUBLE PRECISION arithmetic. ! ! DBSKNU assumes that a significant digit SINH function is ! available. ! ! Description of Arguments ! ! INPUT X,FNU are DOUBLE PRECISION ! X - X > 0.0D0 ! FNU - Order of initial K function, FNU >= 0.0D0 ! N - Number of members of the sequence, N >= 1 ! KODE - A parameter to indicate the scaling option ! KODE= 1 returns ! Y(I)= K/SUB(FNU+I-1)/(X) ! I=1,...,N ! = 2 returns ! Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X) ! I=1,...,N ! ! OUTPUT Y is DOUBLE PRECISION ! Y - A vector whose first N components contain values ! for the sequence ! Y(I)= K/SUB(FNU+I-1)/(X), I=1,...,N or ! Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N ! depending on KODE ! NZ - Number of components set to zero due to ! underflow, ! NZ= 0 , normal return ! NZ /= 0 , first NZ components of Y set to zero ! due to underflow, Y(I)=0.0D0,I=1,...,NZ ! ! Error Conditions ! Improper input arguments - a fatal error ! Overflow - a fatal error ! Underflow with KODE=1 - a non-fatal error (NZ /= 0) ! !***SEE ALSO DBESK !***REFERENCES N. M. Temme, On the numerical evaluation of the modified ! Bessel function of the third kind, Journal of ! Computational Physics 19, (1975), pp. 324-337. !***ROUTINES CALLED D1MACH, DGAMMA, I1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790201 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) ! 900727 Added EXTERNAL statement. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBSKNU ! INTEGER I, IFLAG, INU, J, K, KK, KODE, KODED, N, NN, NZ INTEGER I1MACH DOUBLE PRECISION A,AK,A1,A2,B,BK,CC,CK,COEF,CX,DK,DNU,DNU2,ELIM, & ETEST, EX, F, FC, FHS, FK, FKS, FLRX, FMU, FNU, G1, G2, P, PI, & PT, P1, P2, Q, RTHPI, RX, S, SMU, SQK, ST, S1, S2, TM, TOL, T1, & T2, X, X1, X2, Y DIMENSION A(160), B(160), Y(*), CC(8) DOUBLE PRECISION DGAMMA, D1MACH EXTERNAL DGAMMA SAVE X1, X2, PI, RTHPI, CC DATA X1, X2 / 2.0D0, 17.0D0 / DATA PI,RTHPI / 3.14159265358979D+00, 1.25331413731550D+00/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) & / 5.77215664901533D-01,-4.20026350340952D-02, & -4.21977345555443D-02, 7.21894324666300D-03,-2.15241674114900D-04, & -2.01348547807000D-05, 1.13302723200000D-06, 6.11609500000000D-09/ !***FIRST EXECUTABLE STATEMENT DBSKNU KK = -I1MACH(15) ELIM = 2.303D0*(KK*D1MACH(5)-3.0D0) AK = D1MACH(3) TOL = MAX(AK,1.0D-15) if (X <= 0.0D0) go to 350 if (FNU < 0.0D0) go to 360 if (KODE < 1 .OR. KODE > 2) go to 370 if (N < 1) go to 380 NZ = 0 IFLAG = 0 KODED = KODE RX = 2.0D0/X INU = INT(FNU+0.5D0) DNU = FNU - INU if (ABS(DNU) == 0.5D0) go to 120 DNU2 = 0.0D0 if (ABS(DNU) < TOL) go to 10 DNU2 = DNU*DNU 10 CONTINUE if (X > X1) go to 120 ! ! SERIES FOR X <= X1 ! A1 = 1.0D0 - DNU A2 = 1.0D0 + DNU T1 = 1.0D0/DGAMMA(A1) T2 = 1.0D0/DGAMMA(A2) if (ABS(DNU) > 0.1D0) go to 40 ! SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) S = CC(1) AK = 1.0D0 DO 20 K=2,8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM if (ABS(TM) < TOL) go to 30 20 CONTINUE 30 G1 = -S go to 50 40 CONTINUE G1 = (T1-T2)/(DNU+DNU) 50 CONTINUE G2 = (T1+T2)*0.5D0 SMU = 1.0D0 FC = 1.0D0 FLRX = LOG(RX) FMU = DNU*FLRX if (DNU == 0.0D0) go to 60 FC = DNU*PI FC = FC/SIN(FC) if (FMU /= 0.0D0) SMU = SINH(FMU)/FMU 60 CONTINUE F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) FC = EXP(FMU) P = 0.5D0*FC/T2 Q = 0.5D0/(FC*T1) AK = 1.0D0 CK = 1.0D0 BK = 1.0D0 S1 = F S2 = P if (INU > 0 .OR. N > 1) go to 90 if (X < TOL) go to 80 CX = X*X*0.25D0 70 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) CK = CK*CX/AK T1 = CK*F S1 = S1 + T1 BK = BK + AK + AK + 1.0D0 AK = AK + 1.0D0 S = ABS(T1)/(1.0D0+ABS(S1)) if (S > TOL) go to 70 80 CONTINUE Y(1) = S1 if (KODED == 1) RETURN Y(1) = S1*EXP(X) return 90 CONTINUE if (X < TOL) go to 110 CX = X*X*0.25D0 100 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) CK = CK*CX/AK T1 = CK*F S1 = S1 + T1 T2 = CK*(P-AK*F) S2 = S2 + T2 BK = BK + AK + AK + 1.0D0 AK = AK + 1.0D0 S = ABS(T1)/(1.0D0+ABS(S1)) + ABS(T2)/(1.0D0+ABS(S2)) if (S > TOL) go to 100 110 CONTINUE S2 = S2*RX if (KODED == 1) go to 170 F = EXP(X) S1 = S1*F S2 = S2*F go to 170 120 CONTINUE COEF = RTHPI/SQRT(X) if (KODED == 2) go to 130 if (X > ELIM) go to 330 COEF = COEF*EXP(-X) 130 CONTINUE if (ABS(DNU) == 0.5D0) go to 340 if (X > X2) go to 280 ! ! MILLER ALGORITHM FOR X1 < X <= X2 ! ETEST = COS(PI*DNU)/(PI*X*TOL) FKS = 1.0D0 FHS = 0.25D0 FK = 0.0D0 CK = X + X + 2.0D0 P1 = 0.0D0 P2 = 1.0D0 K = 0 140 CONTINUE K = K + 1 FK = FK + 1.0D0 AK = (FHS-DNU2)/(FKS+FK) BK = CK/(FK+1.0D0) PT = P2 P2 = BK*P2 - AK*P1 P1 = PT A(K) = AK B(K) = BK CK = CK + 2.0D0 FKS = FKS + FK + FK + 1.0D0 FHS = FHS + FK + FK if (ETEST > FK*P1) go to 140 KK = K S = 1.0D0 P1 = 0.0D0 P2 = 1.0D0 DO 150 I=1,K PT = P2 P2 = (B(KK)*P2-P1)/A(KK) P1 = PT S = S + P2 KK = KK - 1 150 CONTINUE S1 = COEF*(P2/S) if (INU > 0 .OR. N > 1) go to 160 go to 200 160 CONTINUE S2 = S1*(X+DNU+0.5D0-P1/P2)/X ! ! FORWARD RECURSION ON THE THREE TERM RECURSION RELATION ! 170 CONTINUE CK = (DNU+DNU+2.0D0)/X if (N == 1) INU = INU - 1 if (INU > 0) go to 180 if (N > 1) go to 200 S1 = S2 go to 200 180 CONTINUE DO 190 I=1,INU ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RX 190 CONTINUE if (N == 1) S1 = S2 200 CONTINUE if (IFLAG == 1) go to 220 Y(1) = S1 if (N == 1) RETURN Y(2) = S2 if (N == 2) RETURN DO 210 I=3,N Y(I) = CK*Y(I-1) + Y(I-2) CK = CK + RX 210 CONTINUE return ! IFLAG=1 CASES 220 CONTINUE S = -X + LOG(S1) Y(1) = 0.0D0 NZ = 1 if (S < -ELIM) go to 230 Y(1) = EXP(S) NZ = 0 230 CONTINUE if (N == 1) RETURN S = -X + LOG(S2) Y(2) = 0.0D0 NZ = NZ + 1 if (S < -ELIM) go to 240 NZ = NZ - 1 Y(2) = EXP(S) 240 CONTINUE if (N == 2) RETURN KK = 2 if (NZ < 2) go to 260 DO 250 I=3,N KK = I ST = S2 S2 = CK*S2 + S1 S1 = ST CK = CK + RX S = -X + LOG(S2) NZ = NZ + 1 Y(I) = 0.0D0 if (S < -ELIM) go to 250 Y(I) = EXP(S) NZ = NZ - 1 go to 260 250 CONTINUE return 260 CONTINUE if (KK == N) RETURN S2 = S2*CK + S1 CK = CK + RX KK = KK + 1 Y(KK) = EXP(-X+LOG(S2)) if (KK == N) RETURN KK = KK + 1 DO 270 I=KK,N Y(I) = CK*Y(I-1) + Y(I-2) CK = CK + RX 270 CONTINUE return ! ! ASYMPTOTIC EXPANSION FOR LARGE X, X > X2 ! ! IFLAG=0 MEANS NO UNDERFLOW OCCURRED ! IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH ! KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD ! RECURSION 280 CONTINUE NN = 2 if (INU == 0 .AND. N == 1) NN = 1 DNU2 = DNU + DNU FMU = 0.0D0 if (ABS(DNU2) < TOL) go to 290 FMU = DNU2*DNU2 290 CONTINUE EX = X*8.0D0 S2 = 0.0D0 DO 320 K=1,NN S1 = S2 S = 1.0D0 AK = 0.0D0 CK = 1.0D0 SQK = 1.0D0 DK = EX DO 300 J=1,30 CK = CK*(FMU-SQK)/DK S = S + CK DK = DK + EX AK = AK + 8.0D0 SQK = SQK + AK if (ABS(CK) < TOL) go to 310 300 CONTINUE 310 S2 = S*COEF FMU = FMU + 8.0D0*DNU + 4.0D0 320 CONTINUE if (NN > 1) go to 170 S1 = S2 go to 200 330 CONTINUE KODED = 2 IFLAG = 1 go to 120 ! ! FNU=HALF ODD INTEGER CASE ! 340 CONTINUE S1 = COEF S2 = COEF go to 170 ! ! 350 call XERMSG ('SLATEC', 'DBSKNU', 'X NOT GREATER THAN ZERO', 2, 1) return 360 call XERMSG ('SLATEC', 'DBSKNU', 'FNU NOT ZERO OR POSITIVE', 2, & 1) return 370 call XERMSG ('SLATEC', 'DBSKNU', 'KODE NOT 1 OR 2', 2, 1) return 380 call XERMSG ('SLATEC', 'DBSKNU', 'N NOT GREATER THAN 0', 2, 1) return end subroutine DBSPDR (T, A, N, K, NDERIV, AD) ! !! DBSPDR uses the B-representation to construct a divided difference table... ! preparatory to a (right) derivative calculation. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE DOUBLE PRECISION (BSPDR-S, DBSPDR-D) !***KEYWORDS B-SPLINE, DATA FITTING, DIFFERENTIATION OF SPLINES, ! INTERPOLATION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract **** a double precision routine **** ! DBSPDR is the BSPLDR routine of the reference. ! ! DBSPDR uses the B-representation (T,A,N,K) to construct a ! divided difference table ADIF preparatory to a (right) ! derivative calculation in DBSPEV. The lower triangular matrix ! ADIF is stored in vector AD by columns. The arrays are ! related by ! ! ADIF(I,J) = AD(I-J+1 + (2*N-J+2)*(J-1)/2) ! ! I = J,N , J=1,NDERIV. ! ! Description of Arguments ! ! Input T,A are double precision ! T - knot vector of length N+K ! A - B-spline coefficient vector of length N ! N - number of B-spline coefficients ! N = sum of knot multiplicities-K ! K - order of the spline, K >= 1 ! NDERIV - number of derivatives, 1 <= NDERIV <= K. ! NDERIV=1 gives the zero-th derivative = ! function value ! ! Output AD is double precision ! AD - table of differences in a vector of length ! (2*N-NDERIV+1)*NDERIV/2 for input to DBSPEV ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBSPDR ! ! INTEGER I, ID, II, IPKMID, JJ, JM, K, KMID, N, NDERIV DOUBLE PRECISION A, AD, DIFF, FKMID, T ! DIMENSION T(N+K), AD((2*N-NDERIV+1)*NDERIV/2) DIMENSION T(*), A(*), AD(*) !***FIRST EXECUTABLE STATEMENT DBSPDR if ( K < 1) go to 100 if ( N < K) go to 105 if ( NDERIV < 1 .OR. NDERIV > K) go to 110 DO 10 I=1,N AD(I) = A(I) 10 CONTINUE if (NDERIV == 1) RETURN KMID = K JJ = N JM = 0 DO 30 ID=2,NDERIV KMID = KMID - 1 FKMID = KMID II = 1 DO 20 I=ID,N IPKMID = I + KMID DIFF = T(IPKMID) - T(I) if (DIFF /= 0.0D0) AD(II+JJ) = (AD(II+JM+1)-AD(II+JM))/ & DIFF*FKMID II = II + 1 20 CONTINUE JM = JJ JJ = JJ + N - ID + 1 30 CONTINUE return ! ! 100 CONTINUE call XERMSG ('SLATEC', 'DBSPDR', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'DBSPDR', 'N DOES NOT SATISFY N >= K', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'DBSPDR', & 'NDERIV DOES NOT SATISFY 1 <= NDERIV <= K', 2, 1) return end subroutine DBSPEV (T, AD, N, K, NDERIV, X, INEV, SVALUE, WORK) ! !! DBSPEV calculates the value of the spline and its derivatives from... ! the B-representation. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE DOUBLE PRECISION (BSPEV-S, DBSPEV-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract **** a double precision routine **** ! DBSPEV is the BSPLEV routine of the reference. ! ! DBSPEV calculates the value of the spline and its derivatives ! at X from the B-representation (T,A,N,K) and returns them in ! SVALUE(I),I=1,NDERIV, T(K) <= X <= T(N+1). AD(I) can be ! the B-spline coefficients A(I), I=1,N) if NDERIV=1. Otherwise ! AD must be computed before hand by a call to DBSPDR (T,A,N,K, ! NDERIV,AD). If X=T(I),I=K,N), right limiting values are ! obtained. ! ! To compute left derivatives or left limiting values at a ! knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1. ! ! DBSPEV calls DINTRV, DBSPVN ! ! Description of Arguments ! ! Input T,AD,X, are double precision ! T - knot vector of length N+K ! AD - vector of length (2*N-NDERIV+1)*NDERIV/2 containing ! the difference table from DBSPDR. ! N - number of B-spline coefficients ! N = sum of knot multiplicities-K ! K - order of the B-spline, K >= 1 ! NDERIV - number of derivatives, 1 <= NDERIV <= K. ! NDERIV=1 gives the zero-th derivative = ! function value ! X - argument, T(K) <= X <= T(N+1) ! INEV - an initialization parameter which must be set ! to 1 the first time DBSPEV is called. ! ! Output SVALUE,WORK are double precision ! INEV - INEV contains information for efficient process- ! ing after the initial call and INEV must not ! be changed by the user. Distinct splines require ! distinct INEV parameters. ! SVALUE - vector of length NDERIV containing the spline ! value in SVALUE(1) and the NDERIV-1 derivatives ! in the remaining components. ! WORK - work vector of length 3*K ! ! Error Conditions ! Improper input is a fatal error. ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED DBSPVN, DINTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBSPEV ! INTEGER I,ID,INEV,IWORK,JJ,K,KP1,KP1MN,L,LEFT,LL,MFLAG, & N, NDERIV DOUBLE PRECISION AD, SVALUE, SUM, T, WORK, X ! DIMENSION T(N+K) DIMENSION T(*), AD(*), SVALUE(*), WORK(*) !***FIRST EXECUTABLE STATEMENT DBSPEV if ( K < 1) go to 100 if ( N < K) go to 105 if ( NDERIV < 1 .OR. NDERIV > K) go to 115 ID = NDERIV call DINTRV(T, N+1, X, INEV, I, MFLAG) if (X < T(K)) go to 110 if (MFLAG == 0) go to 30 if (X > T(I)) go to 110 20 if (I == K) go to 120 I = I - 1 if (X == T(I)) go to 20 ! ! *I* HAS BEEN FOUND IN (K,N) SO THAT T(I) <= X < T(I+1) ! (OR <= T(I+1), if T(I) < T(I+1) = T(N+1) ). 30 KP1MN = K + 1 - ID KP1 = K + 1 call DBSPVN(T, KP1MN, K, 1, X, I, WORK(1),WORK(KP1),IWORK) JJ = (N+N-ID+2)*(ID-1)/2 ! ADIF(LEFTPL,ID) = AD(LEFTPL-ID+1 + (2*N-ID+2)*(ID-1)/2) ! LEFTPL = LEFT + L 40 LEFT = I - KP1MN SUM = 0.0D0 LL = LEFT + JJ + 2 - ID DO 50 L=1,KP1MN SUM = SUM + WORK(L)*AD(LL) LL = LL + 1 50 CONTINUE SVALUE(ID) = SUM ID = ID - 1 if (ID == 0) go to 60 JJ = JJ-(N-ID+1) KP1MN = KP1MN + 1 call DBSPVN(T, KP1MN, K, 2, X, I, WORK(1), WORK(KP1),IWORK) go to 40 ! 60 RETURN ! ! 100 CONTINUE call XERMSG ('SLATEC', 'DBSPEV', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'DBSPEV', 'N DOES NOT SATISFY N >= K', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'DBSPEV', & 'X IS NOT IN T(K) <= X <= T(N+1)', 2, 1) return 115 CONTINUE call XERMSG ('SLATEC', 'DBSPEV', & 'NDERIV DOES NOT SATISFY 1 <= NDERIV <= K', 2, 1) return 120 CONTINUE call XERMSG ('SLATEC', 'DBSPEV', & 'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1) return end subroutine DBSPPP (T, A, N, K, LDC, C, XI, LXI, WORK) ! !! DBSPPP converts the B-representation of a B-spline to the piecewise ... ! polynomial (PP) form. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE DOUBLE PRECISION (BSPPP-S, DBSPPP-D) !***KEYWORDS B-SPLINE, PIECEWISE POLYNOMIAL !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract **** a double precision routine **** ! DBSPPP is the BSPLPP routine of the reference. ! ! DBSPPP converts the B-representation (T,A,N,K) to the ! piecewise polynomial (PP) form (C,XI,LXI,K) for use with ! DPPVAL. Here XI(*), the break point array of length LXI, is ! the knot array T(*) with multiplicities removed. The columns ! of the matrix C(I,J) contain the right Taylor derivatives ! for the polynomial expansion about XI(J) for the intervals ! XI(J) <= X <= XI(J+1), I=1,K, J=1,LXI. Function DPPVAL ! makes this evaluation at a specified point X in ! XI(1) <= X <= XI(LXI+1) ! ! Description of Arguments ! ! Input T,A are double precision ! T - knot vector of length N+K ! A - B-spline coefficient vector of length N ! N - number of B-spline coefficients ! N = sum of knot multiplicities-K ! K - order of the B-spline, K >= 1 ! LDC - leading dimension of C, LDC >= K ! ! Output C,XI,WORK are double precision ! C - matrix of dimension at least (K,LXI) containing ! right derivatives at break points ! XI - XI break point vector of length LXI+1 ! LXI - number of break points, LXI <= N-K+1 ! WORK - work vector of length K*(N+3) ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED DBSPDR, DBSPEV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBSPPP ! INTEGER ILEFT, INEV, K, LDC, LXI, N, NK DOUBLE PRECISION A, C, T, WORK, XI ! DIMENSION T(N+K),XI(LXI+1),C(LDC,*) ! HERE, * = THE FINAL VALUE OF THE OUTPUT PARAMETER LXI. DIMENSION T(*), A(*), WORK(*), XI(*), C(LDC,*) !***FIRST EXECUTABLE STATEMENT DBSPPP if ( K < 1) go to 100 if ( N < K) go to 105 if ( LDC < K) go to 110 call DBSPDR(T, A, N, K, K, WORK) LXI = 0 XI(1) = T(K) INEV = 1 NK = N*K + 1 DO 10 ILEFT=K,N if (T(ILEFT+1) == T(ILEFT)) go to 10 LXI = LXI + 1 XI(LXI+1) = T(ILEFT+1) call DBSPEV(T,WORK(1),N,K, K,XI(LXI),INEV,C(1,LXI),WORK(NK)) 10 CONTINUE return 100 CONTINUE call XERMSG ('SLATEC', 'DBSPPP', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'DBSPPP', 'N DOES NOT SATISFY N >= K', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'DBSPPP', 'LDC DOES NOT SATISFY LDC >= K', & 2, 1) return end subroutine DBSPVD (T, K, NDERIV, X, ILEFT, LDVNIK, VNIKX, WORK) ! !! DBSPVD calculates the value and all derivatives of order less than ... ! NDERIV of all basis functions which do not vanish at X. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE DOUBLE PRECISION (BSPVD-S, DBSPVD-D) !***KEYWORDS DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract **** a double precision routine **** ! ! DBSPVD is the BSPLVD routine of the reference. ! ! DBSPVD calculates the value and all derivatives of order ! less than NDERIV of all basis functions which do not ! (possibly) vanish at X. ILEFT is input such that ! T(ILEFT) <= X < T(ILEFT+1). A call to INTRV(T,N+1,X, ! ILO,ILEFT,MFLAG) will produce the proper ILEFT. The output of ! DBSPVD is a matrix VNIKX(I,J) of dimension at least (K,NDERIV) ! whose columns contain the K nonzero basis functions and ! their NDERIV-1 right derivatives at X, I=1,K, J=1,NDERIV. ! These basis functions have indices ILEFT-K+I, I=1,K, ! K <= ILEFT <= N. The nonzero part of the I-th basis ! function lies in (T(I),T(I+K)), I=1,N). ! ! If X=T(ILEFT+1) then VNIKX contains left limiting values ! (left derivatives) at T(ILEFT+1). In particular, ILEFT = N ! produces left limiting values at the right end point ! X=T(N+1). To obtain left limiting values at T(I), I=K+1,N+1, ! set X= next lower distinct knot, call INTRV to get ILEFT, ! set X=T(I), and then call DBSPVD. ! ! Description of Arguments ! Input T,X are double precision ! T - knot vector of length N+K, where ! N = number of B-spline basis functions ! N = sum of knot multiplicities-K ! K - order of the B-spline, K >= 1 ! NDERIV - number of derivatives = NDERIV-1, ! 1 <= NDERIV <= K ! X - argument of basis functions, ! T(K) <= X <= T(N+1) ! ILEFT - largest integer such that ! T(ILEFT) <= X < T(ILEFT+1) ! LDVNIK - leading dimension of matrix VNIKX ! ! Output VNIKX,WORK are double precision ! VNIKX - matrix of dimension at least (K,NDERIV) contain- ! ing the nonzero basis functions at X and their ! derivatives columnwise. ! WORK - a work vector of length (K+1)*(K+2)/2 ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED DBSPVN, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBSPVD ! INTEGER I,IDERIV,ILEFT,IPKMD,J,JJ,JLOW,JM,JP1MID,K,KMD, KP1, L, & LDUMMY, M, MHIGH, NDERIV DOUBLE PRECISION FACTOR, FKMD, T, V, VNIKX, WORK, X ! DIMENSION T(ILEFT+K), WORK((K+1)*(K+2)/2) ! A(I,J) = WORK(I+J*(J+1)/2), I=1,J+1 J=1,K-1 ! A(I,K) = W0RK(I+K*(K-1)/2) I=1.K ! WORK(1) AND WORK((K+1)*(K+2)/2) ARE NOT USED. DIMENSION T(*), VNIKX(LDVNIK,*), WORK(*) !***FIRST EXECUTABLE STATEMENT DBSPVD if ( K < 1) go to 200 if ( NDERIV < 1 .OR. NDERIV > K) go to 205 if ( LDVNIK < K) go to 210 IDERIV = NDERIV KP1 = K + 1 JJ = KP1 - IDERIV call DBSPVN(T, JJ, K, 1, X, ILEFT, VNIKX, WORK, IWORK) if (IDERIV == 1) go to 100 MHIGH = IDERIV DO 20 M=2,MHIGH JP1MID = 1 DO 10 J=IDERIV,K VNIKX(J,IDERIV) = VNIKX(JP1MID,1) JP1MID = JP1MID + 1 10 CONTINUE IDERIV = IDERIV - 1 JJ = KP1 - IDERIV call DBSPVN(T, JJ, K, 2, X, ILEFT, VNIKX, WORK, IWORK) 20 CONTINUE ! JM = KP1*(KP1+1)/2 DO 30 L = 1,JM WORK(L) = 0.0D0 30 CONTINUE ! A(I,I) = WORK(I*(I+3)/2) = 1.0 I = 1,K L = 2 J = 0 DO 40 I = 1,K J = J + L WORK(J) = 1.0D0 L = L + 1 40 CONTINUE KMD = K DO 90 M=2,MHIGH KMD = KMD - 1 FKMD = KMD I = ILEFT J = K JJ = J*(J+1)/2 JM = JJ - J DO 60 LDUMMY=1,KMD IPKMD = I + KMD FACTOR = FKMD/(T(IPKMD)-T(I)) DO 50 L=1,J WORK(L+JJ) = (WORK(L+JJ)-WORK(L+JM))*FACTOR 50 CONTINUE I = I - 1 J = J - 1 JJ = JM JM = JM - J 60 CONTINUE ! DO 80 I=1,K V = 0.0D0 JLOW = MAX(I,M) JJ = JLOW*(JLOW+1)/2 DO 70 J=JLOW,K V = WORK(I+JJ)*VNIKX(J,M) + V JJ = JJ + J + 1 70 CONTINUE VNIKX(I,M) = V 80 CONTINUE 90 CONTINUE 100 RETURN ! ! 200 CONTINUE call XERMSG ('SLATEC', 'DBSPVD', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 205 CONTINUE call XERMSG ('SLATEC', 'DBSPVD', & 'NDERIV DOES NOT SATISFY 1 <= NDERIV <= K', 2, 1) return 210 CONTINUE call XERMSG ('SLATEC', 'DBSPVD', & 'LDVNIK DOES NOT SATISFY LDVNIK >= K', 2, 1) return end subroutine DBSPVN (T, JHIGH, K, INDEX, X, ILEFT, VNIKX, WORK, & IWORK) ! !! DBSPVN calculates the value of all (possibly) nonzero basis functions at X. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE DOUBLE PRECISION (BSPVN-S, DBSPVN-D) !***KEYWORDS EVALUATION OF B-SPLINE !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract **** a double precision routine **** ! DBSPVN is the BSPLVN routine of the reference. ! ! DBSPVN calculates the value of all (possibly) nonzero basis ! functions at X of order MAX(JHIGH,(J+1)*(INDEX-1)), where T(K) ! <= X <= T(N+1) and J=IWORK is set inside the routine on ! the first call when INDEX=1. ILEFT is such that T(ILEFT) <= ! X < T(ILEFT+1). A call to DINTRV(T,N+1,X,ILO,ILEFT,MFLAG) ! produces the proper ILEFT. DBSPVN calculates using the basic ! algorithm needed in DBSPVD. If only basis functions are ! desired, setting JHIGH=K and INDEX=1 can be faster than ! calling DBSPVD, but extra coding is required for derivatives ! (INDEX=2) and DBSPVD is set up for this purpose. ! ! Left limiting values are set up as described in DBSPVD. ! ! Description of Arguments ! ! Input T,X are double precision ! T - knot vector of length N+K, where ! N = number of B-spline basis functions ! N = sum of knot multiplicities-K ! JHIGH - order of B-spline, 1 <= JHIGH <= K ! K - highest possible order ! INDEX - INDEX = 1 gives basis functions of order JHIGH ! = 2 denotes previous entry with work, IWORK ! values saved for subsequent calls to ! DBSPVN. ! X - argument of basis functions, ! T(K) <= X <= T(N+1) ! ILEFT - largest integer such that ! T(ILEFT) <= X < T(ILEFT+1) ! ! Output VNIKX, WORK are double precision ! VNIKX - vector of length K for spline values. ! WORK - a work vector of length 2*K ! IWORK - a work parameter. Both WORK and IWORK contain ! information necessary to continue for INDEX = 2. ! When INDEX = 1 exclusively, these are scratch ! variables and can be used for other purposes. ! ! Error Conditions ! Improper input is a fatal error. ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBSPVN ! INTEGER ILEFT, IMJP1, INDEX, IPJ, IWORK, JHIGH, JP1, JP1ML, K, L DOUBLE PRECISION T, VM, VMPREV, VNIKX, WORK, X ! DIMENSION T(ILEFT+JHIGH) DIMENSION T(*), VNIKX(*), WORK(*) ! CONTENT OF J, DELTAM, DELTAP IS EXPECTED UNCHANGED BETWEEN CALLS. ! WORK(I) = DELTAP(I), WORK(K+I) = DELTAM(I), I = 1,K !***FIRST EXECUTABLE STATEMENT DBSPVN if ( K < 1) go to 90 if ( JHIGH > K .OR. JHIGH < 1) go to 100 if ( INDEX < 1 .OR. INDEX > 2) go to 105 if ( X < T(ILEFT) .OR. X > T(ILEFT+1)) go to 110 go to (10, 20), INDEX 10 IWORK = 1 VNIKX(1) = 1.0D0 if (IWORK >= JHIGH) go to 40 ! 20 IPJ = ILEFT + IWORK WORK(IWORK) = T(IPJ) - X IMJP1 = ILEFT - IWORK + 1 WORK(K+IWORK) = X - T(IMJP1) VMPREV = 0.0D0 JP1 = IWORK + 1 DO 30 L=1,IWORK JP1ML = JP1 - L VM = VNIKX(L)/(WORK(L)+WORK(K+JP1ML)) VNIKX(L) = VM*WORK(L) + VMPREV VMPREV = VM*WORK(K+JP1ML) 30 CONTINUE VNIKX(JP1) = VMPREV IWORK = JP1 if (IWORK < JHIGH) go to 20 ! 40 RETURN ! ! 90 CONTINUE call XERMSG ('SLATEC', 'DBSPVN', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 100 CONTINUE call XERMSG ('SLATEC', 'DBSPVN', & 'JHIGH DOES NOT SATISFY 1 <= JHIGH <= K', 2, 1) return 105 CONTINUE call XERMSG ('SLATEC', 'DBSPVN', 'INDEX IS NOT 1 OR 2', 2, 1) return 110 CONTINUE call XERMSG ('SLATEC', 'DBSPVN', & 'X DOES NOT SATISFY T(ILEFT) <= X <= T(ILEFT+1)', 2, 1) return end subroutine DBSQAD (T, BCOEF, N, K, X1, X2, BQUAD, WORK) ! !! DBSQAD computes the integral of a K-th order B-spline using the ... ! B-representation. ! !***LIBRARY SLATEC !***CATEGORY H2A2A1, E3, K6 !***TYPE DOUBLE PRECISION (BSQAD-S, DBSQAD-D) !***KEYWORDS INTEGRAL OF B-SPLINES, QUADRATURE !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract **** a double precision routine **** ! ! DBSQAD computes the integral on (X1,X2) of a K-th order ! B-spline using the B-representation (T,BCOEF,N,K). Orders ! K as high as 20 are permitted by applying a 2, 6, or 10 ! point Gauss formula on subintervals of (X1,X2) which are ! formed by included (distinct) knots. ! ! If orders K greater than 20 are needed, use DBFQAD with ! F(X) = 1. ! ! The maximum number of significant digits obtainable in ! DBSQAD is the smaller of 18 and the number of digits ! carried in double precision arithmetic. ! ! Description of Arguments ! Input T,BCOEF,X1,X2 are double precision ! T - knot array of length N+K ! BCOEF - B-spline coefficient array of length N ! N - length of coefficient array ! K - order of B-spline, 1 <= K <= 20 ! X1,X2 - end points of quadrature interval in ! T(K) <= X <= T(N+1) ! ! Output BQUAD,WORK are double precision ! BQUAD - integral of the B-spline over (X1,X2) ! WORK - work vector of length 3*K ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES D. E. Amos, Quadrature subroutines for splines and ! B-splines, Report SAND79-1825, Sandia Laboratories, ! December 1979. !***ROUTINES CALLED DBVALU, DINTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBSQAD ! INTEGER I,IL1,IL2,ILO,INBV, JF,K,LEFT,M,MF,MFLAG,N, NPK, NP1 DOUBLE PRECISION A,AA,B,BB,BCOEF,BMA,BPA,BQUAD,C1,GPTS,GWTS,GX,Q, & SUM, T, TA, TB, WORK, X1, X2, Y1, Y2 DOUBLE PRECISION DBVALU DIMENSION T(*), BCOEF(*), GPTS(9), GWTS(9), SUM(5), WORK(*) ! SAVE GPTS, GWTS DATA GPTS(1), GPTS(2), GPTS(3), GPTS(4), GPTS(5), GPTS(6), & GPTS(7), GPTS(8), GPTS(9)/ & 5.77350269189625764D-01, 2.38619186083196909D-01, & 6.61209386466264514D-01, 9.32469514203152028D-01, & 1.48874338981631211D-01, 4.33395394129247191D-01, & 6.79409568299024406D-01, 8.65063366688984511D-01, & 9.73906528517171720D-01/ DATA GWTS(1), GWTS(2), GWTS(3), GWTS(4), GWTS(5), GWTS(6), & GWTS(7), GWTS(8), GWTS(9)/ & 1.00000000000000000D+00, 4.67913934572691047D-01, & 3.60761573048138608D-01, 1.71324492379170345D-01, & 2.95524224714752870D-01, 2.69266719309996355D-01, & 2.19086362515982044D-01, 1.49451349150580593D-01, & 6.66713443086881376D-02/ ! !***FIRST EXECUTABLE STATEMENT DBSQAD BQUAD = 0.0D0 if ( K < 1 .OR. K > 20) go to 65 if ( N < K) go to 70 AA = MIN(X1,X2) BB = MAX(X1,X2) if (AA < T(K)) go to 60 NP1 = N + 1 if (BB > T(NP1)) go to 60 if (AA == BB) RETURN NPK = N + K ! SELECTION OF 2, 6, OR 10 POINT GAUSS FORMULA JF = 0 MF = 1 if (K <= 4) go to 10 JF = 1 MF = 3 if (K <= 12) go to 10 JF = 4 MF = 5 10 CONTINUE ! DO 20 I=1,MF SUM(I) = 0.0D0 20 CONTINUE ILO = 1 INBV = 1 call DINTRV(T, NPK, AA, ILO, IL1, MFLAG) call DINTRV(T, NPK, BB, ILO, IL2, MFLAG) if (IL2 >= NP1) IL2 = N DO 40 LEFT=IL1,IL2 TA = T(LEFT) TB = T(LEFT+1) if (TA == TB) go to 40 A = MAX(AA,TA) B = MIN(BB,TB) BMA = 0.5D0*(B-A) BPA = 0.5D0*(B+A) DO 30 M=1,MF C1 = BMA*GPTS(JF+M) GX = -C1 + BPA Y2 = DBVALU(T,BCOEF,N,K,0,GX,INBV,WORK) GX = C1 + BPA Y1 = DBVALU(T,BCOEF,N,K,0,GX,INBV,WORK) SUM(M) = SUM(M) + (Y1+Y2)*BMA 30 CONTINUE 40 CONTINUE Q = 0.0D0 DO 50 M=1,MF Q = Q + GWTS(JF+M)*SUM(M) 50 CONTINUE if (X1 > X2) Q = -Q BQUAD = Q return ! ! 60 CONTINUE call XERMSG ('SLATEC', 'DBSQAD', & 'X1 OR X2 OR BOTH DO NOT SATISFY T(K) <= X <= T(N+1)', 2, 1) return 65 CONTINUE call XERMSG ('SLATEC', 'DBSQAD', & 'K DOES NOT SATISFY 1 <= K <= 20', 2, 1) return 70 CONTINUE call XERMSG ('SLATEC', 'DBSQAD', 'N DOES NOT SATISFY N >= K', 2, & 1) return end subroutine DBSYNU (X, FNU, N, Y) ! !! DBSYNU is subsidiary to DBESY. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BESYNU-S, DBSYNU-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract **** A DOUBLE PRECISION routine **** ! DBSYNU computes N member sequences of Y Bessel functions ! Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and ! positive X. Equations of the references are implemented on ! small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X). ! Forward recursion with the three term recursion relation ! generates higher orders FNU+I-1, I=1,...,N. ! ! To start the recursion FNU is normalized to the interval ! -0.5 <= DNU < 0.5. A special form of the power series is ! implemented on 0 < X <= X1 while the Miller algorithm for the ! K Bessel function in terms of the confluent hypergeometric ! function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1 < X <= X ! Here I is the complex number SQRT(-1.). ! For X > X2, the asymptotic expansion for large X is used. ! When FNU is a half odd integer, a special formula for ! DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. ! ! The maximum number of significant digits obtainable ! is the smaller of 14 and the number of digits carried in ! DOUBLE PRECISION arithmetic. ! ! DBSYNU assumes that a significant digit SINH function is ! available. ! ! Description of Arguments ! ! INPUT ! X - X > 0.0D0 ! FNU - Order of initial Y function, FNU >= 0.0D0 ! N - Number of members of the sequence, N >= 1 ! ! OUTPUT ! Y - A vector whose first N components contain values ! for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N. ! ! Error Conditions ! Improper input arguments - a fatal error ! Overflow - a fatal error ! !***SEE ALSO DBESY !***REFERENCES N. M. Temme, On the numerical evaluation of the ordinary ! Bessel function of the second kind, Journal of ! Computational Physics 21, (1976), pp. 343-350. ! N. M. Temme, On the numerical evaluation of the modified ! Bessel function of the third kind, Journal of ! Computational Physics 19, (1975), pp. 324-337. !***ROUTINES CALLED D1MACH, DGAMMA, XERMSG !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) ! 900727 Added EXTERNAL statement. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBSYNU ! INTEGER I, INU, J, K, KK, N, NN DOUBLE PRECISION A,AK,ARG,A1,A2,BK,CB,CBK,CC,CCK,CK,COEF,CPT, & CP1, CP2, CS, CS1, CS2, CX, DNU, DNU2, ETEST, ETX, F, FC, FHS, & FK, FKS, FLRX, FMU, FN, FNU, FX, G, G1, G2, HPI, P, PI, PT, Q, & RB, RBK, RCK, RELB, RPT, RP1, RP2, RS, RS1, RS2, RTHPI, RX, S, & SA, SB, SMU, SS, ST, S1, S2, TB, TM, TOL, T1, T2, X, X1, X2, Y DIMENSION A(120), RB(120), CB(120), Y(*), CC(8) DOUBLE PRECISION DGAMMA, D1MACH EXTERNAL DGAMMA SAVE X1, X2,PI, RTHPI, HPI, CC DATA X1, X2 / 3.0D0, 20.0D0 / DATA PI,RTHPI / 3.14159265358979D+00, 7.97884560802865D-01/ DATA HPI / 1.57079632679490D+00/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) & / 5.77215664901533D-01,-4.20026350340952D-02, & -4.21977345555443D-02, 7.21894324666300D-03,-2.15241674114900D-04, & -2.01348547807000D-05, 1.13302723200000D-06, 6.11609500000000D-09/ !***FIRST EXECUTABLE STATEMENT DBSYNU AK = D1MACH(3) TOL = MAX(AK,1.0D-15) if (X <= 0.0D0) go to 270 if (FNU < 0.0D0) go to 280 if (N < 1) go to 290 RX = 2.0D0/X INU = INT(FNU+0.5D0) DNU = FNU - INU if (ABS(DNU) == 0.5D0) go to 260 DNU2 = 0.0D0 if (ABS(DNU) < TOL) go to 10 DNU2 = DNU*DNU 10 CONTINUE if (X > X1) go to 120 ! ! SERIES FOR X <= X1 ! A1 = 1.0D0 - DNU A2 = 1.0D0 + DNU T1 = 1.0D0/DGAMMA(A1) T2 = 1.0D0/DGAMMA(A2) if (ABS(DNU) > 0.1D0) go to 40 ! SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) S = CC(1) AK = 1.0D0 DO 20 K=2,8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM if (ABS(TM) < TOL) go to 30 20 CONTINUE 30 G1 = -(S+S) go to 50 40 CONTINUE G1 = (T1-T2)/DNU 50 CONTINUE G2 = T1 + T2 SMU = 1.0D0 FC = 1.0D0/PI FLRX = LOG(RX) FMU = DNU*FLRX TM = 0.0D0 if (DNU == 0.0D0) go to 60 TM = SIN(DNU*HPI)/DNU TM = (DNU+DNU)*TM*TM FC = DNU/SIN(DNU*PI) if (FMU /= 0.0D0) SMU = SINH(FMU)/FMU 60 CONTINUE F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) FX = EXP(FMU) P = FC*T1*FX Q = FC*T2/FX G = F + TM*Q AK = 1.0D0 CK = 1.0D0 BK = 1.0D0 S1 = G S2 = P if (INU > 0 .OR. N > 1) go to 90 if (X < TOL) go to 80 CX = X*X*0.25D0 70 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) G = F + TM*Q CK = -CK*CX/AK T1 = CK*G S1 = S1 + T1 BK = BK + AK + AK + 1.0D0 AK = AK + 1.0D0 S = ABS(T1)/(1.0D0+ABS(S1)) if (S > TOL) go to 70 80 CONTINUE Y(1) = -S1 return 90 CONTINUE if (X < TOL) go to 110 CX = X*X*0.25D0 100 CONTINUE F = (AK*F+P+Q)/(BK-DNU2) P = P/(AK-DNU) Q = Q/(AK+DNU) G = F + TM*Q CK = -CK*CX/AK T1 = CK*G S1 = S1 + T1 T2 = CK*(P-AK*G) S2 = S2 + T2 BK = BK + AK + AK + 1.0D0 AK = AK + 1.0D0 S = ABS(T1)/(1.0D0+ABS(S1)) + ABS(T2)/(1.0D0+ABS(S2)) if (S > TOL) go to 100 110 CONTINUE S2 = -S2*RX S1 = -S1 go to 160 120 CONTINUE COEF = RTHPI/SQRT(X) if (X > X2) go to 210 ! ! MILLER ALGORITHM FOR X1 < X <= X2 ! ETEST = COS(PI*DNU)/(PI*X*TOL) FKS = 1.0D0 FHS = 0.25D0 FK = 0.0D0 RCK = 2.0D0 CCK = X + X RP1 = 0.0D0 CP1 = 0.0D0 RP2 = 1.0D0 CP2 = 0.0D0 K = 0 130 CONTINUE K = K + 1 FK = FK + 1.0D0 AK = (FHS-DNU2)/(FKS+FK) PT = FK + 1.0D0 RBK = RCK/PT CBK = CCK/PT RPT = RP2 CPT = CP2 RP2 = RBK*RPT - CBK*CPT - AK*RP1 CP2 = CBK*RPT + RBK*CPT - AK*CP1 RP1 = RPT CP1 = CPT RB(K) = RBK CB(K) = CBK A(K) = AK RCK = RCK + 2.0D0 FKS = FKS + FK + FK + 1.0D0 FHS = FHS + FK + FK PT = MAX(ABS(RP1),ABS(CP1)) FC = (RP1/PT)**2 + (CP1/PT)**2 PT = PT*SQRT(FC)*FK if (ETEST > PT) go to 130 KK = K RS = 1.0D0 CS = 0.0D0 RP1 = 0.0D0 CP1 = 0.0D0 RP2 = 1.0D0 CP2 = 0.0D0 DO 140 I=1,K RPT = RP2 CPT = CP2 RP2 = (RB(KK)*RPT-CB(KK)*CPT-RP1)/A(KK) CP2 = (CB(KK)*RPT+RB(KK)*CPT-CP1)/A(KK) RP1 = RPT CP1 = CPT RS = RS + RP2 CS = CS + CP2 KK = KK - 1 140 CONTINUE PT = MAX(ABS(RS),ABS(CS)) FC = (RS/PT)**2 + (CS/PT)**2 PT = PT*SQRT(FC) RS1 = (RP2*(RS/PT)+CP2*(CS/PT))/PT CS1 = (CP2*(RS/PT)-RP2*(CS/PT))/PT FC = HPI*(DNU-0.5D0) - X P = COS(FC) Q = SIN(FC) S1 = (CS1*Q-RS1*P)*COEF if (INU > 0 .OR. N > 1) go to 150 Y(1) = S1 return 150 CONTINUE PT = MAX(ABS(RP2),ABS(CP2)) FC = (RP2/PT)**2 + (CP2/PT)**2 PT = PT*SQRT(FC) RPT = DNU + 0.5D0 - (RP1*(RP2/PT)+CP1*(CP2/PT))/PT CPT = X - (CP1*(RP2/PT)-RP1*(CP2/PT))/PT CS2 = CS1*CPT - RS1*RPT RS2 = RPT*CS1 + RS1*CPT S2 = (RS2*Q+CS2*P)*COEF/X ! ! FORWARD RECURSION ON THE THREE TERM RECURSION RELATION ! 160 CONTINUE CK = (DNU+DNU+2.0D0)/X if (N == 1) INU = INU - 1 if (INU > 0) go to 170 if (N > 1) go to 190 S1 = S2 go to 190 170 CONTINUE DO 180 I=1,INU ST = S2 S2 = CK*S2 - S1 S1 = ST CK = CK + RX 180 CONTINUE if (N == 1) S1 = S2 190 CONTINUE Y(1) = S1 if (N == 1) RETURN Y(2) = S2 if (N == 2) RETURN DO 200 I=3,N Y(I) = CK*Y(I-1) - Y(I-2) CK = CK + RX 200 CONTINUE return ! ! ASYMPTOTIC EXPANSION FOR LARGE X, X > X2 ! 210 CONTINUE NN = 2 if (INU == 0 .AND. N == 1) NN = 1 DNU2 = DNU + DNU FMU = 0.0D0 if (ABS(DNU2) < TOL) go to 220 FMU = DNU2*DNU2 220 CONTINUE ARG = X - HPI*(DNU+0.5D0) SA = SIN(ARG) SB = COS(ARG) ETX = 8.0D0*X DO 250 K=1,NN S1 = S2 T2 = (FMU-1.0D0)/ETX SS = T2 RELB = TOL*ABS(T2) T1 = ETX S = 1.0D0 FN = 1.0D0 AK = 0.0D0 DO 230 J=1,13 T1 = T1 + ETX AK = AK + 8.0D0 FN = FN + AK T2 = -T2*(FMU-FN)/T1 S = S + T2 T1 = T1 + ETX AK = AK + 8.0D0 FN = FN + AK T2 = T2*(FMU-FN)/T1 SS = SS + T2 if (ABS(T2) <= RELB) go to 240 230 CONTINUE 240 S2 = COEF*(S*SA+SS*SB) FMU = FMU + 8.0D0*DNU + 4.0D0 TB = SA SA = -SB SB = TB 250 CONTINUE if (NN > 1) go to 160 S1 = S2 go to 190 ! ! FNU=HALF ODD INTEGER CASE ! 260 CONTINUE COEF = RTHPI/SQRT(X) S1 = COEF*SIN(X) S2 = -COEF*COS(X) go to 160 ! ! 270 call XERMSG ('SLATEC', 'DBSYNU', 'X NOT GREATER THAN ZERO', 2, 1) return 280 call XERMSG ('SLATEC', 'DBSYNU', 'FNU NOT ZERO OR POSITIVE', 2, & 1) return 290 call XERMSG ('SLATEC', 'DBSYNU', 'N NOT GREATER THAN 0', 2, 1) return end DOUBLE PRECISION FUNCTION DBVALU (T, A, N, K, IDERIV, X, INBV, & WORK) ! !! DBVALU evaluates the B-representation of a B-spline at X for the ... ! function value or any of its derivatives. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE DOUBLE PRECISION (BVALU-S, DBVALU-D) !***KEYWORDS DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract **** a double precision routine **** ! DBVALU is the BVALUE function of the reference. ! ! DBVALU evaluates the B-representation (T,A,N,K) of a B-spline ! at X for the function value on IDERIV=0 or any of its ! derivatives on IDERIV=1,2,...,K-1. Right limiting values ! (right derivatives) are returned except at the right end ! point X=T(N+1) where left limiting values are computed. The ! spline is defined on T(K) <= X <= T(N+1). DBVALU returns ! a fatal error message when X is outside of this interval. ! ! To compute left derivatives or left limiting values at a ! knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1. ! ! DBVALU calls DINTRV ! ! Description of Arguments ! ! Input T,A,X are double precision ! T - knot vector of length N+K ! A - B-spline coefficient vector of length N ! N - number of B-spline coefficients ! N = sum of knot multiplicities-K ! K - order of the B-spline, K >= 1 ! IDERIV - order of the derivative, 0 <= IDERIV <= K-1 ! IDERIV = 0 returns the B-spline value ! X - argument, T(K) <= X <= T(N+1) ! INBV - an initialization parameter which must be set ! to 1 the first time DBVALU is called. ! ! Output WORK,DBVALU are double precision ! INBV - INBV contains information for efficient process- ! ing after the initial call and INBV must not ! be changed by the user. Distinct splines require ! distinct INBV parameters. ! WORK - work vector of length 3*K. ! DBVALU - value of the IDERIV-th derivative at X ! ! Error Conditions ! An improper input is a fatal error ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED DINTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBVALU ! INTEGER I,IDERIV,IDERP1,IHI,IHMKMJ,ILO,IMK,IMKPJ, INBV, IPJ, & IP1, IP1MJ, J, JJ, J1, J2, K, KMIDER, KMJ, KM1, KPK, MFLAG, N DOUBLE PRECISION A, FKMJ, T, WORK, X DIMENSION T(*), A(*), WORK(*) !***FIRST EXECUTABLE STATEMENT DBVALU DBVALU = 0.0D0 if ( K < 1) go to 102 if ( N < K) go to 101 if ( IDERIV < 0 .OR. IDERIV >= K) go to 110 KMIDER = K - IDERIV ! ! *** FIND *I* IN (K,N) SUCH THAT T(I) <= X < T(I+1) ! (OR, <= T(I+1) if T(I) < T(I+1) = T(N+1)). KM1 = K - 1 call DINTRV(T, N+1, X, INBV, I, MFLAG) if (X < T(K)) go to 120 if (MFLAG == 0) go to 20 if (X > T(I)) go to 130 10 if (I == K) go to 140 I = I - 1 if (X == T(I)) go to 10 ! ! *** DIFFERENCE THE COEFFICIENTS *IDERIV* TIMES ! WORK(I) = AJ(I), WORK(K+I) = DP(I), WORK(K+K+I) = DM(I), I=1.K ! 20 IMK = I - K DO 30 J=1,K IMKPJ = IMK + J WORK(J) = A(IMKPJ) 30 CONTINUE if (IDERIV == 0) go to 60 DO 50 J=1,IDERIV KMJ = K - J FKMJ = KMJ DO 40 JJ=1,KMJ IHI = I + JJ IHMKMJ = IHI - KMJ WORK(JJ) = (WORK(JJ+1)-WORK(JJ))/(T(IHI)-T(IHMKMJ))*FKMJ 40 CONTINUE 50 CONTINUE ! ! *** COMPUTE VALUE AT *X* IN (T(I),(T(I+1)) OF IDERIV-TH DERIVATIVE, ! GIVEN ITS RELEVANT B-SPLINE COEFF. IN AJ(1),...,AJ(K-IDERIV). 60 if (IDERIV == KM1) go to 100 IP1 = I + 1 KPK = K + K J1 = K + 1 J2 = KPK + 1 DO 70 J=1,KMIDER IPJ = I + J WORK(J1) = T(IPJ) - X IP1MJ = IP1 - J WORK(J2) = X - T(IP1MJ) J1 = J1 + 1 J2 = J2 + 1 70 CONTINUE IDERP1 = IDERIV + 1 DO 90 J=IDERP1,KM1 KMJ = K - J ILO = KMJ DO 80 JJ=1,KMJ WORK(JJ) = (WORK(JJ+1)*WORK(KPK+ILO)+WORK(JJ) & *WORK(K+JJ))/(WORK(KPK+ILO)+WORK(K+JJ)) ILO = ILO - 1 80 CONTINUE 90 CONTINUE 100 DBVALU = WORK(1) return ! ! 101 CONTINUE call XERMSG ('SLATEC', 'DBVALU', 'N DOES NOT SATISFY N >= K', 2, & 1) return 102 CONTINUE call XERMSG ('SLATEC', 'DBVALU', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 110 CONTINUE call XERMSG ('SLATEC', 'DBVALU', & 'IDERIV DOES NOT SATISFY 0 <= IDERIV < K', 2, 1) return 120 CONTINUE call XERMSG ('SLATEC', 'DBVALU', & 'X IS N0T GREATER THAN OR EQUAL TO T(K)', 2, 1) return 130 CONTINUE call XERMSG ('SLATEC', 'DBVALU', & 'X IS NOT LESS THAN OR EQUAL TO T(N+1)', 2, 1) return 140 CONTINUE call XERMSG ('SLATEC', 'DBVALU', & 'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1) return end subroutine DBVDER (X, Y, YP, G, IPAR, dfmat, dgvec, duivp, duvec ) ! !! DBVDER is subsidiary to DBVSUP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BVDER-S, DBVDER-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! NFC = Number of base solution vectors ! ! NCOMP = Number of components per solution vector ! ! 1 -- Nonzero particular solution ! INHOMO = ! 2 or 3 -- Zero particular solution ! ! 0 -- Inhomogeneous vector term G(X) identically zero ! IGOFX = ! 1 -- Inhomogeneous vector term G(X) not identically zero ! ! G = Inhomogeneous vector term G(X) ! ! XSAV = Previous value of X ! ! C = Normalization factor for the particular solution ! ! 0 ( if NEQIVP = 0 ) ! IVP = ! Number of differential equations integrated due to ! the original boundary value problem ( if NEQIVP > 0 ) ! ! NOFST - For problems with auxiliary initial value equations, ! NOFST communicates to the routine DFMAT how to access ! the dependent variables corresponding to this initial ! value problem. For example, during any call to DFMAT, ! the first dependent variable for the initial value ! problem is in position Y(NOFST + 1). ! See example in SAND77-1328. ! ********************************************************************** ! !***SEE ALSO DBVSUP !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DML8SZ, DMLIVP !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910701 Corrected ROUTINES CALLED section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920618 Minor restructuring of code. (RWC, WRB) !***END PROLOGUE DBVDER ! external duivp external dfmat external dgvec external duvec INTEGER IGOFX, INHOMO, IPAR, IVP, J, K, L, NA, NCOMP, NFC, NOFST DOUBLE PRECISION C, G(*), X, XSAV, Y(*), YP(*) ! ! ********************************************************************** ! COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC ! ! ********************************************************************** ! The COMMON block below is used to communicate with the user ! supplied subroutine DFMAT. The user should not alter this ! COMMON block. ! COMMON /DMLIVP/ NOFST ! ********************************************************************** ! !***FIRST EXECUTABLE STATEMENT DBVDER if (IVP > 0) call DUIVP(X,Y(IVP+1),YP(IVP+1)) NOFST = IVP NA = 1 DO 10 K=1,NFC call DFMAT(X,Y(NA),YP(NA)) NOFST = NOFST - NCOMP NA = NA + NCOMP 10 CONTINUE ! if (INHOMO /= 1) RETURN call DFMAT(X,Y(NA),YP(NA)) ! if (IGOFX == 0) RETURN if (X /= XSAV) THEN if (IVP == 0) call DGVEC(X,G) if (IVP > 0) call DUVEC(X,Y(IVP+1),G) XSAV = X end if ! ! If the user has chosen not to normalize the particular ! solution, then C is defined in DBVPOR to be 1.0 ! ! The following loop is just ! call DAXPY (NCOMP, 1.0D0/C, G, 1, YP(NA), 1) ! DO 20 J=1,NCOMP L = NA + J - 1 YP(L) = YP(L) + G(J)/C 20 CONTINUE return end subroutine DBVPOR (Y, NROWY, NCOMP, XPTS, NXPTS, A, NROWA, ALPHA, & NIC, B, NROWB, BETA, NFC, IFLAG, Z, MXNON, P, NTP, IP, W, NIV, & YHP, U, V, COEF, S, STOWA, G, WORK, IWORK, NFCC) ! !! DBVPOR is subsidiary to DBVSUP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BVPOR-S, DBVPOR-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! INPUT to DBVPOR (items not defined in DBVSUP comments) ! ********************************************************************** ! ! NOPG = 0 -- orthonormalization points not pre-assigned ! = 1 -- orthonormalization points pre-assigned ! ! MXNON = maximum number of orthogonalizations allowed. ! ! NDISK = 0 -- in-core storage ! = 1 -- disk storage. Value of NTAPE in data statement ! is set to 13. If another value is desired, ! the data statement must be changed. ! ! INTEG = type of integrator and associated test to be used ! to determine when to orthonormalize. ! ! 1 -- use GRAM-SCHMIDT test and DDERKF ! 2 -- use GRAM-SCHMIDT test and DDEABM ! ! TOL = tolerance for allowable error in orthogonalization test. ! ! NPS = 0 normalize particular solution to unit length at each ! point of orthonormalization. ! = 1 do not normalize particular solution. ! ! NTP = must be >= NFC*(NFC+1)/2. ! ! NFCC = 2*NFC for special treatment of a COMPLEX*16 valued problem ! ! ICOCO = 0 skip final computations (superposition coefficients ! and, hence, boundary problem solution) ! = 1 calculate superposition coefficients and obtain ! solution to the boundary value problem ! ! ********************************************************************** ! OUTPUT from DBVPOR ! ********************************************************************** ! ! Y(NROWY,NXPTS) = solution at specified output points. ! ! MXNON = number of orthonormalizations performed by DBVPOR. ! ! Z(MXNON+1) = locations of orthonormalizations performed by DBVPOR. ! ! NIV = number of independent vectors returned from DMGSBV. Normally ! this parameter will be meaningful only when DMGSBV returns ! with MFLAG = 2. ! ! ********************************************************************** ! ! The following variables are in the argument list because of ! variable dimensioning. In general, they contain no information of ! use to the user. The amount of storage set aside by the user must ! be greater than or equal to that indicated by the dimension ! statements. For the disk storage mode, NON = 0 and KPTS = 1, ! while for the in-core storage mode, NON = MXNON and KPTS = NXPTS. ! ! P(NTP,NON+1) ! IP(NFCC,NON+1) ! YHP(NCOMP,NFC+1) plus an additional column of the length NEQIVP ! U(NCOMP,NFC,KPTS) ! V(NCOMP,KPTS) ! W(NFCC,NON+1) ! COEF(NFCC) ! S(NFC+1) ! STOWA(NCOMP*(NFC+1)+NEQIVP+1) ! G(NCOMP) ! WORK(KKKWS) ! IWORK(LLLIWS) ! ! ********************************************************************** ! SUBROUTINES used by DBVPOR ! DLSSUD -- solves an underdetermined system of linear ! equations. This routine is used to get a full ! set of initial conditions for integration. ! Called by DBVPOR. ! ! DVECS -- obtains starting vectors for special treatment ! of COMPLEX*16 valued problems, called by DBVPOR. ! ! DRKFAB -- routine which conducts integration using DDERKF or ! DDEABM. ! ! DSTWAY -- storage for backup capability, called by ! DBVPOR and DREORT. ! ! DSTOR1 -- storage at output points, called by DBVPOR, ! DRKFAB, DREORT and DSTWAY. ! ! DDOT -- single precision vector inner product routine, ! called by DBVPOR, DCOEF, DLSSUD, DMGSBV, ! DBKSOL, DREORT and DPRVEC. ! ** NOTE ** ! a considerable improvement in speed can be achieved if a ! machine language version is used for DDOT. ! ! DCOEF -- computes the superposition constants from the ! boundary conditions at XFINAL. ! ! DBKSOL -- solves an upper triangular set of linear equations. ! ! ********************************************************************** ! !***SEE ALSO DBVSUP !***ROUTINES CALLED DBKSOL, DCOEF, DDOT, DLSSUD, DRKFAB, DSTOR1, ! DSTWAY, DVECS !***COMMON BLOCKS DML15T, DML18J, DML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DBVPOR ! DOUBLE PRECISION DDOT INTEGER I, I1, I2, IC, ICOCO, IFLAG, IGOFX, INDPVT, INFO, INHOMO, & INTEG, IRA, ISFLG, ISTKOP, IVP, J, & K, KNSWOT, KOD, KOP, KPTS, KWC, KWD, KWS, KWT, L, LOTJP, M, & MNSWOT, MXNON, MXNOND, N, NCOMP, NCOMP2, NCOMPD, NDISK, NDW, & NEQ, NEQIVP, NFC, NFCC, NFCCD, NFCD, NFCP1, NFCP2, NIC, & NICD, NIV, NN, NON, NOPG, NPS, NROWA, NROWB, NROWY, NSWOT, & NTAPE, NTP, NTPD, NUMORT, NXPTS, NXPTSD, & IP(NFCC,*), IWORK(*) DOUBLE PRECISION A(NROWA,*), AE, ALPHA(*), B(NROWB,*), & BETA(*), C, COEF(*), G(*), P(NTP,*), PWCND, PX, & RE, S(*), STOWA(*), TND, TOL, U(NCOMP,NFC,*), & V(NCOMP,*), W(NFCC,*), WORK(*), X, XBEG, XEND, XOP, & XOT, XPTS(*), XSAV, Y(NROWY,*), YHP(NCOMP,*), & Z(*) ! ! ****************************************************************** ! COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /DML18J/ AE,RE,TOL,NXPTSD,NICD,NOPG,MXNOND,NDISK,NTAPE, & NEQ,INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD, & ICOCO ! ! ***************************************************************** ! !***FIRST EXECUTABLE STATEMENT DBVPOR NFCP1 = NFC + 1 NUMORT = 0 C = 1.0D0 ! ! ****************************************************************** ! CALCULATE INITIAL CONDITIONS WHICH SATISFY ! A*YH(XINITIAL)=0 AND A*YP(XINITIAL)=ALPHA. ! WHEN NFC /= NFCC DLSSUD DEFINES VALUES YHP IN A MATRIX OF ! SIZE (NFCC+1)*NCOMP AND ,HENCE, OVERFLOWS THE STORAGE ! ALLOCATION INTO THE U ARRAY. HOWEVER, THIS IS OKAY SINCE ! PLENTY OF SPACE IS AVAILABLE IN U AND IT HAS NOT YET BEEN ! USED. ! NDW = NROWA*NCOMP KWS = NDW + NIC + 1 KWD = KWS + NIC KWT = KWD + NIC KWC = KWT + NIC IFLAG = 0 call DLSSUD(A,YHP(1,NFCC+1),ALPHA,NIC,NCOMP,NROWA,YHP,NCOMP,IFLAG, & 1,IRA,0,WORK(1),WORK(NDW+1),IWORK,WORK(KWS),WORK(KWD), & WORK(KWT),ISFLG,WORK(KWC)) if (IFLAG == 1) go to 10 IFLAG = -4 go to 200 10 CONTINUE if (NFC /= NFCC) & call DVECS(NCOMP,NFC,YHP,WORK,IWORK,INHOMO,IFLAG) if (IFLAG == 1) go to 20 IFLAG = -5 go to 190 20 CONTINUE ! ! ************************************************************ ! DETERMINE THE NUMBER OF DIFFERENTIAL EQUATIONS TO BE ! INTEGRATED, INITIALIZE VARIABLES FOR AUXILIARY INITIAL ! VALUE PROBLEM AND STORE INITIAL CONDITIONS. ! NEQ = NCOMP*NFC if (INHOMO == 1) NEQ = NEQ + NCOMP IVP = 0 if (NEQIVP == 0) go to 40 IVP = NEQ NEQ = NEQ + NEQIVP NFCP2 = NFCP1 if (INHOMO == 1) NFCP2 = NFCP1 + 1 DO 30 K = 1, NEQIVP YHP(K,NFCP2) = ALPHA(NIC+K) 30 CONTINUE 40 CONTINUE call DSTOR1(U,YHP,V,YHP(1,NFCP1),0,NDISK,NTAPE) ! ! ************************************************************ ! SET UP DATA FOR THE ORTHONORMALIZATION TESTING PROCEDURE ! AND SAVE INITIAL CONDITIONS IN CASE A RESTART IS ! NECESSARY. ! NSWOT = 1 KNSWOT = 0 LOTJP = 1 TND = LOG10(10.0D0*TOL) PWCND = LOG10(SQRT(TOL)) X = XBEG PX = X XOT = XEND XOP = X KOP = 1 call DSTWAY(U,V,YHP,0,STOWA) ! ! ************************************************************ ! ******** FORWARD INTEGRATION OF ALL INITIAL VALUE EQUATIONS ! ********** ! ************************************************************ ! call DRKFAB(NCOMP,XPTS,NXPTS,NFC,IFLAG,Z,MXNON,P,NTP,IP,YHP, & NIV,U,V,W,S,STOWA,G,WORK,IWORK,NFCC) if (IFLAG /= 0 .OR. ICOCO == 0) go to 180 ! ! ********************************************************* ! **************** BACKWARD SWEEP TO OBTAIN SOLUTION ! ******************* ! ********************************************************* ! ! CALCULATE SUPERPOSITION COEFFICIENTS AT XFINAL. ! ! FOR THE DISK STORAGE VERSION, IT IS NOT NECESSARY TO ! READ U AND V AT THE LAST OUTPUT POINT, SINCE THE ! LOCAL COPY OF EACH STILL EXISTS. ! KOD = 1 if (NDISK == 0) KOD = NXPTS I1 = 1 + NFCC*NFCC I2 = I1 + NFCC call DCOEF(U(1,1,KOD),V(1,KOD),NCOMP,NROWB,NFC,NIC,B, & BETA,COEF,INHOMO,RE,AE,WORK,WORK(I1), & WORK(I2),IWORK,IFLAG,NFCC) ! ! ********************************************************* ! CALCULATE SOLUTION AT OUTPUT POINTS BY RECURRING ! BACKWARDS. AS WE RECUR BACKWARDS FROM XFINAL TO ! XINITIAL WE MUST CALCULATE NEW SUPERPOSITION ! COEFFICIENTS EACH TIME WE CROSS A POINT OF ! ORTHONORMALIZATION. ! K = NUMORT NCOMP2 = NCOMP/2 IC = 1 if (NFC /= NFCC) IC = 2 DO 170 J = 1, NXPTS KPTS = NXPTS - J + 1 KOD = KPTS if (NDISK == 1) KOD = 1 50 CONTINUE ! ...EXIT if (K == 0) go to 120 ! ...EXIT if (XEND > XBEG .AND. XPTS(KPTS) >= Z(K)) & go to 120 ! ...EXIT if (XEND < XBEG .AND. XPTS(KPTS) <= Z(K)) & go to 120 NON = K if (NDISK == 0) go to 60 NON = 1 BACKSPACE NTAPE READ (NTAPE) & (IP(I,1), I = 1, NFCC),(P(I,1), I = 1, NTP) BACKSPACE NTAPE 60 CONTINUE if (INHOMO /= 1) go to 90 if (NDISK == 0) go to 70 BACKSPACE NTAPE READ (NTAPE) (W(I,1), I = 1, NFCC) BACKSPACE NTAPE 70 CONTINUE DO 80 N = 1, NFCC COEF(N) = COEF(N) - W(N,NON) 80 CONTINUE 90 CONTINUE call DBKSOL(NFCC,P(1,NON),COEF) DO 100 M = 1, NFCC WORK(M) = COEF(M) 100 CONTINUE DO 110 M = 1, NFCC L = IP(M,NON) COEF(L) = WORK(M) 110 CONTINUE K = K - 1 go to 50 120 CONTINUE if (NDISK == 0) go to 130 BACKSPACE NTAPE READ (NTAPE) & (V(I,1), I = 1, NCOMP), & ((U(I,M,1), I = 1, NCOMP), M = 1, NFC) BACKSPACE NTAPE 130 CONTINUE DO 140 N = 1, NCOMP Y(N,KPTS) = V(N,KOD) & + DDOT(NFC,U(N,1,KOD),NCOMP,COEF,IC) 140 CONTINUE if (NFC == NFCC) go to 160 DO 150 N = 1, NCOMP2 NN = NCOMP2 + N Y(N,KPTS) = Y(N,KPTS) & - DDOT(NFC,U(NN,1,KOD),NCOMP, & COEF(2),2) Y(NN,KPTS) = Y(NN,KPTS) & + DDOT(NFC,U(N,1,KOD),NCOMP, & COEF(2),2) 150 CONTINUE 160 CONTINUE 170 CONTINUE 180 CONTINUE 190 CONTINUE 200 CONTINUE ! ! ****************************************************************** ! MXNON = NUMORT return end subroutine DBVSUP (Y, NROWY, NCOMP, XPTS, NXPTS, A, NROWA, ALPHA, & NIC, B, NROWB, BETA, NFC, IGOFX, RE, AE, IFLAG, WORK, NDW, & IWORK, NDIW, NEQIVP) ! !! DBVSUP solves a linear two-point boundary value problem using ... ! superposition coupled with an orthonormalization procedure ! and a variable-step integration scheme. ! !***LIBRARY SLATEC !***CATEGORY I1B1 !***TYPE DOUBLE PRECISION (BVSUP-S, DBVSUP-D) !***KEYWORDS ORTHONORMALIZATION, SHOOTING, ! TWO-POINT BOUNDARY VALUE PROBLEM !***AUTHOR Scott, M. R., (SNLA) ! Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! ! Subroutine DBVSUP solves a linear two-point boundary-value problem ! of the form ! DY/DX = MATRIX(X,U)*Y(X) + G(X,U) ! A*Y(XINITIAL) = ALPHA , B*Y(XFINAL) = BETA ! ! coupled with the solution of the initial value problem ! ! DU/DX = F(X,U) ! U(XINITIAL) = ETA ! ! ********************************************************************** ! ABSTRACT ! The method of solution uses superposition coupled with an ! orthonormalization procedure and a variable-step integration ! scheme. Each time the superposition solutions start to ! lose their numerical linear independence, the vectors are ! reorthonormalized before integration proceeds. The underlying ! principle of the algorithm is then to piece together the ! intermediate (orthogonalized) solutions, defined on the various ! subintervals, to obtain the desired solutions. ! ! ********************************************************************** ! INPUT to DBVSUP ! ********************************************************************** ! ! NROWY = actual row dimension of Y in calling program. ! NROWY must be >= NCOMP ! ! NCOMP = number of components per solution vector. ! NCOMP is equal to number of original differential ! equations. NCOMP = NIC + NFC. ! ! XPTS = desired output points for solution. They must be monotonic. ! XINITIAL = XPTS(1) ! XFINAL = XPTS(NXPTS) ! ! NXPTS = number of output points. ! ! A(NROWA,NCOMP) = boundary condition matrix at XINITIAL ! must be contained in (NIC,NCOMP) sub-matrix. ! ! NROWA = actual row dimension of A in calling program, ! NROWA must be >= NIC. ! ! ALPHA(NIC+NEQIVP) = boundary conditions at XINITIAL. ! If NEQIVP > 0 (see below), the boundary ! conditions at XINITIAL for the initial value ! equations must be stored starting in ! position (NIC + 1) of ALPHA. ! Thus, ALPHA(NIC+K) = ETA(K). ! ! NIC = number of boundary conditions at XINITIAL. ! ! B(NROWB,NCOMP) = boundary condition matrix at XFINAL. ! Must be contained in (NFC,NCOMP) sub-matrix. ! ! NROWB = actual row dimension of B in calling program, ! NROWB must be >= NFC. ! ! BETA(NFC) = boundary conditions at XFINAL. ! ! NFC = number of boundary conditions at XFINAL. ! ! IGOFX =0 -- The inhomogeneous term G(X) is identically zero. ! =1 -- The inhomogeneous term G(X) is not identically zero. ! (if IGOFX=1, then Subroutine DGVEC (or DUVEC) must be ! supplied). ! ! RE = relative error tolerance used by the integrator. ! (see one of the integrators) ! ! AE = absolute error tolerance used by the integrator. ! (see one of the integrators) ! **NOTE- RE and AE should not both be zero. ! ! IFLAG = a status parameter used principally for output. ! However, for efficient solution of problems which ! are originally defined as COMPLEX*16 valued (but ! converted to double precision systems to use this code), ! the user must set IFLAG=13 on input. See the comment ! below for more information on solving such problems. ! ! WORK(NDW) = floating point array used for internal storage. ! ! NDW = actual dimension of work array allocated by user. ! An estimate for NDW can be computed from the following ! NDW = 130 + NCOMP**2 * (6 + NXPTS/2 + expected number of ! orthonormalizations/8) ! For the disk or tape storage mode, ! NDW = 6 * NCOMP**2 + 10 * NCOMP + 130 ! However, when the ADAMS integrator is to be used, the estimates are ! NDW = 130 + NCOMP**2 * (13 + NXPTS/2 + expected number of ! orthonormalizations/8) ! and NDW = 13 * NCOMP**2 + 22 * NCOMP + 130 , respectively. ! ! IWORK(NDIW) = integer array used for internal storage. ! ! NDIW = actual dimension of IWORK array allocated by user. ! An estimate for NDIW can be computed from the following ! NDIW = 68 + NCOMP * (1 + expected number of ! orthonormalizations) ! **NOTE -- the amount of storage required is problem dependent and may ! be difficult to predict in advance. Experience has shown ! that for most problems 20 or fewer orthonormalizations ! should suffice. If the problem cannot be completed with the ! allotted storage, then a message will be printed which ! estimates the amount of storage necessary. In any case, the ! user can examine the IWORK array for the actual storage ! requirements, as described in the output information below. ! ! NEQIVP = number of auxiliary initial value equations being added ! to the boundary value problem. ! **NOTE -- Occasionally the coefficients matrix and/or G may be ! functions which depend on the independent variable X and ! on U, the solution of an auxiliary initial value problem. ! In order to avoid the difficulties associated with ! interpolation, the auxiliary equations may be solved ! simultaneously with the given boundary value problem. ! This initial value problem may be linear or nonlinear. ! See SAND77-1328 for an example. ! ! ! The user must supply subroutines DFMAT, DGVEC, DUIVP and DUVEC, ! when needed (they must be so named), to evaluate the derivatives ! as follows ! ! A. DFMAT must be supplied. ! ! SUBROUTINE DFMAT(X,Y,YP) ! X = independent variable (input to DFMAT) ! Y = dependent variable vector (input to DFMAT) ! YP = DY/DX = derivative vector (output from DFMAT) ! ! Compute the derivatives for the homogeneous problem ! YP(I) = DY(I)/DX = MATRIX(X) * Y(I) , I = 1,...,NCOMP ! ! When (NEQIVP > 0) and matrix is dependent on U as ! well as on X, the following common statement must be ! included in DFMAT ! COMMON /DMLIVP/ NOFST ! for convenience, the U vector is stored at the bottom ! of the Y array. Thus, during any call to DFMAT, ! U(I) is referenced by Y(NOFST + I). ! ! ! Subroutine DBVDER calls DFMAT NFC times to evaluate the ! homogeneous equations and, if necessary, it calls DFMAT ! once in evaluating the particular solution. since X remains ! unchanged in this sequence of calls it is possible to ! realize considerable computational savings for complicated ! and expensive evaluations of the matrix entries. To do this ! the user merely passes a variable, say XS, via common where ! XS is defined in the main program to be any value except ! the initial X. Then the non-constant elements of matrix(x) ! appearing in the differential equations need only be ! computed if X is unequal to XS, whereupon XS is reset to X. ! ! ! B. If NEQIVP > 0 , DUIVP must also be supplied. ! ! SUBROUTINE DUIVP(X,U,UP) ! X = independent variable (input to DUIVP) ! U = dependent variable vector (input to DUIVP) ! UP = DU/DX = derivative vector (output from DUIVP) ! ! Compute the derivatives for the auxiliary initial value eqs ! UP(I) = DU(I)/DX, I = 1,...,NEQIVP. ! ! Subroutine DBVDER calls DUIVP once to evaluate the ! derivatives for the auxiliary initial value equations. ! ! ! C. If NEQIVP = 0 and IGOFX = 1 , DGVEC must be supplied. ! ! SUBROUTINE DGVEC(X,G) ! X = independent variable (input to DGVEC) ! G = vector of inhomogeneous terms G(X) (output from ! DGVEC) ! ! Compute the inhomogeneous terms G(X) ! G(I) = G(X) values for I = 1,...,NCOMP. ! ! Subroutine DBVDER calls DGVEC in evaluating the particular ! solution provided G(X) is not identically zero. Thus, when ! IGOFX=0, the user need not write a DGVEC subroutine. Also, ! the user does not have to bother with the computational ! savings scheme for DGVEC as this is automatically achieved ! via the DBVDER subroutine. ! ! ! D. If NEQIVP > 0 and IGOFX = 1 , DUVEC must be supplied. ! ! SUBROUTINE DUVEC(X,U,G) ! X = independent variable (input to DUVEC) ! U = dependent variable vector from the auxiliary initial ! value problem (input to DUVEC) ! G = array of inhomogeneous terms G(X,U)(output from DUVEC) ! ! Compute the inhomogeneous terms G(X,U) ! G(I) = G(X,U) values for I = 1,...,NCOMP. ! ! Subroutine DBVDER calls DUVEC in evaluating the particular ! solution provided G(X,U) is not identically zero. Thus, ! when IGOFX=0, the user need not write a DUVEC subroutine. ! ! ! ! The following is optional input to DBVSUP to give user more ! flexibility in use of code. See SAND75-0198, SAND77-1328, ! SAND77-1690, SAND78-0522, and SAND78-1501 for more information. ! ! ****CAUTION -- The user must zero out IWORK(1),...,IWORK(15) ! prior to calling DBVSUP. These locations define ! optional input and must be zero unless set to special ! values by the user as described below. ! ! IWORK(1) -- number of orthonormalization points. ! A value need be set only if IWORK(11) = 1 ! ! IWORK(9) -- integrator and orthonormalization parameter ! (default value is 1) ! 1 = RUNGE-KUTTA-FEHLBERG code using GRAM-SCHMIDT test. ! 2 = ADAMS code using GRAM-SCHMIDT test. ! ! IWORK(11) -- orthonormalization points parameter ! (default value is 0) ! 0 - orthonormalization points not pre-assigned. ! 1 - orthonormalization points pre-assigned in ! the first IWORK(1) positions of work. ! ! IWORK(12) -- storage parameter ! (default value is 0) ! 0 - all storage in core. ! LUN - homogeneous and inhomogeneous solutions at ! output points and orthonormalization information ! are stored on disk. The logical unit number to ! be used for disk I/O (NTAPE) is set to IWORK(12). ! ! WORK(1),... -- pre-assigned orthonormalization points, stored ! monotonically, corresponding to the direction ! of integration. ! ! ! ! ****************************************************** ! *** COMPLEX*16 VALUED PROBLEM *** ! ****************************************************** ! **NOTE*** ! Suppose the original boundary value problem is NC equations ! of the form ! DW/DX = MAT(X,U)*W(X) + H(X,U) ! R*W(XINITIAL)=GAMMA , S*W(XFINAL)=DELTA ! where all variables are COMPLEX*16 valued. The DBVSUP code can be ! used by converting to a double precision system of size 2*NC. To ! solve the larger dimensioned problem efficiently, the user must ! initialize IFLAG=13 on input and order the vector components ! according to Y(1)=DOUBLE PRECISION(W(1)),...,Y(NC)=DOUBLE ! PRECISION(W(NC)),Y(NC+1)=IMAG(W(1)),...., Y(2*NC)=IMAG(W(NC)). ! Then define ! ............................................... ! . DOUBLE PRECISION(MAT) -IMAG(MAT) . ! MATRIX = . . ! . IMAG(MAT) DOUBLE PRECISION(MAT) . ! ............................................... ! ! The matrices A,B and vectors G,ALPHA,BETA must be defined ! similarly. Further details can be found in SAND78-1501. ! ! ! ********************************************************************** ! OUTPUT from DBVSUP ! ********************************************************************** ! ! Y(NROWY,NXPTS) = solution at specified output points. ! ! IFLAG Output Values ! =-5 algorithm ,for obtaining starting vectors for the ! special COMPLEX*16 problem structure, was unable to ! obtain the initial vectors satisfying the necessary ! independence criteria. ! =-4 rank of boundary condition matrix A is less than NIC, ! as determined by DLSSUD. ! =-2 invalid input parameters. ! =-1 insufficient number of storage locations allocated for ! WORK or IWORK. ! ! =0 indicates successful solution. ! ! =1 a computed solution is returned but uniqueness of the ! solution of the boundary-value problem is questionable. ! For an eigenvalue problem, this should be treated as a ! successful execution since this is the expected mode ! of return. ! =2 a computed solution is returned but the existence of the ! solution to the boundary-value problem is questionable. ! =3 a nontrivial solution approximation is returned although ! the boundary condition matrix B*Y(XFINAL) is found to be ! nonsingular (to the desired accuracy level) while the ! right hand side vector is zero. To eliminate this type ! of return, the accuracy of the eigenvalue parameter ! must be improved. ! ***NOTE-We attempt to diagnose the correct problem behavior ! and report possible difficulties by the appropriate ! error flag. However, the user should probably resolve ! the problem using smaller error tolerances and/or ! perturbations in the boundary conditions or other ! parameters. This will often reveal the correct ! interpretation for the problem posed. ! ! =13 maximum number of orthonormalizations attained before ! reaching XFINAL. ! =20-flag from integrator (DDERKF or DDEABM) values can ! range from 21 to 25. ! =30 solution vectors form a dependent set. ! ! WORK(1),...,WORK(IWORK(1)) = orthonormalization points ! determined by DBVPOR. ! ! IWORK(1) = number of orthonormalizations performed by DBVPOR. ! ! IWORK(2) = maximum number of orthonormalizations allowed as ! calculated from storage allocated by user. ! ! IWORK(3),IWORK(4),IWORK(5),IWORK(6) give information about ! actual storage requirements for WORK and IWORK ! arrays. In particular, ! required storage for work array is ! IWORK(3) + IWORK(4)*(expected number of orthonormalizations) ! ! required storage for IWORK array is ! IWORK(5) + IWORK(6)*(expected number of orthonormalizations) ! ! IWORK(8) = final value of exponent parameter used in tolerance ! test for orthonormalization. ! ! IWORK(16) = number of independent vectors returned from DMGSBV. ! It is only of interest when IFLAG=30 is obtained. ! ! IWORK(17) = numerically estimated rank of the boundary ! condition matrix defined from B*Y(XFINAL) ! ! ********************************************************************** ! ! Necessary machine constants are defined in the Function ! Routine D1MACH. The user must make sure that the values ! set in D1MACH are relevant to the computer being used. ! ! ********************************************************************** ! ********************************************************************** ! !***REFERENCES M. R. Scott and H. A. Watts, SUPORT - a computer code ! for two-point boundary-value problems via ! orthonormalization, SIAM Journal of Numerical ! Analysis 14, (1977), pp. 40-70. ! B. L. Darlow, M. R. Scott and H. A. Watts, Modifications ! of SUPORT, a linear boundary value problem solver ! Part I - pre-assigning orthonormalization points, ! auxiliary initial value problem, disk or tape storage, ! Report SAND77-1328, Sandia Laboratories, Albuquerque, ! New Mexico, 1977. ! B. L. Darlow, M. R. Scott and H. A. Watts, Modifications ! of SUPORT, a linear boundary value problem solver ! Part II - inclusion of an Adams integrator, Report ! SAND77-1690, Sandia Laboratories, Albuquerque, ! New Mexico, 1977. ! M. E. Lord and H. A. Watts, Modifications of SUPORT, ! a linear boundary value problem solver Part III - ! orthonormalization improvements, Report SAND78-0522, ! Sandia Laboratories, Albuquerque, New Mexico, 1978. ! H. A. Watts, M. R. Scott and M. E. Lord, Computational ! solution of complex*16 valued boundary problems, ! Report SAND78-1501, Sandia Laboratories, ! Albuquerque, New Mexico, 1978. !***ROUTINES CALLED DEXBVP, DMACON, XERMSG !***COMMON BLOCKS DML15T, DML17B, DML18J, DML5MC, DML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 890921 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls, remove some extraneous ! comments. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DBVSUP ! ********************************************************************** ! INTEGER ICOCO, IFLAG, IGOFX, IGOFXD, INDPVT, INFO, INHOMO, INTEG, & IS, ISTKOP, IVP, IWORK(*), J, K, K1, K10, K11, K2, & K3, K4, K5, K6, K7, K8, K9, KKKCOE, KKKCOF, KKKG, KKKINT, & KKKS, KKKSTO, KKKSUD, KKKSVC, KKKU, KKKV, KKKWS, KKKYHP, & KKKZPW, KNSWOT, KOP, KPTS, L1, L2, LLLCOF, LLLINT, LLLIP, & LLLIWS, LLLSUD, LLLSVC, LOTJP, LPAR, MNSWOT, & MXNON, MXNONI, MXNONR, NCOMP, NCOMPD, NDEQ, NDISK, NDIW, & NDW, NEEDIW, NEEDW, NEQ, NEQIVD, NEQIVP, NFC, NFCC, & NFCD, NIC, NICD, NITEMP, NON, NOPG, NPS, NROWA, NROWB, & NROWY, NRTEMP, NSWOT, NTAPE, NTP, NUMORT, NXPTS, NXPTSD, & NXPTSM DOUBLE PRECISION A(NROWA,*), AE, AED, ALPHA(*), & B(NROWB,*), BETA(*), C, EPS, FOURU, PWCND, PX, RE, & RED, SQOVFL, SRU, TND, TOL, TWOU, URO, WORK(NDW), X, XBEG, & XEND, XOP, XOT, XPTS(*), XSAV, Y(NROWY,*) CHARACTER*8 XERN1, XERN2, XERN3, XERN4 ! ! ****************************************************************** ! THE COMMON BLOCK BELOW IS USED TO COMMUNICATE WITH SUBROUTINE ! DBVDER. THE USER SHOULD NOT ALTER OR USE THIS COMMON BLOCK IN ! THE CALLING PROGRAM. ! COMMON /DML8SZ/ C,XSAV,IGOFXD,INHOMO,IVP,NCOMPD,NFCD ! ! ****************************************************************** ! THESE COMMON BLOCKS AID IN REDUCING THE NUMBER OF SUBROUTINE ! ARGUMENTS PREVALENT IN THIS MODULAR STRUCTURE ! COMMON /DML18J/ AED,RED,TOL,NXPTSD,NICD,NOPG,MXNON,NDISK,NTAPE, & NEQ,INDPVT,INTEG,NPS,NTP,NEQIVD,NUMORT,NFCC, & ICOCO COMMON /DML17B/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, & K10,K11,L1,L2,KKKINT,LLLINT ! ! ****************************************************************** ! THIS COMMON BLOCK IS USED IN SUBROUTINES DBVSUP,DBVPOR,DRKFAB, ! DREORT, AND DSTWAY. IT CONTAINS INFORMATION NECESSARY ! FOR THE ORTHONORMALIZATION TESTING PROCEDURE AND A BACKUP ! RESTARTING CAPABILITY. ! COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT ! ! ****************************************************************** ! THIS COMMON BLOCK CONTAINS THE MACHINE DEPENDENT PARAMETERS ! USED BY THE CODE ! COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR ! ! ***************************************************************** ! SET UP MACHINE DEPENDENT CONSTANTS. ! !***FIRST EXECUTABLE STATEMENT DBVSUP call DMACON ! ! ************************************************ ! TEST FOR INVALID INPUT ! if (NROWY < NCOMP) go to 80 if (NCOMP /= NIC + NFC) go to 80 if (NXPTS < 2) go to 80 if (NIC <= 0) go to 80 if (NROWA < NIC) go to 80 if (NFC <= 0) go to 80 if (NROWB < NFC) go to 80 if (IGOFX < 0 .OR. IGOFX > 1) go to 80 if (RE < 0.0D0) go to 80 if (AE < 0.0D0) go to 80 if (RE == 0.0D0 .AND. AE == 0.0D0) go to 80 ! BEGIN BLOCK PERMITTING ...EXITS TO 70 IS = 1 if (XPTS(NXPTS) < XPTS(1)) IS = 2 NXPTSM = NXPTS - 1 DO 30 K = 1, NXPTSM if (IS == 2) go to 10 ! .........EXIT if (XPTS(K+1) <= XPTS(K)) go to 70 go to 20 10 CONTINUE ! .........EXIT if (XPTS(K) <= XPTS(K+1)) go to 70 20 CONTINUE 30 CONTINUE ! ! ****************************************** ! CHECK FOR DISK STORAGE ! KPTS = NXPTS NDISK = 0 if (IWORK(12) == 0) go to 40 NTAPE = IWORK(12) KPTS = 1 NDISK = 1 40 CONTINUE ! ! ****************************************** ! SET INTEG PARAMETER ACCORDING TO ! CHOICE OF INTEGRATOR. ! INTEG = 1 if (IWORK(9) == 2) INTEG = 2 ! ! ****************************************** ! COMPUTE INHOMO ! ! ............EXIT if (IGOFX == 1) go to 100 DO 50 J = 1, NIC ! ...............EXIT if (ALPHA(J) /= 0.0D0) go to 100 50 CONTINUE DO 60 J = 1, NFC ! ............EXIT if (BETA(J) /= 0.0D0) go to 90 60 CONTINUE INHOMO = 3 ! ...............EXIT go to 110 70 CONTINUE 80 CONTINUE IFLAG = -2 ! ..................EXIT go to 220 90 CONTINUE INHOMO = 2 ! ......EXIT go to 110 100 CONTINUE INHOMO = 1 110 CONTINUE ! ! ********************************************************* ! TO TAKE ADVANTAGE OF THE SPECIAL STRUCTURE WHEN ! SOLVING A COMPLEX*16 VALUED PROBLEM,WE INTRODUCE ! NFCC=NFC WHILE CHANGING THE INTERNAL VALUE OF NFC ! NFCC = NFC if (IFLAG == 13) NFC = NFC/2 ! ! ********************************************************* ! DETERMINE NECESSARY STORAGE REQUIREMENTS ! ! FOR BASIC ARRAYS IN DBVPOR KKKYHP = NCOMP*(NFC + 1) + NEQIVP KKKU = NCOMP*NFC*KPTS KKKV = NCOMP*KPTS KKKCOE = NFCC KKKS = NFC + 1 KKKSTO = NCOMP*(NFC + 1) + NEQIVP + 1 KKKG = NCOMP ! ! FOR ORTHONORMALIZATION RELATED MATTERS NTP = (NFCC*(NFCC + 1))/2 KKKZPW = 1 + NTP + NFCC LLLIP = NFCC ! ! FOR ADDITIONAL REQUIRED WORK SPACE ! (DLSSUD) KKKSUD = 4*NIC + (NROWA + 1)*NCOMP LLLSUD = NIC ! (DVECS) KKKSVC = 1 + 4*NFCC + 2*NFCC**2 LLLSVC = 2*NFCC ! NDEQ = NCOMP*NFC + NEQIVP if (INHOMO == 1) NDEQ = NDEQ + NCOMP go to (120,130), INTEG ! (DDERKF) 120 CONTINUE KKKINT = 33 + 7*NDEQ LLLINT = 34 go to 140 ! (DDEABM) 130 CONTINUE KKKINT = 130 + 21*NDEQ LLLINT = 51 140 CONTINUE ! ! (COEF) KKKCOF = 5*NFCC + NFCC**2 LLLCOF = 3 + NFCC ! KKKWS = MAX(KKKSUD,KKKSVC,KKKINT,KKKCOF) LLLIWS = MAX(LLLSUD,LLLSVC,LLLINT,LLLCOF) ! NEEDW = KKKYHP + KKKU + KKKV + KKKCOE + KKKS + KKKSTO & + KKKG + KKKZPW + KKKWS NEEDIW = 17 + LLLIP + LLLIWS ! ********************************************************* ! COMPUTE THE NUMBER OF POSSIBLE ORTHONORMALIZATIONS ! WITH THE ALLOTTED STORAGE ! IWORK(3) = NEEDW IWORK(4) = KKKZPW IWORK(5) = NEEDIW IWORK(6) = LLLIP NRTEMP = NDW - NEEDW NITEMP = NDIW - NEEDIW ! ...EXIT if (NRTEMP < 0) go to 180 ! ...EXIT if (NITEMP < 0) go to 180 ! if (NDISK == 0) go to 150 NON = 0 MXNON = NRTEMP go to 160 150 CONTINUE ! MXNONR = NRTEMP/KKKZPW MXNONI = NITEMP/LLLIP MXNON = MIN(MXNONR,MXNONI) NON = MXNON 160 CONTINUE ! IWORK(2) = MXNON ! ! ********************************************************* ! CHECK FOR PRE-ASSIGNED ORTHONORMALIZATION POINTS ! NOPG = 0 ! ......EXIT if (IWORK(11) /= 1) go to 210 if (MXNON < IWORK(1)) go to 170 NOPG = 1 MXNON = IWORK(1) WORK(MXNON+1) = 2.0D0*XPTS(NXPTS) - XPTS(1) ! .........EXIT go to 210 170 CONTINUE 180 CONTINUE ! IFLAG = -1 if (NDISK /= 1) THEN WRITE (XERN1, '(I8)') NEEDW WRITE (XERN2, '(I8)') KKKZPW WRITE (XERN3, '(I8)') NEEDIW WRITE (XERN4, '(I8)') LLLIP call XERMSG ('SLATEC', 'DBVSUP', & 'REQUIRED STORAGE FOR WORK ARRAY IS ' // XERN1 // ' + ' // & XERN2 // '*(EXPECTED NUMBER OF ORTHONORMALIZATIONS) $$' // & 'REQUIRED STORAGE FOR IWORK ARRAY IS ' // XERN3 // ' + ' // & XERN4 // '*(EXPECTED NUMBER OF ORTHONORMALIZATIONS)', 1, 0) ELSE WRITE (XERN1, '(I8)') NEEDW WRITE (XERN2, '(I8)') NEEDIW call XERMSG ('SLATEC', 'DBVSUP', & 'REQUIRED STORAGE FOR WORK ARRAY IS ' // XERN1 // & ' + NUMBER OF ORTHONOMALIZATIONS. $$' // & 'REQUIRED STORAGE FOR IWORK ARRAY IS ' // XERN2, 1, 0) end if return ! ! *************************************************************** ! ALLOCATE STORAGE FROM WORK AND IWORK ARRAYS ! ! (Z) 210 K1 = 1 + (MXNON + 1) ! (P) K2 = K1 + NTP*(NON + 1) ! (W) K3 = K2 + NFCC*(NON + 1) ! (YHP) K4 = K3 + KKKYHP ! (U) K5 = K4 + KKKU ! (V) K6 = K5 + KKKV ! (COEF) K7 = K6 + KKKCOE ! (S) K8 = K7 + KKKS ! (STOWA) K9 = K8 + KKKSTO ! (G) K10 = K9 + KKKG K11 = K10 + KKKWS ! REQUIRED ADDITIONAL DOUBLE PRECISION WORK SPACE ! STARTS AT WORK(K10) AND EXTENDS TO WORK(K11-1) ! ! FIRST 17 LOCATIONS OF IWORK ARE USED FOR OPTIONAL ! INPUT AND OUTPUT ITEMS ! (IP) L1 = 18 + NFCC*(NON + 1) L2 = L1 + LLLIWS ! REQUIRED INTEGER WORK SPACE STARTS AT IWORK(L1) ! AND EXTENDS TO IWORK(L2-1) ! ! *************************************************************** ! SET INDICATOR FOR NORMALIZATION OF PARTICULAR SOLUTION ! NPS = 0 if (IWORK(10) == 1) NPS = 1 ! ! *************************************************************** ! SET PIVOTING PARAMETER ! INDPVT = 0 if (IWORK(15) == 1) INDPVT = 1 ! ! *************************************************************** ! SET OTHER COMMON BLOCK PARAMETERS ! NFCD = NFC NCOMPD = NCOMP IGOFXD = IGOFX NXPTSD = NXPTS NICD = NIC RED = RE AED = AE NEQIVD = NEQIVP MNSWOT = 20 if (IWORK(13) == -1) MNSWOT = MAX(1,IWORK(14)) XBEG = XPTS(1) XEND = XPTS(NXPTS) XSAV = XEND ICOCO = 1 if (INHOMO == 3 .AND. NOPG == 1) WORK(MXNON+1) = XEND ! ! *************************************************************** ! call DEXBVP(Y,NROWY,XPTS,A,NROWA,ALPHA,B,NROWB,BETA,IFLAG,WORK, & IWORK) NFC = NFCC IWORK(17) = IWORK(L1) 220 CONTINUE return end DOUBLE PRECISION FUNCTION DCBRT (X) ! !! DCBRT computes the cube root. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C2 !***TYPE DOUBLE PRECISION (CBRT-S, DCBRT-D, CCBRT-C) !***KEYWORDS CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DCBRT(X) calculates the double precision cube root for ! double precision argument X. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9PAK, D9UPAK !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DCBRT DOUBLE PRECISION X, CBRT2(5), Y, CBRTSQ, D9PAK, D1MACH SAVE CBRT2, NITER DATA CBRT2(1) / 0.62996052494743658238360530363911D0 / DATA CBRT2(2) / 0.79370052598409973737585281963615D0 / DATA CBRT2(3) / 1.0D0 / DATA CBRT2(4) / 1.25992104989487316476721060727823D0 / DATA CBRT2(5) / 1.58740105196819947475170563927231D0 / DATA NITER / 0 / !***FIRST EXECUTABLE STATEMENT DCBRT if (NITER == 0) NITER = 1.443*LOG(-.106*LOG(0.1*REAL(D1MACH(3))) & ) + 1.0 ! DCBRT = 0.D0 if (X == 0.D0) RETURN ! call D9UPAK (ABS(X), Y, N) IXPNT = N/3 IREM = N - 3*IXPNT + 3 ! ! THE APPROXIMATION BELOW IS A GENERALIZED CHEBYSHEV SERIES CONVERTED ! TO POLYNOMIAL FORM. THE APPROX IS NEARLY BEST IN THE SENSE OF ! RELATIVE ERROR WITH 4.085 DIGITS ACCURACY. ! Z = Y DCBRT = .439581E0 + Z*(.928549E0 + Z*(-.512653E0 + Z*.144586E0)) ! DO 10 ITER=1,NITER CBRTSQ = DCBRT*DCBRT DCBRT = DCBRT + (Y-DCBRT*CBRTSQ)/(3.D0*CBRTSQ) 10 CONTINUE ! DCBRT = D9PAK (CBRT2(IREM)*SIGN(DCBRT,X), IXPNT) return ! end subroutine DCDOT (N, FM, CX, INCX, CY, INCY, DCR, DCI) ! !! DCDOT computes the inner product of two vectors with extended ... ! precision accumulation and result. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A4 !***TYPE COMPLEX (DSDOT-D, DCDOT-C) !***KEYWORDS BLAS, COMPLEX VECTORS, DOT PRODUCT, INNER PRODUCT, ! LINEAR ALGEBRA, VECTOR !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Compute the dot product of 2 complex vectors, CX and CY, e.g. ! CX DOT CY, or, CXconjugate DOT CY. The real and imaginary ! parts of CX and CY are converted to double precision, the dot ! product accumulation is done in double precision and the output ! is given as 2 double precision numbers, corresponding to the real ! and imaginary part of the result. ! Input ! N: Number of complex components of CX and CY. ! FM: =+1.0 compute CX DOT CY. ! =-1.0 compute CXconjugate DOT CY. ! CX(N): ! CY(N): Complex arrays of length N. ! INCX:(Integer) Spacing of elements of CX to use ! INCY:(Integer) Spacing of elements of CY to use. ! Output ! DCR:(Double Precision) Real part of dot product. ! DCI:(Double Precision) Imaginary part of dot product. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DCDOT INTEGER I, INCX, INCY, KX, KY, N COMPLEX CX(*), CY(*) DOUBLE PRECISION DCR, DCI, DT1, DT2, DT3, DT4, FM !***FIRST EXECUTABLE STATEMENT DCDOT DCR = 0.0D0 DCI = 0.0D0 if (N <= 0) go to 20 ! KX = 1 KY = 1 if (INCX < 0) KX = 1+(1-N)*INCX if (INCY < 0) KY = 1+(1-N)*INCY DO 10 I = 1,N DT1 = DBLE(REAL(CX(KX))) DT2 = DBLE(REAL(CY(KY))) DT3 = DBLE(AIMAG(CX(KX))) DT4 = DBLE(AIMAG(CY(KY))) DCR = DCR+(DT1*DT2)-FM*(DT3*DT4) DCI = DCI+(DT1*DT4)+FM*(DT3*DT2) KX = KX+INCX KY = KY+INCY 10 CONTINUE 20 RETURN end subroutine DCFOD (METH, ELCO, TESCO) ! !! DCFOD is subsidiary to DDEBDF. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CFOD-S, DCFOD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DCFOD defines coefficients needed in the integrator package DDEBDF ! !***SEE ALSO DDEBDF !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DCFOD ! ! INTEGER I, IB, METH, NQ, NQM1, NQP1 DOUBLE PRECISION AGAMQ, ELCO, FNQ, FNQM1, PC, PINT, RAGQ, & RQ1FAC, RQFAC, TESCO, TSIGN, XPIN DIMENSION ELCO(13,12),TESCO(3,12) ! ------------------------------------------------------------------ ! DCFOD IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS ! NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS ! GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. ! THE MAXIMUM ORDER ASSUMED HERE IS 12 if METH = 1 AND 5 IF METH = ! 2. (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) ! DCFOD IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, ! AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. ! ! THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. ! THE COEFFICIENTS EL(I), 1 <= I <= NQ+1, FOR THE METHOD OF ! ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A ! GENERATING POLYNOMIAL, I.E., ! L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. ! FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY ! DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = ! 0. FOR THE BDF METHODS, L(X) IS GIVEN BY ! L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, ! WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). ! ! THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE ! LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. ! AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP ! SIZE AT ORDER NQ - 1 if K = 1, AT ORDER NQ IF K = 2, AND AT ORDER ! NQ + 1 if K = 3. ! ------------------------------------------------------------------ DIMENSION PC(12) ! !***FIRST EXECUTABLE STATEMENT DCFOD go to (10,60), METH ! 10 CONTINUE ELCO(1,1) = 1.0D0 ELCO(2,1) = 1.0D0 TESCO(1,1) = 0.0D0 TESCO(2,1) = 2.0D0 TESCO(1,2) = 1.0D0 TESCO(3,12) = 0.0D0 PC(1) = 1.0D0 RQFAC = 1.0D0 DO 50 NQ = 2, 12 ! ------------------------------------------------------------ ! THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE ! POLYNOMIAL P(X) = (X+1)*(X+2)*...*(X+NQ-1). ! INITIALLY, P(X) = 1. ! ------------------------------------------------------------ RQ1FAC = RQFAC RQFAC = RQFAC/NQ NQM1 = NQ - 1 FNQM1 = NQM1 NQP1 = NQ + 1 ! FORM COEFFICIENTS OF P(X)*(X+NQ-1). ! ---------------------------------- PC(NQ) = 0.0D0 DO 20 IB = 1, NQM1 I = NQP1 - IB PC(I) = PC(I-1) + FNQM1*PC(I) 20 CONTINUE PC(1) = FNQM1*PC(1) ! COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). ! ----------------------- PINT = PC(1) XPIN = PC(1)/2.0D0 TSIGN = 1.0D0 DO 30 I = 2, NQ TSIGN = -TSIGN PINT = PINT + TSIGN*PC(I)/I XPIN = XPIN + TSIGN*PC(I)/(I+1) 30 CONTINUE ! STORE COEFFICIENTS IN ELCO AND TESCO. ! -------------------------------- ELCO(1,NQ) = PINT*RQ1FAC ELCO(2,NQ) = 1.0D0 DO 40 I = 2, NQ ELCO(I+1,NQ) = RQ1FAC*PC(I)/I 40 CONTINUE AGAMQ = RQFAC*XPIN RAGQ = 1.0D0/AGAMQ TESCO(2,NQ) = RAGQ if (NQ < 12) TESCO(1,NQP1) = RAGQ*RQFAC/NQP1 TESCO(3,NQM1) = RAGQ 50 CONTINUE go to 100 ! 60 CONTINUE PC(1) = 1.0D0 RQ1FAC = 1.0D0 DO 90 NQ = 1, 5 ! ------------------------------------------------------------ ! THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE ! POLYNOMIAL P(X) = (X+1)*(X+2)*...*(X+NQ). ! INITIALLY, P(X) = 1. ! ------------------------------------------------------------ FNQ = NQ NQP1 = NQ + 1 ! FORM COEFFICIENTS OF P(X)*(X+NQ). ! ------------------------------------ PC(NQP1) = 0.0D0 DO 70 IB = 1, NQ I = NQ + 2 - IB PC(I) = PC(I-1) + FNQ*PC(I) 70 CONTINUE PC(1) = FNQ*PC(1) ! STORE COEFFICIENTS IN ELCO AND TESCO. ! -------------------------------- DO 80 I = 1, NQP1 ELCO(I,NQ) = PC(I)/PC(2) 80 CONTINUE ELCO(2,NQ) = 1.0D0 TESCO(1,NQ) = RQ1FAC TESCO(2,NQ) = NQP1/ELCO(1,NQ) TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) RQ1FAC = RQ1FAC/FNQ 90 CONTINUE 100 CONTINUE return ! ----------------------- END OF SUBROUTINE DCFOD ! ----------------------- end subroutine DCG (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, & IWORK) ! !! DCG is a Preconditioned Conjugate Gradient Sparse Ax=b Solver. ! ! Routine to solve a symmetric positive definite linear ! system Ax = b using the Preconditioned Conjugate ! Gradient method. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2B4 !***TYPE DOUBLE PRECISION (SCG-S, DCG-D) !***KEYWORDS ITERATIVE PRECONDITION, SLAP, SPARSE, ! SYMMETRIC LINEAR SYSTEM !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) ! DOUBLE PRECISION P(N), DZ(N), RWORK(USER DEFINED) ! EXTERNAL MATVEC, MSOLVE ! ! call DCG(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ! $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, ! $ RWORK, IWORK ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, ! for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! ! Where N is the number of unknowns, Y is the product A*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP IA, JA, A storage for the matrix A. ! ISYM is a flag which, if non-zero, denotest that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IWORK is an integer work array ! for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Double Precision R(N). ! Z :WORK Double Precision Z(N). ! P :WORK Double Precision P(N). ! DZ :WORK Double Precision DZ(N). ! Double Precision arrays used for workspace. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! ! *Description ! This routine does not care what matrix data structure is ! used for A and M. It simply calls the MATVEC and MSOLVE ! routines, with the arguments as described above. The user ! could write any type of structure and the appropriate MATVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK in some fashion. The SLAP ! routines DSDCG and DSICCG are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the double pre- ! cision array A. In other words, for each column in the ! matrix first put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- ! th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) ! are the last elements of the ICOL-th column. Note that we ! always have JA(N+1)=NELT+1, where N is the number of columns ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DSDCG, DSICCG !***REFERENCES 1. Louis Hageman and David Young, Applied Iterative ! Methods, Academic Press, New York, 1981. ! 2. Concus, Golub and O'Leary, A Generalized Conjugate ! Gradient Method for the Numerical Solution of ! Elliptic Partial Differential Equations, in Sparse ! Matrix Computations, Bunch and Rose, Eds., Academic ! Press, New York, 1979. ! 3. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, ISDCG !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) !***END PROLOGUE DCG ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), DZ(N), P(N), R(N), RWORK(*), X(N), & Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. DOUBLE PRECISION AK, AKDEN, BK, BKDEN, BKNUM, BNRM, SOLNRM, TOLMIN INTEGER I, K ! .. External Functions .. DOUBLE PRECISION D1MACH, DDOT INTEGER ISDCG EXTERNAL D1MACH, DDOT, ISDCG ! .. External Subroutines .. EXTERNAL DAXPY, DCOPY !***FIRST EXECUTABLE STATEMENT DCG ! ! Check some of the input data. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if TOLMIN = 500*D1MACH(3) if ( TOL < TOLMIN ) THEN TOL = TOLMIN IERR = 4 end if ! ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N R(I) = B(I) - R(I) 10 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! if ( ISDCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, & RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) go to 200 if ( IERR /= 0 ) RETURN ! ! ***** Iteration loop ***** ! DO 100 K=1,ITMAX ITER = K ! ! Calculate coefficient bk and direction vector p. BKNUM = DDOT(N, Z, 1, R, 1) if ( BKNUM <= 0.0D0 ) THEN IERR = 5 return ENDIF if ( ITER == 1) THEN call DCOPY(N, Z, 1, P, 1) ELSE BK = BKNUM/BKDEN DO 20 I = 1, N P(I) = Z(I) + BK*P(I) 20 CONTINUE ENDIF BKDEN = BKNUM ! ! Calculate coefficient ak, new iterate x, new residual r, ! and new pseudo-residual z. call MATVEC(N, P, Z, NELT, IA, JA, A, ISYM) AKDEN = DDOT(N, P, 1, Z, 1) if ( AKDEN <= 0.0D0 ) THEN IERR = 6 return ENDIF AK = BKNUM/AKDEN call DAXPY(N, AK, P, 1, X, 1) call DAXPY(N, -AK, Z, 1, R, 1) call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! ! check stopping criterion. if ( ISDCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, & IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) go to 200 ! 100 CONTINUE ! ! ***** end of loop ***** ! ! stopping criterion not satisfied. ITER = ITMAX + 1 IERR = 2 ! 200 return !------------- LAST LINE OF DCG FOLLOWS ----------------------------- end subroutine DCGN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, & MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ATP, & ATZ, DZ, ATDZ, RWORK, IWORK) ! !! DCGN is a Preconditioned CG Sparse Ax=b Solver for Normal Equations. ! ! Routine to solve a general linear system Ax = b using the ! Preconditioned Conjugate Gradient method applied to the ! normal equations AA'y = b, x=A'y. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SCGN-S, DCGN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! NORMAL EQUATIONS., SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) ! DOUBLE PRECISION P(N), ATP(N), ATZ(N), DZ(N), ATDZ(N) ! DOUBLE PRECISION RWORK(USER DEFINED) ! EXTERNAL MATVEC, MTTVEC, MSOLVE ! ! call DCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, ! $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, ! $ Z, P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, ! for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP-Column IA, JA, A storage for the matrix ! A. ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MTTVEC :EXT External. ! Name of a routine which performs the matrix transpose vector ! multiply y = A'*X given A and X (where ' denotes transpose). ! The name of the MTTVEC routine must be declared external in ! the calling program. The calling sequence to MTTVEC is the ! same as that for MATVEC, viz.: ! call MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A'*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP-Column IA, JA, A storage for the matrix ! A. ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IWORK is an integer work array ! for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Double Precision R(N). ! Z :WORK Double Precision Z(N). ! P :WORK Double Precision P(N). ! ATP :WORK Double Precision ATP(N). ! ATZ :WORK Double Precision ATZ(N). ! DZ :WORK Double Precision DZ(N). ! ATDZ :WORK Double Precision ATDZ(N). ! Double Precision arrays used for workspace. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! ! *Description: ! This routine applies the preconditioned conjugate gradient ! (PCG) method to a non-symmetric system of equations Ax=b. To ! do this the normal equations are solved: ! AA' y = b, where x = A'y. ! In PCG method the iteration count is determined by condition ! -1 ! number of the matrix (M A). In the situation where the ! normal equations are used to solve a non-symmetric system ! the condition number depends on AA' and should therefore be ! much worse than that of A. This is the conventional wisdom. ! When one has a good preconditioner for AA' this may not hold. ! The latter is the situation when DCGN should be tried. ! ! If one is trying to solve a symmetric system, SCG should be ! used instead. ! ! This routine does not care what matrix data structure is ! used for A and M. It simply calls MATVEC, MTTVEC and MSOLVE ! routines, with arguments as described above. The user could ! write any type of structure, and appropriate MATVEC, MTTVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK) in some fashion. The SLAP ! routines SSDCGN and SSLUCN are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the double pre- ! cision array A. In other words, for each column in the ! matrix first put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- ! th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) ! are the last elements of the ICOL-th column. Note that we ! always have JA(N+1)=NELT+1, where N is the number of columns ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DSDCGN, DSLUCN, ISDCGN !***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, ISDCGN !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC, MTTVEC and MSOLVE from ROUTINES CALLED ! list. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DCGN ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(N), ATDZ(N), ATP(N), ATZ(N), B(N), DZ(N), P(N), & R(N), RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE, MTTVEC ! .. Local Scalars .. DOUBLE PRECISION AK, AKDEN, BK, BKDEN, BKNUM, BNRM, SOLNRM, TOLMIN INTEGER I, K ! .. External Functions .. DOUBLE PRECISION D1MACH, DDOT INTEGER ISDCGN EXTERNAL D1MACH, DDOT, ISDCGN ! .. External Subroutines .. EXTERNAL DAXPY, DCOPY !***FIRST EXECUTABLE STATEMENT DCGN ! ! Check user input. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if TOLMIN = 500*D1MACH(3) if ( TOL < TOLMIN ) THEN TOL = TOLMIN IERR = 4 end if ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N R(I) = B(I) - R(I) 10 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) call MTTVEC(N, Z, ATZ, NELT, IA, JA, A, ISYM) ! if ( ISDCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ATP, ATZ, & DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) & go to 200 if ( IERR /= 0 ) RETURN ! ! ***** iteration loop ***** ! DO 100 K=1,ITMAX ITER = K ! ! Calculate coefficient BK and direction vector P. BKNUM = DDOT(N, Z, 1, R, 1) if ( BKNUM <= 0.0D0 ) THEN IERR = 6 return ENDIF if ( ITER == 1) THEN call DCOPY(N, Z, 1, P, 1) ELSE BK = BKNUM/BKDEN DO 20 I = 1, N P(I) = Z(I) + BK*P(I) 20 CONTINUE ENDIF BKDEN = BKNUM ! ! Calculate coefficient AK, new iterate X, new residual R, ! and new pseudo-residual ATZ. if ( ITER /= 1) call DAXPY(N, BK, ATP, 1, ATZ, 1) call DCOPY(N, ATZ, 1, ATP, 1) AKDEN = DDOT(N, ATP, 1, ATP, 1) if ( AKDEN <= 0.0D0 ) THEN IERR = 6 return ENDIF AK = BKNUM/AKDEN call DAXPY(N, AK, ATP, 1, X, 1) call MATVEC(N, ATP, Z, NELT, IA, JA, A, ISYM) call DAXPY(N, -AK, Z, 1, R, 1) call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) call MTTVEC(N, Z, ATZ, NELT, IA, JA, A, ISYM) ! ! check stopping criterion. if ( ISDCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, & MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, & Z, P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, & SOLNRM) /= 0) GOTO 200 ! 100 CONTINUE ! ! ***** end of loop ***** ! ! stopping criterion not satisfied. ITER = ITMAX + 1 ! 200 return !------------- LAST LINE OF DCGN FOLLOWS ---------------------------- end subroutine DCGS (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U, V1, & V2, RWORK, IWORK) ! !! DCGS is the Preconditioned BiConjugate Gradient Squared Ax=b Solver. ! Routine to solve a Non-Symmetric linear system Ax = b ! using the Preconditioned BiConjugate Gradient Squared ! method. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SCGS-S, DCGS-D) !***KEYWORDS BICONJUGATE GRADIENT, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), R0(N), P(N) ! DOUBLE PRECISION Q(N), U(N), V1(N), V2(N), RWORK(USER DEFINED) ! EXTERNAL MATVEC, MSOLVE ! ! call DCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, ! $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, ! $ R, R0, P, Q, U, V1, V2, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, ! for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! operation Y = A*X given A and X. The name of the MATVEC ! routine must be declared external in the calling program. ! The calling sequence of MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X upon ! return, X is an input vector. NELT, IA, JA, A and ISYM ! define the SLAP matrix data structure: see Description,below. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for Z ! given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine ! must be declared external in the calling program. The ! calling sequence of MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector, and Z is the solution upon return. NELT, IA, JA, A ! and ISYM define the SLAP matrix data structure: see ! Description, below. RWORK is a double precision array that ! can be used to pass necessary preconditioning information and/ ! or workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! This routine must calculate the residual from R = A*X - B. ! This is unnatural and hence expensive for this type of iter- ! ative method. ITOL=2 is *STRONGLY* recommended. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv time a vector is the pre- ! conditioning step. This is the *NATURAL* stopping for this ! iterative method and is *STRONGLY* recommended. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Breakdown of the method detected. ! (r0,r) approximately 0. ! IERR = 6 => Stagnation of the method detected. ! (r0,v) approximately 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Double Precision R(N). ! R0 :WORK Double Precision R0(N). ! P :WORK Double Precision P(N). ! Q :WORK Double Precision Q(N). ! U :WORK Double Precision U(N). ! V1 :WORK Double Precision V1(N). ! V2 :WORK Double Precision V2(N). ! Double Precision arrays used for workspace. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used for workspace in ! MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE. ! ! *Description ! This routine does not care what matrix data structure is ! used for A and M. It simply calls the MATVEC and MSOLVE ! routines, with the arguments as described above. The user ! could write any type of structure and the appropriate MATVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK in some fashion. The SLAP ! routines DSDBCG and DSLUCS are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the double pre- ! cision array A. In other words, for each column in the ! matrix first put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- ! th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) ! are the last elements of the ICOL-th column. Note that we ! always have JA(N+1)=NELT+1, where N is the number of columns ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DSDCGS, DSLUCS !***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver ! for nonsymmetric linear systems, Delft University ! of Technology Report 84-16, Department of Mathe- ! matics and Informatics, Delft, The Netherlands. ! 2. E. F. Kaasschieter, The solution of non-symmetric ! linear systems by biconjugate gradients or conjugate ! gradients squared, Delft University of Technology ! Report 86-21, Department of Mathematics and Informa- ! tics, Delft, The Netherlands. ! 3. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED D1MACH, DAXPY, DDOT, ISDCGS !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DCGS ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), P(N), Q(N), R(N), R0(N), RWORK(*), & U(N), V1(N), V2(N), X(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. DOUBLE PRECISION AK, AKM, BK, BNRM, FUZZ, RHON, RHONM1, SIGMA, & SOLNRM, TOLMIN INTEGER I, K ! .. External Functions .. DOUBLE PRECISION D1MACH, DDOT INTEGER ISDCGS EXTERNAL D1MACH, DDOT, ISDCGS ! .. External Subroutines .. EXTERNAL DAXPY ! .. Intrinsic Functions .. INTRINSIC ABS !***FIRST EXECUTABLE STATEMENT DCGS ! ! Check some of the input data. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if TOLMIN = 500*D1MACH(3) if ( TOL < TOLMIN ) THEN TOL = TOLMIN IERR = 4 end if ! ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N V1(I) = R(I) - B(I) 10 CONTINUE call MSOLVE(N, V1, R, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! if ( ISDCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, & U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) & go to 200 if ( IERR /= 0 ) RETURN ! ! Set initial values. ! FUZZ = D1MACH(3)**2 DO 20 I = 1, N R0(I) = R(I) 20 CONTINUE RHONM1 = 1 ! ! ***** ITERATION LOOP ***** ! DO 100 K=1,ITMAX ITER = K ! ! Calculate coefficient BK and direction vectors U, V and P. RHON = DDOT(N, R0, 1, R, 1) if ( ABS(RHONM1) < FUZZ ) GOTO 998 BK = RHON/RHONM1 if ( ITER == 1 ) THEN DO 30 I = 1, N U(I) = R(I) P(I) = R(I) 30 CONTINUE ELSE DO 40 I = 1, N U(I) = R(I) + BK*Q(I) V1(I) = Q(I) + BK*P(I) 40 CONTINUE DO 50 I = 1, N P(I) = U(I) + BK*V1(I) 50 CONTINUE ENDIF ! ! Calculate coefficient AK, new iterate X, Q call MATVEC(N, P, V2, NELT, IA, JA, A, ISYM) call MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK) SIGMA = DDOT(N, R0, 1, V1, 1) if ( ABS(SIGMA) < FUZZ ) GOTO 999 AK = RHON/SIGMA AKM = -AK DO 60 I = 1, N Q(I) = U(I) + AKM*V1(I) 60 CONTINUE DO 70 I = 1, N V1(I) = U(I) + Q(I) 70 CONTINUE ! X = X - ak*V1. call DAXPY( N, AKM, V1, 1, X, 1 ) ! -1 ! R = R - ak*M *A*V1 call MATVEC(N, V1, V2, NELT, IA, JA, A, ISYM) call MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK) call DAXPY( N, AKM, V1, 1, R, 1 ) ! ! check stopping criterion. if ( ISDCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, & U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) & go to 200 ! ! Update RHO. RHONM1 = RHON 100 CONTINUE ! ! ***** end of loop ***** ! Stopping criterion not satisfied. ITER = ITMAX + 1 IERR = 2 200 return ! ! Breakdown of method detected. 998 IERR = 5 return ! ! Stagnation of method detected. 999 IERR = 6 return !------------- LAST LINE OF DCGS FOLLOWS ---------------------------- end subroutine DCHDC (A, LDA, P, WORK, JPVT, JOB, INFO) ! !! DCHDC computes the Cholesky decomposition of a positive definite matrix. ! A pivoting option allows the user to estimate the ! condition number of a positive definite matrix or determine ! the rank of a positive semidefinite matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE DOUBLE PRECISION (SCHDC-S, DCHDC-D, CCHDC-C) !***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, ! POSITIVE DEFINITE !***AUTHOR Dongarra, J., (ANL) ! Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! DCHDC computes the Cholesky decomposition of a positive definite ! matrix. A pivoting option allows the user to estimate the ! condition of a positive definite matrix or determine the rank ! of a positive semidefinite matrix. ! ! On Entry ! ! A DOUBLE PRECISION(LDA,P). ! A contains the matrix whose decomposition is to ! be computed. Only the upper half of A need be stored. ! The lower part of the array A is not referenced. ! ! LDA INTEGER. ! LDA is the leading dimension of the array A. ! ! P INTEGER. ! P is the order of the matrix. ! ! WORK DOUBLE PRECISION. ! WORK is a work array. ! ! JPVT INTEGER(P). ! JPVT contains integers that control the selection ! of the pivot elements, if pivoting has been requested. ! Each diagonal element A(K,K) ! is placed in one of three classes according to the ! value of JPVT(K). ! ! If JPVT(K) > 0, then X(K) is an initial ! element. ! ! If JPVT(K) == 0, then X(K) is a free element. ! ! If JPVT(K) < 0, then X(K) is a final element. ! ! Before the decomposition is computed, initial elements ! are moved by symmetric row and column interchanges to ! the beginning of the array A and final ! elements to the end. Both initial and final elements ! are frozen in place during the computation and only ! free elements are moved. At the K-th stage of the ! reduction, if A(K,K) is occupied by a free element ! it is interchanged with the largest free element ! A(L,L) with L >= K. JPVT is not referenced if ! JOB == 0. ! ! JOB INTEGER. ! JOB is an integer that initiates column pivoting. ! If JOB == 0, no pivoting is done. ! If JOB /= 0, pivoting is done. ! ! On Return ! ! A A contains in its upper half the Cholesky factor ! of the matrix A as it has been permuted by pivoting. ! ! JPVT JPVT(J) contains the index of the diagonal element ! of a that was moved into the J-th position, ! provided pivoting was requested. ! ! INFO contains the index of the last positive diagonal ! element of the Cholesky factor. ! ! For positive definite matrices INFO = P is the normal return. ! For pivoting with positive semidefinite matrices INFO will ! in general be less than P. However, INFO may be greater than ! the rank of A, since rounding error can cause an otherwise zero ! element to be positive. Indefinite systems will always cause ! INFO to be less than P. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DSWAP !***REVISION HISTORY (YYMMDD) ! 790319 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DCHDC INTEGER LDA,P,JPVT(*),JOB,INFO DOUBLE PRECISION A(LDA,*),WORK(*) ! INTEGER PU,PL,PLP1,J,JP,JT,K,KB,KM1,KP1,L,MAXL DOUBLE PRECISION TEMP DOUBLE PRECISION MAXDIA LOGICAL SWAPK,NEGK !***FIRST EXECUTABLE STATEMENT DCHDC PL = 1 PU = 0 INFO = P if (JOB == 0) go to 160 ! ! PIVOTING HAS BEEN REQUESTED. REARRANGE THE ! THE ELEMENTS ACCORDING TO JPVT. ! DO 70 K = 1, P SWAPK = JPVT(K) > 0 NEGK = JPVT(K) < 0 JPVT(K) = K if (NEGK) JPVT(K) = -JPVT(K) if (.NOT.SWAPK) go to 60 if (K == PL) go to 50 call DSWAP(PL-1,A(1,K),1,A(1,PL),1) TEMP = A(K,K) A(K,K) = A(PL,PL) A(PL,PL) = TEMP PLP1 = PL + 1 if (P < PLP1) go to 40 DO 30 J = PLP1, P if (J >= K) go to 10 TEMP = A(PL,J) A(PL,J) = A(J,K) A(J,K) = TEMP go to 20 10 CONTINUE if (J == K) go to 20 TEMP = A(K,J) A(K,J) = A(PL,J) A(PL,J) = TEMP 20 CONTINUE 30 CONTINUE 40 CONTINUE JPVT(K) = JPVT(PL) JPVT(PL) = K 50 CONTINUE PL = PL + 1 60 CONTINUE 70 CONTINUE PU = P if (P < PL) go to 150 DO 140 KB = PL, P K = P - KB + PL if (JPVT(K) >= 0) go to 130 JPVT(K) = -JPVT(K) if (PU == K) go to 120 call DSWAP(K-1,A(1,K),1,A(1,PU),1) TEMP = A(K,K) A(K,K) = A(PU,PU) A(PU,PU) = TEMP KP1 = K + 1 if (P < KP1) go to 110 DO 100 J = KP1, P if (J >= PU) go to 80 TEMP = A(K,J) A(K,J) = A(J,PU) A(J,PU) = TEMP go to 90 80 CONTINUE if (J == PU) go to 90 TEMP = A(K,J) A(K,J) = A(PU,J) A(PU,J) = TEMP 90 CONTINUE 100 CONTINUE 110 CONTINUE JT = JPVT(K) JPVT(K) = JPVT(PU) JPVT(PU) = JT 120 CONTINUE PU = PU - 1 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE DO 270 K = 1, P ! ! REDUCTION LOOP. ! MAXDIA = A(K,K) KP1 = K + 1 MAXL = K ! ! DETERMINE THE PIVOT ELEMENT. ! if (K < PL .OR. K >= PU) go to 190 DO 180 L = KP1, PU if (A(L,L) <= MAXDIA) go to 170 MAXDIA = A(L,L) MAXL = L 170 CONTINUE 180 CONTINUE 190 CONTINUE ! ! QUIT if THE PIVOT ELEMENT IS NOT POSITIVE. ! if (MAXDIA > 0.0D0) go to 200 INFO = K - 1 go to 280 200 CONTINUE if (K == MAXL) go to 210 ! ! START THE PIVOTING AND UPDATE JPVT. ! KM1 = K - 1 call DSWAP(KM1,A(1,K),1,A(1,MAXL),1) A(MAXL,MAXL) = A(K,K) A(K,K) = MAXDIA JP = JPVT(MAXL) JPVT(MAXL) = JPVT(K) JPVT(K) = JP 210 CONTINUE ! ! REDUCTION STEP. PIVOTING IS CONTAINED ACROSS THE ROWS. ! WORK(K) = SQRT(A(K,K)) A(K,K) = WORK(K) if (P < KP1) go to 260 DO 250 J = KP1, P if (K == MAXL) go to 240 if (J >= MAXL) go to 220 TEMP = A(K,J) A(K,J) = A(J,MAXL) A(J,MAXL) = TEMP go to 230 220 CONTINUE if (J == MAXL) go to 230 TEMP = A(K,J) A(K,J) = A(MAXL,J) A(MAXL,J) = TEMP 230 CONTINUE 240 CONTINUE A(K,J) = A(K,J)/WORK(K) WORK(J) = A(K,J) TEMP = -A(K,J) call DAXPY(J-K,TEMP,WORK(KP1),1,A(KP1,J),1) 250 CONTINUE 260 CONTINUE 270 CONTINUE 280 CONTINUE return end subroutine DCHDD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S, INFO) ! !! DCHDD downdates an augmented Cholesky decomposition or the ... ! triangular factor of an augmented QR decomposition. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D7B !***TYPE DOUBLE PRECISION (SCHDD-S, DCHDD-D, CCHDD-C) !***KEYWORDS CHOLESKY DECOMPOSITION, DOWNDATE, LINEAR ALGEBRA, LINPACK, ! MATRIX !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! DCHDD downdates an augmented Cholesky decomposition or the ! triangular factor of an augmented QR decomposition. ! Specifically, given an upper triangular matrix R of order P, a ! row vector X, a column vector Z, and a scalar Y, DCHDD ! determines an orthogonal matrix U and a scalar ZETA such that ! ! (R Z ) (RR ZZ) ! U * ( ) = ( ) , ! (0 ZETA) ( X Y) ! ! where RR is upper triangular. If R and Z have been obtained ! from the factorization of a least squares problem, then ! RR and ZZ are the factors corresponding to the problem ! with the observation (X,Y) removed. In this case, if RHO ! is the norm of the residual vector, then the norm of ! the residual vector of the downdated problem is ! SQRT(RHO**2 - ZETA**2). DCHDD will simultaneously downdate ! several triplets (Z,Y,RHO) along with R. ! For a less terse description of what DCHDD does and how ! it may be applied, see the LINPACK guide. ! ! The matrix U is determined as the product U(1)*...*U(P) ! where U(I) is a rotation in the (P+1,I)-plane of the ! form ! ! ( C(I) -S(I) ) ! ( ) . ! ( S(I) C(I) ) ! ! The rotations are chosen so that C(I) is double precision. ! ! The user is warned that a given downdating problem may ! be impossible to accomplish or may produce ! inaccurate results. For example, this can happen ! if X is near a vector whose removal will reduce the ! rank of R. Beware. ! ! On Entry ! ! R DOUBLE PRECISION(LDR,P), where LDR >= P. ! R contains the upper triangular matrix ! that is to be downdated. The part of R ! below the diagonal is not referenced. ! ! LDR INTEGER. ! LDR is the leading dimension of the array R. ! ! P INTEGER. ! P is the order of the matrix R. ! ! X DOUBLE PRECISION(P). ! X contains the row vector that is to ! be removed from R. X is not altered by DCHDD. ! ! Z DOUBLE PRECISION(LDZ,N)Z), where LDZ >= P. ! Z is an array of NZ P-vectors which ! are to be downdated along with R. ! ! LDZ INTEGER. ! LDZ is the leading dimension of the array Z. ! ! NZ INTEGER. ! NZ is the number of vectors to be downdated ! NZ may be zero, in which case Z, Y, and RHO ! are not referenced. ! ! Y DOUBLE PRECISION(NZ). ! Y contains the scalars for the downdating ! of the vectors Z. Y is not altered by DCHDD. ! ! RHO DOUBLE PRECISION(NZ). ! RHO contains the norms of the residual ! vectors that are to be downdated. ! ! On Return ! ! R ! Z contain the downdated quantities. ! RHO ! ! C DOUBLE PRECISION(P). ! C contains the cosines of the transforming ! rotations. ! ! S DOUBLE PRECISION(P). ! S contains the sines of the transforming ! rotations. ! ! INFO INTEGER. ! INFO is set as follows. ! ! INFO = 0 if the entire downdating ! was successful. ! ! INFO =-1 if R could not be downdated. ! in this case, all quantities ! are left unaltered. ! ! INFO = 1 if some RHO could not be ! downdated. The offending RHO's are ! set to -1. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DDOT, DNRM2 !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DCHDD INTEGER LDR,P,LDZ,NZ,INFO DOUBLE PRECISION R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) DOUBLE PRECISION RHO(*),C(*) ! INTEGER I,II,J DOUBLE PRECISION A,ALPHA,AZETA,NORM,DNRM2 DOUBLE PRECISION DDOT,T,ZETA,B,XX,SCALE ! ! SOLVE THE SYSTEM TRANS(R)*A = X, PLACING THE RESULT ! IN THE ARRAY S. ! !***FIRST EXECUTABLE STATEMENT DCHDD INFO = 0 S(1) = X(1)/R(1,1) if (P < 2) go to 20 DO 10 J = 2, P S(J) = X(J) - DDOT(J-1,R(1,J),1,S,1) S(J) = S(J)/R(J,J) 10 CONTINUE 20 CONTINUE NORM = DNRM2(P,S,1) if (NORM < 1.0D0) go to 30 INFO = -1 go to 120 30 CONTINUE ALPHA = SQRT(1.0D0-NORM**2) ! ! DETERMINE THE TRANSFORMATIONS. ! DO 40 II = 1, P I = P - II + 1 SCALE = ALPHA + ABS(S(I)) A = ALPHA/SCALE B = S(I)/SCALE NORM = SQRT(A**2+B**2) C(I) = A/NORM S(I) = B/NORM ALPHA = SCALE*NORM 40 CONTINUE ! ! APPLY THE TRANSFORMATIONS TO R. ! DO 60 J = 1, P XX = 0.0D0 DO 50 II = 1, J I = J - II + 1 T = C(I)*XX + S(I)*R(I,J) R(I,J) = C(I)*R(I,J) - S(I)*XX XX = T 50 CONTINUE 60 CONTINUE ! ! if REQUIRED, DOWNDATE Z AND RHO. ! if (NZ < 1) go to 110 DO 100 J = 1, NZ ZETA = Y(J) DO 70 I = 1, P Z(I,J) = (Z(I,J) - S(I)*ZETA)/C(I) ZETA = C(I)*ZETA - S(I)*Z(I,J) 70 CONTINUE AZETA = ABS(ZETA) if (AZETA <= RHO(J)) go to 80 INFO = 1 RHO(J) = -1.0D0 go to 90 80 CONTINUE RHO(J) = RHO(J)*SQRT(1.0D0-(AZETA/RHO(J))**2) 90 CONTINUE 100 CONTINUE 110 CONTINUE 120 CONTINUE return end subroutine DCHEX (R, LDR, P, K, L, Z, LDZ, NZ, C, S, JOB) ! !! DCHEX updates the Cholesky factorization A=TRANS(R)*R of a ... ! positive definite matrix A of order P under diagonal ... ! permutations of the form TRANS(E)*A*E, where E is a ... ! permutation matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D7B !***TYPE DOUBLE PRECISION (SCHEX-S, DCHEX-D, CCHEX-C) !***KEYWORDS CHOLESKY DECOMPOSITION, EXCHANGE, LINEAR ALGEBRA, LINPACK, ! MATRIX, POSITIVE DEFINITE !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! DCHEX updates the Cholesky factorization ! ! A = TRANS(R)*R ! ! of a positive definite matrix A of order P under diagonal ! permutations of the form ! ! TRANS(E)*A*E ! ! where E is a permutation matrix. Specifically, given ! an upper triangular matrix R and a permutation matrix ! E (which is specified by K, L, and JOB), DCHEX determines ! an orthogonal matrix U such that ! ! U*R*E = RR, ! ! where RR is upper triangular. At the users option, the ! transformation U will be multiplied into the array Z. ! If A = TRANS(X)*X, so that R is the triangular part of the ! QR factorization of X, then RR is the triangular part of the ! QR factorization of X*E, i.e. X with its columns permuted. ! For a less terse description of what DCHEX does and how ! it may be applied, see the LINPACK guide. ! ! The matrix Q is determined as the product U(L-K)*...*U(1) ! of plane rotations of the form ! ! ( C(I) S(I) ) ! ( ) , ! ( -S(I) C(I) ) ! ! where C(I) is double precision. The rows these rotations operate ! on are described below. ! ! There are two types of permutations, which are determined ! by the value of JOB. ! ! 1. Right circular shift (JOB = 1). ! ! The columns are rearranged in the following order. ! ! 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. ! ! U is the product of L-K rotations U(I), where U(I) ! acts in the (L-I,L-I+1)-plane. ! ! 2. Left circular shift (JOB = 2). ! The columns are rearranged in the following order ! ! 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. ! ! U is the product of L-K rotations U(I), where U(I) ! acts in the (K+I-1,K+I)-plane. ! ! On Entry ! ! R DOUBLE PRECISION(LDR,P), where LDR >= P. ! R contains the upper triangular factor ! that is to be updated. Elements of R ! below the diagonal are not referenced. ! ! LDR INTEGER. ! LDR is the leading dimension of the array R. ! ! P INTEGER. ! P is the order of the matrix R. ! ! K INTEGER. ! K is the first column to be permuted. ! ! L INTEGER. ! L is the last column to be permuted. ! L must be strictly greater than K. ! ! Z DOUBLE PRECISION(LDZ,N)Z), where LDZ >= P. ! Z is an array of NZ P-vectors into which the ! transformation U is multiplied. Z is ! not referenced if NZ = 0. ! ! LDZ INTEGER. ! LDZ is the leading dimension of the array Z. ! ! NZ INTEGER. ! NZ is the number of columns of the matrix Z. ! ! JOB INTEGER. ! JOB determines the type of permutation. ! JOB = 1 right circular shift. ! JOB = 2 left circular shift. ! ! On Return ! ! R contains the updated factor. ! ! Z contains the updated matrix Z. ! ! C DOUBLE PRECISION(P). ! C contains the cosines of the transforming rotations. ! ! S DOUBLE PRECISION(P). ! S contains the sines of the transforming rotations. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DROTG !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DCHEX INTEGER LDR,P,K,L,LDZ,NZ,JOB DOUBLE PRECISION R(LDR,*),Z(LDZ,*),S(*) DOUBLE PRECISION C(*) ! INTEGER I,II,IL,IU,J,JJ,KM1,KP1,LMK,LM1 DOUBLE PRECISION T ! ! INITIALIZE ! !***FIRST EXECUTABLE STATEMENT DCHEX KM1 = K - 1 KP1 = K + 1 LMK = L - K LM1 = L - 1 ! ! PERFORM THE APPROPRIATE TASK. ! go to (10,130), JOB ! ! RIGHT CIRCULAR SHIFT. ! 10 CONTINUE ! ! REORDER THE COLUMNS. ! DO 20 I = 1, L II = L - I + 1 S(I) = R(II,L) 20 CONTINUE DO 40 JJ = K, LM1 J = LM1 - JJ + K DO 30 I = 1, J R(I,J+1) = R(I,J) 30 CONTINUE R(J+1,J+1) = 0.0D0 40 CONTINUE if (K == 1) go to 60 DO 50 I = 1, KM1 II = L - I + 1 R(I,K) = S(II) 50 CONTINUE 60 CONTINUE ! ! CALCULATE THE ROTATIONS. ! T = S(1) DO 70 I = 1, LMK call DROTG(S(I+1),T,C(I),S(I)) T = S(I+1) 70 CONTINUE R(K,K) = T DO 90 J = KP1, P IL = MAX(1,L-J+1) DO 80 II = IL, LMK I = L - II T = C(II)*R(I,J) + S(II)*R(I+1,J) R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) R(I,J) = T 80 CONTINUE 90 CONTINUE ! ! if REQUIRED, APPLY THE TRANSFORMATIONS TO Z. ! if (NZ < 1) go to 120 DO 110 J = 1, NZ DO 100 II = 1, LMK I = L - II T = C(II)*Z(I,J) + S(II)*Z(I+1,J) Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) Z(I,J) = T 100 CONTINUE 110 CONTINUE 120 CONTINUE go to 260 ! ! LEFT CIRCULAR SHIFT ! 130 CONTINUE ! ! REORDER THE COLUMNS ! DO 140 I = 1, K II = LMK + I S(II) = R(I,K) 140 CONTINUE DO 160 J = K, LM1 DO 150 I = 1, J R(I,J) = R(I,J+1) 150 CONTINUE JJ = J - KM1 S(JJ) = R(J+1,J+1) 160 CONTINUE DO 170 I = 1, K II = LMK + I R(I,L) = S(II) 170 CONTINUE DO 180 I = KP1, L R(I,L) = 0.0D0 180 CONTINUE ! ! REDUCTION LOOP. ! DO 220 J = K, P if (J == K) go to 200 ! ! APPLY THE ROTATIONS. ! IU = MIN(J-1,L-1) DO 190 I = K, IU II = I - K + 1 T = C(II)*R(I,J) + S(II)*R(I+1,J) R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) R(I,J) = T 190 CONTINUE 200 CONTINUE if (J >= L) go to 210 JJ = J - K + 1 T = S(JJ) call DROTG(R(J,J),T,C(JJ),S(JJ)) 210 CONTINUE 220 CONTINUE ! ! APPLY THE ROTATIONS TO Z. ! if (NZ < 1) go to 250 DO 240 J = 1, NZ DO 230 I = K, LM1 II = I - KM1 T = C(II)*Z(I,J) + S(II)*Z(I+1,J) Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) Z(I,J) = T 230 CONTINUE 240 CONTINUE 250 CONTINUE 260 CONTINUE return end INTEGER FUNCTION DCHFCM (D1, D2, DELTA) ! !! DCHFCM checks a single cubic for monotonicity. ! !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (CHFCM-S, DCHFCM-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! *Usage: ! ! DOUBLE PRECISION D1, D2, DELTA ! INTEGER ISMON, DCHFCM ! ! ISMON = DCHFCM (D1, D2, DELTA) ! ! *Arguments: ! ! D1,D2:IN are the derivative values at the ends of an interval. ! ! DELTA:IN is the data slope over that interval. ! ! *Function Return Values: ! ISMON : indicates the monotonicity of the cubic segment: ! ISMON = -3 if function is probably decreasing; ! ISMON = -1 if function is strictly decreasing; ! ISMON = 0 if function is constant; ! ISMON = 1 if function is strictly increasing; ! ISMON = 2 if function is non-monotonic; ! ISMON = 3 if function is probably increasing. ! If ABS(ISMON)=3, the derivative values are too close to the ! boundary of the monotonicity region to declare monotonicity ! in the presence of roundoff error. ! ! *Description: ! ! DCHFCM: Cubic Hermite Function -- Check Monotonicity. ! ! Called by DPCHCM to determine the monotonicity properties of the ! cubic with boundary derivative values D1,D2 and chord slope DELTA. ! ! *Cautions: ! This is essentially the same as old DCHFMC, except that a ! new output value, -3, was added February 1989. (Formerly, -3 ! and +3 were lumped together in the single value 3.) Codes that ! flag nonmonotonicity by "IF (ISMON == 2)" need not be changed. ! Codes that check via "IF (ISMON >= 3)" should change the test to ! "IF (IABS(ISMON) >= 3)". Codes that declare monotonicity via ! "IF (ISMON <= 1)" should change to "IF (IABS(ISMON) <= 1)". ! ! REFER TO DPCHCM ! !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 820518 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 831201 Changed from ISIGN to SIGN to correct bug that ! produced wrong sign when -1 < DELTA < 0 . ! 890206 Added SAVE statements. ! 890209 Added sign to returned value ISMON=3 and corrected ! argument description accordingly. ! 890306 Added caution about changed output. ! 890407 Changed name from DCHFMC to DCHFCM, as requested at the ! March 1989 SLATEC CML meeting, and made a few other ! minor modifications necessitated by this change. ! 890407 Converted to new SLATEC format. ! 890407 Modified DESCRIPTION to LDOC format. ! 891214 Moved SAVE statements. (WRB) !***END PROLOGUE DCHFCM ! ! Fortran intrinsics used: DSIGN. ! Other routines used: D1MACH. ! ! ---------------------------------------------------------------------- ! ! Programming notes: ! ! TEN is actually a tuning parameter, which determines the width of ! the fuzz around the elliptical boundary. ! ! To produce a single precision version, simply: ! a. Change DCHFCM to CHFCM wherever it occurs, ! b. Change the double precision declarations to real, and ! c. Change the constants ZERO, ONE, ... to single precision. ! ! DECLARE ARGUMENTS. ! DOUBLE PRECISION D1, D2, DELTA, D1MACH ! ! DECLARE LOCAL VARIABLES. ! INTEGER ISMON, ITRUE DOUBLE PRECISION A, B, EPS, FOUR, ONE, PHI, TEN, THREE, TWO, & ZERO SAVE ZERO, ONE, TWO, THREE, FOUR SAVE TEN ! ! INITIALIZE. ! DATA ZERO /0.D0/, ONE/1.D0/, TWO/2.D0/, THREE/3.D0/, FOUR/4.D0/, & TEN /10.D0/ ! ! MACHINE-DEPENDENT PARAMETER -- SHOULD BE ABOUT 10*UROUND. !***FIRST EXECUTABLE STATEMENT DCHFCM EPS = TEN*D1MACH(4) ! ! MAKE THE CHECK. ! if (DELTA == ZERO) THEN ! CASE OF CONSTANT DATA. if ((D1 == ZERO) .AND. (D2 == ZERO)) THEN ISMON = 0 ELSE ISMON = 2 ENDIF ELSE ! DATA IS NOT CONSTANT -- PICK UP SIGN. ITRUE = DSIGN (ONE, DELTA) A = D1/DELTA B = D2/DELTA if ((A < ZERO) .OR. (B < ZERO)) THEN ISMON = 2 ELSE if ((A <= THREE-EPS) .AND. (B <= THREE-EPS)) THEN ! INSIDE SQUARE (0,3)X(0,3) IMPLIES OK. ISMON = ITRUE ELSE if ((A > FOUR+EPS) .AND. (B > FOUR+EPS)) THEN ! OUTSIDE SQUARE (0,4)X(0,4) IMPLIES NONMONOTONIC. ISMON = 2 ELSE ! MUST CHECK AGAINST BOUNDARY OF ELLIPSE. A = A - TWO B = B - TWO PHI = ((A*A + B*B) + A*B) - THREE if (PHI < -EPS) THEN ISMON = ITRUE ELSE if (PHI > EPS) THEN ISMON = 2 ELSE ! TO CLOSE TO BOUNDARY TO TELL, ! IN THE PRESENCE OF ROUND-OFF ERRORS. ISMON = 3*ITRUE ENDIF ENDIF end if ! ! return VALUE. ! DCHFCM = ISMON return !------------- LAST LINE OF DCHFCM FOLLOWS ----------------------------- end subroutine DCHFDV (X1, X2, F1, F2, D1, D2, NE, XE, FE, DE, NEXT, & IERR) ! !! DCHFDV evaluates a cubic polynomial given in Hermite form and its ... ! first derivative at an array of points. ! ! While designed for ! use by DPCHFD, it may be useful directly as an evaluator ! for a piecewise cubic Hermite function in applications, ! such as graphing, where the interval is known in advance. ! If only function values are required, use DCHFEV instead. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3, H1 !***TYPE DOUBLE PRECISION (CHFDV-S, DCHFDV-D) !***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, ! CUBIC POLYNOMIAL EVALUATION, PCHIP !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! DCHFDV: Cubic Hermite Function and Derivative Evaluator ! ! Evaluates the cubic polynomial determined by function values ! F1,F2 and derivatives D1,D2 on interval (X1,X2), together with ! its first derivative, at the points XE(J), J=1(1)NE. ! ! If only function values are required, use DCHFEV, instead. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! INTEGER NE, NEXT(2), IERR ! DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(NE), FE(NE), ! DE(NE) ! ! call DCHFDV (X1,X2, F1,F2, D1,D2, NE, XE, FE, DE, NEXT, IERR) ! ! Parameters: ! ! X1,X2 -- (input) endpoints of interval of definition of cubic. ! (Error return if X1 == X2 .) ! ! F1,F2 -- (input) values of function at X1 and X2, respectively. ! ! D1,D2 -- (input) values of derivative at X1 and X2, respectively. ! ! NE -- (input) number of evaluation points. (Error return if ! NE < 1 .) ! ! XE -- (input) real*8 array of points at which the functions are to ! be evaluated. If any of the XE are outside the interval ! [X1,X2], a warning error is returned in NEXT. ! ! FE -- (output) real*8 array of values of the cubic function ! defined by X1,X2, F1,F2, D1,D2 at the points XE. ! ! DE -- (output) real*8 array of values of the first derivative of ! the same function at the points XE. ! ! NEXT -- (output) integer array indicating number of extrapolation ! points: ! NEXT(1) = number of evaluation points to left of interval. ! NEXT(2) = number of evaluation points to right of interval. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -1 if NE < 1 . ! IERR = -2 if X1 == X2 . ! (Output arrays have not been changed in either case.) ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811019 DATE WRITTEN ! 820803 Minor cosmetic changes for release 1. ! 870707 Corrected XERROR calls for d.p. names(s). ! 870813 Minor cosmetic changes. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DCHFDV ! Programming notes: ! ! To produce a single precision version, simply: ! a. Change DCHFDV to CHFDV wherever it occurs, ! b. Change the double precision declaration to real, and ! c. Change the constant ZERO to single precision. ! ! DECLARE ARGUMENTS. ! INTEGER NE, NEXT(2), IERR DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(*), FE(*), DE(*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I DOUBLE PRECISION C2, C2T2, C3, C3T3, DEL1, DEL2, DELTA, H, X, & XMI, XMA, ZERO SAVE ZERO DATA ZERO /0.D0/ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT DCHFDV if (NE < 1) go to 5001 H = X2 - X1 if (H == ZERO) go to 5002 ! ! INITIALIZE. ! IERR = 0 NEXT(1) = 0 NEXT(2) = 0 XMI = MIN(ZERO, H) XMA = MAX(ZERO, H) ! ! COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). ! DELTA = (F2 - F1)/H DEL1 = (D1 - DELTA)/H DEL2 = (D2 - DELTA)/H ! (DELTA IS NO LONGER NEEDED.) C2 = -(DEL1+DEL1 + DEL2) C2T2 = C2 + C2 C3 = (DEL1 + DEL2)/H ! (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) C3T3 = C3+C3+C3 ! ! EVALUATION LOOP. ! DO 500 I = 1, NE X = XE(I) - X1 FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) DE(I) = D1 + X*(C2T2 + X*C3T3) ! COUNT EXTRAPOLATION POINTS. if ( X < XMI ) NEXT(1) = NEXT(1) + 1 if ( X > XMA ) NEXT(2) = NEXT(2) + 1 ! (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) 500 CONTINUE ! ! NORMAL RETURN. ! return ! ! ERROR RETURNS. ! 5001 CONTINUE ! NE < 1 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DCHFDV', & 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) return ! 5002 CONTINUE ! X1 == X2 RETURN. IERR = -2 call XERMSG ('SLATEC', 'DCHFDV', 'INTERVAL ENDPOINTS EQUAL', & IERR, 1) return !------------- LAST LINE OF DCHFDV FOLLOWS ----------------------------- end subroutine DCHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR) ! !! DCHFEV evaluates a cubic polynomial in Hermite form at an array of points. ! ! While designed for use by DPCHFE, it may ! be useful directly as an evaluator for a piecewise cubic ! Hermite function in applications, such as graphing, where ! the interval is known in advance. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3 !***TYPE DOUBLE PRECISION (CHFEV-S, DCHFEV-D) !***KEYWORDS CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION, ! PCHIP !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! DCHFEV: Cubic Hermite Function EValuator ! ! Evaluates the cubic polynomial determined by function values ! F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points ! XE(J), J=1(1)NE. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! INTEGER NE, NEXT(2), IERR ! DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(NE), FE(NE) ! ! call DCHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR) ! ! Parameters: ! ! X1,X2 -- (input) endpoints of interval of definition of cubic. ! (Error return if X1 == X2 .) ! ! F1,F2 -- (input) values of function at X1 and X2, respectively. ! ! D1,D2 -- (input) values of derivative at X1 and X2, respectively. ! ! NE -- (input) number of evaluation points. (Error return if ! NE < 1 .) ! ! XE -- (input) real*8 array of points at which the function is to ! be evaluated. If any of the XE are outside the interval ! [X1,X2], a warning error is returned in NEXT. ! ! FE -- (output) real*8 array of values of the cubic function ! defined by X1,X2, F1,F2, D1,D2 at the points XE. ! ! NEXT -- (output) integer array indicating number of extrapolation ! points: ! NEXT(1) = number of evaluation points to left of interval. ! NEXT(2) = number of evaluation points to right of interval. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -1 if NE < 1 . ! IERR = -2 if X1 == X2 . ! (The FE-array has not been changed in either case.) ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811019 DATE WRITTEN ! 820803 Minor cosmetic changes for release 1. ! 870813 Corrected XERROR calls for d.p. names(s). ! 890206 Corrected XERROR calls. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DCHFEV ! Programming notes: ! ! To produce a single precision version, simply: ! a. Change DCHFEV to CHFEV wherever it occurs, ! b. Change the double precision declaration to real, and ! c. Change the constant ZERO to single precision. ! ! DECLARE ARGUMENTS. ! INTEGER NE, NEXT(2), IERR DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(*), FE(*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I DOUBLE PRECISION C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, & ZERO SAVE ZERO DATA ZERO /0.D0/ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT DCHFEV if (NE < 1) go to 5001 H = X2 - X1 if (H == ZERO) go to 5002 ! ! INITIALIZE. ! IERR = 0 NEXT(1) = 0 NEXT(2) = 0 XMI = MIN(ZERO, H) XMA = MAX(ZERO, H) ! ! COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). ! DELTA = (F2 - F1)/H DEL1 = (D1 - DELTA)/H DEL2 = (D2 - DELTA)/H ! (DELTA IS NO LONGER NEEDED.) C2 = -(DEL1+DEL1 + DEL2) C3 = (DEL1 + DEL2)/H ! (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) ! ! EVALUATION LOOP. ! DO 500 I = 1, NE X = XE(I) - X1 FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) ! COUNT EXTRAPOLATION POINTS. if ( X < XMI ) NEXT(1) = NEXT(1) + 1 if ( X > XMA ) NEXT(2) = NEXT(2) + 1 ! (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) 500 CONTINUE ! ! NORMAL RETURN. ! return ! ! ERROR RETURNS. ! 5001 CONTINUE ! NE < 1 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DCHFEV', & 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) return ! 5002 CONTINUE ! X1 == X2 RETURN. IERR = -2 call XERMSG ('SLATEC', 'DCHFEV', 'INTERVAL ENDPOINTS EQUAL', & IERR, 1) return end FUNCTION DCHFIE (X1, X2, F1, F2, D1, D2, A, B) ! !! DCHFIE evaluates the integral of a single cubic for DPCHIA. ! !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (CHFIE-S, DCHFIE-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DCHFIE: Cubic Hermite Function Integral Evaluator. ! ! Called by DPCHIA to evaluate the integral of a single cubic (in ! Hermite form) over an arbitrary interval (A,B). ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! DOUBLE PRECISION X1, X2, F1, F2, D1, D2, A, B ! DOUBLE PRECISION VALUE, DCHFIE ! ! VALUE = DCHFIE (X1, X2, F1, F2, D1, D2, A, B) ! ! Parameters: ! ! VALUE -- (output) value of the requested integral. ! ! X1,X2 -- (input) endpoints if interval of definition of cubic. ! ! F1,F2 -- (input) function values at the ends of the interval. ! ! D1,D2 -- (input) derivative values at the ends of the interval. ! ! A,B -- (input) endpoints of interval of integration. ! !***SEE ALSO DPCHIA !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820730 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 870707 Corrected subroutine name from DCHIV to DCHFIV. ! 870813 Minor cosmetic changes. ! 890411 1. Added SAVE statements (Vers. 3.2). ! 2. Added SIX to DOUBLE PRECISION declaration. ! 890411 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR section in prologue. (WRB) ! 930503 Corrected to set VALUE=0 when IERR.ne.0. (FNF) ! 930504 Eliminated IERR and changed name DCHFIV to DCHFIE. (FNF) !***END PROLOGUE DCHFIE ! ! Programming notes: ! 1. There is no error return from this routine because zero is ! indeed the mathematically correct answer when X1 == X2 . !**End ! ! DECLARE ARGUMENTS. ! DOUBLE PRECISION DCHFIE DOUBLE PRECISION X1, X2, F1, F2, D1, D2, A, B ! ! DECLARE LOCAL VARIABLES. ! DOUBLE PRECISION DTERM, FOUR, FTERM, H, HALF, PHIA1, PHIA2, & PHIB1, PHIB2, PSIA1, PSIA2, PSIB1, PSIB2, SIX, TA1, TA2, & TB1, TB2, THREE, TWO, UA1, UA2, UB1, UB2 SAVE HALF, TWO, THREE, FOUR, SIX ! ! INITIALIZE. ! DATA HALF/.5D0/, TWO/2.D0/, THREE/3.D0/, FOUR/4.D0/, SIX/6.D0/ ! ! VALIDITY CHECK INPUT. ! !***FIRST EXECUTABLE STATEMENT DCHFIE if (X1 == X2) THEN DCHFIE = 0 ELSE H = X2 - X1 TA1 = (A - X1) / H TA2 = (X2 - A) / H TB1 = (B - X1) / H TB2 = (X2 - B) / H ! UA1 = TA1**3 PHIA1 = UA1 * (TWO - TA1) PSIA1 = UA1 * (THREE*TA1 - FOUR) UA2 = TA2**3 PHIA2 = UA2 * (TWO - TA2) PSIA2 = -UA2 * (THREE*TA2 - FOUR) ! UB1 = TB1**3 PHIB1 = UB1 * (TWO - TB1) PSIB1 = UB1 * (THREE*TB1 - FOUR) UB2 = TB2**3 PHIB2 = UB2 * (TWO - TB2) PSIB2 = -UB2 * (THREE*TB2 - FOUR) ! FTERM = F1*(PHIA2 - PHIB2) + F2*(PHIB1 - PHIA1) DTERM = ( D1*(PSIA2 - PSIB2) + D2*(PSIB1 - PSIA1) )*(H/SIX) ! DCHFIE = (HALF*H) * (FTERM + DTERM) end if ! return end subroutine DCHKW (NAME, LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR) ! !! DCHKW is the SLAP WORK/IWORK Array Bounds Checker. ! ! This routine checks the work array lengths and interfaces ! to the SLATEC error handler if a problem is found. !***LIBRARY SLATEC (SLAP) !***CATEGORY R2 !***TYPE DOUBLE PRECISION (SCHKW-S, DCHKW-D) !***KEYWORDS ERROR CHECKING, SLAP, WORKSPACE CHECKING !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! CHARACTER*(*) NAME ! INTEGER LOCIW, LENIW, LOCW, LENW, IERR, ITER ! DOUBLE PRECISION ERR ! ! call DCHKW( NAME, LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) ! ! *Arguments: ! NAME :IN Character*(*). ! Name of the calling routine. This is used in the output ! message, if an error is detected. ! LOCIW :IN Integer. ! Location of the first free element in the integer workspace ! array. ! LENIW :IN Integer. ! Length of the integer workspace array. ! LOCW :IN Integer. ! Location of the first free element in the double precision ! workspace array. ! LENRW :IN Integer. ! Length of the double precision workspace array. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient storage allocated for ! WORK or IWORK. ! ITER :OUT Integer. ! Set to zero on return. ! ERR :OUT Double Precision. ! Set to the smallest positive magnitude if all went well. ! Set to a very large number if an error is detected. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 880225 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 900805 Changed XERRWV calls to calls to XERMSG. (RWC) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Corrected XERMSG calls to satisfy Section 6.2.2 of ANSI ! X3.9-1978. (FNF) ! 910506 Made subsidiary. (FNF) ! 920511 Added complete declaration section. (WRB) ! 921015 Added code to initialize ITER and ERR when IERR=0. (FNF) !***END PROLOGUE DCHKW ! .. Scalar Arguments .. DOUBLE PRECISION ERR INTEGER IERR, ITER, LENIW, LENW, LOCIW, LOCW CHARACTER NAME*(*) ! .. Local Scalars .. CHARACTER XERN1*8, XERN2*8, XERNAM*8 ! .. External Functions .. DOUBLE PRECISION D1MACH EXTERNAL D1MACH ! .. External Subroutines .. EXTERNAL XERMSG !***FIRST EXECUTABLE STATEMENT DCHKW ! ! Check the Integer workspace situation. ! IERR = 0 ITER = 0 ERR = D1MACH(1) if ( LOCIW > LENIW ) THEN IERR = 1 ERR = D1MACH(2) XERNAM = NAME WRITE (XERN1, '(I8)') LOCIW WRITE (XERN2, '(I8)') LENIW call XERMSG ('SLATEC', 'DCHKW', & 'In ' // XERNAM // ', INTEGER work array too short. ' // & 'IWORK needs ' // XERN1 // '; have allocated ' // XERN2, & 1, 1) end if ! ! Check the Double Precision workspace situation. if ( LOCW > LENW ) THEN IERR = 1 ERR = D1MACH(2) XERNAM = NAME WRITE (XERN1, '(I8)') LOCW WRITE (XERN2, '(I8)') LENW call XERMSG ('SLATEC', 'DCHKW', & 'In ' // XERNAM // ', DOUBLE PRECISION work array too ' // & 'short. RWORK needs ' // XERN1 // '; have allocated ' // & XERN2, 1, 1) end if return end subroutine DCHUD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S) ! !! DCHUD updates an augmented Cholesky decomposition... ! of the triangular part of an augmented QR decomposition. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D7B !***TYPE DOUBLE PRECISION (SCHUD-S, DCHUD-D, CCHUD-C) !***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, ! UPDATE !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! DCHUD updates an augmented Cholesky decomposition of the ! triangular part of an augmented QR decomposition. Specifically, ! given an upper triangular matrix R of order P, a row vector ! X, a column vector Z, and a scalar Y, DCHUD determines a ! unitary matrix U and a scalar ZETA such that ! ! ! (R Z) (RR ZZ ) ! U * ( ) = ( ) , ! (X Y) ( 0 ZETA) ! ! where RR is upper triangular. If R and Z have been ! obtained from the factorization of a least squares ! problem, then RR and ZZ are the factors corresponding to ! the problem with the observation (X,Y) appended. In this ! case, if RHO is the norm of the residual vector, then the ! norm of the residual vector of the updated problem is ! SQRT(RHO**2 + ZETA**2). DCHUD will simultaneously update ! several triplets (Z,Y,RHO). ! For a less terse description of what DCHUD does and how ! it may be applied, see the LINPACK guide. ! ! The matrix U is determined as the product U(P)*...*U(1), ! where U(I) is a rotation in the (I,P+1) plane of the ! form ! ! ( C(I) S(I) ) ! ( ) . ! ( -S(I) C(I) ) ! ! The rotations are chosen so that C(I) is double precision. ! ! On Entry ! ! R DOUBLE PRECISION(LDR,P), where LDR >= P. ! R contains the upper triangular matrix ! that is to be updated. The part of R ! below the diagonal is not referenced. ! ! LDR INTEGER. ! LDR is the leading dimension of the array R. ! ! P INTEGER. ! P is the order of the matrix R. ! ! X DOUBLE PRECISION(P). ! X contains the row to be added to R. X is ! not altered by DCHUD. ! ! Z DOUBLE PRECISION(LDZ,N)Z), where LDZ >= P. ! Z is an array containing NZ P-vectors to ! be updated with R. ! ! LDZ INTEGER. ! LDZ is the leading dimension of the array Z. ! ! NZ INTEGER. ! NZ is the number of vectors to be updated ! NZ may be zero, in which case Z, Y, and RHO ! are not referenced. ! ! Y DOUBLE PRECISION(NZ). ! Y contains the scalars for updating the vectors ! Z. Y is not altered by DCHUD. ! ! RHO DOUBLE PRECISION(NZ). ! RHO contains the norms of the residual ! vectors that are to be updated. If RHO(J) ! is negative, it is left unaltered. ! ! On Return ! ! RC ! RHO contain the updated quantities. ! Z ! ! C DOUBLE PRECISION(P). ! C contains the cosines of the transforming ! rotations. ! ! S DOUBLE PRECISION(P). ! S contains the sines of the transforming ! rotations. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DROTG !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DCHUD INTEGER LDR,P,LDZ,NZ DOUBLE PRECISION RHO(*),C(*) DOUBLE PRECISION R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) ! INTEGER I,J,JM1 DOUBLE PRECISION AZETA,SCALE DOUBLE PRECISION T,XJ,ZETA ! ! UPDATE R. ! !***FIRST EXECUTABLE STATEMENT DCHUD DO 30 J = 1, P XJ = X(J) ! ! APPLY THE PREVIOUS ROTATIONS. ! JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 T = C(I)*R(I,J) + S(I)*XJ XJ = C(I)*XJ - S(I)*R(I,J) R(I,J) = T 10 CONTINUE 20 CONTINUE ! ! COMPUTE THE NEXT ROTATION. ! call DROTG(R(J,J),XJ,C(J),S(J)) 30 CONTINUE ! ! if REQUIRED, UPDATE Z AND RHO. ! if (NZ < 1) go to 70 DO 60 J = 1, NZ ZETA = Y(J) DO 40 I = 1, P T = C(I)*Z(I,J) + S(I)*ZETA ZETA = C(I)*ZETA - S(I)*Z(I,J) Z(I,J) = T 40 CONTINUE AZETA = ABS(ZETA) if (AZETA == 0.0D0 .OR. RHO(J) < 0.0D0) go to 50 SCALE = AZETA + RHO(J) RHO(J) = SCALE*SQRT((AZETA/SCALE)**2+(RHO(J)/SCALE)**2) 50 CONTINUE 60 CONTINUE 70 CONTINUE return end FUNCTION DCHU (A, B, X) ! !! DCHU computes the logarithmic confluent hypergeometric function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C11 !***TYPE DOUBLE PRECISION (CHU-S, DCHU-D) !***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DCHU(A,B,X) calculates the double precision logarithmic confluent ! hypergeometric function U(A,B,X) for double precision arguments ! A, B, and X. ! ! This routine is not valid when 1+A-B is close to zero if X is small. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9CHU, DEXPRL, DGAMMA, DGAMR, DPOCH, ! DPOCH1, XERMSG !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE DCHU DOUBLE PRECISION DCHU DOUBLE PRECISION A, B, X, AINTB, ALNX, A0, BEPS, B0, C0, EPS, & FACTOR, GAMRI1, GAMRNI, PCH1AI, PCH1I, PI, POCHAI, SUM, T, & XEPS1, XI, XI1, XN, XTOEPS, D1MACH, DPOCH, DGAMMA, DGAMR, & DPOCH1, DEXPRL, D9CHU EXTERNAL DGAMMA SAVE PI, EPS DATA PI / 3.141592653589793238462643383279503D0 / DATA EPS / 0.0D0 / !***FIRST EXECUTABLE STATEMENT DCHU if (EPS == 0.0D0) EPS = D1MACH(3) ! if (X == 0.0D0) call XERMSG ('SLATEC', 'DCHU', & 'X IS ZERO SO DCHU IS INFINITE', 1, 2) if (X < 0.0D0) call XERMSG ('SLATEC', 'DCHU', & 'X IS NEGATIVE, USE CCHU', 2, 2) ! if (MAX(ABS(A),1.0D0)*MAX(ABS(1.0D0+A-B),1.0D0) < & 0.99D0*ABS(X)) go to 120 ! ! THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL ! APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. ! if (ABS(1.0D0+A-B) < SQRT(EPS)) call XERMSG ('SLATEC', 'DCHU', & 'ALGORITHMIS BAD WHEN 1+A-B IS NEAR ZERO FOR SMALL X', 10, 2) ! if (B >= 0.0D0) AINTB = AINT(B+0.5D0) if (B < 0.0D0) AINTB = AINT(B-0.5D0) BEPS = B - AINTB N = AINTB ! ALNX = LOG(X) XTOEPS = EXP (-BEPS*ALNX) ! ! EVALUATE THE FINITE SUM. ----------------------------------------- ! if (N >= 1) go to 40 ! ! CONSIDER THE CASE B < 1.0 FIRST. ! SUM = 1.0D0 if (N == 0) go to 30 ! T = 1.0D0 M = -N DO 20 I=1,M XI1 = I - 1 T = T*(A+XI1)*X/((B+XI1)*(XI1+1.0D0)) SUM = SUM + T 20 CONTINUE ! 30 SUM = DPOCH(1.0D0+A-B, -A)*SUM go to 70 ! ! NOW CONSIDER THE CASE B >= 1.0. ! 40 SUM = 0.0D0 M = N - 2 if (M < 0) go to 70 T = 1.0D0 SUM = 1.0D0 if (M == 0) go to 60 ! DO 50 I=1,M XI = I T = T * (A-B+XI)*X/((1.0D0-B+XI)*XI) SUM = SUM + T 50 CONTINUE ! 60 SUM = DGAMMA(B-1.0D0) * DGAMR(A) * X**(1-N) * XTOEPS * SUM ! ! NEXT EVALUATE THE INFINITE SUM. ---------------------------------- ! 70 ISTRT = 0 if (N < 1) ISTRT = 1 - N XI = ISTRT ! FACTOR = (-1.0D0)**N * DGAMR(1.0D0+A-B) * X**ISTRT if (BEPS /= 0.0D0) FACTOR = FACTOR * BEPS*PI/SIN(BEPS*PI) ! POCHAI = DPOCH (A, XI) GAMRI1 = DGAMR (XI+1.0D0) GAMRNI = DGAMR (AINTB+XI) B0 = FACTOR * DPOCH(A,XI-BEPS) * GAMRNI * DGAMR(XI+1.0D0-BEPS) ! if (ABS(XTOEPS-1.0D0) > 0.5D0) go to 90 ! ! X**(-BEPS) IS CLOSE TO 1.0D0, SO WE MUST BE CAREFUL IN EVALUATING THE ! DIFFERENCES. ! PCH1AI = DPOCH1 (A+XI, -BEPS) PCH1I = DPOCH1 (XI+1.0D0-BEPS, BEPS) C0 = FACTOR * POCHAI * GAMRNI * GAMRI1 * ( & -DPOCH1(B+XI,-BEPS) + PCH1AI - PCH1I + BEPS*PCH1AI*PCH1I) ! ! XEPS1 = (1.0 - X**(-BEPS))/BEPS = (X**(-BEPS) - 1.0)/(-BEPS) XEPS1 = ALNX*DEXPRL(-BEPS*ALNX) ! DCHU = SUM + C0 + XEPS1*B0 XN = N DO 80 I=1,1000 XI = ISTRT + I XI1 = ISTRT + I - 1 B0 = (A+XI1-BEPS)*B0*X/((XN+XI1)*(XI-BEPS)) C0 = (A+XI1)*C0*X/((B+XI1)*XI) & - ((A-1.0D0)*(XN+2.D0*XI-1.0D0) + XI*(XI-BEPS)) * B0 & / (XI*(B+XI1)*(A+XI1-BEPS)) T = C0 + XEPS1*B0 DCHU = DCHU + T if (ABS(T) < EPS*ABS(DCHU)) go to 130 80 CONTINUE call XERMSG ('SLATEC', 'DCHU', & 'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2) ! ! X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD ! FORMULATION IS STABLE. ! 90 A0 = FACTOR * POCHAI * DGAMR(B+XI) * GAMRI1 / BEPS B0 = XTOEPS * B0 / BEPS ! DCHU = SUM + A0 - B0 DO 100 I=1,1000 XI = ISTRT + I XI1 = ISTRT + I - 1 A0 = (A+XI1)*A0*X/((B+XI1)*XI) B0 = (A+XI1-BEPS)*B0*X/((AINTB+XI1)*(XI-BEPS)) T = A0 - B0 DCHU = DCHU + T if (ABS(T) < EPS*ABS(DCHU)) go to 130 100 CONTINUE call XERMSG ('SLATEC', 'DCHU', & 'NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING SERIES', 3, 2) ! ! USE LUKE-S RATIONAL APPROXIMATION IN THE ASYMPTOTIC REGION. ! 120 DCHU = X**(-A) * D9CHU(A,B,X) ! 130 return end subroutine DCKDER (M, N, X, FVEC, FJAC, LDFJAC, XP, FVECP, MODE, ERR) ! !! DCKDER checks the gradients of M nonlinear functions in N variables... ! evaluated at a point X, for consistency with the functions themselves. ! !***LIBRARY SLATEC !***CATEGORY F3, G4C !***TYPE DOUBLE PRECISION (CHKDER-S, DCKDER-D) !***KEYWORDS GRADIENTS, JACOBIAN, MINPACK, NONLINEAR !***AUTHOR Hiebert, K. L. (SNLA) !***DESCRIPTION ! ! This subroutine is a companion routine to DNSQ and DNSQE. It may ! be used to check the coding of the Jacobian calculation. ! ! SUBROUTINE DCKDER ! ! This subroutine checks the gradients of M nonlinear functions ! in N variables, evaluated at a point X, for consistency with ! the functions themselves. The user must call DCKDER twice, ! first with MODE = 1 and then with MODE = 2. ! ! MODE = 1. On input, X must contain the point of evaluation. ! On output, XP is set to a neighboring point. ! ! MODE = 2. On input, FVEC must contain the functions and the ! rows of FJAC must contain the gradients ! of the respective functions each evaluated ! at X, and FVECP must contain the functions ! evaluated at XP. ! On output, ERR contains measures of correctness of ! the respective gradients. ! ! The subroutine does not perform reliably if cancellation or ! rounding errors cause a severe loss of significance in the ! evaluation of a function. Therefore, none of the components ! of X should be unusually small (in particular, zero) or any ! other value which may cause loss of significance. ! ! The SUBROUTINE statement is ! ! SUBROUTINE DCKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) ! ! where ! ! M is a positive integer input variable set to the number ! of functions. ! ! N is a positive integer input variable set to the number ! of variables. ! ! X is an input array of length N. ! ! FVEC is an array of length M. On input when MODE = 2, ! FVEC must contain the functions evaluated at X. ! ! FJAC is an M by N array. On input when MODE = 2, ! the rows of FJAC must contain the gradients of ! the respective functions evaluated at X. ! ! LDFJAC is a positive integer input parameter not less than M ! which specifies the leading dimension of the array FJAC. ! ! XP is an array of length N. On output when MODE = 1, ! XP is set to a neighboring point of X. ! ! FVECP is an array of length M. On input when MODE = 2, ! FVECP must contain the functions evaluated at XP. ! ! MODE is an integer input variable set to 1 on the first call ! and 2 on the second. Other values of MODE are equivalent ! to MODE = 1. ! ! ERR is an array of length M. On output when MODE = 2, ! ERR contains measures of correctness of the respective ! gradients. If there is no severe loss of significance, ! then if ERR(I) is 1.0 the I-th gradient is correct, ! while if ERR(I) is 0.0 the I-th gradient is incorrect. ! For values of ERR between 0.0 and 1.0, the categorization ! is less certain. In general, a value of ERR(I) greater ! than 0.5 indicates that the I-th gradient is probably ! correct, while a value of ERR(I) less than 0.5 indicates ! that the I-th gradient is probably incorrect. ! !***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- ! tions. In Numerical Methods for Nonlinear Algebraic ! Equations, P. Rabinowitz, Editor. Gordon and Breach, ! 1988. !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DCKDER INTEGER I, J, LDFJAC, M, MODE, N DOUBLE PRECISION D1MACH, EPS, EPSF, EPSLOG, EPSMCH, ERR(*), & FACTOR, FJAC(LDFJAC,*), FVEC(*), FVECP(*), ONE, TEMP, X(*), & XP(*), ZERO SAVE FACTOR, ONE, ZERO DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/ ! ! EPSMCH IS THE MACHINE PRECISION. ! !***FIRST EXECUTABLE STATEMENT DCKDER EPSMCH = D1MACH(4) ! EPS = SQRT(EPSMCH) ! if (MODE == 2) go to 20 ! ! MODE = 1. ! DO 10 J = 1, N TEMP = EPS*ABS(X(J)) if (TEMP == ZERO) TEMP = EPS XP(J) = X(J) + TEMP 10 CONTINUE go to 70 20 CONTINUE ! ! MODE = 2. ! EPSF = FACTOR*EPSMCH EPSLOG = LOG10(EPS) DO 30 I = 1, M ERR(I) = ZERO 30 CONTINUE DO 50 J = 1, N TEMP = ABS(X(J)) if (TEMP == ZERO) TEMP = ONE DO 40 I = 1, M ERR(I) = ERR(I) + TEMP*FJAC(I,J) 40 CONTINUE 50 CONTINUE DO 60 I = 1, M TEMP = ONE if (FVEC(I) /= ZERO .AND. FVECP(I) /= ZERO & .AND. ABS(FVECP(I)-FVEC(I)) >= EPSF*ABS(FVEC(I))) & TEMP = EPS*ABS((FVECP(I)-FVEC(I))/EPS-ERR(I)) & /(ABS(FVEC(I)) + ABS(FVECP(I))) ERR(I) = ONE if (TEMP > EPSMCH .AND. TEMP < EPS) & ERR(I) = (LOG10(TEMP) - EPSLOG)/EPSLOG if (TEMP >= EPS) ERR(I) = ZERO 60 CONTINUE 70 CONTINUE ! return end subroutine DCOEF (YH, YP, NCOMP, NROWB, NFC, NIC, B, BETA, COEF, & INHOMO, RE, AE, BY, CVEC, WORK, IWORK, IFLAG, NFCC) ! !! DCOEF is subsidiary to DBVSUP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SCOEF-S, DCOEF-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! INPUT to DCOEF ! ********************************************************************** ! ! YH = matrix of homogeneous solutions. ! YP = vector containing particular solution. ! NCOMP = number of components per solution vector. ! NROWB = first dimension of B in calling program. ! NFC = number of base solution vectors. ! NFCC = 2*NFC for the special treatment of COMPLEX*16 valued ! equations. Otherwise, NFCC=NFC. ! NIC = number of specified initial conditions. ! B = boundary condition matrix at X = XFINAL. ! BETA = vector of nonhomogeneous boundary conditions at X = XFINAL. ! 1 - nonzero particular solution ! INHOMO = 2 - zero particular solution ! 3 - eigenvalue problem ! RE = relative error tolerance. ! AE = absolute error tolerance. ! BY = storage space for the matrix B*YH ! CVEC = storage space for the vector BETA-B*YP ! WORK = double precision array of internal storage. Dimension must ! be GE ! NFCC*(NFCC+4) ! IWORK = integer array of internal storage. Dimension must be GE ! 3+NFCC ! ! ********************************************************************** ! OUTPUT from DCOEF ! ********************************************************************** ! ! COEF = array containing superposition constants. ! IFLAG = indicator of success from DSUDS in solving the ! boundary equations. ! = 0 boundary equations are solved. ! = 1 boundary equations appear to have many solutions. ! = 2 boundary equations appear to be inconsistent. ! = 3 for this value of an eigenparameter, the boundary ! equations have only the zero solution. ! ! ********************************************************************** ! ! Subroutine DCOEF solves for the superposition constants from the ! linear equations defined by the boundary conditions at X = XFINAL. ! ! B*YP + B*YH*COEF = BETA ! ! ********************************************************************** ! !***SEE ALSO DBVSUP !***ROUTINES CALLED DDOT, DSUDS, XGETF, XSETF !***COMMON BLOCKS DML5MC !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 890921 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DCOEF ! DOUBLE PRECISION DDOT INTEGER I, IFLAG, INHOMO, IWORK(*), J, K, KFLAG, KI, L, LPAR, & MLSO, NCOMP, NCOMP2, NF, NFC, NFCC, NFCCM1, NIC, & NROWB DOUBLE PRECISION AE, B(NROWB,*), BBN, BETA(*), BN, BRN, & BY(NFCC,*), BYKL, BYS, COEF(*), CONS, CVEC(*), EPS, & FOURU, GAM, RE, SQOVFL, SRU, TWOU, UN, URO, WORK(*), & YH(NCOMP,*), YP(*), YPN ! COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR !***FIRST EXECUTABLE STATEMENT DCOEF ! ! SET UP MATRIX B*YH AND VECTOR BETA - B*YP ! NCOMP2 = NCOMP/2 DO 80 K = 1, NFCC DO 10 J = 1, NFC L = J if (NFC /= NFCC) L = 2*J - 1 BY(K,L) = DDOT(NCOMP,B(K,1),NROWB,YH(1,J),1) 10 CONTINUE if (NFC == NFCC) go to 30 DO 20 J = 1, NFC L = 2*J BYKL = DDOT(NCOMP2,B(K,1),NROWB,YH(NCOMP2+1,J),1) BY(K,L) = DDOT(NCOMP2,B(K,NCOMP2+1),NROWB,YH(1,J),1) & - BYKL 20 CONTINUE 30 CONTINUE go to (40,50,60), INHOMO ! CASE 1 40 CONTINUE CVEC(K) = BETA(K) - DDOT(NCOMP,B(K,1),NROWB,YP,1) go to 70 ! CASE 2 50 CONTINUE CVEC(K) = BETA(K) go to 70 ! CASE 3 60 CONTINUE CVEC(K) = 0.0D0 70 CONTINUE 80 CONTINUE CONS = ABS(CVEC(1)) BYS = ABS(BY(1,1)) ! ! SOLVE LINEAR SYSTEM ! IFLAG = 0 MLSO = 0 if (INHOMO == 3) MLSO = 1 KFLAG = 0.5D0 * LOG10(EPS) call XGETF(NF) call XSETF(0) 90 CONTINUE call DSUDS(BY,COEF,CVEC,NFCC,NFCC,NFCC,KFLAG,MLSO,WORK,IWORK) if (KFLAG /= 3) go to 100 KFLAG = 1 IFLAG = 1 go to 90 100 CONTINUE if (KFLAG == 4) IFLAG = 2 call XSETF(NF) if (NFCC == 1) go to 180 if (INHOMO /= 3) go to 170 if (IWORK(1) < NFCC) go to 140 IFLAG = 3 DO 110 K = 1, NFCC COEF(K) = 0.0D0 110 CONTINUE COEF(NFCC) = 1.0D0 NFCCM1 = NFCC - 1 DO 130 K = 1, NFCCM1 J = NFCC - K L = NFCC - J + 1 GAM = DDOT(L,BY(J,J),NFCC,COEF(J),1)/(WORK(J)*BY(J,J)) DO 120 I = J, NFCC COEF(I) = COEF(I) + GAM*BY(J,I) 120 CONTINUE 130 CONTINUE go to 160 140 CONTINUE DO 150 K = 1, NFCC KI = 4*NFCC + K COEF(K) = WORK(KI) 150 CONTINUE 160 CONTINUE 170 CONTINUE go to 220 180 CONTINUE ! ! TESTING FOR EXISTENCE AND UNIQUENESS OF BOUNDARY-VALUE ! PROBLEM SOLUTION IN A SCALAR CASE ! BN = 0.0D0 UN = 0.0D0 YPN = 0.0D0 DO 190 K = 1, NCOMP UN = MAX(UN,ABS(YH(K,1))) YPN = MAX(YPN,ABS(YP(K))) BN = MAX(BN,ABS(B(1,K))) 190 CONTINUE BBN = MAX(BN,ABS(BETA(1))) if (BYS > 10.0D0*(RE*UN + AE)*BN) go to 200 BRN = BBN/BN*BYS if (CONS >= 0.1D0*BRN .AND. CONS <= 10.0D0*BRN) & IFLAG = 1 if (CONS > 10.0D0*BRN) IFLAG = 2 if (CONS <= RE*ABS(BETA(1)) + AE + (RE*YPN + AE)*BN) & IFLAG = 1 if (INHOMO == 3) COEF(1) = 1.0D0 go to 210 200 CONTINUE if (INHOMO /= 3) go to 210 IFLAG = 3 COEF(1) = 1.0D0 210 CONTINUE 220 CONTINUE return end subroutine DCOPY (N, DX, INCX, DY, INCY) ! !! DCOPY copies a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A5 !***TYPE DOUBLE PRECISION (SCOPY-S, DCOPY-D, CCOPY-C, ICOPY-I) !***KEYWORDS BLAS, COPY, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! DY double precision vector with N elements ! INCY storage spacing between elements of DY ! ! --Output-- ! DY copy of vector DX (unchanged if N <= 0) ! ! Copy double precision DX to double precision DY. ! For I = 0 to N-1, copy DX(LX+I*INCX) to DY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DCOPY DOUBLE PRECISION DX(*), DY(*) !***FIRST EXECUTABLE STATEMENT DCOPY if (N <= 0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IX = 1 IY = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE return ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 7. ! 20 M = MOD(N,7) if (M == 0) go to 40 DO 30 I = 1,M DY(I) = DX(I) 30 CONTINUE if (N < 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 ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX DY(I) = DX(I) 70 CONTINUE return end subroutine DCOPYM (N, DX, INCX, DY, INCY) ! !! DCOPYM copies the negative of a vector to a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A5 !***TYPE DOUBLE PRECISION (SCOPYM-S, DCOPYM-D) !***KEYWORDS BLAS, COPY, VECTOR !***AUTHOR Kahaner, D. K., (NBS) !***DESCRIPTION ! ! Description of Parameters ! The * Flags Output Variables ! ! N Number of elements in vector(s) ! DX Double precision vector with N elements ! INCX Storage spacing between elements of DX ! DY* Double precision negative copy of DX ! INCY Storage spacing between elements of DY ! ! *** Note that DY = -DX *** ! ! Copy negative of d.p. DX to d.p. DY. For I=0 to N-1, ! copy -DX(LX+I*INCX) to DY(LY+I*INCY), where LX=1 if ! INCX >= 0, else LX = 1+(1-N)*INCX, and LY is defined ! in a similar way using INCY. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) !***END PROLOGUE DCOPYM DOUBLE PRECISION DX(*), DY(*) !***FIRST EXECUTABLE STATEMENT DCOPYM if (N <= 0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IX=1 IY=1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = -DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE return ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 7. ! 20 M = MOD(N,7) if (M == 0) go to 40 DO 30 I = 1,M DY(I) = -DX(I) 30 CONTINUE if (N < 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 ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX DY(I) = -DX(I) 70 CONTINUE return end FUNCTION DCOSDG (X) ! !! DCOSDG computes the cosine of an argument in degrees. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE DOUBLE PRECISION (COSDG-S, DCOSDG-D) !***KEYWORDS COSINE, DEGREES, ELEMENTARY FUNCTIONS, FNLIB, ! TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DCOSDG(X) calculates the double precision trigonometric cosine ! for double precision argument X in units of degrees. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DCOSDG DOUBLE PRECISION DCOSDG DOUBLE PRECISION X, RADDEG SAVE RADDEG DATA RADDEG / 0.017453292519943295769236907684886D0 / !***FIRST EXECUTABLE STATEMENT DCOSDG DCOSDG = COS (RADDEG*X) ! if (MOD(X,90.D0) /= 0.D0) RETURN N = ABS(X)/90.D0 + 0.5D0 N = MOD (N, 2) if (N == 0) DCOSDG = SIGN (1.0D0, DCOSDG) if (N == 1) DCOSDG = 0.0D0 ! return end FUNCTION DCOT (X) ! !! DCOT computes the cotangent. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE DOUBLE PRECISION (COT-S, DCOT-D, CCOT-C) !***KEYWORDS COTANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DCOT(X) calculates the double precision trigonometric cotangent ! for double precision argument X. X is in units of radians. ! ! Series for COT on the interval 0. to 6.25000E-02 ! with weighted error 5.52E-34 ! log weighted error 33.26 ! significant figures required 32.34 ! decimal places required 33.85 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE DCOT DOUBLE PRECISION DCOT DOUBLE PRECISION X, COTCS(15), AINTY, AINTY2, PI2REC, SQEPS, & XMAX, XMIN, XSML, Y, YREM, PRODBG, DCSEVL, D1MACH LOGICAL FIRST SAVE COTCS, PI2REC, NTERMS, XMAX, XSML, XMIN, SQEPS, FIRST DATA COTCS( 1) / +.240259160982956302509553617744970D+0 / DATA COTCS( 2) / -.165330316015002278454746025255758D-1 / DATA COTCS( 3) / -.429983919317240189356476228239895D-4 / DATA COTCS( 4) / -.159283223327541046023490851122445D-6 / DATA COTCS( 5) / -.619109313512934872588620579343187D-9 / DATA COTCS( 6) / -.243019741507264604331702590579575D-11 / DATA COTCS( 7) / -.956093675880008098427062083100000D-14 / DATA COTCS( 8) / -.376353798194580580416291539706666D-16 / DATA COTCS( 9) / -.148166574646746578852176794666666D-18 / DATA COTCS( 10) / -.583335658903666579477984000000000D-21 / DATA COTCS( 11) / -.229662646964645773928533333333333D-23 / DATA COTCS( 12) / -.904197057307483326719999999999999D-26 / DATA COTCS( 13) / -.355988551920600064000000000000000D-28 / DATA COTCS( 14) / -.140155139824298666666666666666666D-30 / DATA COTCS( 15) / -.551800436872533333333333333333333D-33 / DATA PI2REC / .011619772367581343075535053490057D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DCOT if (FIRST) THEN NTERMS = INITDS (COTCS, 15, 0.1*REAL(D1MACH(3)) ) XMAX = 1.0D0/D1MACH(4) XSML = SQRT(3.0D0*D1MACH(3)) XMIN = EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0) SQEPS = SQRT(D1MACH(4)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y < XMIN) call XERMSG ('SLATEC', 'DCOT', & 'ABS(X) IS ZERO OR SO SMALL DCOT OVERFLOWS', 2, 2) if (Y > XMAX) call XERMSG ('SLATEC', 'DCOT', & 'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 3, 2) ! ! CAREFULLY COMPUTE Y * (2/PI) = (AINT(Y) + REM(Y)) * (.625 + PI2REC) ! = AINT(.625*Y) + REM(.625*Y) + Y*PI2REC = AINT(.625*Y) + Z ! = AINT(.625*Y) + AINT(Z) + REM(Z) ! AINTY = AINT (Y) YREM = Y - AINTY PRODBG = 0.625D0*AINTY AINTY = AINT (PRODBG) Y = (PRODBG-AINTY) + 0.625D0*YREM + PI2REC*Y AINTY2 = AINT (Y) AINTY = AINTY + AINTY2 Y = Y - AINTY2 ! IFN = MOD (AINTY, 2.0D0) if (IFN == 1) Y = 1.0D0 - Y ! if (ABS(X) > 0.5D0 .AND. Y < ABS(X)*SQEPS) call XERMSG & ('SLATEC', 'DCOT', & 'ANSWER LT HALF PRECISION, ABS(X) TOO BIG OR X NEAR N*PI ' // & '(N /= 0)', 1, 1) ! if (Y > 0.25D0) go to 20 DCOT = 1.0D0/X if (Y > XSML) DCOT = (0.5D0 + DCSEVL (32.0D0*Y*Y-1.D0, COTCS, & NTERMS)) / Y go to 40 ! 20 if (Y > 0.5D0) go to 30 DCOT = (0.5D0 + DCSEVL (8.D0*Y*Y-1.D0, COTCS, NTERMS))/(0.5D0*Y) DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT go to 40 ! 30 DCOT = (0.5D0 + DCSEVL (2.D0*Y*Y-1.D0, COTCS, NTERMS))/(.25D0*Y) DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT ! 40 if (X /= 0.D0) DCOT = SIGN (DCOT, X) if (IFN == 1) DCOT = -DCOT ! return end subroutine DCOV (FCN, IOPT, M, N, X, FVEC, R, LDR, INFO, WA1, WA2, & WA3, WA4) ! !! DCOV calculates the covariance matrix for a nonlinear data fitting problem. ! It is intended to be used after a ! successful return from either DNLS1 or DNLS1E. ! !***LIBRARY SLATEC !***CATEGORY K1B1 !***TYPE DOUBLE PRECISION (SCOV-S, DCOV-D) !***KEYWORDS COVARIANCE MATRIX, NONLINEAR DATA FITTING, ! NONLINEAR LEAST SQUARES !***AUTHOR Hiebert, K. L., (SNLA) !***DESCRIPTION ! ! 1. Purpose. ! ! DCOV calculates the covariance matrix for a nonlinear data ! fitting problem. It is intended to be used after a ! successful return from either DNLS1 or DNLS1E. DCOV ! and DNLS1 (and DNLS1E) have compatible parameters. The ! required external subroutine, FCN, is the same ! for all three codes, DCOV, DNLS1, and DNLS1E. ! ! 2. Subroutine and Type Statements. ! ! SUBROUTINE DCOV(FCN,IOPT,M,N,X,FVEC,R,LDR,INFO, ! WA1,WA2,WA3,WA4) ! INTEGER IOPT,M,N,LDR,INFO ! DOUBLE PRECISION X(N),FVEC(M),R(LDR,N),WA1(N),WA2(N),WA3(N),WA4(M) ! EXTERNAL FCN ! ! 3. Parameters. All TYPE REAL parameters are DOUBLE PRECISION ! ! FCN is the name of the user-supplied subroutine which calculates ! the functions. If the user wants to supply the Jacobian ! (IOPT=2 or 3), then FCN must be written to calculate the ! Jacobian, as well as the functions. See the explanation ! of the IOPT argument below. ! If the user wants the iterates printed in DNLS1 or DNLS1E, ! then FCN must do the printing. See the explanation of NPRINT ! in DNLS1 or DNLS1E. FCN must be declared in an EXTERNAL ! statement in the calling program and should be written as ! follows. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! INTEGER IFLAG,LDFJAC,M,N ! DOUBLE PRECISION X(N),FVEC(M) ! ---------- ! FJAC and LDFJAC may be ignored , if IOPT=1. ! DOUBLE PRECISION FJAC(LDFJAC,N) , if IOPT=2. ! DOUBLE PRECISION FJAC(N) , if IOPT=3. ! ---------- ! If IFLAG=0, the values in X and FVEC are available ! for printing in DNLS1 or DNLS1E. ! IFLAG will never be zero when FCN is called by DCOV. ! The values of X and FVEC must not be changed. ! return ! ---------- ! If IFLAG=1, calculate the functions at X and return ! this vector in FVEC. ! return ! ---------- ! If IFLAG=2, calculate the full Jacobian at X and return ! this matrix in FJAC. Note that IFLAG will never be 2 unless ! IOPT=2. FVEC contains the function values at X and must ! not be altered. FJAC(I,J) must be set to the derivative ! of FVEC(I) with respect to X(J). ! return ! ---------- ! If IFLAG=3, calculate the LDFJAC-th row of the Jacobian ! and return this vector in FJAC. Note that IFLAG will ! never be 3 unless IOPT=3. FJAC(J) must be set to ! the derivative of FVEC(LDFJAC) with respect to X(J). ! return ! ---------- ! END ! ! ! The value of IFLAG should not be changed by FCN unless the ! user wants to terminate execution of DCOV. In this case, set ! IFLAG to a negative integer. ! ! ! IOPT is an input variable which specifies how the Jacobian will ! be calculated. If IOPT=2 or 3, then the user must supply the ! Jacobian, as well as the function values, through the ! subroutine FCN. If IOPT=2, the user supplies the full ! Jacobian with one call to FCN. If IOPT=3, the user supplies ! one row of the Jacobian with each call. (In this manner, ! storage can be saved because the full Jacobian is not stored.) ! If IOPT=1, the code will approximate the Jacobian by forward ! differencing. ! ! M is a positive integer input variable set to the number of ! functions. ! ! N is a positive integer input variable set to the number of ! variables. N must not exceed M. ! ! X is an array of length N. On input X must contain the value ! at which the covariance matrix is to be evaluated. This is ! usually the value for X returned from a successful run of ! DNLS1 (or DNLS1E). The value of X will not be changed. ! ! FVEC is an output array of length M which contains the functions ! evaluated at X. ! ! R is an output array. For IOPT=1 and 2, R is an M by N array. ! For IOPT=3, R is an N by N array. On output, if INFO=1, ! the upper N by N submatrix of R contains the covariance ! matrix evaluated at X. ! ! LDR is a positive integer input variable which specifies ! the leading dimension of the array R. For IOPT=1 and 2, ! LDR must not be less than M. For IOPT=3, LDR must not ! be less than N. ! ! INFO is an integer output variable. If the user has terminated ! execution, INFO is set to the (negative) value of IFLAG. See ! description of FCN. Otherwise, INFO is set as follows. ! ! INFO = 0 Improper input parameters (M <= 0 or N <= 0). ! ! INFO = 1 Successful return. The covariance matrix has been ! calculated and stored in the upper N by N ! submatrix of R. ! ! INFO = 2 The Jacobian matrix is singular for the input value ! of X. The covariance matrix cannot be calculated. ! The upper N by N submatrix of R contains the QR ! factorization of the Jacobian (probably not of ! interest to the user). ! ! WA1,WA2 are work arrays of length N. ! and WA3 ! ! WA4 is a work array of length M. ! !***REFERENCES (NONE) !***ROUTINES CALLED DENORM, DFDJC3, DQRFAC, DWUPDT, XERMSG !***REVISION HISTORY (YYMMDD) ! 810522 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Fixed an error message. (RWC) !***END PROLOGUE DCOV ! ! REVISED 850601-1100 ! REVISED YYMMDD HHMM ! INTEGER I,IDUM,IFLAG,INFO,IOPT,J,K,KP1,LDR,M,N,NM1,NROW DOUBLE PRECISION X(*),R(LDR,*),FVEC(*),WA1(*),WA2(*),WA3(*), & WA4(*) EXTERNAL FCN DOUBLE PRECISION ONE,SIGMA,TEMP,ZERO,DENORM LOGICAL SING SAVE ZERO, ONE DATA ZERO/0.D0/,ONE/1.D0/ !***FIRST EXECUTABLE STATEMENT DCOV SING=.FALSE. IFLAG=0 if (M <= 0 .OR. N <= 0) go to 300 ! ! CALCULATE SIGMA = (SUM OF THE SQUARED RESIDUALS) / (M-N) IFLAG=1 call FCN(IFLAG,M,N,X,FVEC,R,LDR) if (IFLAG < 0) go to 300 TEMP=DENORM(M,FVEC) SIGMA=ONE if (M /= N) SIGMA=TEMP*TEMP/(M-N) ! ! CALCULATE THE JACOBIAN if (IOPT == 3) go to 200 ! ! STORE THE FULL JACOBIAN USING M*N STORAGE if (IOPT == 1) go to 100 ! ! USER SUPPLIES THE JACOBIAN IFLAG=2 call FCN(IFLAG,M,N,X,FVEC,R,LDR) go to 110 ! ! CODE APPROXIMATES THE JACOBIAN 100 call DFDJC3(FCN,M,N,X,FVEC,R,LDR,IFLAG,ZERO,WA4) 110 if (IFLAG < 0) go to 300 ! ! COMPUTE THE QR DECOMPOSITION call DQRFAC(M,N,R,LDR,.FALSE.,IDUM,1,WA1,WA1,WA1) DO 120 I=1,N 120 R(I,I)=WA1(I) go to 225 ! ! COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX CALCULATED ONE ! ROW AT A TIME AND STORED IN THE UPPER TRIANGLE OF R. ! ( (Q TRANSPOSE)*FVEC IS ALSO CALCULATED BUT NOT USED.) 200 CONTINUE DO 210 J=1,N WA2(J)=ZERO DO 205 I=1,N R(I,J)=ZERO 205 CONTINUE 210 CONTINUE IFLAG=3 DO 220 I=1,M NROW = I call FCN(IFLAG,M,N,X,FVEC,WA1,NROW) if (IFLAG < 0) go to 300 TEMP=FVEC(I) call DWUPDT(N,R,LDR,WA1,WA2,TEMP,WA3,WA4) 220 CONTINUE ! ! CHECK if R IS SINGULAR. 225 CONTINUE DO 230 I=1,N if (R(I,I) == ZERO) SING=.TRUE. 230 CONTINUE if (SING) go to 300 ! ! R IS UPPER TRIANGULAR. CALCULATE (R TRANSPOSE) INVERSE AND STORE ! IN THE UPPER TRIANGLE OF R. if (N == 1) go to 275 NM1=N-1 DO 270 K=1,NM1 ! ! INITIALIZE THE RIGHT-HAND SIDE (WA1(*)) AS THE K-TH COLUMN OF THE ! IDENTITY MATRIX. DO 240 I=1,N WA1(I)=ZERO 240 CONTINUE WA1(K)=ONE ! R(K,K)=WA1(K)/R(K,K) KP1=K+1 DO 260 I=KP1,N ! ! SUBTRACT R(K,I-1)*R(I-1,*) FROM THE RIGHT-HAND SIDE, WA1(*). DO 250 J=I,N WA1(J)=WA1(J)-R(K,I-1)*R(I-1,J) 250 CONTINUE R(K,I)=WA1(I)/R(I,I) 260 CONTINUE 270 CONTINUE 275 R(N,N)=ONE/R(N,N) ! ! CALCULATE R-INVERSE * (R TRANSPOSE) INVERSE AND STORE IN THE UPPER ! TRIANGLE OF R. DO 290 I=1,N DO 290 J=I,N TEMP=ZERO DO 280 K=J,N TEMP=TEMP+R(I,K)*R(J,K) 280 CONTINUE R(I,J)=TEMP*SIGMA 290 CONTINUE INFO=1 ! 300 CONTINUE if (M <= 0 .OR. N <= 0) INFO=0 if (IFLAG < 0) INFO=IFLAG if (SING) INFO=2 if (INFO < 0) call XERMSG ('SLATEC', 'DCOV', & 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) if (INFO == 0) call XERMSG ('SLATEC', 'DCOV', & 'INVALID INPUT PARAMETER.', 2, 1) if (INFO == 2) call XERMSG ('SLATEC', 'DCOV', & 'SINGULAR JACOBIAN MATRIX, COVARIANCE MATRIX CANNOT BE ' // & 'CALCULATED.', 1, 1) return end subroutine DCPPLT (N, NELT, IA, JA, A, ISYM, IUNIT) ! !! DCPPLT makes a Printer Plot of a SLAP Column Format Matrix. ! ! Routine to print out a SLAP Column format matrix in a ! "printer plot" graphical representation. !***LIBRARY SLATEC (SLAP) !***CATEGORY N1 !***TYPE DOUBLE PRECISION (SCPPLT-S, DCPPLT-D) !***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT ! DOUBLE PRECISION A(NELT) ! ! call DCPPLT( N, NELT, IA, JA, A, ISYM, IUNIT ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! If N.gt.MAXORD, only the leading MAXORD x MAXORD ! submatrix will be printed. (Currently MAXORD = 225.) ! NELT :IN Integer. ! Number of non-zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in the SLAP ! Column format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! IUNIT :IN Integer. ! Fortran logical I/O device unit number to write the matrix ! to. This unit must be connected in a system dependent fashion ! to a file or the console or you will get a nasty message ! from the Fortran I/O libraries. ! ! *Description: ! This routine prints out a SLAP Column format matrix to the ! Fortran logical I/O unit number IUNIT. The numbers them ! selves are not printed out, but rather a one character ! representation of the numbers. Elements of the matrix that ! are not represented in the (IA,JA,A) arrays are denoted by ! ' ' character (a blank). Elements of A that are *ZERO* (and ! hence should really not be stored) are denoted by a '0' ! character. Elements of A that are *POSITIVE* are denoted by ! 'D' if they are Diagonal elements and '#' if they are off ! Diagonal elements. Elements of A that are *NEGATIVE* are ! denoted by 'N' if they are Diagonal elements and '*' if ! they are off Diagonal elements. ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! ! *Portability: ! This routine, as distributed, can generate lines up to 229 ! characters long. Some Fortran systems have more restricted ! line lengths. Change parameter MAXORD and the large number ! in FORMAT 1010 to reduce this line length. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921007 Replaced hard-wired 225 with parameter MAXORD. (FNF) ! 921021 Corrected syntax of CHARACTER declaration. (FNF) ! 921026 Corrected D to E in output format. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DCPPLT ! .. Scalar Arguments .. INTEGER ISYM, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT) INTEGER IA(NELT), JA(NELT) ! .. Parameters .. INTEGER MAXORD PARAMETER (MAXORD=225) ! .. Local Scalars .. INTEGER I, ICOL, IROW, J, JBGN, JEND, NMAX ! .. Local Arrays .. CHARACTER CHMAT(MAXORD)*(MAXORD) ! .. Intrinsic Functions .. INTRINSIC MIN, MOD, REAL !***FIRST EXECUTABLE STATEMENT DCPPLT ! ! Set up the character matrix... ! NMAX = MIN( MAXORD, N ) DO 10 I = 1, NMAX CHMAT(I)(1:NMAX) = ' ' 10 CONTINUE DO 30 ICOL = 1, NMAX JBGN = JA(ICOL) JEND = JA(ICOL+1)-1 DO 20 J = JBGN, JEND IROW = IA(J) if ( IROW <= NMAX ) THEN if ( ISYM /= 0 ) THEN ! Put in non-sym part as well... if ( A(J) == 0.0D0 ) THEN CHMAT(IROW)(ICOL:ICOL) = '0' ELSEIF( A(J) > 0.0D0 ) THEN CHMAT(IROW)(ICOL:ICOL) = '#' ELSE CHMAT(IROW)(ICOL:ICOL) = '*' ENDIF ENDIF if ( IROW == ICOL ) THEN ! Diagonal entry. if ( A(J) == 0.0D0 ) THEN CHMAT(IROW)(ICOL:ICOL) = '0' ELSEIF( A(J) > 0.0D0 ) THEN CHMAT(IROW)(ICOL:ICOL) = 'D' ELSE CHMAT(IROW)(ICOL:ICOL) = 'N' ENDIF ELSE ! Off-Diagonal entry if ( A(J) == 0.0D0 ) THEN CHMAT(IROW)(ICOL:ICOL) = '0' ELSEIF( A(J) > 0.0D0 ) THEN CHMAT(IROW)(ICOL:ICOL) = '#' ELSE CHMAT(IROW)(ICOL:ICOL) = '*' ENDIF ENDIF ENDIF 20 CONTINUE 30 CONTINUE ! ! Write out the heading. WRITE(IUNIT,1000) N, NELT, REAL(NELT)/(N*N) WRITE(IUNIT,1010) (MOD(I,10),I=1,NMAX) ! ! Write out the character representations matrix elements. DO 40 IROW = 1, NMAX WRITE(IUNIT,1020) IROW, CHMAT(IROW)(1:NMAX) 40 CONTINUE return ! 1000 FORMAT(/'**** Picture of Column SLAP matrix follows ****'/ & ' N, NELT and Density = ',2I10,D16.7) ! The following assumes MAXORD.le.225. 1010 FORMAT(4X,225(I1)) 1020 FORMAT(1X,I3,A) end subroutine DCSCAL (A, NRDA, NROW, NCOL, COLS, COLSAV, ROWS, & ROWSAV, ANORM, SCALES, ISCALE, IC) ! !! DCSCAL is subsidiary to DBVSUP and DSUDS. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CSCALE-S, DCSCAL-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This routine scales the matrix A by columns when needed. ! !***SEE ALSO DBVSUP, DSUDS !***ROUTINES CALLED DDOT !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DCSCAL DOUBLE PRECISION DDOT INTEGER IC, IP, ISCALE, J, K, NCOL, NRDA, NROW DOUBLE PRECISION A(NRDA,*), ALOG2, ANORM, ASCALE, COLS(*), & COLSAV(*), CS, P, ROWS(*), ROWSAV(*), S, & SCALES(*), TEN20, TEN4 ! SAVE TEN4, TEN20 DATA TEN4,TEN20 /1.0D4,1.0D20/ ! ! BEGIN BLOCK PERMITTING ...EXITS TO 130 ! BEGIN BLOCK PERMITTING ...EXITS TO 60 !***FIRST EXECUTABLE STATEMENT DCSCAL if (ISCALE /= (-1)) go to 40 ! if (IC == 0) go to 20 DO 10 K = 1, NCOL COLS(K) = DDOT(NROW,A(1,K),1,A(1,K),1) 10 CONTINUE 20 CONTINUE ! ASCALE = ANORM/NCOL DO 30 K = 1, NCOL CS = COLS(K) ! .........EXIT if ((CS > TEN4*ASCALE) .OR. (TEN4*CS < ASCALE)) & go to 60 ! .........EXIT if ((CS < 1.0D0/TEN20) .OR. (CS > TEN20)) & go to 60 30 CONTINUE 40 CONTINUE ! DO 50 K = 1, NCOL SCALES(K) = 1.0D0 50 CONTINUE ! ......EXIT go to 130 60 CONTINUE ! ALOG2 = LOG(2.0D0) ANORM = 0.0D0 DO 110 K = 1, NCOL CS = COLS(K) if (CS /= 0.0D0) go to 70 SCALES(K) = 1.0D0 go to 100 70 CONTINUE P = LOG(CS)/ALOG2 IP = -0.5D0*P S = 2.0D0**IP SCALES(K) = S if (IC == 1) go to 80 COLS(K) = S*S*COLS(K) ANORM = ANORM + COLS(K) COLSAV(K) = COLS(K) 80 CONTINUE DO 90 J = 1, NROW A(J,K) = S*A(J,K) 90 CONTINUE 100 CONTINUE 110 CONTINUE ! ! ...EXIT if (IC == 0) go to 130 ! DO 120 K = 1, NROW ROWS(K) = DDOT(NCOL,A(K,1),NRDA,A(K,1),NRDA) ROWSAV(K) = ROWS(K) ANORM = ANORM + ROWS(K) 120 CONTINUE 130 CONTINUE return end DOUBLE PRECISION FUNCTION DCSEVL (X, CS, N) ! !! DCSEVL evaluates a Chebyshev series. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C3A2 !***TYPE DOUBLE PRECISION (CSEVL-S, DCSEVL-D) !***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate the N-term Chebyshev series CS at X. Adapted from ! a method presented in the paper by Broucke referenced below. ! ! Input Arguments -- ! X value at which the series is to be evaluated. ! CS array of N terms of a Chebyshev series. In evaluating ! CS, only half the first coefficient is summed. ! N number of terms in array CS. ! !***REFERENCES R. Broucke, Ten subroutines for the manipulation of ! Chebyshev series, Algorithm 446, Communications of ! the A.C.M. 16, (1973) pp. 254-256. ! L. Fox and I. B. Parker, Chebyshev Polynomials in ! Numerical Analysis, Oxford University Press, 1968, ! page 56. !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900329 Prologued revised extensively and code rewritten to allow ! X to be slightly outside interval (-1,+1). (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DCSEVL DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X, D1MACH LOGICAL FIRST SAVE FIRST, ONEPL DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DCSEVL if (FIRST) ONEPL = 1.0D0 + D1MACH(4) FIRST = .FALSE. if (N < 1) call XERMSG ('SLATEC', 'DCSEVL', & 'NUMBER OF TERMS <= 0', 2, 2) if (N > 1000) call XERMSG ('SLATEC', 'DCSEVL', & 'NUMBER OF TERMS > 1000', 3, 2) if (ABS(X) > ONEPL) call XERMSG ('SLATEC', 'DCSEVL', & 'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1) ! B1 = 0.0D0 B0 = 0.0D0 TWOX = 2.0D0*X DO 10 I = 1,N B2 = B1 B1 = B0 NI = N + 1 - I B0 = TWOX*B1 - B2 + CS(NI) 10 CONTINUE ! DCSEVL = 0.5D0*(B0-B2) ! return end DOUBLE PRECISION FUNCTION DCV (XVAL, NDATA, NCONST, NORD, NBKPT, & BKPT, W) ! !! DCV evaluates the variance function of the curve obtained ... ! by the constrained B-spline fitting subprogram DFC. ! !***LIBRARY SLATEC !***CATEGORY L7A3 !***TYPE DOUBLE PRECISION (CV-S, DCV-D) !***KEYWORDS ANALYSIS OF COVARIANCE, B-SPLINE, ! CONSTRAINED LEAST SQUARES, CURVE FITTING !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DCV( ) is a companion function subprogram for DFC( ). The ! documentation for DFC( ) has complete usage instructions. ! ! DCV( ) is used to evaluate the variance function of the curve ! obtained by the constrained B-spline fitting subprogram, DFC( ). ! The variance function defines the square of the probable error ! of the fitted curve at any point, XVAL. One can use the square ! root of this variance function to determine a probable error band ! around the fitted curve. ! ! DCV( ) is used after a call to DFC( ). MODE, an input variable to ! DFC( ), is used to indicate if the variance function is desired. ! In order to use DCV( ), MODE must equal 2 or 4 on input to DFC( ). ! MODE is also used as an output flag from DFC( ). Check to make ! sure that MODE = 0 after calling DFC( ), indicating a successful ! constrained curve fit. The array SDDATA, as input to DFC( ), must ! also be defined with the standard deviation or uncertainty of the ! Y values to use DCV( ). ! ! To evaluate the variance function after calling DFC( ) as stated ! above, use DCV( ) as shown here ! ! VAR=DCV(XVAL,NDATA,NCONST,NORD,NBKPT,BKPT,W) ! ! The variance function is given by ! ! VAR=(transpose of B(XVAL))*C*B(XVAL)/DBLE(MAX(NDATA-N,1)) ! ! where N = NBKPT - NORD. ! ! The vector B(XVAL) is the B-spline basis function values at ! X=XVAL. The covariance matrix, C, of the solution coefficients ! accounts only for the least squares equations and the explicitly ! stated equality constraints. This fact must be considered when ! interpreting the variance function from a data fitting problem ! that has inequality constraints on the fitted curve. ! ! All the variables in the calling sequence for DCV( ) are used in ! DFC( ) except the variable XVAL. Do not change the values of ! these variables between the call to DFC( ) and the use of DCV( ). ! ! The following is a brief description of the variables ! ! XVAL The point where the variance is desired, a double ! precision variable. ! ! NDATA The number of discrete (X,Y) pairs for which DFC( ) ! calculated a piece-wise polynomial curve. ! ! NCONST The number of conditions that constrained the B-spline in ! DFC( ). ! ! NORD The order of the B-spline used in DFC( ). ! The value of NORD must satisfy 1 < NORD < 20 . ! ! (The order of the spline is one more than the degree of ! the piece-wise polynomial defined on each interval. This ! is consistent with the B-spline package convention. For ! example, NORD=4 when we are using piece-wise cubics.) ! ! NBKPT The number of knots in the array BKPT(*). ! The value of NBKPT must satisfy NBKPT >= 2*NORD. ! ! BKPT(*) The double precision array of knots. Normally the problem ! data interval will be included between the limits ! BKPT(NORD) and BKPT(NBKPT-NORD+1). The additional end ! knots BKPT(I),I=1,...,NORD-1 and I=NBKPT-NORD+2,...,NBKPT, ! are required by DFC( ) to compute the functions used to ! fit the data. ! ! W(*) Double precision work array as used in DFC( ). See DFC( ) ! for the required length of W(*). The contents of W(*) ! must not be modified by the user if the variance function ! is desired. ! !***REFERENCES R. J. Hanson, Constrained least squares curve fitting ! to discrete data using B-splines, a users guide, ! Report SAND78-1291, Sandia Laboratories, December ! 1978. !***ROUTINES CALLED DDOT, DFSPVN !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DCV INTEGER I, ILEFT, IP, IS, LAST, MDG, MDW, N, NBKPT, NCONST, & NDATA, NORD DOUBLE PRECISION BKPT, DDOT, V, W, XVAL, ZERO DIMENSION BKPT(*),W(*),V(40) !***FIRST EXECUTABLE STATEMENT DCV ZERO = 0.0D0 MDG = NBKPT - NORD + 3 MDW = NBKPT - NORD + 1 + NCONST IS = MDG*(NORD + 1) + 2*MAX(NDATA,NBKPT) + NBKPT + NORD**2 LAST = NBKPT - NORD + 1 ILEFT = NORD 10 if (XVAL < BKPT(ILEFT+1) .OR. ILEFT >= LAST - 1) go to 20 ILEFT = ILEFT + 1 go to 10 20 CONTINUE call DFSPVN(BKPT,NORD,1,XVAL,ILEFT,V(NORD+1)) ILEFT = ILEFT - NORD + 1 IP = MDW*(ILEFT - 1) + ILEFT + IS N = NBKPT - NORD DO 30 I = 1, NORD V(I) = DDOT(NORD,W(IP),1,V(NORD+1),1) IP = IP + MDW 30 CONTINUE DCV = MAX(DDOT(NORD,V,1,V(NORD+1),1),ZERO) ! ! SCALE THE VARIANCE SO IT IS AN UNBIASED ESTIMATE. DCV = DCV/MAX(NDATA-N,1) return end subroutine DDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR, & IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP) ! !! DDAINI is the initialization routine for DDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDAINI-S, DDAINI-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------- ! DDAINI TAKES ONE STEP OF SIZE H OR SMALLER ! WITH THE BACKWARD EULER METHOD, TO ! FIND YPRIME. X AND Y ARE UPDATED TO BE CONSISTENT WITH THE ! NEW STEP. A MODIFIED DAMPED NEWTON ITERATION IS USED TO ! SOLVE THE CORRECTOR ITERATION. ! ! THE INITIAL GUESS FOR YPRIME IS USED IN THE ! PREDICTION, AND IN FORMING THE ITERATION ! MATRIX, BUT IS NOT INVOLVED IN THE ! ERROR TEST. THIS MAY HAVE TROUBLE ! CONVERGING if THE INITIAL GUESS IS NO ! GOOD, OR if G(X,Y,YPRIME) DEPENDS ! NONLINEARLY ON YPRIME. ! ! THE PARAMETERS REPRESENT: ! X -- INDEPENDENT VARIABLE ! Y -- SOLUTION VECTOR AT X ! YPRIME -- DERIVATIVE OF SOLUTION VECTOR ! NEQ -- NUMBER OF EQUATIONS ! H -- STEPSIZE. IMDER MAY USE A STEPSIZE ! SMALLER THAN H. ! WT -- VECTOR OF WEIGHTS FOR ERROR ! CRITERION ! IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS ! IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY ! IDID=-12 -- DDAINI FAILED TO FIND YPRIME ! RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS ! THAT ARE NOT ALTERED BY DDAINI ! PHI -- WORK SPACE FOR DDAINI ! DELTA,E -- WORK SPACE FOR DDAINI ! WM,IWM -- REAL AND INTEGER ARRAYS STORING ! MATRIX INFORMATION ! !----------------------------------------------------------------- !***ROUTINES CALLED DDAJAC, DDANRM, DDASLV !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) ! 901030 Minor corrections to declarations. (FNF) !***END PROLOGUE DDAINI ! INTEGER NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP DOUBLE PRECISION & X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), & E(*), WM(*), HMIN, UROUND EXTERNAL RES, JAC ! EXTERNAL DDAJAC, DDANRM, DDASLV DOUBLE PRECISION DDANRM ! INTEGER I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF, & NEF, NSF DOUBLE PRECISION & CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM LOGICAL CONVGD ! PARAMETER (LNRE=12) PARAMETER (LNJE=13) ! DATA MAXIT/10/,MJAC/5/ DATA DAMP/0.75D0/ ! ! !--------------------------------------------------- ! BLOCK 1. ! INITIALIZATIONS. !--------------------------------------------------- ! !***FIRST EXECUTABLE STATEMENT DDAINI IDID=1 NEF=0 NCF=0 NSF=0 XOLD=X YNORM=DDANRM(NEQ,Y,WT,RPAR,IPAR) ! ! SAVE Y AND YPRIME IN PHI DO 100 I=1,NEQ PHI(I,1)=Y(I) 100 PHI(I,2)=YPRIME(I) ! ! !---------------------------------------------------- ! BLOCK 2. ! DO ONE BACKWARD EULER STEP. !---------------------------------------------------- ! ! SET UP FOR START OF CORRECTOR ITERATION 200 CJ=1.0D0/H X=X+H ! ! PREDICT SOLUTION AND DERIVATIVE DO 250 I=1,NEQ 250 Y(I)=Y(I)+H*YPRIME(I) ! JCALC=-1 M=0 CONVGD=.TRUE. ! ! ! CORRECTOR LOOP. 300 IWM(LNRE)=IWM(LNRE)+1 IRES=0 ! call RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) if (IRES < 0) go to 430 ! ! ! EVALUATE THE ITERATION MATRIX if (JCALC /= -1) go to 310 IWM(LNJE)=IWM(LNJE)+1 JCALC=0 call DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, & IER,WT,E,WM,IWM,RES,IRES, & UROUND,JAC,RPAR,IPAR,NTEMP) ! S=1000000.D0 if (IRES < 0) go to 430 if (IER /= 0) go to 430 NSF=0 ! ! ! ! MULTIPLY RESIDUAL BY DAMPING FACTOR 310 CONTINUE DO 320 I=1,NEQ 320 DELTA(I)=DELTA(I)*DAMP ! ! COMPUTE A NEW ITERATE (BACK SUBSTITUTION) ! STORE THE CORRECTION IN DELTA ! call DDASLV(NEQ,DELTA,WM,IWM) ! ! UPDATE Y AND YPRIME DO 330 I=1,NEQ Y(I)=Y(I)-DELTA(I) 330 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) ! ! TEST FOR CONVERGENCE OF THE ITERATION. ! DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) if (DELNRM <= 100.D0*UROUND*YNORM) & go to 400 ! if (M > 0) go to 340 OLDNRM=DELNRM go to 350 ! 340 RATE=(DELNRM/OLDNRM)**(1.0D0/M) if (RATE > 0.90D0) go to 430 S=RATE/(1.0D0-RATE) ! 350 if (S*DELNRM <= 0.33D0) go to 400 ! ! ! THE CORRECTOR HAS NOT YET CONVERGED. UPDATE ! M AND AND TEST WHETHER THE MAXIMUM ! NUMBER OF ITERATIONS HAVE BEEN TRIED. ! EVERY MJAC ITERATIONS, GET A NEW ! ITERATION MATRIX. ! M=M+1 if (M >= MAXIT) go to 430 ! if ((M/MJAC)*MJAC == M) JCALC=-1 go to 300 ! ! ! THE ITERATION HAS CONVERGED. ! CHECK NONNEGATIVITY CONSTRAINTS 400 if (NONNEG == 0) go to 450 DO 410 I=1,NEQ 410 DELTA(I)=MIN(Y(I),0.0D0) ! DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) if (DELNRM > 0.33D0) go to 430 ! DO 420 I=1,NEQ Y(I)=Y(I)-DELTA(I) 420 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) go to 450 ! ! ! EXITS FROM CORRECTOR LOOP. 430 CONVGD=.FALSE. 450 if (.NOT.CONVGD) go to 600 ! ! ! !----------------------------------------------------- ! BLOCK 3. ! THE CORRECTOR ITERATION CONVERGED. ! DO ERROR TEST. !----------------------------------------------------- ! DO 510 I=1,NEQ 510 E(I)=Y(I)-PHI(I,1) ERR=DDANRM(NEQ,E,WT,RPAR,IPAR) ! if (ERR <= 1.0D0) RETURN ! ! ! !-------------------------------------------------------- ! BLOCK 4. ! THE BACKWARD EULER STEP FAILED. RESTORE X, Y ! AND YPRIME TO THEIR ORIGINAL VALUES. ! REDUCE STEPSIZE AND TRY AGAIN, IF ! POSSIBLE. !--------------------------------------------------------- ! 600 CONTINUE X = XOLD DO 610 I=1,NEQ Y(I)=PHI(I,1) 610 YPRIME(I)=PHI(I,2) ! if (CONVGD) go to 640 if (IER == 0) go to 620 NSF=NSF+1 H=H*0.25D0 if (NSF < 3.AND.ABS(H) >= HMIN) go to 690 IDID=-12 return 620 if (IRES > -2) go to 630 IDID=-12 return 630 NCF=NCF+1 H=H*0.25D0 if (NCF < 10.AND.ABS(H) >= HMIN) go to 690 IDID=-12 return ! 640 NEF=NEF+1 R=0.90D0/(2.0D0*ERR+0.0001D0) R=MAX(0.1D0,MIN(0.5D0,R)) H=H*R if (ABS(H) >= HMIN.AND.NEF < 10) go to 690 IDID=-12 return 690 go to 200 ! !-------------END OF SUBROUTINE DDAINI---------------------- end subroutine DDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H, IER, WT, E, & WM, IWM, RES, IRES, UROUND, JAC, RPAR, IPAR, NTEMP) ! !! DDAJAC computes the DDASSL iteration matrix and forms the LU-decomposition. ! !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDAJAC-S, DDAJAC-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! THIS ROUTINE COMPUTES THE ITERATION MATRIX ! PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0). ! HERE PD IS COMPUTED BY THE USER-SUPPLIED ! ROUTINE JAC if IWM(MTYPE) IS 1 OR 4, AND ! IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING ! if IWM(MTYPE)IS 2 OR 5 ! THE PARAMETERS HAVE THE FOLLOWING MEANINGS. ! Y = ARRAY CONTAINING PREDICTED VALUES ! YPRIME = ARRAY CONTAINING PREDICTED DERIVATIVES ! DELTA = RESIDUAL EVALUATED AT (X,Y,YPRIME) ! (USED ONLY if IWM(MTYPE)=2 OR 5) ! CJ = SCALAR PARAMETER DEFINING ITERATION MATRIX ! H = CURRENT STEPSIZE IN INTEGRATION ! IER = VARIABLE WHICH IS /= 0 ! if ITERATION MATRIX IS SINGULAR, ! AND 0 OTHERWISE. ! WT = VECTOR OF WEIGHTS FOR COMPUTING NORMS ! E = WORK SPACE (TEMPORARY) OF LENGTH NEQ ! WM = REAL WORK SPACE FOR MATRICES. ON ! OUTPUT IT CONTAINS THE LU DECOMPOSITION ! OF THE ITERATION MATRIX. ! IWM = INTEGER WORK SPACE CONTAINING ! MATRIX INFORMATION ! RES = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE ! TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME) ! IRES = FLAG WHICH IS EQUAL TO ZERO if NO ILLEGAL VALUES ! IN RES, AND LESS THAN ZERO OTHERWISE. (IF IRES ! IS LESS THAN ZERO, THE MATRIX WAS NOT COMPLETED) ! IN THIS CASE (IF IRES < 0), THEN IER = 0. ! UROUND = THE UNIT ROUNDOFF ERROR OF THE MACHINE BEING USED. ! JAC = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE ! TO EVALUATE THE ITERATION MATRIX (THIS ROUTINE ! IS ONLY USED if IWM(MTYPE) IS 1 OR 4) !----------------------------------------------------------------------- !***ROUTINES CALLED DGBFA, DGEFA !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901010 Modified three MAX calls to be all on one line. (FNF) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) ! 901101 Corrected PURPOSE. (FNF) !***END PROLOGUE DDAJAC ! INTEGER NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP DOUBLE PRECISION & X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*), & UROUND, RPAR(*) EXTERNAL RES, JAC ! EXTERNAL DGBFA, DGEFA ! INTEGER I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT, & LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N, & NPD, NPDM1, NROW DOUBLE PRECISION DEL, DELINV, SQUR, YPSAVE, YSAVE ! PARAMETER (NPD=1) PARAMETER (LML=1) PARAMETER (LMU=2) PARAMETER (LMTYPE=4) PARAMETER (LIPVT=21) ! !***FIRST EXECUTABLE STATEMENT DDAJAC IER = 0 NPDM1=NPD-1 MTYPE=IWM(LMTYPE) go to (100,200,300,400,500),MTYPE ! ! ! DENSE USER-SUPPLIED MATRIX 100 LENPD=NEQ*NEQ DO 110 I=1,LENPD 110 WM(NPDM1+I)=0.0D0 call JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) go to 230 ! ! ! DENSE FINITE-DIFFERENCE-GENERATED MATRIX 200 IRES=0 NROW=NPDM1 SQUR = SQRT(UROUND) DO 210 I=1,NEQ DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(I))) DEL=SIGN(DEL,H*YPRIME(I)) DEL=(Y(I)+DEL)-Y(I) YSAVE=Y(I) YPSAVE=YPRIME(I) Y(I)=Y(I)+DEL YPRIME(I)=YPRIME(I)+CJ*DEL call RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) if (IRES < 0) RETURN DELINV=1.0D0/DEL DO 220 L=1,NEQ 220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV NROW=NROW+NEQ Y(I)=YSAVE YPRIME(I)=YPSAVE 210 CONTINUE ! ! ! DO DENSE-MATRIX LU DECOMPOSITION ON PD 230 call DGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER) return ! ! ! DUMMY SECTION FOR IWM(MTYPE)=3 300 return ! ! ! BANDED USER-SUPPLIED MATRIX 400 LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ DO 410 I=1,LENPD 410 WM(NPDM1+I)=0.0D0 call JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) MEBAND=2*IWM(LML)+IWM(LMU)+1 go to 550 ! ! ! BANDED FINITE-DIFFERENCE-GENERATED MATRIX 500 MBAND=IWM(LML)+IWM(LMU)+1 MBA=MIN(MBAND,NEQ) MEBAND=MBAND+IWM(LML) MEB1=MEBAND-1 MSAVE=(NEQ/MBAND)+1 ISAVE=NTEMP-1 IPSAVE=ISAVE+MSAVE IRES=0 SQUR=SQRT(UROUND) DO 540 J=1,MBA DO 510 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 WM(ISAVE+K)=Y(N) WM(IPSAVE+K)=YPRIME(N) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) Y(N)=Y(N)+DEL 510 YPRIME(N)=YPRIME(N)+CJ*DEL call RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) if (IRES < 0) RETURN DO 530 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 Y(N)=WM(ISAVE+K) YPRIME(N)=WM(IPSAVE+K) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) DELINV=1.0D0/DEL I1=MAX(1,(N-IWM(LMU))) I2=MIN(NEQ,(N+IWM(LML))) II=N*MEB1-IWM(LML)+NPDM1 DO 520 I=I1,I2 520 WM(II+I)=(E(I)-DELTA(I))*DELINV 530 CONTINUE 540 CONTINUE ! ! ! DO LU DECOMPOSITION OF BANDED PD 550 call DGBFA(WM(NPD),MEBAND,NEQ, & IWM(LML),IWM(LMU),IWM(LIPVT),IER) return !------END OF SUBROUTINE DDAJAC------ end DOUBLE PRECISION FUNCTION DDANRM (NEQ, V, WT, RPAR, IPAR) ! !! DDANRM computes vector norms for DDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDANRM-S, DDANRM-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ! ROOT-MEAN-SQUARE NORM OF THE VECTOR OF LENGTH ! NEQ CONTAINED IN THE ARRAY V,WITH WEIGHTS ! CONTAINED IN THE ARRAY WT OF LENGTH NEQ. ! DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) !----------------------------------------------------------------------- !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) !***END PROLOGUE DDANRM ! INTEGER NEQ, IPAR(*) DOUBLE PRECISION V(NEQ), WT(NEQ), RPAR(*) ! INTEGER I DOUBLE PRECISION SUM, VMAX ! !***FIRST EXECUTABLE STATEMENT DDANRM DDANRM = 0.0D0 VMAX = 0.0D0 DO I = 1, NEQ if ( ABS(V(I)/WT(I)) > VMAX) VMAX = ABS(V(I)/WT(I)) end do if ( 0.0D0 < VMAX ) then SUM = 0.0D0 DO I = 1,NEQ SUM = SUM + ((V(I)/WT(I))/VMAX)**2 end do DDANRM = VMAX*SQRT(SUM/NEQ) end if return end subroutine DDASLV (NEQ, DELTA, WM, IWM) ! !! DDASLV is a linear system solver for DDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDASLV-S, DDASLV-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR ! SYSTEM ARISING IN THE NEWTON ITERATION. ! MATRICES AND REAL TEMPORARY STORAGE AND ! REAL INFORMATION ARE STORED IN THE ARRAY WM. ! INTEGER MATRIX INFORMATION IS STORED IN ! THE ARRAY IWM. ! FOR A DENSE MATRIX, THE LINPACK ROUTINE ! DGESL IS CALLED. ! FOR A BANDED MATRIX,THE LINPACK ROUTINE ! DGBSL IS CALLED. !----------------------------------------------------------------------- !***ROUTINES CALLED DGBSL, DGESL !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) !***END PROLOGUE DDASLV ! INTEGER NEQ, IWM(*) DOUBLE PRECISION DELTA(*), WM(*) ! EXTERNAL DGBSL, DGESL ! INTEGER LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD PARAMETER (NPD=1) PARAMETER (LML=1) PARAMETER (LMU=2) PARAMETER (LMTYPE=4) PARAMETER (LIPVT=21) ! !***FIRST EXECUTABLE STATEMENT DDASLV MTYPE=IWM(LMTYPE) go to(100,100,300,400,400),MTYPE ! ! DENSE MATRIX 100 call DGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0) return ! ! DUMMY SECTION FOR MTYPE=3 300 CONTINUE return ! ! BANDED MATRIX 400 MEBAND=2*IWM(LML)+IWM(LMU)+1 call DGBSL(WM(NPD),MEBAND,NEQ,IWM(LML), & IWM(LMU),IWM(LIPVT),DELTA,0) return end subroutine DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, & IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) ! !! DDASSL solves a system of differential/algebraic equations... ! of the form G(T,Y,YPRIME) = 0. ! !***LIBRARY SLATEC (DASSL) !***CATEGORY I1A2 !***TYPE DOUBLE PRECISION (SDASSL-S, DDASSL-D) !***KEYWORDS BACKWARD DIFFERENTIATION FORMULAS, DASSL, ! DIFFERENTIAL/ALGEBRAIC, IMPLICIT DIFFERENTIAL SYSTEMS !***AUTHOR Petzold, Linda R., (LLNL) ! Computing and Mathematics Research Division ! Lawrence Livermore National Laboratory ! L - 316, P.O. Box 808, ! Livermore, CA. 94550 !***DESCRIPTION ! ! *Usage: ! ! EXTERNAL RES, JAC ! INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR ! DOUBLE PRECISION T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, ! * RWORK(LRW), RPAR ! ! call DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, ! * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) ! ! ! *Arguments: ! (In the following, all real arrays should be type DOUBLE PRECISION.) ! ! RES:EXT This is a subroutine which you provide to define the ! differential/algebraic system. ! ! NEQ:IN This is the number of equations to be solved. ! ! T:INOUT This is the current value of the independent variable. ! ! Y(*):INOUT This array contains the solution components at T. ! ! YPRIME(*):INOUT This array contains the derivatives of the solution ! components at T. ! ! TOUT:IN This is a point at which a solution is desired. ! ! INFO(N):IN The basic task of the code is to solve the system from T ! to TOUT and return an answer at TOUT. INFO is an integer ! array which is used to communicate exactly how you want ! this task to be carried out. (See below for details.) ! N must be greater than or equal to 15. ! ! RTOL,ATOL:INOUT These quantities represent relative and absolute ! error tolerances which you provide to indicate how ! accurately you wish the solution to be computed. You ! may choose them to be both scalars or else both vectors. ! Caution: In Fortran 77, a scalar is not the same as an ! array of length 1. Some compilers may object ! to using scalars for RTOL,ATOL. ! ! IDID:OUT This scalar quantity is an indicator reporting what the ! code did. You must monitor this integer variable to ! decide what action to take next. ! ! RWORK:WORK A real work array of length LRW which provides the ! code with needed storage space. ! ! LRW:IN The length of RWORK. (See below for required length.) ! ! IWORK:WORK An integer work array of length LIW which provides the ! code with needed storage space. ! ! LIW:IN The length of IWORK. (See below for required length.) ! ! RPAR,IPAR:IN These are real and integer parameter arrays which ! you can use for communication between your calling ! program and the RES subroutine (and the JAC subroutine) ! ! JAC:EXT This is the name of a subroutine which you may choose ! to provide for defining a matrix of partial derivatives ! described below. ! ! Quantities which may be altered by DDASSL are: ! T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, ! IDID, RWORK(*) AND IWORK(*) ! ! *Description ! ! Subroutine DDASSL uses the backward differentiation formulas of ! orders one through five to solve a system of the above form for Y and ! YPRIME. Values for Y and YPRIME at the initial time must be given as ! input. These values must be consistent, (that is, if T,Y,YPRIME are ! the given initial values, they must satisfy G(T,Y,YPRIME) = 0.). The ! subroutine solves the system from T to TOUT. It is easy to continue ! the solution to get results at additional TOUT. This is the interval ! mode of operation. Intermediate results can also be obtained easily ! by using the intermediate-output capability. ! ! The following detailed description is divided into subsections: ! 1. Input required for the first call to DDASSL. ! 2. Output after any return from DDASSL. ! 3. What to do to continue the integration. ! 4. Error messages. ! ! ! -------- INPUT -- WHAT TO DO ON THE FIRST call TO DDASSL ------------ ! ! The first call of the code is defined to be the start of each new ! problem. Read through the descriptions of all the following items, ! provide sufficient storage space for designated arrays, set ! appropriate variables for the initialization of the problem, and ! give information about how you want the problem to be solved. ! ! ! RES -- Provide a subroutine of the form ! SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR) ! to define the system of differential/algebraic ! equations which is to be solved. For the given values ! of T,Y and YPRIME, the subroutine should ! return the residual of the differential/algebraic ! system ! DELTA = G(T,Y,YPRIME) ! (DELTA(*) is a vector of length NEQ which is ! output for RES.) ! ! Subroutine RES must not alter T,Y or YPRIME. ! You must declare the name RES in an external ! statement in your program that calls DDASSL. ! You must dimension Y,YPRIME and DELTA in RES. ! ! IRES is an integer flag which is always equal to ! zero on input. Subroutine RES should alter IRES ! only if it encounters an illegal value of Y or ! a stop condition. Set IRES = -1 if an input value ! is illegal, and DDASSL will try to solve the problem ! without getting IRES = -1. If IRES = -2, DDASSL ! will return control to the calling program ! with IDID = -11. ! ! RPAR and IPAR are real and integer parameter arrays which ! you can use for communication between your calling program ! and subroutine RES. They are not altered by DDASSL. If you ! do not need RPAR or IPAR, ignore these parameters by treat- ! ing them as dummy arguments. If you do choose to use them, ! dimension them in your calling program and in RES as arrays ! of appropriate length. ! ! NEQ -- Set it to the number of differential equations. ! (NEQ >= 1) ! ! T -- Set it to the initial point of the integration. ! T must be defined as a variable. ! ! Y(*) -- Set this vector to the initial values of the NEQ solution ! components at the initial point. You must dimension Y of ! length at least NEQ in your calling program. ! ! YPRIME(*) -- Set this vector to the initial values of the NEQ ! first derivatives of the solution components at the initial ! point. You must dimension YPRIME at least NEQ in your ! calling program. If you do not know initial values of some ! of the solution components, see the explanation of INFO(11). ! ! TOUT -- Set it to the first point at which a solution ! is desired. You can not take TOUT = T. ! integration either forward in T (TOUT > T) or ! backward in T (TOUT < T) is permitted. ! ! The code advances the solution from T to TOUT using ! step sizes which are automatically selected so as to ! achieve the desired accuracy. If you wish, the code will ! return with the solution and its derivative at ! intermediate steps (intermediate-output mode) so that ! you can monitor them, but you still must provide TOUT in ! accord with the basic aim of the code. ! ! The first step taken by the code is a critical one ! because it must reflect how fast the solution changes near ! the initial point. The code automatically selects an ! initial step size which is practically always suitable for ! the problem. By using the fact that the code will not step ! past TOUT in the first step, you could, if necessary, ! restrict the length of the initial step size. ! ! For some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP. When you have declared a TSTOP point (SEE INFO(4) ! and RWORK(1)), you have told the code not to integrate ! past TSTOP. In this case any TOUT beyond TSTOP is invalid ! input. ! ! INFO(*) -- Use the INFO array to give the code more details about ! how you want your problem solved. This array should be ! dimensioned of length 15, though DDASSL uses only the first ! eleven entries. You must respond to all of the following ! items, which are arranged as questions. The simplest use ! of the code corresponds to answering all questions as yes, ! i.e. setting all entries of INFO to 0. ! ! INFO(1) - This parameter enables the code to initialize ! itself. You must set it to indicate the start of every ! new problem. ! ! **** Is this the first call for this problem ... ! Yes - Set INFO(1) = 0 ! No - Not applicable here. ! See below for continuation calls. **** ! ! INFO(2) - How much accuracy you want of your solution ! is specified by the error tolerances RTOL and ATOL. ! The simplest use is to take them both to be scalars. ! To obtain more flexibility, they can both be vectors. ! The code must be told your choice. ! ! **** Are both error tolerances RTOL, ATOL scalars ... ! Yes - Set INFO(2) = 0 ! and input scalars for both RTOL and ATOL ! No - Set INFO(2) = 1 ! and input arrays for both RTOL and ATOL **** ! ! INFO(3) - The code integrates from T in the direction ! of TOUT by steps. If you wish, it will return the ! computed solution and derivative at the next ! intermediate step (the intermediate-output mode) or ! TOUT, whichever comes first. This is a good way to ! proceed if you want to see the behavior of the solution. ! If you must have solutions at a great many specific ! TOUT points, this code will compute them efficiently. ! ! **** Do you want the solution only at ! TOUT (and not at the next intermediate step) ... ! Yes - Set INFO(3) = 0 ! No - Set INFO(3) = 1 **** ! ! INFO(4) - To handle solutions at a great many specific ! values TOUT efficiently, this code may integrate past ! TOUT and interpolate to obtain the result at TOUT. ! Sometimes it is not possible to integrate beyond some ! point TSTOP because the equation changes there or it is ! not defined past TSTOP. Then you must tell the code ! not to go past. ! ! **** Can the integration be carried out without any ! restrictions on the independent variable T ... ! Yes - Set INFO(4)=0 ! No - Set INFO(4)=1 ! and define the stopping point TSTOP by ! setting RWORK(1)=TSTOP **** ! ! INFO(5) - To solve differential/algebraic problems it is ! necessary to use a matrix of partial derivatives of the ! system of differential equations. If you do not ! provide a subroutine to evaluate it analytically (see ! description of the item JAC in the call list), it will ! be approximated by numerical differencing in this code. ! although it is less trouble for you to have the code ! compute partial derivatives by numerical differencing, ! the solution will be more reliable if you provide the ! derivatives via JAC. Sometimes numerical differencing ! is cheaper than evaluating derivatives in JAC and ! sometimes it is not - this depends on your problem. ! ! **** Do you want the code to evaluate the partial ! derivatives automatically by numerical differences ... ! Yes - Set INFO(5)=0 ! No - Set INFO(5)=1 ! and provide subroutine JAC for evaluating the ! matrix of partial derivatives **** ! ! INFO(6) - DDASSL will perform much better if the matrix of ! partial derivatives, DG/DY + CJ*DG/DYPRIME, ! (here CJ is a scalar determined by DDASSL) ! is banded and the code is told this. In this ! case, the storage needed will be greatly reduced, ! numerical differencing will be performed much cheaper, ! and a number of important algorithms will execute much ! faster. The differential equation is said to have ! half-bandwidths ML (lower) and MU (upper) if equation i ! involves only unknowns Y(J) with ! I-ML <= J <= I+MU ! for all I=1,2,...,NEQ. Thus, ML and MU are the widths ! of the lower and upper parts of the band, respectively, ! with the main diagonal being excluded. If you do not ! indicate that the equation has a banded matrix of partial ! derivatives, the code works with a full matrix of NEQ**2 ! elements (stored in the conventional way). Computations ! with banded matrices cost less time and storage than with ! full matrices if 2*ML+MU < NEQ. If you tell the ! code that the matrix of partial derivatives has a banded ! structure and you want to provide subroutine JAC to ! compute the partial derivatives, then you must be careful ! to store the elements of the matrix in the special form ! indicated in the description of JAC. ! ! **** Do you want to solve the problem using a full ! (dense) matrix (and not a special banded ! structure) ... ! Yes - Set INFO(6)=0 ! No - Set INFO(6)=1 ! and provide the lower (ML) and upper (MU) ! bandwidths by setting ! IWORK(1)=ML ! IWORK(2)=MU **** ! ! ! INFO(7) -- You can specify a maximum (absolute value of) ! stepsize, so that the code ! will avoid passing over very ! large regions. ! ! **** Do you want the code to decide ! on its own maximum stepsize? ! Yes - Set INFO(7)=0 ! No - Set INFO(7)=1 ! and define HMAX by setting ! RWORK(2)=HMAX **** ! ! INFO(8) -- Differential/algebraic problems ! may occasionally suffer from ! severe scaling difficulties on the ! first step. If you know a great deal ! about the scaling of your problem, you can ! help to alleviate this problem by ! specifying an initial stepsize HO. ! ! **** Do you want the code to define ! its own initial stepsize? ! Yes - Set INFO(8)=0 ! No - Set INFO(8)=1 ! and define HO by setting ! RWORK(3)=HO **** ! ! INFO(9) -- If storage is a severe problem, ! you can save some locations by ! restricting the maximum order MAXORD. ! the default value is 5. for each ! order decrease below 5, the code ! requires NEQ fewer locations, however ! it is likely to be slower. In any ! case, you must have 1 <= MAXORD <= 5 ! **** Do you want the maximum order to ! default to 5? ! Yes - Set INFO(9)=0 ! No - Set INFO(9)=1 ! and define MAXORD by setting ! IWORK(3)=MAXORD **** ! ! INFO(10) --If you know that the solutions to your equations ! will always be nonnegative, it may help to set this ! parameter. However, it is probably best to ! try the code without using this option first, ! and only to use this option if that doesn't ! work very well. ! **** Do you want the code to solve the problem without ! invoking any special nonnegativity constraints? ! Yes - Set INFO(10)=0 ! No - Set INFO(10)=1 ! ! INFO(11) --DDASSL normally requires the initial T, ! Y, and YPRIME to be consistent. That is, ! you must have G(T,Y,YPRIME) = 0 at the initial ! time. If you do not know the initial ! derivative precisely, you can let DDASSL try ! to compute it. ! **** Are the initial T, Y, YPRIME consistent? ! Yes - Set INFO(11) = 0 ! No - Set INFO(11) = 1, ! and set YPRIME to an initial approximation ! to YPRIME. (If you have no idea what ! YPRIME should be, set it to zero. Note ! that the initial Y should be such ! that there must exist a YPRIME so that ! G(T,Y,YPRIME) = 0.) ! ! RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL ! error tolerances to tell the code how accurately you ! want the solution to be computed. They must be defined ! as variables because the code may change them. You ! have two choices -- ! Both RTOL and ATOL are scalars. (INFO(2)=0) ! Both RTOL and ATOL are vectors. (INFO(2)=1) ! in either case all components must be non-negative. ! ! The tolerances are used by the code in a local error ! test at each step which requires roughly that ! ABS(LOCAL ERROR) <= RTOL*ABS(Y)+ATOL ! for each vector component. ! (More specifically, a root-mean-square norm is used to ! measure the size of vectors, and the error test uses the ! magnitude of the solution at the beginning of the step.) ! ! The true (global) error is the difference between the ! true solution of the initial value problem and the ! computed approximation. Practically all present day ! codes, including this one, control the local error at ! each step and do not even attempt to control the global ! error directly. ! Usually, but not always, the true accuracy of the ! computed Y is comparable to the error tolerances. This ! code will usually, but not always, deliver a more ! accurate solution if you reduce the tolerances and ! integrate again. By comparing two such solutions you ! can get a fairly reliable idea of the true error in the ! solution at the bigger tolerances. ! ! Setting ATOL=0. results in a pure relative error test on ! that component. Setting RTOL=0. results in a pure ! absolute error test on that component. A mixed test ! with non-zero RTOL and ATOL corresponds roughly to a ! relative error test when the solution component is much ! bigger than ATOL and to an absolute error test when the ! solution component is smaller than the threshhold ATOL. ! ! The code will not attempt to compute a solution at an ! accuracy unreasonable for the machine being used. It will ! advise you if you ask for too much accuracy and inform ! you as to the maximum accuracy it believes possible. ! ! RWORK(*) -- Dimension this real work array of length LRW in your ! calling program. ! ! LRW -- Set it to the declared length of the RWORK array. ! You must have ! LRW >= 40+(MAXORD+4)*NEQ+NEQ**2 ! for the full (dense) JACOBIAN case (when INFO(6)=0), or ! LRW >= 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ ! for the banded user-defined JACOBIAN case ! (when INFO(5)=1 and INFO(6)=1), or ! LRW >= 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ ! +2*(NEQ/(ML+MU+1)+1) ! for the banded finite-difference-generated JACOBIAN case ! (when INFO(5)=0 and INFO(6)=1) ! ! IWORK(*) -- Dimension this integer work array of length LIW in ! your calling program. ! ! LIW -- Set it to the declared length of the IWORK array. ! You must have LIW >= 20+NEQ ! ! RPAR, IPAR -- These are parameter arrays, of real and integer ! type, respectively. You can use them for communication ! between your program that calls DDASSL and the ! RES subroutine (and the JAC subroutine). They are not ! altered by DDASSL. If you do not need RPAR or IPAR, ! ignore these parameters by treating them as dummy ! arguments. If you do choose to use them, dimension ! them in your calling program and in RES (and in JAC) ! as arrays of appropriate length. ! ! JAC -- If you have set INFO(5)=0, you can ignore this parameter ! by treating it as a dummy argument. Otherwise, you must ! provide a subroutine of the form ! SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR) ! to define the matrix of partial derivatives ! PD=DG/DY+CJ*DG/DYPRIME ! CJ is a scalar which is input to JAC. ! For the given values of T,Y,YPRIME, the ! subroutine must evaluate the non-zero partial ! derivatives for each equation and each solution ! component, and store these values in the ! matrix PD. The elements of PD are set to zero ! before each call to JAC so only non-zero elements ! need to be defined. ! ! Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ. ! You must declare the name JAC in an EXTERNAL statement in ! your program that calls DDASSL. You must dimension Y, ! YPRIME and PD in JAC. ! ! The way you must store the elements into the PD matrix ! depends on the structure of the matrix which you ! indicated by INFO(6). ! *** INFO(6)=0 -- Full (dense) matrix *** ! Give PD a first dimension of NEQ. ! When you evaluate the (non-zero) partial derivative ! of equation I with respect to variable J, you must ! store it in PD according to ! PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" ! *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU ! upper diagonal bands (refer to INFO(6) description ! of ML and MU) *** ! Give PD a first dimension of 2*ML+MU+1. ! when you evaluate the (non-zero) partial derivative ! of equation I with respect to variable J, you must ! store it in PD according to ! IROW = I - J + ML + MU + 1 ! PD(IROW,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" ! ! RPAR and IPAR are real and integer parameter arrays ! which you can use for communication between your calling ! program and your JACOBIAN subroutine JAC. They are not ! altered by DDASSL. If you do not need RPAR or IPAR, ! ignore these parameters by treating them as dummy ! arguments. If you do choose to use them, dimension ! them in your calling program and in JAC as arrays of ! appropriate length. ! ! ! OPTIONALLY REPLACEABLE NORM ROUTINE: ! ! DDASSL uses a weighted norm DDANRM to measure the size ! of vectors such as the estimated error in each step. ! A FUNCTION subprogram ! DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR) ! DIMENSION V(NEQ),WT(NEQ) ! is used to define this norm. Here, V is the vector ! whose norm is to be computed, and WT is a vector of ! weights. A DDANRM routine has been included with DDASSL ! which computes the weighted root-mean-square norm ! given by ! DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) ! this norm is suitable for most problems. In some ! special cases, it may be more convenient and/or ! efficient to define your own norm by writing a function ! subprogram to be called instead of DDANRM. This should, ! however, be attempted only after careful thought and ! consideration. ! ! ! -------- OUTPUT -- AFTER ANY RETURN FROM DDASSL --------------------- ! ! The principal aim of the code is to return a computed solution at ! TOUT, although it is also possible to obtain intermediate results ! along the way. To find out whether the code achieved its goal ! or if the integration process was interrupted before the task was ! completed, you must check the IDID parameter. ! ! ! T -- The solution was successfully advanced to the ! output value of T. ! ! Y(*) -- Contains the computed solution approximation at T. ! ! YPRIME(*) -- Contains the computed derivative ! approximation at T. ! ! IDID -- Reports what the code did. ! ! *** Task completed *** ! Reported by positive values of IDID ! ! IDID = 1 -- A step was successfully taken in the ! intermediate-output mode. The code has not ! yet reached TOUT. ! ! IDID = 2 -- The integration to TSTOP was successfully ! completed (T=TSTOP) by stepping exactly to TSTOP. ! ! IDID = 3 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping past TOUT. ! Y(*) is obtained by interpolation. ! YPRIME(*) is obtained by interpolation. ! ! *** Task interrupted *** ! Reported by negative values of IDID ! ! IDID = -1 -- A large amount of work has been expended. ! (About 500 steps) ! ! IDID = -2 -- The error tolerances are too stringent. ! ! IDID = -3 -- The local error test cannot be satisfied ! because you specified a zero component in ATOL ! and the corresponding computed solution ! component is zero. Thus, a pure relative error ! test is impossible for this component. ! ! IDID = -6 -- DDASSL had repeated error test ! failures on the last attempted step. ! ! IDID = -7 -- The corrector could not converge. ! ! IDID = -8 -- The matrix of partial derivatives ! is singular. ! ! IDID = -9 -- The corrector could not converge. ! there were repeated error test failures ! in this step. ! ! IDID =-10 -- The corrector could not converge ! because IRES was equal to minus one. ! ! IDID =-11 -- IRES equal to -2 was encountered ! and control is being returned to the ! calling program. ! ! IDID =-12 -- DDASSL failed to compute the initial ! YPRIME. ! ! ! ! IDID = -13,..,-32 -- Not applicable for this code ! ! *** Task terminated *** ! Reported by the value of IDID=-33 ! ! IDID = -33 -- The code has encountered trouble from which ! it cannot recover. A message is printed ! explaining the trouble and control is returned ! to the calling program. For example, this occurs ! when invalid input is detected. ! ! RTOL, ATOL -- These quantities remain unchanged except when ! IDID = -2. In this case, the error tolerances have been ! increased by the code to values which are estimated to ! be appropriate for continuing the integration. However, ! the reported solution at T was obtained using the input ! values of RTOL and ATOL. ! ! RWORK, IWORK -- Contain information which is usually of no ! interest to the user but necessary for subsequent calls. ! However, you may find use for ! ! RWORK(3)--Which contains the step size H to be ! attempted on the next step. ! ! RWORK(4)--Which contains the current value of the ! independent variable, i.e., the farthest point ! integration has reached. This will be different ! from T only when interpolation has been ! performed (IDID=3). ! ! RWORK(7)--Which contains the stepsize used ! on the last successful step. ! ! IWORK(7)--Which contains the order of the method to ! be attempted on the next step. ! ! IWORK(8)--Which contains the order of the method used ! on the last step. ! ! IWORK(11)--Which contains the number of steps taken so ! far. ! ! IWORK(12)--Which contains the number of calls to RES ! so far. ! ! IWORK(13)--Which contains the number of evaluations of ! the matrix of partial derivatives needed so ! far. ! ! IWORK(14)--Which contains the total number ! of error test failures so far. ! ! IWORK(15)--Which contains the total number ! of convergence test failures so far. ! (includes singular iteration matrix ! failures.) ! ! ! -------- INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ------------ ! (CALLS AFTER THE FIRST) ! ! This code is organized so that subsequent calls to continue the ! integration involve little (if any) additional effort on your ! part. You must monitor the IDID parameter in order to determine ! what to do next. ! ! Recalling that the principal task of the code is to integrate ! from T to TOUT (the interval mode), usually all you will need ! to do is specify a new TOUT upon reaching the current TOUT. ! ! Do not alter any quantity not specifically permitted below, ! in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*) ! or the differential equation in subroutine RES. Any such ! alteration constitutes a new problem and must be treated as such, ! i.e., you must start afresh. ! ! You cannot change from vector to scalar error control or vice ! versa (INFO(2)), but you can change the size of the entries of ! RTOL, ATOL. Increasing a tolerance makes the equation easier ! to integrate. Decreasing a tolerance will make the equation ! harder to integrate and should generally be avoided. ! ! You can switch from the intermediate-output mode to the ! interval mode (INFO(3)) or vice versa at any time. ! ! If it has been necessary to prevent the integration from going ! past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the ! code will not integrate to any TOUT beyond the currently ! specified TSTOP. Once TSTOP has been reached you must change ! the value of TSTOP or set INFO(4)=0. You may change INFO(4) ! or TSTOP at any time but you must supply the value of TSTOP in ! RWORK(1) whenever you set INFO(4)=1. ! ! Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) ! unless you are going to restart the code. ! ! *** Following a completed task *** ! If ! IDID = 1, call the code again to continue the integration ! another step in the direction of TOUT. ! ! IDID = 2 or 3, define a new TOUT and call the code again. ! TOUT must be different from T. You cannot change ! the direction of integration without restarting. ! ! *** Following an interrupted task *** ! To show the code that you realize the task was ! interrupted and that you want to continue, you ! must take appropriate action and set INFO(1) = 1 ! If ! IDID = -1, The code has taken about 500 steps. ! If you want to continue, set INFO(1) = 1 and ! call the code again. An additional 500 steps ! will be allowed. ! ! IDID = -2, The error tolerances RTOL, ATOL have been ! increased to values the code estimates appropriate ! for continuing. You may want to change them ! yourself. If you are sure you want to continue ! with relaxed error tolerances, set INFO(1)=1 and ! call the code again. ! ! IDID = -3, A solution component is zero and you set the ! corresponding component of ATOL to zero. If you ! are sure you want to continue, you must first ! alter the error criterion to use positive values ! for those components of ATOL corresponding to zero ! solution components, then set INFO(1)=1 and call ! the code again. ! ! IDID = -4,-5 --- Cannot occur with this code. ! ! IDID = -6, Repeated error test failures occurred on the ! last attempted step in DDASSL. A singularity in the ! solution may be present. If you are absolutely ! certain you want to continue, you should restart ! the integration. (Provide initial values of Y and ! YPRIME which are consistent) ! ! IDID = -7, Repeated convergence test failures occurred ! on the last attempted step in DDASSL. An inaccurate ! or ill-conditioned JACOBIAN may be the problem. If ! you are absolutely certain you want to continue, you ! should restart the integration. ! ! IDID = -8, The matrix of partial derivatives is singular. ! Some of your equations may be redundant. ! DDASSL cannot solve the problem as stated. ! It is possible that the redundant equations ! could be removed, and then DDASSL could ! solve the problem. It is also possible ! that a solution to your problem either ! does not exist or is not unique. ! ! IDID = -9, DDASSL had multiple convergence test ! failures, preceded by multiple error ! test failures, on the last attempted step. ! It is possible that your problem ! is ill-posed, and cannot be solved ! using this code. Or, there may be a ! discontinuity or a singularity in the ! solution. If you are absolutely certain ! you want to continue, you should restart ! the integration. ! ! IDID =-10, DDASSL had multiple convergence test failures ! because IRES was equal to minus one. ! If you are absolutely certain you want ! to continue, you should restart the ! integration. ! ! IDID =-11, IRES=-2 was encountered, and control is being ! returned to the calling program. ! ! IDID =-12, DDASSL failed to compute the initial YPRIME. ! This could happen because the initial ! approximation to YPRIME was not very good, or ! if a YPRIME consistent with the initial Y ! does not exist. The problem could also be caused ! by an inaccurate or singular iteration matrix. ! ! IDID = -13,..,-32 --- Cannot occur with this code. ! ! ! *** Following a terminated task *** ! ! If IDID= -33, you cannot continue the solution of this problem. ! An attempt to do so will result in your ! run being terminated. ! ! ! -------- ERROR MESSAGES --------------------------------------------- ! ! The SLATEC error print routine XERMSG is called in the event of ! unsuccessful completion of a task. Most of these are treated as ! "recoverable errors", which means that (unless the user has directed ! otherwise) control will be returned to the calling program for ! possible action after the message has been printed. ! ! In the event of a negative value of IDID other than -33, an appro- ! priate message is printed and the "error number" printed by XERMSG ! is the value of IDID. There are quite a number of illegal input ! errors that can lead to a returned value IDID=-33. The conditions ! and their printed "error numbers" are as follows: ! ! Error number Condition ! ! 1 Some element of INFO vector is not zero or one. ! 2 NEQ .le. 0 ! 3 MAXORD not in range. ! 4 LRW is less than the required length for RWORK. ! 5 LIW is less than the required length for IWORK. ! 6 Some element of RTOL is .lt. 0 ! 7 Some element of ATOL is .lt. 0 ! 8 All elements of RTOL and ATOL are zero. ! 9 INFO(4)=1 and TSTOP is behind TOUT. ! 10 HMAX .lt. 0.0 ! 11 TOUT is behind T. ! 12 INFO(8)=1 and H0=0.0 ! 13 Some element of WT is .le. 0.0 ! 14 TOUT is too close to T to start integration. ! 15 INFO(4)=1 and TSTOP is behind T. ! 16 --( Not used in this version )-- ! 17 ML illegal. Either .lt. 0 or .gt. NEQ ! 18 MU illegal. Either .lt. 0 or .gt. NEQ ! 19 TOUT = T. ! ! If DDASSL is called again without any action taken to remove the ! cause of an unsuccessful return, XERMSG will be called with a fatal ! error flag, which will cause unconditional termination of the ! program. There are two such fatal errors: ! ! Error number -998: The last step was terminated with a negative ! value of IDID other than -33, and no appropriate action was ! taken. ! ! Error number -999: The previous call was terminated because of ! illegal input (IDID=-33) and there is illegal input in the ! present call, as well. (Suspect infinite loop.) ! ! --------------------------------------------------------------------- ! !***REFERENCES A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC ! SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637, ! SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982. !***ROUTINES CALLED D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, ! XERMSG !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 880387 Code changes made. All common statements have been ! replaced by a DATA statement, which defines pointers into ! RWORK, and PARAMETER statements which define pointers ! into IWORK. As well the documentation has gone through ! grammatical changes. ! 881005 The prologue has been changed to mixed case. ! The subordinate routines had revision dates changed to ! this date, although the documentation for these routines ! is all upper case. No code changes. ! 890511 Code changes made. The DATA statement in the declaration ! section of DDASSL was replaced with a PARAMETER ! statement. Also the statement S = 100.D0 was removed ! from the top of the Newton iteration in DDASTP. ! The subordinate routines had revision dates changed to ! this date. ! 890517 The revision date syntax was replaced with the revision ! history syntax. Also the "DECK" comment was added to ! the top of all subroutines. These changes are consistent ! with new SLATEC guidelines. ! The subordinate routines had revision dates changed to ! this date. No code changes. ! 891013 Code changes made. ! Removed all occurrences of FLOAT or DBLE. All operations ! are now performed with "mixed-mode" arithmetic. ! Also, specific function names were replaced with generic ! function names to be consistent with new SLATEC guidelines. ! In particular: ! Replaced DSQRT with SQRT everywhere. ! Replaced DABS with ABS everywhere. ! Replaced DMIN1 with MIN everywhere. ! Replaced MIN0 with MIN everywhere. ! Replaced DMAX1 with MAX everywhere. ! Replaced MAX0 with MAX everywhere. ! Replaced DSIGN with SIGN everywhere. ! Also replaced REVISION DATE with REVISION HISTORY in all ! subordinate routines. ! 901004 Miscellaneous changes to prologue to complete conversion ! to SLATEC 4.0 format. No code changes. (F.N.Fritsch) ! 901009 Corrected GAMS classification code and converted subsidiary ! routines to 4.0 format. No code changes. (F.N.Fritsch) ! 901010 Converted XERRWV calls to XERMSG calls. (R.Clemens, AFWL) ! 901019 Code changes made. ! Merged SLATEC 4.0 changes with previous changes made ! by C. Ulrich. Below is a history of the changes made by ! C. Ulrich. (Changes in subsidiary routines are implied ! by this history) ! 891228 Bug was found and repaired inside the DDASSL ! and DDAINI routines. DDAINI was incorrectly ! returning the initial T with Y and YPRIME ! computed at T+H. The routine now returns T+H ! rather than the initial T. ! Cosmetic changes made to DDASTP. ! 900904 Three modifications were made to fix a bug (inside ! DDASSL) re interpolation for continuation calls and ! cases where TN is very close to TSTOP: ! ! 1) In testing for whether H is too large, just ! compare H to (TSTOP - TN), rather than ! (TSTOP - TN) * (1-4*UROUND), and set H to ! TSTOP - TN. This will force DDASTP to step ! exactly to TSTOP under certain situations ! (i.e. when H returned from DDASTP would otherwise ! take TN beyond TSTOP). ! ! 2) Inside the DDASTP loop, interpolate exactly to ! TSTOP if TN is very close to TSTOP (rather than ! interpolating to within roundoff of TSTOP). ! ! 3) Modified IDID description for IDID = 2 to say ! that the solution is returned by stepping exactly ! to TSTOP, rather than TOUT. (In some cases the ! solution is actually obtained by extrapolating ! over a distance near unit roundoff to TSTOP, ! but this small distance is deemed acceptable in ! these circumstances.) ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue, removed unreferenced labels, ! and improved XERMSG calls. (FNF) ! 901030 Added ERROR MESSAGES section and reworked other sections to ! be of more uniform format. (FNF) ! 910624 Fixed minor bug related to HMAX (six lines after label ! 525). (LRP) !***END PROLOGUE DDASSL ! !**End ! ! Declare arguments. ! INTEGER NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*) DOUBLE PRECISION & T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*), & RPAR(*) EXTERNAL RES, JAC ! ! Declare externals. ! EXTERNAL D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, XERMSG DOUBLE PRECISION D1MACH, DDANRM ! ! Declare local variables. ! INTEGER I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA, & LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, LIPVT, & LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD, & LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS, & LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP, & NZFLG DOUBLE PRECISION & ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT, & TSTOP, UROUND, YPNORM LOGICAL DONE ! Auxiliary variables for conversion of values to be included in ! error messages. CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 ! ! SET POINTERS INTO IWORK PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, & LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16, & LIPVT=21, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, & LNS=9, LNSTL=10, LIWM=1) ! ! SET RELATIVE OFFSET INTO RWORK PARAMETER (NPD=1) ! ! SET POINTERS INTO RWORK PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, & LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, & LALPHA=11, LBETA=17, LGAMMA=23, & LPSI=29, LSIGMA=35, LDELTA=41) ! !***FIRST EXECUTABLE STATEMENT DDASSL if ( INFO(1) /= 0)go to 100 ! !----------------------------------------------------------------------- ! THIS BLOCK IS EXECUTED FOR THE INITIAL call ONLY. ! IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS. !----------------------------------------------------------------------- ! ! FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO ! ARE EITHER ZERO OR ONE. DO 10 I=2,11 if ( INFO(I) /= 0.AND.INFO(I) /= 1)go to 701 10 CONTINUE ! if ( NEQ <= 0)go to 702 ! ! CHECK AND COMPUTE MAXIMUM ORDER MXORD=5 if ( INFO(9) == 0)go to 20 MXORD=IWORK(LMXORD) if ( MXORD < 1.OR.MXORD > 5)go to 703 20 IWORK(LMXORD)=MXORD ! ! COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU. if ( INFO(6) /= 0)go to 40 LENPD=NEQ**2 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD if ( INFO(5) /= 0)go to 30 IWORK(LMTYPE)=2 go to 60 30 IWORK(LMTYPE)=1 go to 60 40 if ( IWORK(LML) < 0.OR.IWORK(LML) >= NEQ)go to 717 if ( IWORK(LMU) < 0.OR.IWORK(LMU) >= NEQ)go to 718 LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ if ( INFO(5) /= 0)go to 50 IWORK(LMTYPE)=5 MBAND=IWORK(LML)+IWORK(LMU)+1 MSAVE=(NEQ/MBAND)+1 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE go to 60 50 IWORK(LMTYPE)=4 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD ! ! CHECK LENGTHS OF RWORK AND IWORK 60 LENIW=20+NEQ IWORK(LNPD)=LENPD if ( LRW < LENRW)go to 704 if ( LIW < LENIW)go to 705 ! ! CHECK TO SEE THAT TOUT IS DIFFERENT FROM T if ( TOUT == T)go to 719 ! ! CHECK HMAX if ( INFO(7) == 0)go to 70 HMAX=RWORK(LHMAX) if ( HMAX <= 0.0D0)go to 710 70 CONTINUE ! ! INITIALIZE COUNTERS IWORK(LNST)=0 IWORK(LNRE)=0 IWORK(LNJE)=0 ! IWORK(LNSTL)=0 IDID=1 go to 200 ! !----------------------------------------------------------------------- ! THIS BLOCK IS FOR CONTINUATION CALLS ! ONLY. HERE WE CHECK INFO(1), AND if THE ! LAST STEP WAS INTERRUPTED WE CHECK WHETHER ! APPROPRIATE ACTION WAS TAKEN. !----------------------------------------------------------------------- ! 100 CONTINUE if ( INFO(1) == 1)go to 110 if ( INFO(1) /= -1)go to 701 ! ! if WE ARE HERE, THE LAST STEP WAS INTERRUPTED ! BY AN ERROR CONDITION FROM DDASTP, AND ! APPROPRIATE ACTION WAS NOT TAKEN. THIS ! IS A FATAL ERROR. WRITE (XERN1, '(I8)') IDID call XERMSG ('SLATEC', 'DDASSL', & 'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' // & XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN. ' // & 'RUN TERMINATED', -998, 2) return 110 CONTINUE IWORK(LNSTL)=IWORK(LNST) ! !----------------------------------------------------------------------- ! THIS BLOCK IS EXECUTED ON ALL CALLS. ! THE ERROR TOLERANCE PARAMETERS ARE ! CHECKED, AND THE WORK ARRAY POINTERS ! ARE SET. !----------------------------------------------------------------------- ! 200 CONTINUE ! CHECK RTOL,ATOL NZFLG=0 RTOLI=RTOL(1) ATOLI=ATOL(1) DO 210 I=1,NEQ if ( INFO(2) == 1)RTOLI=RTOL(I) if ( INFO(2) == 1)ATOLI=ATOL(I) if ( RTOLI > 0.0D0.OR.ATOLI > 0.0D0)NZFLG=1 if ( RTOLI < 0.0D0)go to 706 if ( ATOLI < 0.0D0)go to 707 210 CONTINUE if ( NZFLG == 0)go to 708 ! ! SET UP RWORK STORAGE.IWORK STORAGE IS FIXED ! IN DATA STATEMENT. LE=LDELTA+NEQ LWT=LE+NEQ LPHI=LWT+NEQ LPD=LPHI+(IWORK(LMXORD)+1)*NEQ LWM=LPD NTEMP=NPD+IWORK(LNPD) if ( INFO(1) == 1)go to 400 ! !----------------------------------------------------------------------- ! THIS BLOCK IS EXECUTED ON THE INITIAL CALL ! ONLY. SET THE INITIAL STEP SIZE, AND ! THE ERROR WEIGHT VECTOR, AND PHI. ! COMPUTE INITIAL YPRIME, if NECESSARY. !----------------------------------------------------------------------- ! TN=T IDID=1 ! ! SET ERROR WEIGHT VECTOR WT call DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) DO 305 I = 1,NEQ if ( RWORK(LWT+I-1) <= 0.0D0) go to 713 305 CONTINUE ! ! COMPUTE UNIT ROUNDOFF AND HMIN UROUND = D1MACH(4) RWORK(LROUND) = UROUND HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) ! ! CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH TDIST = ABS(TOUT - T) if ( TDIST < HMIN) go to 714 ! ! CHECK HO, if THIS WAS INPUT if (INFO(8) == 0) go to 310 HO = RWORK(LH) if ((TOUT - T)*HO < 0.0D0) go to 711 if (HO == 0.0D0) go to 712 go to 320 310 CONTINUE ! ! COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER ! DDASTP OR DDAINI, DEPENDING ON INFO(11) HO = 0.001D0*TDIST YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) if (YPNORM > 0.5D0/HO) HO = 0.5D0/YPNORM HO = SIGN(HO,TOUT-T) ! ADJUST HO if NECESSARY TO MEET HMAX BOUND 320 if (INFO(7) == 0) go to 330 RH = ABS(HO)/RWORK(LHMAX) if (RH > 1.0D0) HO = HO/RH ! COMPUTE TSTOP, if APPLICABLE 330 if (INFO(4) == 0) go to 340 TSTOP = RWORK(LTSTOP) if ((TSTOP - T)*HO < 0.0D0) go to 715 if ((T + HO - TSTOP)*HO > 0.0D0) HO = TSTOP - T if ((TSTOP - TOUT)*HO < 0.0D0) go to 709 ! ! COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, if APPLICABLE 340 if (INFO(11) == 0) go to 350 call DDAINI(TN,Y,YPRIME,NEQ, & RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, & RWORK(LPHI),RWORK(LDELTA),RWORK(LE), & RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), & INFO(10),NTEMP) if (IDID < 0) go to 390 ! ! LOAD H WITH HO. STORE H IN RWORK(LH) 350 H = HO RWORK(LH) = H ! ! LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2) ITEMP = LPHI + NEQ DO 370 I = 1,NEQ RWORK(LPHI + I - 1) = Y(I) 370 RWORK(ITEMP + I - 1) = H*YPRIME(I) ! 390 go to 500 ! !------------------------------------------------------- ! THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS ! PURPOSE IS TO CHECK STOP CONDITIONS BEFORE ! TAKING A STEP. ! ADJUST H if NECESSARY TO MEET HMAX BOUND !------------------------------------------------------- ! 400 CONTINUE UROUND=RWORK(LROUND) DONE = .FALSE. TN=RWORK(LTN) H=RWORK(LH) if ( INFO(7) == 0) go to 410 RH = ABS(H)/RWORK(LHMAX) if ( RH > 1.0D0) H = H/RH 410 CONTINUE if ( T == TOUT) go to 719 if ( (T - TOUT)*H > 0.0D0) go to 711 if ( INFO(4) == 1) go to 430 if ( INFO(3) == 1) go to 420 if ( (TN-TOUT)*H < 0.0D0)go to 490 call DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. go to 490 420 if ( (TN-T)*H <= 0.0D0) go to 490 if ( (TN - TOUT)*H > 0.0D0) go to 425 call DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. go to 490 425 CONTINUE call DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. go to 490 430 if ( INFO(3) == 1) go to 440 TSTOP=RWORK(LTSTOP) if ( (TN-TSTOP)*H > 0.0D0) go to 715 if ( (TSTOP-TOUT)*H < 0.0D0)go to 709 if ( (TN-TOUT)*H < 0.0D0)go to 450 call DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. go to 490 440 TSTOP = RWORK(LTSTOP) if ( (TN-TSTOP)*H > 0.0D0) go to 715 if ( (TSTOP-TOUT)*H < 0.0D0) go to 709 if ( (TN-T)*H <= 0.0D0) go to 450 if ( (TN - TOUT)*H > 0.0D0) go to 445 call DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. go to 490 445 CONTINUE call DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. go to 490 450 CONTINUE ! CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP if ( ABS(TN-TSTOP) > 100.0D0*UROUND* & (ABS(TN)+ABS(H)))go to 460 call DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP DONE = .TRUE. go to 490 460 TNEXT=TN+H if ( (TNEXT-TSTOP)*H <= 0.0D0)go to 490 H=TSTOP-TN RWORK(LH)=H ! 490 if (DONE) go to 580 ! !------------------------------------------------------- ! THE NEXT BLOCK CONTAINS THE call TO THE ! ONE-STEP INTEGRATOR DDASTP. ! THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. ! CHECK FOR TOO MANY STEPS. ! UPDATE WT. ! CHECK FOR TOO MUCH ACCURACY REQUESTED. ! COMPUTE MINIMUM STEPSIZE. !------------------------------------------------------- ! 500 CONTINUE ! CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME if (IDID == -12) go to 527 ! ! CHECK FOR TOO MANY STEPS if ( (IWORK(LNST)-IWORK(LNSTL)) < 500) & go to 510 IDID=-1 go to 527 ! ! UPDATE WT 510 call DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), & RWORK(LWT),RPAR,IPAR) DO 520 I=1,NEQ if ( RWORK(I+LWT-1) > 0.0D0)go to 520 IDID=-3 go to 527 520 CONTINUE ! ! TEST FOR TOO MUCH ACCURACY REQUESTED. R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* & 100.0D0*UROUND if ( R <= 1.0D0)go to 525 ! MULTIPLY RTOL AND ATOL BY R AND RETURN if ( INFO(2) == 1)go to 523 RTOL(1)=R*RTOL(1) ATOL(1)=R*ATOL(1) IDID=-2 go to 527 523 DO 524 I=1,NEQ RTOL(I)=R*RTOL(I) 524 ATOL(I)=R*ATOL(I) IDID=-2 go to 527 525 CONTINUE ! ! COMPUTE MINIMUM STEPSIZE HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT)) ! ! TEST H VS. HMAX if (INFO(7) /= 0) THEN RH = ABS(H)/RWORK(LHMAX) if (RH > 1.0D0) H = H/RH end if ! call DDASTP(TN,Y,YPRIME,NEQ, & RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, & RWORK(LPHI),RWORK(LDELTA),RWORK(LE), & RWORK(LWM),IWORK(LIWM), & RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), & RWORK(LPSI),RWORK(LSIGMA), & RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD), & RWORK(LS),HMIN,RWORK(LROUND), & IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), & IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) 527 if ( IDID < 0)go to 600 ! !-------------------------------------------------------- ! THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN ! FROM DDASTP (IDID=1). TEST FOR STOP CONDITIONS. !-------------------------------------------------------- ! if ( INFO(4) /= 0)go to 540 if ( INFO(3) /= 0)go to 530 if ( (TN-TOUT)*H < 0.0D0)go to 500 call DDATRP(TN,TOUT,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT go to 580 530 if ( (TN-TOUT)*H >= 0.0D0)go to 535 T=TN IDID=1 go to 580 535 call DDATRP(TN,TOUT,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT go to 580 540 if ( INFO(3) /= 0)go to 550 if ( (TN-TOUT)*H < 0.0D0)go to 542 call DDATRP(TN,TOUT,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 go to 580 542 if ( ABS(TN-TSTOP) <= 100.0D0*UROUND* & (ABS(TN)+ABS(H)))go to 545 TNEXT=TN+H if ( (TNEXT-TSTOP)*H <= 0.0D0)go to 500 H=TSTOP-TN go to 500 545 call DDATRP(TN,TSTOP,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP go to 580 550 if ( (TN-TOUT)*H >= 0.0D0)go to 555 if ( ABS(TN-TSTOP) <= 100.0D0*UROUND*(ABS(TN)+ABS(H)))go to 552 T=TN IDID=1 go to 580 552 call DDATRP(TN,TSTOP,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP go to 580 555 call DDATRP(TN,TOUT,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 go to 580 ! !-------------------------------------------------------- ! ALL SUCCESSFUL RETURNS FROM DDASSL ARE MADE FROM ! THIS BLOCK. !-------------------------------------------------------- ! 580 CONTINUE RWORK(LTN)=TN RWORK(LH)=H return ! !----------------------------------------------------------------------- ! THIS BLOCK HANDLES ALL UNSUCCESSFUL ! returnS OTHER THAN FOR ILLEGAL INPUT. !----------------------------------------------------------------------- ! 600 CONTINUE ITEMP=-IDID go to (610,620,630,690,690,640,650,660,670,675, & 680,685), ITEMP ! ! THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE ! REACHING TOUT 610 WRITE (XERN3, '(1P,D15.6)') TN call XERMSG ('SLATEC', 'DDASSL', & 'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' // & 'CALL BEFORE REACHING TOUT', IDID, 1) go to 690 ! ! TOO MUCH ACCURACY FOR MACHINE PRECISION 620 WRITE (XERN3, '(1P,D15.6)') TN call XERMSG ('SLATEC', 'DDASSL', & 'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' // & 'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' // & 'APPROPRIATE VALUES', IDID, 1) go to 690 ! ! WT(I) <= 0.0 FOR SOME I (NOT AT START OF PROBLEM) 630 WRITE (XERN3, '(1P,D15.6)') TN call XERMSG ('SLATEC', 'DDASSL', & 'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME <= ' // & '0.0', IDID, 1) go to 690 ! ! ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN 640 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H call XERMSG ('SLATEC', 'DDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN', & IDID, 1) go to 690 ! ! CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN 650 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H call XERMSG ('SLATEC', 'DDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' // & 'ABS(H)=HMIN', IDID, 1) go to 690 ! ! THE ITERATION MATRIX IS SINGULAR 660 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H call XERMSG ('SLATEC', 'DDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE ITERATION MATRIX IS SINGULAR', IDID, 1) go to 690 ! ! CORRECTOR FAILURE PRECEDED BY ERROR TEST FAILURES. 670 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H call XERMSG ('SLATEC', 'DDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE CORRECTOR COULD NOT CONVERGE. ALSO, THE ERROR TEST ' // & 'FAILED REPEATEDLY.', IDID, 1) go to 690 ! ! CORRECTOR FAILURE BECAUSE IRES = -1 675 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H call XERMSG ('SLATEC', 'DDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' // & 'TO MINUS ONE', IDID, 1) go to 690 ! ! FAILURE BECAUSE IRES = -2 680 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H call XERMSG ('SLATEC', 'DDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' IRES WAS EQUAL TO MINUS TWO', IDID, 1) go to 690 ! ! FAILED TO COMPUTE INITIAL YPRIME 685 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') HO call XERMSG ('SLATEC', 'DDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1) go to 690 ! 690 CONTINUE INFO(1)=-1 T=TN RWORK(LTN)=TN RWORK(LH)=H return ! !----------------------------------------------------------------------- ! THIS BLOCK HANDLES ALL ERROR RETURNS DUE ! TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING ! DDASTP. FIRST THE ERROR MESSAGE ROUTINE IS ! CALLED. if THIS HAPPENS TWICE IN ! SUCCESSION, EXECUTION IS TERMINATED ! !----------------------------------------------------------------------- 701 call XERMSG ('SLATEC', 'DDASSL', & 'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1) go to 750 ! 702 WRITE (XERN1, '(I8)') NEQ call XERMSG ('SLATEC', 'DDASSL', & 'NEQ = ' // XERN1 // ' <= 0', 2, 1) go to 750 ! 703 WRITE (XERN1, '(I8)') MXORD call XERMSG ('SLATEC', 'DDASSL', & 'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1) go to 750 ! 704 WRITE (XERN1, '(I8)') LENRW WRITE (XERN2, '(I8)') LRW call XERMSG ('SLATEC', 'DDASSL', & 'RWORK LENGTH NEEDED, LENRW = ' // XERN1 // & ', EXCEEDS LRW = ' // XERN2, 4, 1) go to 750 ! 705 WRITE (XERN1, '(I8)') LENIW WRITE (XERN2, '(I8)') LIW call XERMSG ('SLATEC', 'DDASSL', & 'IWORK LENGTH NEEDED, LENIW = ' // XERN1 // & ', EXCEEDS LIW = ' // XERN2, 5, 1) go to 750 ! 706 call XERMSG ('SLATEC', 'DDASSL', & 'SOME ELEMENT OF RTOL IS < 0', 6, 1) go to 750 ! 707 call XERMSG ('SLATEC', 'DDASSL', & 'SOME ELEMENT OF ATOL IS < 0', 7, 1) go to 750 ! 708 call XERMSG ('SLATEC', 'DDASSL', & 'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1) go to 750 ! 709 WRITE (XERN3, '(1P,D15.6)') TSTOP WRITE (XERN4, '(1P,D15.6)') TOUT call XERMSG ('SLATEC', 'DDASSL', & 'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' // & XERN4, 9, 1) go to 750 ! 710 WRITE (XERN3, '(1P,D15.6)') HMAX call XERMSG ('SLATEC', 'DDASSL', & 'HMAX = ' // XERN3 // ' < 0.0', 10, 1) go to 750 ! 711 WRITE (XERN3, '(1P,D15.6)') TOUT WRITE (XERN4, '(1P,D15.6)') T call XERMSG ('SLATEC', 'DDASSL', & 'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1) go to 750 ! 712 call XERMSG ('SLATEC', 'DDASSL', & 'INFO(8)=1 AND H0=0.0', 12, 1) go to 750 ! 713 call XERMSG ('SLATEC', 'DDASSL', & 'SOME ELEMENT OF WT IS <= 0.0', 13, 1) go to 750 ! 714 WRITE (XERN3, '(1P,D15.6)') TOUT WRITE (XERN4, '(1P,D15.6)') T call XERMSG ('SLATEC', 'DDASSL', & 'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 // & ' TO START INTEGRATION', 14, 1) go to 750 ! 715 WRITE (XERN3, '(1P,D15.6)') TSTOP WRITE (XERN4, '(1P,D15.6)') T call XERMSG ('SLATEC', 'DDASSL', & 'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4, & 15, 1) go to 750 ! 717 WRITE (XERN1, '(I8)') IWORK(LML) call XERMSG ('SLATEC', 'DDASSL', & 'ML = ' // XERN1 // ' ILLEGAL. EITHER < 0 OR > NEQ', & 17, 1) go to 750 ! 718 WRITE (XERN1, '(I8)') IWORK(LMU) call XERMSG ('SLATEC', 'DDASSL', & 'MU = ' // XERN1 // ' ILLEGAL. EITHER < 0 OR > NEQ', & 18, 1) go to 750 ! 719 WRITE (XERN3, '(1P,D15.6)') TOUT call XERMSG ('SLATEC', 'DDASSL', & 'TOUT = T = ' // XERN3, 19, 1) go to 750 ! 750 IDID=-33 if ( INFO(1) == -1) THEN call XERMSG ('SLATEC', 'DDASSL', & 'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' // & 'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2) end if ! INFO(1)=-1 return !-----------END OF SUBROUTINE DDASSL------------------------------------ end subroutine DDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART, & IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA, & PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC, K, & KOLD, NS, NONNEG, NTEMP) ! !! DDASTP performs one step of the DDASSL integration. ! !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDASTP-S, DDASTP-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! DDASTP SOLVES A SYSTEM OF DIFFERENTIAL/ ! ALGEBRAIC EQUATIONS OF THE FORM ! G(X,Y,YPRIME) = 0, FOR ONE STEP (NORMALLY ! FROM X TO X+H). ! ! THE METHODS USED ARE MODIFIED DIVIDED ! DIFFERENCE,FIXED LEADING COEFFICIENT ! FORMS OF BACKWARD DIFFERENTIATION ! FORMULAS. THE CODE ADJUSTS THE STEPSIZE ! AND ORDER TO CONTROL THE LOCAL ERROR PER ! STEP. ! ! ! THE PARAMETERS REPRESENT ! X -- INDEPENDENT VARIABLE ! Y -- SOLUTION VECTOR AT X ! YPRIME -- DERIVATIVE OF SOLUTION VECTOR ! AFTER SUCCESSFUL STEP ! NEQ -- NUMBER OF EQUATIONS TO BE INTEGRATED ! RES -- EXTERNAL USER-SUPPLIED SUBROUTINE ! TO EVALUATE THE RESIDUAL. THE call IS ! call RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) ! X,Y,YPRIME ARE INPUT. DELTA IS OUTPUT. ! ON INPUT, IRES=0. RES SHOULD ALTER IRES ONLY ! if IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A ! STOP CONDITION. SET IRES=-1 if AN INPUT VALUE ! OF Y IS ILLEGAL, AND DDASTP WILL TRY TO SOLVE ! THE PROBLEM WITHOUT GETTING IRES = -1. IF ! IRES=-2, DDASTP RETURNS CONTROL TO THE CALLING ! PROGRAM WITH IDID = -11. ! JAC -- EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE ! THE ITERATION MATRIX (THIS IS OPTIONAL) ! THE call IS OF THE FORM ! call JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR) ! PD IS THE MATRIX OF PARTIAL DERIVATIVES, ! PD=DG/DY+CJ*DG/DYPRIME ! H -- APPROPRIATE STEP SIZE FOR NEXT STEP. ! NORMALLY DETERMINED BY THE CODE ! WT -- VECTOR OF WEIGHTS FOR ERROR CRITERION. ! JSTART -- INTEGER VARIABLE SET 0 FOR ! FIRST STEP, 1 OTHERWISE. ! IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS: ! IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY ! IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY ! IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE ! IDID=-8 -- THE ITERATION MATRIX IS SINGULAR ! IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE. ! THERE WERE REPEATED ERROR TEST ! FAILURES ON THIS STEP. ! IDID=-10-- THE CORRECTOR COULD NOT CONVERGE ! BECAUSE IRES WAS EQUAL TO MINUS ONE ! IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED, ! AND CONTROL IS BEING RETURNED TO ! THE CALLING PROGRAM ! RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS THAT ! ARE USED FOR COMMUNICATION BETWEEN THE ! CALLING PROGRAM AND EXTERNAL USER ROUTINES ! THEY ARE NOT ALTERED BY DDASTP ! PHI -- ARRAY OF DIVIDED DIFFERENCES USED BY ! DDASTP. THE LENGTH IS NEQ*(K+1),WHERE ! K IS THE MAXIMUM ORDER ! DELTA,E -- WORK VECTORS FOR DDASTP OF LENGTH NEQ ! WM,IWM -- REAL AND INTEGER ARRAYS STORING ! MATRIX INFORMATION SUCH AS THE MATRIX ! OF PARTIAL DERIVATIVES,PERMUTATION ! VECTOR, AND VARIOUS OTHER INFORMATION. ! ! THE OTHER PARAMETERS ARE INFORMATION ! WHICH IS NEEDED INTERNALLY BY DDASTP TO ! CONTINUE FROM STEP TO STEP. ! !----------------------------------------------------------------------- !***ROUTINES CALLED DDAJAC, DDANRM, DDASLV, DDATRP !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) !***END PROLOGUE DDASTP ! INTEGER NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K, & KOLD, NS, NONNEG, NTEMP DOUBLE PRECISION & X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), & E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ, & CJOLD, HOLD, S, HMIN, UROUND EXTERNAL RES, JAC ! EXTERNAL DDAJAC, DDANRM, DDASLV, DDATRP DOUBLE PRECISION DDANRM ! INTEGER I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF, & LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1 DOUBLE PRECISION & ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1, & ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, & TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE LOGICAL CONVGD ! PARAMETER (LMXORD=3) PARAMETER (LNST=11) PARAMETER (LNRE=12) PARAMETER (LNJE=13) PARAMETER (LETF=14) PARAMETER (LCTF=15) ! DATA MAXIT/4/ DATA XRATE/0.25D0/ ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 1. ! INITIALIZE. ON THE FIRST CALL,SET ! THE ORDER TO 1 AND INITIALIZE ! OTHER VARIABLES. !----------------------------------------------------------------------- ! ! INITIALIZATIONS FOR ALL CALLS !***FIRST EXECUTABLE STATEMENT DDASTP IDID=1 XOLD=X NCF=0 NSF=0 NEF=0 if ( JSTART /= 0) go to 120 ! ! if THIS IS THE FIRST STEP,PERFORM ! OTHER INITIALIZATIONS IWM(LETF) = 0 IWM(LCTF) = 0 K=1 KOLD=0 HOLD=0.0D0 JSTART=1 PSI(1)=H CJOLD = 1.0D0/H CJ = CJOLD S = 100.D0 JCALC = -1 DELNRM=1.0D0 IPHASE = 0 NS=0 120 CONTINUE ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 2 ! COMPUTE COEFFICIENTS OF FORMULAS FOR ! THIS STEP. !----------------------------------------------------------------------- 200 CONTINUE KP1=K+1 KP2=K+2 KM1=K-1 XOLD=X if ( H /= HOLD.OR.K /= KOLD) NS = 0 NS=MIN(NS+1,KOLD+2) NSP1=NS+1 if ( KP1 < NS)go to 230 ! BETA(1)=1.0D0 ALPHA(1)=1.0D0 TEMP1=H GAMMA(1)=0.0D0 SIGMA(1)=1.0D0 DO 210 I=2,KP1 TEMP2=PSI(I-1) PSI(I-1)=TEMP1 BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 TEMP1=TEMP2+H ALPHA(I)=H/TEMP1 SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H 210 CONTINUE PSI(KP1)=TEMP1 230 CONTINUE ! ! COMPUTE ALPHAS, ALPHA0 ALPHAS = 0.0D0 ALPHA0 = 0.0D0 DO 240 I = 1,K ALPHAS = ALPHAS - 1.0D0/I ALPHA0 = ALPHA0 - ALPHA(I) 240 CONTINUE ! ! COMPUTE LEADING COEFFICIENT CJ CJLAST = CJ CJ = -ALPHAS/H ! ! COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) CK = MAX(CK,ALPHA(KP1)) ! ! DECIDE WHETHER NEW JACOBIAN IS NEEDED TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) TEMP2 = 1.0D0/TEMP1 if (CJ/CJOLD < TEMP1 .OR. CJ/CJOLD > TEMP2) JCALC = -1 if (CJ /= CJLAST) S = 100.D0 ! ! CHANGE PHI TO PHI STAR if ( KP1 < NSP1) go to 280 DO 270 J=NSP1,KP1 DO 260 I=1,NEQ 260 PHI(I,J)=BETA(J)*PHI(I,J) 270 CONTINUE 280 CONTINUE ! ! UPDATE TIME X=X+H ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 3 ! PREDICT THE SOLUTION AND DERIVATIVE, ! AND SOLVE THE CORRECTOR EQUATION !----------------------------------------------------------------------- ! ! FIRST,PREDICT THE SOLUTION AND DERIVATIVE 300 CONTINUE DO 310 I=1,NEQ Y(I)=PHI(I,1) 310 YPRIME(I)=0.0D0 DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) 320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 330 CONTINUE PNORM = DDANRM (NEQ,Y,WT,RPAR,IPAR) ! ! ! ! SOLVE THE CORRECTOR EQUATION USING A ! MODIFIED NEWTON SCHEME. CONVGD= .TRUE. M=0 IWM(LNRE)=IWM(LNRE)+1 IRES = 0 call RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) if (IRES < 0) go to 380 ! ! ! if INDICATED,REEVALUATE THE ! ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME ! (WHERE G(X,Y,YPRIME)=0). SET ! JCALC TO 0 AS AN INDICATOR THAT ! THIS HAS BEEN DONE. if ( JCALC /= -1)go to 340 IWM(LNJE)=IWM(LNJE)+1 JCALC=0 call DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, & IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR, & IPAR,NTEMP) CJOLD=CJ S = 100.D0 if (IRES < 0) go to 380 if ( IER /= 0)go to 380 NSF=0 ! ! ! INITIALIZE THE ERROR ACCUMULATION VECTOR E. 340 CONTINUE DO 345 I=1,NEQ 345 E(I)=0.0D0 ! ! ! CORRECTOR LOOP. 350 CONTINUE ! ! MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) DO 355 I = 1,NEQ 355 DELTA(I) = DELTA(I) * TEMP1 ! ! COMPUTE A NEW ITERATE (BACK-SUBSTITUTION). ! STORE THE CORRECTION IN DELTA. call DDASLV(NEQ,DELTA,WM,IWM) ! ! UPDATE Y, E, AND YPRIME DO 360 I=1,NEQ Y(I)=Y(I)-DELTA(I) E(I)=E(I)-DELTA(I) 360 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) ! ! TEST FOR CONVERGENCE OF THE ITERATION DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) if (DELNRM <= 100.D0*UROUND*PNORM) go to 375 if (M > 0) go to 365 OLDNRM = DELNRM go to 367 365 RATE = (DELNRM/OLDNRM)**(1.0D0/M) if (RATE > 0.90D0) go to 370 S = RATE/(1.0D0 - RATE) 367 if (S*DELNRM <= 0.33D0) go to 375 ! ! THE CORRECTOR HAS NOT YET CONVERGED. ! UPDATE M AND TEST WHETHER THE ! MAXIMUM NUMBER OF ITERATIONS HAVE ! BEEN TRIED. M=M+1 if ( M >= MAXIT)go to 370 ! ! EVALUATE THE RESIDUAL ! AND GO BACK TO DO ANOTHER ITERATION IWM(LNRE)=IWM(LNRE)+1 IRES = 0 call RES(X,Y,YPRIME,DELTA,IRES, & RPAR,IPAR) if (IRES < 0) go to 380 go to 350 ! ! ! THE CORRECTOR FAILED TO CONVERGE IN MAXIT ! ITERATIONS. if THE ITERATION MATRIX ! IS NOT CURRENT,RE-DO THE STEP WITH ! A NEW ITERATION MATRIX. 370 CONTINUE if ( JCALC == 0)go to 380 JCALC=-1 go to 300 ! ! ! THE ITERATION HAS CONVERGED. if NONNEGATIVITY OF SOLUTION IS ! REQUIRED, SET THE SOLUTION NONNEGATIVE, if THE PERTURBATION ! TO DO IT IS SMALL ENOUGH. if THE CHANGE IS TOO LARGE, THEN ! CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED. 375 if ( NONNEG == 0) go to 390 DO 377 I = 1,NEQ 377 DELTA(I) = MIN(Y(I),0.0D0) DELNRM = DDANRM(NEQ,DELTA,WT,RPAR,IPAR) if ( DELNRM > 0.33D0) go to 380 DO 378 I = 1,NEQ 378 E(I) = E(I) - DELTA(I) go to 390 ! ! ! EXITS FROM BLOCK 3 ! NO CONVERGENCE WITH CURRENT ITERATION ! MATRIX,OR SINGULAR ITERATION MATRIX 380 CONVGD= .FALSE. 390 JCALC = 1 if ( .NOT.CONVGD)go to 600 ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 4 ! ESTIMATE THE ERRORS AT ORDERS K,K-1,K-2 ! AS if CONSTANT STEPSIZE WAS USED. ESTIMATE ! THE LOCAL ERROR AT ORDER K AND TEST ! WHETHER THE CURRENT STEP IS SUCCESSFUL. !----------------------------------------------------------------------- ! ! ESTIMATE ERRORS AT ORDERS K,K-1,K-2 ENORM = DDANRM(NEQ,E,WT,RPAR,IPAR) ERK = SIGMA(K+1)*ENORM TERK = (K+1)*ERK EST = ERK KNEW=K if ( K == 1)go to 430 DO 405 I = 1,NEQ 405 DELTA(I) = PHI(I,KP1) + E(I) ERKM1=SIGMA(K)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKM1 = K*ERKM1 if ( K > 2)go to 410 if ( TERKM1 <= 0.5D0*TERK)go to 420 go to 430 410 CONTINUE DO 415 I = 1,NEQ 415 DELTA(I) = PHI(I,K) + DELTA(I) ERKM2=SIGMA(K-1)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKM2 = (K-1)*ERKM2 if ( MAX(TERKM1,TERKM2) > TERK)go to 430 ! LOWER THE ORDER 420 CONTINUE KNEW=K-1 EST = ERKM1 ! ! ! CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP ! TO SEE if THE STEP WAS SUCCESSFUL 430 CONTINUE ERR = CK * ENORM if ( ERR > 1.0D0)go to 600 ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 5 ! THE STEP IS SUCCESSFUL. DETERMINE ! THE BEST ORDER AND STEPSIZE FOR ! THE NEXT STEP. UPDATE THE DIFFERENCES ! FOR THE NEXT STEP. !----------------------------------------------------------------------- IDID=1 IWM(LNST)=IWM(LNST)+1 KDIFF=K-KOLD KOLD=K HOLD=H ! ! ! ESTIMATE THE ERROR AT ORDER K+1 UNLESS: ! ALREADY DECIDED TO LOWER ORDER, OR ! ALREADY USING MAXIMUM ORDER, OR ! STEPSIZE NOT CONSTANT, OR ! ORDER RAISED IN PREVIOUS STEP if ( KNEW == KM1.OR.K == IWM(LMXORD))IPHASE=1 if ( IPHASE == 0)go to 545 if ( KNEW == KM1)go to 540 if ( K == IWM(LMXORD)) go to 550 if ( KP1 >= NS.OR.KDIFF == 1)go to 550 DO 510 I=1,NEQ 510 DELTA(I)=E(I)-PHI(I,KP2) ERKP1 = (1.0D0/(K+2))*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKP1 = (K+2)*ERKP1 if ( K > 1)go to 520 if ( TERKP1 >= 0.5D0*TERK)go to 550 go to 530 520 if ( TERKM1 <= MIN(TERK,TERKP1))go to 540 if ( TERKP1 >= TERK.OR.K == IWM(LMXORD))go to 550 ! ! RAISE ORDER 530 K=KP1 EST = ERKP1 go to 550 ! ! LOWER ORDER 540 K=KM1 EST = ERKM1 go to 550 ! ! if IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY ! FACTOR TWO 545 K = KP1 HNEW = H*2.0D0 H = HNEW go to 575 ! ! ! DETERMINE THE APPROPRIATE STEPSIZE FOR ! THE NEXT STEP. 550 HNEW=H TEMP2=K+1 R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) if ( R < 2.0D0) go to 555 HNEW = 2.0D0*H go to 560 555 if ( R > 1.0D0) go to 560 R = MAX(0.5D0,MIN(0.9D0,R)) HNEW = H*R 560 H=HNEW ! ! ! UPDATE DIFFERENCES FOR NEXT STEP 575 CONTINUE if ( KOLD == IWM(LMXORD))go to 585 DO 580 I=1,NEQ 580 PHI(I,KP2)=E(I) 585 CONTINUE DO 590 I=1,NEQ 590 PHI(I,KP1)=PHI(I,KP1)+E(I) DO 595 J1=2,KP1 J=KP1-J1+1 DO 595 I=1,NEQ 595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) return ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 6 ! THE STEP IS UNSUCCESSFUL. RESTORE X,PSI,PHI ! DETERMINE APPROPRIATE STEPSIZE FOR ! CONTINUING THE INTEGRATION, OR EXIT WITH ! AN ERROR FLAG if THERE HAVE BEEN MANY ! FAILURES. !----------------------------------------------------------------------- 600 IPHASE = 1 ! ! RESTORE X,PHI,PSI X=XOLD if ( KP1 < NSP1)go to 630 DO 620 J=NSP1,KP1 TEMP1=1.0D0/BETA(J) DO 610 I=1,NEQ 610 PHI(I,J)=TEMP1*PHI(I,J) 620 CONTINUE 630 CONTINUE DO 640 I=2,KP1 640 PSI(I-1)=PSI(I)-H ! ! ! TEST WHETHER FAILURE IS DUE TO CORRECTOR ITERATION ! OR ERROR TEST if ( CONVGD)go to 660 IWM(LCTF)=IWM(LCTF)+1 ! ! ! THE NEWTON ITERATION FAILED TO CONVERGE WITH ! A CURRENT ITERATION MATRIX. DETERMINE THE CAUSE ! OF THE FAILURE AND TAKE APPROPRIATE ACTION. if ( IER == 0)go to 650 ! ! THE ITERATION MATRIX IS SINGULAR. REDUCE ! THE STEPSIZE BY A FACTOR OF 4. IF ! THIS HAPPENS THREE TIMES IN A ROW ON ! THE SAME STEP, RETURN WITH AN ERROR FLAG NSF=NSF+1 R = 0.25D0 H=H*R if (NSF < 3 .AND. ABS(H) >= HMIN) go to 690 IDID=-8 go to 675 ! ! ! THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON ! OTHER THAN A SINGULAR ITERATION MATRIX. if IRES = -2, THEN ! return. OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS ! TOO MANY FAILURES HAVE OCCURRED. 650 CONTINUE if (IRES > -2) go to 655 IDID = -11 go to 675 655 NCF = NCF + 1 R = 0.25D0 H = H*R if (NCF < 10 .AND. ABS(H) >= HMIN) go to 690 IDID = -7 if (IRES < 0) IDID = -10 if (NEF >= 3) IDID = -9 go to 675 ! ! ! THE NEWTON SCHEME CONVERGED, AND THE CAUSE ! OF THE FAILURE WAS THE ERROR ESTIMATE ! EXCEEDING THE TOLERANCE. 660 NEF=NEF+1 IWM(LETF)=IWM(LETF)+1 if (NEF > 1) go to 665 ! ! ON FIRST ERROR TEST FAILURE, KEEP CURRENT ORDER OR LOWER ! ORDER BY ONE. COMPUTE NEW STEPSIZE BASED ON DIFFERENCES ! OF THE SOLUTION. K = KNEW TEMP2 = K + 1 R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) R = MAX(0.25D0,MIN(0.9D0,R)) H = H*R if (ABS(H) >= HMIN) go to 690 IDID = -6 go to 675 ! ! ON SECOND ERROR TEST FAILURE, USE THE CURRENT ORDER OR ! DECREASE ORDER BY ONE. REDUCE THE STEPSIZE BY A FACTOR OF ! FOUR. 665 if (NEF > 2) go to 670 K = KNEW H = 0.25D0*H if (ABS(H) >= HMIN) go to 690 IDID = -6 go to 675 ! ! ON THIRD AND SUBSEQUENT ERROR TEST FAILURES, SET THE ORDER TO ! ONE AND REDUCE THE STEPSIZE BY A FACTOR OF FOUR. 670 K = 1 H = 0.25D0*H if (ABS(H) >= HMIN) go to 690 IDID = -6 go to 675 ! ! ! ! ! FOR ALL CRASHES, RESTORE Y TO ITS LAST VALUE, ! INTERPOLATE TO FIND YPRIME AT LAST X, AND RETURN 675 CONTINUE call DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) return ! ! ! GO BACK AND TRY THIS STEP AGAIN 690 go to 200 ! !------END OF SUBROUTINE DDASTP------ end subroutine DDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI) ! !! DDATRP is an interpolation routine for DDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDATRP-S, DDATRP-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! THE METHODS IN SUBROUTINE DDASTP USE POLYNOMIALS ! TO APPROXIMATE THE SOLUTION. DDATRP APPROXIMATES THE ! SOLUTION AND ITS DERIVATIVE AT TIME XOUT BY EVALUATING ! ONE OF THESE POLYNOMIALS, AND ITS DERIVATIVE,THERE. ! INFORMATION DEFINING THIS POLYNOMIAL IS PASSED FROM ! DDASTP, SO DDATRP CANNOT BE USED ALONE. ! ! THE PARAMETERS ARE: ! X THE CURRENT TIME IN THE INTEGRATION. ! XOUT THE TIME AT WHICH THE SOLUTION IS DESIRED ! YOUT THE INTERPOLATED APPROXIMATION TO Y AT XOUT ! (THIS IS OUTPUT) ! YPOUT THE INTERPOLATED APPROXIMATION TO YPRIME AT XOUT ! (THIS IS OUTPUT) ! NEQ NUMBER OF EQUATIONS ! KOLD ORDER USED ON LAST SUCCESSFUL STEP ! PHI ARRAY OF SCALED DIVIDED DIFFERENCES OF Y ! PSI ARRAY OF PAST STEPSIZE HISTORY !----------------------------------------------------------------------- !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) !***END PROLOGUE DDATRP ! INTEGER NEQ, KOLD DOUBLE PRECISION X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*) ! INTEGER I, J, KOLDP1 DOUBLE PRECISION C, D, GAMMA, TEMP1 ! !***FIRST EXECUTABLE STATEMENT DDATRP KOLDP1=KOLD+1 TEMP1=XOUT-X DO 10 I=1,NEQ YOUT(I)=PHI(I,1) 10 YPOUT(I)=0.0D0 C=1.0D0 D=0.0D0 GAMMA=TEMP1/PSI(1) DO 30 J=2,KOLDP1 D=D*GAMMA+C/PSI(J-1) C=C*GAMMA GAMMA=(TEMP1+PSI(J-1))/PSI(J) DO 20 I=1,NEQ YOUT(I)=YOUT(I)+C*PHI(I,J) 20 YPOUT(I)=YPOUT(I)+D*PHI(I,J) 30 CONTINUE return end DOUBLE PRECISION FUNCTION DDAWS (X) ! !! DDAWS computes Dawson's function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C8C !***TYPE DOUBLE PRECISION (DAWS-S, DDAWS-D) !***KEYWORDS DAWSON'S FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DDAWS(X) calculates the double precision Dawson's integral ! for double precision argument X. ! ! Series for DAW on the interval 0. to 1.00000E+00 ! with weighted error 8.95E-32 ! log weighted error 31.05 ! significant figures required 30.41 ! decimal places required 31.71 ! ! Series for DAW2 on the interval 0. to 1.60000E+01 ! with weighted error 1.61E-32 ! log weighted error 31.79 ! significant figures required 31.40 ! decimal places required 32.62 ! ! Series for DAWA on the interval 0. to 6.25000E-02 ! with weighted error 1.97E-32 ! log weighted error 31.71 ! significant figures required 29.79 ! decimal places required 32.64 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 780401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE DDAWS DOUBLE PRECISION X, DAWCS(21), DAW2CS(45), DAWACS(75), XBIG, & XMAX, XSML, Y, DCSEVL, D1MACH LOGICAL FIRST SAVE DAWCS, DAW2CS, DAWACS, NTDAW, NTDAW2, NTDAWA, & XSML, XBIG, XMAX, FIRST DATA DAWCS( 1) / -.6351734375145949201065127736293D-2 / DATA DAWCS( 2) / -.2294071479677386939899824125866D+0 / DATA DAWCS( 3) / +.2213050093908476441683979161786D-1 / DATA DAWCS( 4) / -.1549265453892985046743057753375D-2 / DATA DAWCS( 5) / +.8497327715684917456777542948066D-4 / DATA DAWCS( 6) / -.3828266270972014924994099521309D-5 / DATA DAWCS( 7) / +.1462854806250163197757148949539D-6 / DATA DAWCS( 8) / -.4851982381825991798846715425114D-8 / DATA DAWCS( 9) / +.1421463577759139790347568183304D-9 / DATA DAWCS( 10) / -.3728836087920596525335493054088D-11 / DATA DAWCS( 11) / +.8854942961778203370194565231369D-13 / DATA DAWCS( 12) / -.1920757131350206355421648417493D-14 / DATA DAWCS( 13) / +.3834325867246327588241074439253D-16 / DATA DAWCS( 14) / -.7089154168175881633584099327999D-18 / DATA DAWCS( 15) / +.1220552135889457674416901120000D-19 / DATA DAWCS( 16) / -.1966204826605348760299451733333D-21 / DATA DAWCS( 17) / +.2975845541376597189113173333333D-23 / DATA DAWCS( 18) / -.4247069514800596951039999999999D-25 / DATA DAWCS( 19) / +.5734270767391742798506666666666D-27 / DATA DAWCS( 20) / -.7345836823178450261333333333333D-29 / DATA DAWCS( 21) / +.8951937667516552533333333333333D-31 / DATA DAW2CS( 1) / -.56886544105215527114160533733674D-1 / DATA DAW2CS( 2) / -.31811346996168131279322878048822D+0 / DATA DAW2CS( 3) / +.20873845413642236789741580198858D+0 / DATA DAW2CS( 4) / -.12475409913779131214073498314784D+0 / DATA DAW2CS( 5) / +.67869305186676777092847516423676D-1 / DATA DAW2CS( 6) / -.33659144895270939503068230966587D-1 / DATA DAW2CS( 7) / +.15260781271987971743682460381640D-1 / DATA DAW2CS( 8) / -.63483709625962148230586094788535D-2 / DATA DAW2CS( 9) / +.24326740920748520596865966109343D-2 / DATA DAW2CS( 10) / -.86219541491065032038526983549637D-3 / DATA DAW2CS( 11) / +.28376573336321625302857636538295D-3 / DATA DAW2CS( 12) / -.87057549874170423699396581464335D-4 / DATA DAW2CS( 13) / +.24986849985481658331800044137276D-4 / DATA DAW2CS( 14) / -.67319286764160294344603050339520D-5 / DATA DAW2CS( 15) / +.17078578785573543710504524047844D-5 / DATA DAW2CS( 16) / -.40917551226475381271896592490038D-6 / DATA DAW2CS( 17) / +.92828292216755773260751785312273D-7 / DATA DAW2CS( 18) / -.19991403610147617829845096332198D-7 / DATA DAW2CS( 19) / +.40963490644082195241210487868917D-8 / DATA DAW2CS( 20) / -.80032409540993168075706781753561D-9 / DATA DAW2CS( 21) / +.14938503128761465059143225550110D-9 / DATA DAW2CS( 22) / -.26687999885622329284924651063339D-10 / DATA DAW2CS( 23) / +.45712216985159458151405617724103D-11 / DATA DAW2CS( 24) / -.75187305222043565872243727326771D-12 / DATA DAW2CS( 25) / +.11893100052629681879029828987302D-12 / DATA DAW2CS( 26) / -.18116907933852346973490318263084D-13 / DATA DAW2CS( 27) / +.26611733684358969193001612199626D-14 / DATA DAW2CS( 28) / -.37738863052129419795444109905930D-15 / DATA DAW2CS( 29) / +.51727953789087172679680082229329D-16 / DATA DAW2CS( 30) / -.68603684084077500979419564670102D-17 / DATA DAW2CS( 31) / +.88123751354161071806469337321745D-18 / DATA DAW2CS( 32) / -.10974248249996606292106299624652D-18 / DATA DAW2CS( 33) / +.13261199326367178513595545891635D-19 / DATA DAW2CS( 34) / -.15562732768137380785488776571562D-20 / DATA DAW2CS( 35) / +.17751425583655720607833415570773D-21 / DATA DAW2CS( 36) / -.19695006967006578384953608765439D-22 / DATA DAW2CS( 37) / +.21270074896998699661924010120533D-23 / DATA DAW2CS( 38) / -.22375398124627973794182113962666D-24 / DATA DAW2CS( 39) / +.22942768578582348946971383125333D-25 / DATA DAW2CS( 40) / -.22943788846552928693329592319999D-26 / DATA DAW2CS( 41) / +.22391702100592453618342297600000D-27 / DATA DAW2CS( 42) / -.21338230616608897703678225066666D-28 / DATA DAW2CS( 43) / +.19866196585123531518028458666666D-29 / DATA DAW2CS( 44) / -.18079295866694391771955199999999D-30 / DATA DAW2CS( 45) / +.16090686015283030305450666666666D-31 / DATA DAWACS( 1) / +.1690485637765703755422637438849D-1 / DATA DAWACS( 2) / +.8683252278406957990536107850768D-2 / DATA DAWACS( 3) / +.2424864042417715453277703459889D-3 / DATA DAWACS( 4) / +.1261182399572690001651949240377D-4 / DATA DAWACS( 5) / +.1066453314636176955705691125906D-5 / DATA DAWACS( 6) / +.1358159794790727611348424505728D-6 / DATA DAWACS( 7) / +.2171042356577298398904312744743D-7 / DATA DAWACS( 8) / +.2867010501805295270343676804813D-8 / DATA DAWACS( 9) / -.1901336393035820112282492378024D-9 / DATA DAWACS( 10) / -.3097780484395201125532065774268D-9 / DATA DAWACS( 11) / -.1029414876057509247398132286413D-9 / DATA DAWACS( 12) / -.6260356459459576150417587283121D-11 / DATA DAWACS( 13) / +.8563132497446451216262303166276D-11 / DATA DAWACS( 14) / +.3033045148075659292976266276257D-11 / DATA DAWACS( 15) / -.2523618306809291372630886938826D-12 / DATA DAWACS( 16) / -.4210604795440664513175461934510D-12 / DATA DAWACS( 17) / -.4431140826646238312143429452036D-13 / DATA DAWACS( 18) / +.4911210272841205205940037065117D-13 / DATA DAWACS( 19) / +.1235856242283903407076477954739D-13 / DATA DAWACS( 20) / -.5788733199016569246955765071069D-14 / DATA DAWACS( 21) / -.2282723294807358620978183957030D-14 / DATA DAWACS( 22) / +.7637149411014126476312362917590D-15 / DATA DAWACS( 23) / +.3851546883566811728777594002095D-15 / DATA DAWACS( 24) / -.1199932056928290592803237283045D-15 / DATA DAWACS( 25) / -.6313439150094572347334270285250D-16 / DATA DAWACS( 26) / +.2239559965972975375254912790237D-16 / DATA DAWACS( 27) / +.9987925830076495995132891200749D-17 / DATA DAWACS( 28) / -.4681068274322495334536246507252D-17 / DATA DAWACS( 29) / -.1436303644349721337241628751534D-17 / DATA DAWACS( 30) / +.1020822731410541112977908032130D-17 / DATA DAWACS( 31) / +.1538908873136092072837389822372D-18 / DATA DAWACS( 32) / -.2189157877645793888894790926056D-18 / DATA DAWACS( 33) / +.2156879197938651750392359152517D-20 / DATA DAWACS( 34) / +.4370219827442449851134792557395D-19 / DATA DAWACS( 35) / -.8234581460977207241098927905177D-20 / DATA DAWACS( 36) / -.7498648721256466222903202835420D-20 / DATA DAWACS( 37) / +.3282536720735671610957612930039D-20 / DATA DAWACS( 38) / +.8858064309503921116076561515151D-21 / DATA DAWACS( 39) / -.9185087111727002988094460531485D-21 / DATA DAWACS( 40) / +.2978962223788748988314166045791D-22 / DATA DAWACS( 41) / +.1972132136618471883159505468041D-21 / DATA DAWACS( 42) / -.5974775596362906638089584995117D-22 / DATA DAWACS( 43) / -.2834410031503850965443825182441D-22 / DATA DAWACS( 44) / +.2209560791131554514777150489012D-22 / DATA DAWACS( 45) / -.5439955741897144300079480307711D-25 / DATA DAWACS( 46) / -.5213549243294848668017136696470D-23 / DATA DAWACS( 47) / +.1702350556813114199065671499076D-23 / DATA DAWACS( 48) / +.6917400860836148343022185660197D-24 / DATA DAWACS( 49) / -.6540941793002752512239445125802D-24 / DATA DAWACS( 50) / +.6093576580439328960371824654636D-25 / DATA DAWACS( 51) / +.1408070432905187461501945080272D-24 / DATA DAWACS( 52) / -.6785886121054846331167674943755D-25 / DATA DAWACS( 53) / -.9799732036214295711741583102225D-26 / DATA DAWACS( 54) / +.2121244903099041332598960939160D-25 / DATA DAWACS( 55) / -.5954455022548790938238802154487D-26 / DATA DAWACS( 56) / -.3093088861875470177838847232049D-26 / DATA DAWACS( 57) / +.2854389216344524682400691986104D-26 / DATA DAWACS( 58) / -.3951289447379305566023477271811D-27 / DATA DAWACS( 59) / -.5906000648607628478116840894453D-27 / DATA DAWACS( 60) / +.3670236964668687003647889980609D-27 / DATA DAWACS( 61) / -.4839958238042276256598303038941D-29 / DATA DAWACS( 62) / -.9799265984210443869597404017022D-28 / DATA DAWACS( 63) / +.4684773732612130606158908804300D-28 / DATA DAWACS( 64) / +.5030877696993461051647667603155D-29 / DATA DAWACS( 65) / -.1547395051706028239247552068295D-28 / DATA DAWACS( 66) / +.6112180185086419243976005662714D-29 / DATA DAWACS( 67) / +.1357913399124811650343602736158D-29 / DATA DAWACS( 68) / -.2417687752768673088385304299044D-29 / DATA DAWACS( 69) / +.8369074582074298945292887587291D-30 / DATA DAWACS( 70) / +.2665413042788979165838319401566D-30 / DATA DAWACS( 71) / -.3811653692354890336935691003712D-30 / DATA DAWACS( 72) / +.1230054721884951464371706872585D-30 / DATA DAWACS( 73) / +.4622506399041493508805536929983D-31 / DATA DAWACS( 74) / -.6120087296881677722911435593001D-31 / DATA DAWACS( 75) / +.1966024640193164686956230217896D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DDAWS if (FIRST) THEN EPS = D1MACH(3) NTDAW = INITDS (DAWCS, 21, 0.1*EPS) NTDAW2 = INITDS (DAW2CS, 45, 0.1*EPS) NTDAWA = INITDS (DAWACS, 75, 0.1*EPS) ! XSML = SQRT(1.5*EPS) XBIG = SQRT (0.5/EPS) XMAX = EXP (MIN (-LOG(2.D0*D1MACH(1)), LOG(D1MACH(2))) & - 0.001D0) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 1.0D0) go to 20 ! DDAWS = X if (Y <= XSML) RETURN ! DDAWS = X * (.75D0 + DCSEVL (2.D0*Y*Y-1.D0, DAWCS, NTDAW)) return ! 20 if (Y > 4.D0) go to 30 DDAWS = X * (.25D0 + DCSEVL (.125D0*Y*Y-1.D0, DAW2CS, NTDAW2)) return ! 30 if (Y > XMAX) go to 40 DDAWS = 0.5D0/X if (Y > XBIG) RETURN ! DDAWS = (0.5D0 + DCSEVL (32.D0/Y**2-1.D0, DAWACS, NTDAWA)) / X return ! 40 call XERMSG ('SLATEC', 'DDAWS', 'ABS(X) SO LARGE DAWS UNDERFLOWS', & 1, 1) DDAWS = 0.0D0 return ! end subroutine DDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR) ! !! DDAWTS sets the error weight vector for DDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDAWTS-S, DDAWTS-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR ! WT ACCORDING TO WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), ! I=1,-,N. ! RTOL AND ATOL ARE SCALARS if IWT = 0, ! AND VECTORS if IWT = 1. !----------------------------------------------------------------------- !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) !***END PROLOGUE DDAWTS ! INTEGER NEQ, IWT, IPAR(*) DOUBLE PRECISION RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*) ! INTEGER I DOUBLE PRECISION ATOLI, RTOLI ! !***FIRST EXECUTABLE STATEMENT DDAWTS RTOLI=RTOL(1) ATOLI=ATOL(1) DO 20 I=1,NEQ if (IWT == 0) go to 10 RTOLI=RTOL(I) ATOLI=ATOL(I) 10 WT(I)=RTOLI*ABS(Y(I))+ATOLI 20 CONTINUE return !-----------END OF SUBROUTINE DDAWTS------------------------------------ end subroutine DDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, & MITER, ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, SAVE1, & SAVE2, A, D, JSTATE) ! !! DDCOR computes corrections to the Y array for DDRIVE. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE DOUBLE PRECISION (SDCOR-S, DDCOR-D, CDCOR-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! In the case of functional iteration, update Y directly from the ! result of the last call to F. ! In the case of the chord method, compute the corrector error and ! solve the linear system with that as right hand side and DFDY as ! coefficient matrix, using the LU decomposition if MITER is 1, 2, 4, ! or 5. ! !***ROUTINES CALLED DGBSL, DGESL, DNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDCOR INTEGER I, IERROR, IFLAG, IMPL, J, JSTATE, MATDIM, MITER, ML, MU, & MW, N, NDE, NQ DOUBLE PRECISION A(MATDIM,*), D, DFDY(MATDIM,*), EL(13,12), H, & SAVE1(*), SAVE2(*), DNRM2, T, Y(*), YH(N,*), YWT(*) INTEGER IPVT(*) LOGICAL EVALFA !***FIRST EXECUTABLE STATEMENT DDCOR if (MITER == 0) THEN if (IERROR == 1 .OR. IERROR == 5) THEN DO 100 I = 1,N 100 SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/YWT(I) ELSE DO 102 I = 1,N SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/ & MAX(ABS(Y(I)), YWT(I)) 102 CONTINUE end if D = DNRM2(N, SAVE1, 1)/SQRT(DBLE(N)) DO 105 I = 1,N 105 SAVE1(I) = H*SAVE2(I) - YH(I,2) ELSE if (MITER == 1 .OR. MITER == 2) THEN if (IMPL == 0) THEN DO 130 I = 1,N 130 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) ELSE if (IMPL == 1) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 150 I = 1,N 150 SAVE2(I) = H*SAVE2(I) DO 160 J = 1,N DO 160 I = 1,N 160 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) ELSE if (IMPL == 2) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 180 I = 1,N 180 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) ELSE if (IMPL == 3) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 140 I = 1,N 140 SAVE2(I) = H*SAVE2(I) DO 170 J = 1,NDE DO 170 I = 1,NDE 170 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) end if call DGESL (DFDY, MATDIM, N, IPVT, SAVE2, 0) if (IERROR == 1 .OR. IERROR == 5) THEN DO 200 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 200 SAVE2(I) = SAVE2(I)/YWT(I) ELSE DO 205 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 205 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) end if D = DNRM2(N, SAVE2, 1)/SQRT(DBLE(N)) ELSE if (MITER == 4 .OR. MITER == 5) THEN if (IMPL == 0) THEN DO 230 I = 1,N 230 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) ELSE if (IMPL == 1) THEN if (EVALFA) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 250 I = 1,N 250 SAVE2(I) = H*SAVE2(I) MW = ML + 1 + MU DO 260 J = 1,N DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) SAVE2(I+J-MW) = SAVE2(I+J-MW) & - A(I,J)*(YH(J,2) + SAVE1(J)) 260 CONTINUE ELSE if (IMPL == 2) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 280 I = 1,N 280 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) ELSE if (IMPL == 3) THEN if (EVALFA) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 270 I = 1,N 270 SAVE2(I) = H*SAVE2(I) MW = ML + 1 + MU DO 290 J = 1,NDE DO 290 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) SAVE2(I+J-MW) = SAVE2(I+J-MW) & - A(I,J)*(YH(J,2) + SAVE1(J)) 290 CONTINUE end if call DGBSL (DFDY, MATDIM, N, ML, MU, IPVT, SAVE2, 0) if (IERROR == 1 .OR. IERROR == 5) THEN DO 300 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 300 SAVE2(I) = SAVE2(I)/YWT(I) ELSE DO 305 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 305 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) end if D = DNRM2(N, SAVE2, 1)/SQRT(DBLE(N)) ELSE if (MITER == 3) THEN IFLAG = 2 call USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, & N, NDE, IFLAG) if (N == 0) THEN JSTATE = 10 return end if if (IERROR == 1 .OR. IERROR == 5) THEN DO 320 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 320 SAVE2(I) = SAVE2(I)/YWT(I) ELSE DO 325 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 325 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) end if D = DNRM2(N, SAVE2, 1)/SQRT(DBLE(N)) end if return end subroutine DDCST (MAXORD, MINT, ISWFLG, EL, TQ) ! !! DDCST sets coefficients used by the core integrator DDSTP. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE DOUBLE PRECISION (SDCST-S, DDCST-D, CDCST-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! DDCST is called by DDNTL. The array EL determines the basic method. ! The array TQ is involved in adjusting the step size in relation ! to truncation error. EL and TQ depend upon MINT, and are calculated ! for orders 1 to MAXORD( <= 12). For each order NQ, the coefficients ! EL are calculated from the generating polynomial: ! L(T) = EL(1,NQ) + EL(2,NQ)*T + ... + EL(NQ+1,NQ)*T**NQ. ! For the implicit Adams methods, L(T) is given by ! dL/dT = (1+T)*(2+T)* ... *(NQ-1+T)/K, L(-1) = 0, ! where K = factorial(NQ-1). ! For the Gear methods, ! L(T) = (1+T)*(2+T)* ... *(NQ+T)/K, ! where K = factorial(NQ)*(1 + 1/2 + ... + 1/NQ). ! For each order NQ, there are three components of TQ. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDCST DOUBLE PRECISION EL(13,12), FACTRL(12), GAMMA(14), SUM, TQ(3,12) INTEGER I, ISWFLG, J, MAXORD, MINT, MXRD !***FIRST EXECUTABLE STATEMENT DDCST FACTRL(1) = 1.D0 DO 10 I = 2,MAXORD 10 FACTRL(I) = I*FACTRL(I-1) ! Compute Adams coefficients if (MINT == 1) THEN GAMMA(1) = 1.D0 DO 40 I = 1,MAXORD+1 SUM = 0.D0 DO 30 J = 1,I 30 SUM = SUM - GAMMA(J)/(I-J+2) 40 GAMMA(I+1) = SUM EL(1,1) = 1.D0 EL(2,1) = 1.D0 EL(2,2) = 1.D0 EL(3,2) = 1.D0 DO 60 J = 3,MAXORD EL(2,J) = FACTRL(J-1) DO 50 I = 3,J 50 EL(I,J) = (J-1)*EL(I,J-1) + EL(I-1,J-1) 60 EL(J+1,J) = 1.D0 DO 80 J = 2,MAXORD EL(1,J) = EL(1,J-1) + GAMMA(J) EL(2,J) = 1.D0 DO 80 I = 3,J+1 80 EL(I,J) = EL(I,J)/((I-1)*FACTRL(J-1)) DO 100 J = 1,MAXORD TQ(1,J) = -1.D0/(FACTRL(J)*GAMMA(J)) TQ(2,J) = -1.D0/GAMMA(J+1) 100 TQ(3,J) = -1.D0/GAMMA(J+2) ! Compute Gear coefficients ELSE if (MINT == 2) THEN EL(1,1) = 1.D0 EL(2,1) = 1.D0 DO 130 J = 2,MAXORD EL(1,J) = FACTRL(J) DO 120 I = 2,J 120 EL(I,J) = J*EL(I,J-1) + EL(I-1,J-1) 130 EL(J+1,J) = 1.D0 SUM = 1.D0 DO 150 J = 2,MAXORD SUM = SUM + 1.D0/J DO 150 I = 1,J+1 150 EL(I,J) = EL(I,J)/(FACTRL(J)*SUM) DO 170 J = 1,MAXORD if (J > 1) TQ(1,J) = 1.D0/FACTRL(J-1) TQ(2,J) = (J+1)/EL(1,J) 170 TQ(3,J) = (J+2)/EL(1,J) end if ! Compute constants used in the stiffness test. ! These are the ratio of TQ(2,NQ) for the Gear ! methods to those for the Adams methods. if (ISWFLG == 3) THEN MXRD = MIN(MAXORD, 5) if (MINT == 2) THEN GAMMA(1) = 1.D0 DO 190 I = 1,MXRD SUM = 0.D0 DO 180 J = 1,I 180 SUM = SUM - GAMMA(J)/(I-J+2) 190 GAMMA(I+1) = SUM end if SUM = 1.D0 DO 200 I = 2,MXRD SUM = SUM + 1.D0/I 200 EL(1+I,1) = -(I+1)*SUM*GAMMA(I+1) end if return end subroutine DDEABM (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, & RWORK, LRW, IWORK, LIW, RPAR, IPAR) ! !! DDEABM solves an initial value problem in ordinary differential ... ! equations using an Adams-Bashforth method. ! !***LIBRARY SLATEC (DEPAC) !***CATEGORY I1A1B !***TYPE DOUBLE PRECISION (DEABM-S, DDEABM-D) !***KEYWORDS ADAMS-BASHFORTH METHOD, DEPAC, INITIAL VALUE PROBLEMS, ! ODE, ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR !***AUTHOR Shampine, L. F., (SNLA) ! Watts, H. A., (SNLA) !***DESCRIPTION ! ! This is the Adams code in the package of differential equation ! solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF. ! Design of the package was by L. F. Shampine and H. A. Watts. ! It is documented in ! SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE ! Solvers. ! DDEABM is a driver for a modification of the code ODE written by ! L. F. Shampine and M. K. Gordon ! Sandia Laboratories ! Albuquerque, New Mexico 87185 ! ! ********************************************************************** ! * ABSTRACT * ! ************ ! ! Subroutine DDEABM uses the Adams-Bashforth-Moulton ! Predictor-Corrector formulas of orders one through twelve to ! integrate a system of NEQ first order ordinary differential ! equations of the form ! DU/DX = DF(X,U) ! when the vector Y(*) of initial values for U(*) at X=T is given. ! The subroutine integrates from T to TOUT. It is easy to continue the ! integration to get results at additional TOUT. This is the interval ! mode of operation. It is also easy for the routine to return with ! the solution at each intermediate step on the way to TOUT. This is ! the intermediate-output mode of operation. ! ! DDEABM uses subprograms DDES, DSTEPS, DINTP, DHSTRT, DHVNRM, ! D1MACH, and the error handling routine XERMSG. The only machine ! dependent parameters to be assigned appear in D1MACH. ! ! ********************************************************************** ! * Description of The Arguments To DDEABM (An Overview) * ! ********************************************************************** ! ! The Parameters are ! ! DF -- This is the name of a subroutine which you provide to ! define the differential equations. ! ! NEQ -- This is the number of (first order) differential ! equations to be integrated. ! ! T -- This is a DOUBLE PRECISION value of the independent ! variable. ! ! Y(*) -- This DOUBLE PRECISION array contains the solution ! components at T. ! ! TOUT -- This is a DOUBLE PRECISION point at which a solution is ! desired. ! ! INFO(*) -- The basic task of the code is to integrate the ! differential equations from T to TOUT and return an ! answer at TOUT. INFO(*) is an INTEGER array which is used ! to communicate exactly how you want this task to be ! carried out. ! ! RTOL, ATOL -- These DOUBLE PRECISION quantities represent ! relative and absolute error tolerances which you ! provide to indicate how accurately you wish the ! solution to be computed. You may choose them to be ! both scalars or else both vectors. ! ! IDID -- This scalar quantity is an indicator reporting what ! the code did. You must monitor this INTEGER variable to ! decide what action to take next. ! ! RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of ! length LRW which provides the code with needed storage ! space. ! ! IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW ! which provides the code with needed storage space and an ! across call flag. ! ! RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter ! arrays which you can use for communication between your ! calling program and the DF subroutine. ! ! Quantities which are used as input items are ! NEQ, T, Y(*), TOUT, INFO(*), ! RTOL, ATOL, RWORK(1), LRW and LIW. ! ! Quantities which may be altered by the code are ! T, Y(*), INFO(1), RTOL, ATOL, ! IDID, RWORK(*) and IWORK(*). ! ! ********************************************************************** ! * INPUT -- What To Do On The First Call To DDEABM * ! ********************************************************************** ! ! The first call of the code is defined to be the start of each new ! problem. Read through the descriptions of all the following items, ! provide sufficient storage space for designated arrays, set ! appropriate variables for the initialization of the problem, and ! give information about how you want the problem to be solved. ! ! ! DF -- Provide a subroutine of the form ! DF(X,U,UPRIME,RPAR,IPAR) ! to define the system of first order differential equations ! which is to be solved. For the given values of X and the ! vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must ! evaluate the NEQ components of the system of differential ! equations DU/DX=DF(X,U) and store the derivatives in the ! array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for ! equations I=1,...,NEQ. ! ! Subroutine DF must NOT alter X or U(*). You must declare ! the name df in an external statement in your program that ! calls DDEABM. You must dimension U and UPRIME in DF. ! ! RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter ! arrays which you can use for communication between your ! calling program and subroutine DF. They are not used or ! altered by DDEABM. If you do not need RPAR or IPAR, ! ignore these parameters by treating them as dummy ! arguments. If you do choose to use them, dimension them in ! your calling program and in DF as arrays of appropriate ! length. ! ! NEQ -- Set it to the number of differential equations. ! (NEQ >= 1) ! ! T -- Set it to the initial point of the integration. ! You must use a program variable for T because the code ! changes its value. ! ! Y(*) -- Set this vector to the initial values of the NEQ solution ! components at the initial point. You must dimension Y at ! least NEQ in your calling program. ! ! TOUT -- Set it to the first point at which a solution ! is desired. You can take TOUT = T, in which case the code ! will evaluate the derivative of the solution at T and ! return. Integration either forward in T (TOUT > T) or ! backward in T (TOUT < T) is permitted. ! ! The code advances the solution from T to TOUT using ! step sizes which are automatically selected so as to ! achieve the desired accuracy. If you wish, the code will ! return with the solution and its derivative following ! each intermediate step (intermediate-output mode) so that ! you can monitor them, but you still must provide TOUT in ! accord with the basic aim of the code. ! ! The first step taken by the code is a critical one ! because it must reflect how fast the solution changes near ! the initial point. The code automatically selects an ! initial step size which is practically always suitable for ! the problem. By using the fact that the code will not step ! past TOUT in the first step, you could, if necessary, ! restrict the length of the initial step size. ! ! For some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP. When you have declared a TSTOP point (see INFO(4) ! and RWORK(1)), you have told the code not to integrate ! past TSTOP. In this case any TOUT beyond TSTOP is invalid ! input. ! ! INFO(*) -- Use the INFO array to give the code more details about ! how you want your problem solved. This array should be ! dimensioned of length 15 to accommodate other members of ! DEPAC or possible future extensions, though DDEABM uses ! only the first four entries. You must respond to all of ! the following items which are arranged as questions. The ! simplest use of the code corresponds to answering all ! questions as YES ,i.e. setting ALL entries of INFO to 0. ! ! INFO(1) -- This parameter enables the code to initialize ! itself. You must set it to indicate the start of every ! new problem. ! ! **** Is this the first call for this problem ... ! YES -- set INFO(1) = 0 ! NO -- not applicable here. ! See below for continuation calls. **** ! ! INFO(2) -- How much accuracy you want of your solution ! is specified by the error tolerances RTOL and ATOL. ! The simplest use is to take them both to be scalars. ! To obtain more flexibility, they can both be vectors. ! The code must be told your choice. ! ! **** Are both error tolerances RTOL, ATOL scalars ... ! YES -- set INFO(2) = 0 ! and input scalars for both RTOL and ATOL ! NO -- set INFO(2) = 1 ! and input arrays for both RTOL and ATOL **** ! ! INFO(3) -- The code integrates from T in the direction ! of TOUT by steps. If you wish, it will return the ! computed solution and derivative at the next ! intermediate step (the intermediate-output mode) or ! TOUT, whichever comes first. This is a good way to ! proceed if you want to see the behavior of the solution. ! If you must have solutions at a great many specific ! TOUT points, this code will compute them efficiently. ! ! **** Do you want the solution only at ! TOUT (and not at the next intermediate step) ... ! YES -- set INFO(3) = 0 ! NO -- set INFO(3) = 1 **** ! ! INFO(4) -- To handle solutions at a great many specific ! values TOUT efficiently, this code may integrate past ! TOUT and interpolate to obtain the result at TOUT. ! Sometimes it is not possible to integrate beyond some ! point TSTOP because the equation changes there or it is ! not defined past TSTOP. Then you must tell the code ! not to go past. ! ! **** Can the integration be carried out without any ! Restrictions on the independent variable T ... ! YES -- set INFO(4)=0 ! NO -- set INFO(4)=1 ! and define the stopping point TSTOP by ! setting RWORK(1)=TSTOP **** ! ! RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) ! error tolerances to tell the code how accurately you want ! the solution to be computed. They must be defined as ! program variables because the code may change them. You ! have two choices -- ! Both RTOL and ATOL are scalars. (INFO(2)=0) ! Both RTOL and ATOL are vectors. (INFO(2)=1) ! In either case all components must be non-negative. ! ! The tolerances are used by the code in a local error test ! at each step which requires roughly that ! ABS(LOCAL ERROR) <= RTOL*ABS(Y)+ATOL ! for each vector component. ! (More specifically, a Euclidean norm is used to measure ! the size of vectors, and the error test uses the magnitude ! of the solution at the beginning of the step.) ! ! The true (global) error is the difference between the true ! solution of the initial value problem and the computed ! approximation. Practically all present day codes, ! including this one, control the local error at each step ! and do not even attempt to control the global error ! directly. Roughly speaking, they produce a solution Y(T) ! which satisfies the differential equations with a ! residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , ! and, almost always, R(T) is bounded by the error ! tolerances. Usually, but not always, the true accuracy of ! the computed Y is comparable to the error tolerances. This ! code will usually, but not always, deliver a more accurate ! solution if you reduce the tolerances and integrate again. ! By comparing two such solutions you can get a fairly ! reliable idea of the true error in the solution at the ! bigger tolerances. ! ! Setting ATOL=0.D0 results in a pure relative error test on ! that component. Setting RTOL=0. results in a pure absolute ! error test on that component. A mixed test with non-zero ! RTOL and ATOL corresponds roughly to a relative error ! test when the solution component is much bigger than ATOL ! and to an absolute error test when the solution component ! is smaller than the threshold ATOL. ! ! Proper selection of the absolute error control parameters ! ATOL requires you to have some idea of the scale of the ! solution components. To acquire this information may mean ! that you will have to solve the problem more than once. In ! the absence of scale information, you should ask for some ! relative accuracy in all the components (by setting RTOL ! values non-zero) and perhaps impose extremely small ! absolute error tolerances to protect against the danger of ! a solution component becoming zero. ! ! The code will not attempt to compute a solution at an ! accuracy unreasonable for the machine being used. It will ! advise you if you ask for too much accuracy and inform ! you as to the maximum accuracy it believes possible. ! ! RWORK(*) -- Dimension this DOUBLE PRECISION work array of length ! LRW in your calling program. ! ! RWORK(1) -- If you have set INFO(4)=0, you can ignore this ! optional input parameter. Otherwise you must define a ! stopping point TSTOP by setting RWORK(1) = TSTOP. ! (for some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP.) ! ! LRW -- Set it to the declared length of the RWORK array. ! You must have LRW >= 130+21*NEQ ! ! IWORK(*) -- Dimension this INTEGER work array of length LIW in ! your calling program. ! ! LIW -- Set it to the declared length of the IWORK array. ! You must have LIW >= 51 ! ! RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and ! INTEGER type, respectively. You can use them for ! communication between your program that calls DDEABM and ! the DF subroutine. They are not used or altered by ! DDEABM. If you do not need RPAR or IPAR, ignore these ! parameters by treating them as dummy arguments. If you do ! choose to use them, dimension them in your calling program ! and in DF as arrays of appropriate length. ! ! ********************************************************************** ! * OUTPUT -- After Any Return From DDEABM * ! ********************************************************************** ! ! The principal aim of the code is to return a computed solution at ! TOUT, although it is also possible to obtain intermediate results ! along the way. To find out whether the code achieved its goal ! or if the integration process was interrupted before the task was ! completed, you must check the IDID parameter. ! ! ! T -- The solution was successfully advanced to the ! output value of T. ! ! Y(*) -- Contains the computed solution approximation at T. ! You may also be interested in the approximate derivative ! of the solution at T. It is contained in ! RWORK(21),...,RWORK(20+NEQ). ! ! IDID -- Reports what the code did ! ! *** Task Completed *** ! Reported by positive values of IDID ! ! IDID = 1 -- A step was successfully taken in the ! intermediate-output mode. The code has not ! yet reached TOUT. ! ! IDID = 2 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping exactly to TOUT. ! ! IDID = 3 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping past TOUT. ! Y(*) is obtained by interpolation. ! ! *** Task Interrupted *** ! Reported by negative values of IDID ! ! IDID = -1 -- A large amount of work has been expended. ! (500 steps attempted) ! ! IDID = -2 -- The error tolerances are too stringent. ! ! IDID = -3 -- The local error test cannot be satisfied ! because you specified a zero component in ATOL ! and the corresponding computed solution ! component is zero. Thus, a pure relative error ! test is impossible for this component. ! ! IDID = -4 -- The problem appears to be stiff. ! ! IDID = -5,-6,-7,..,-32 -- Not applicable for this code ! but used by other members of DEPAC or possible ! future extensions. ! ! *** Task Terminated *** ! Reported by the value of IDID=-33 ! ! IDID = -33 -- The code has encountered trouble from which ! it cannot recover. A message is printed ! explaining the trouble and control is returned ! to the calling program. For example, this occurs ! when invalid input is detected. ! ! RTOL, ATOL -- These quantities remain unchanged except when ! IDID = -2. In this case, the error tolerances have been ! increased by the code to values which are estimated to be ! appropriate for continuing the integration. However, the ! reported solution at T was obtained using the input values ! of RTOL and ATOL. ! ! RWORK, IWORK -- Contain information which is usually of no ! interest to the user but necessary for subsequent calls. ! However, you may find use for ! ! RWORK(11)--which contains the step size H to be ! attempted on the next step. ! ! RWORK(12)--if the tolerances have been increased by the ! code (IDID = -2) , they were multiplied by the ! value in RWORK(12). ! ! RWORK(13)--Which contains the current value of the ! independent variable, i.e. the farthest point ! integration has reached. This will be different ! from T only when interpolation has been ! performed (IDID=3). ! ! RWORK(20+I)--Which contains the approximate derivative ! of the solution component Y(I). In DDEABM, it ! is obtained by calling subroutine DF to ! evaluate the differential equation using T and ! Y(*) when IDID=1 or 2, and by interpolation ! when IDID=3. ! ! ********************************************************************** ! * INPUT -- What To Do To Continue The Integration * ! * (calls after the first) * ! ********************************************************************** ! ! This code is organized so that subsequent calls to continue the ! integration involve little (if any) additional effort on your ! part. You must monitor the IDID parameter in order to determine ! what to do next. ! ! Recalling that the principal task of the code is to integrate ! from T to TOUT (the interval mode), usually all you will need ! to do is specify a new TOUT upon reaching the current TOUT. ! ! Do not alter any quantity not specifically permitted below, ! in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or ! the differential equation in subroutine DF. Any such alteration ! constitutes a new problem and must be treated as such, i.e. ! you must start afresh. ! ! You cannot change from vector to scalar error control or vice ! versa (INFO(2)) but you can change the size of the entries of ! RTOL, ATOL. Increasing a tolerance makes the equation easier ! to integrate. Decreasing a tolerance will make the equation ! harder to integrate and should generally be avoided. ! ! You can switch from the intermediate-output mode to the ! interval mode (INFO(3)) or vice versa at any time. ! ! If it has been necessary to prevent the integration from going ! past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the ! code will not integrate to any TOUT beyond the currently ! specified TSTOP. Once TSTOP has been reached you must change ! the value of TSTOP or set INFO(4)=0. You may change INFO(4) ! or TSTOP at any time but you must supply the value of TSTOP in ! RWORK(1) whenever you set INFO(4)=1. ! ! The parameter INFO(1) is used by the code to indicate the ! beginning of a new problem and to indicate whether integration ! is to be continued. You must input the value INFO(1) = 0 ! when starting a new problem. You must input the value ! INFO(1) = 1 if you wish to continue after an interrupted task. ! Do not set INFO(1) = 0 on a continuation call unless you ! want the code to restart at the current T. ! ! *** Following A Completed Task *** ! If ! IDID = 1, call the code again to continue the integration ! another step in the direction of TOUT. ! ! IDID = 2 or 3, define a new TOUT and call the code again. ! TOUT must be different from T. You cannot change ! the direction of integration without restarting. ! ! *** Following An Interrupted Task *** ! To show the code that you realize the task was ! interrupted and that you want to continue, you ! must take appropriate action and reset INFO(1) = 1 ! If ! IDID = -1, the code has attempted 500 steps. ! If you want to continue, set INFO(1) = 1 and ! call the code again. An additional 500 steps ! will be allowed. ! ! IDID = -2, the error tolerances RTOL, ATOL have been ! increased to values the code estimates appropriate ! for continuing. You may want to change them ! yourself. If you are sure you want to continue ! with relaxed error tolerances, set INFO(1)=1 and ! call the code again. ! ! IDID = -3, a solution component is zero and you set the ! corresponding component of ATOL to zero. If you ! are sure you want to continue, you must first ! alter the error criterion to use positive values ! for those components of ATOL corresponding to zero ! solution components, then set INFO(1)=1 and call ! the code again. ! ! IDID = -4, the problem appears to be stiff. It is very ! inefficient to solve such problems with DDEABM. ! The code DDEBDF in DEPAC handles this task ! efficiently. If you are absolutely sure you want ! to continue with DDEABM, set INFO(1)=1 and call ! the code again. ! ! IDID = -5,-6,-7,..,-32 --- cannot occur with this code ! but used by other members of DEPAC or possible ! future extensions. ! ! *** Following A Terminated Task *** ! If ! IDID = -33, you cannot continue the solution of this ! problem. An attempt to do so will result in your ! run being terminated. ! ! ********************************************************************** ! *Long Description: ! ! ********************************************************************** ! * DEPAC Package Overview * ! ********************************************************************** ! ! .... You have a choice of three differential equation solvers from ! .... DEPAC. The following brief descriptions are meant to aid you in ! .... choosing the most appropriate code for your problem. ! ! .... DDERKF is a fifth order Runge-Kutta code. It is the simplest of ! .... the three choices, both algorithmically and in the use of the ! .... code. DDERKF is primarily designed to solve non-stiff and ! .... mildly stiff differential equations when derivative evaluations ! .... are not expensive. It should generally not be used to get high ! .... accuracy results nor answers at a great many specific points. ! .... Because DDERKF has very low overhead costs, it will usually ! .... result in the least expensive integration when solving ! .... problems requiring a modest amount of accuracy and having ! .... equations that are not costly to evaluate. DDERKF attempts to ! .... discover when it is not suitable for the task posed. ! ! .... DDEABM is a variable order (one through twelve) Adams code. ! .... Its complexity lies somewhere between that of DDERKF and ! .... DDEBDF. DDEABM is primarily designed to solve non-stiff and ! .... mildly stiff differential equations when derivative evaluations ! .... are expensive, high accuracy results are needed or answers at ! .... many specific points are required. DDEABM attempts to discover ! .... when it is not suitable for the task posed. ! ! .... DDEBDF is a variable order (one through five) backward ! .... differentiation formula code. it is the most complicated of ! .... the three choices. DDEBDF is primarily designed to solve stiff ! .... differential equations at crude to moderate tolerances. ! .... If the problem is very stiff at all, DDERKF and DDEABM will be ! .... quite inefficient compared to DDEBDF. However, DDEBDF will be ! .... inefficient compared to DDERKF and DDEABM on non-stiff problems ! .... because it uses much more storage, has a much larger overhead, ! .... and the low order formulas will not give high accuracies ! .... efficiently. ! ! .... The concept of stiffness cannot be described in a few words. ! .... If you do not know the problem to be stiff, try either DDERKF ! .... or DDEABM. Both of these codes will inform you of stiffness ! .... when the cost of solving such problems becomes important. ! ! ********************************************************************* ! !***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user ! oriented package of ODE solvers, Report SAND79-2374, ! Sandia Laboratories, 1979. !***ROUTINES CALLED DDES, XERMSG !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891024 Changed references from DVNORM to DHVNRM. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DDEABM ! INTEGER IALPHA, IBETA, IDELSN, IDID, IFOURU, IG, IHOLD, & INFO, IP, IPAR, IPHI, IPSI, ISIG, ITOLD, ITSTAR, ITWOU, & IV, IW, IWORK, IWT, IYP, IYPOUT, IYY, LIW, LRW, NEQ DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y LOGICAL START,PHASE1,NORND,STIFF,INTOUT ! DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), & RPAR(*),IPAR(*) ! CHARACTER*8 XERN1 CHARACTER*16 XERN3 ! EXTERNAL DF ! ! CHECK FOR AN APPARENT INFINITE LOOP ! !***FIRST EXECUTABLE STATEMENT DDEABM if ( INFO(1) == 0 ) IWORK(LIW) = 0 if (IWORK(LIW) >= 5) THEN if (T == RWORK(21 + NEQ)) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DDEABM', & 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // & 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // & ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // & 'WAY YOU HAVE SET PARAMETERS FOR THE call TO THE ' // & 'CODE, PARTICULARLY INFO(1).', 13, 2) return ENDIF end if ! ! CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION ! IDID=0 if (LRW < 130+21*NEQ) THEN WRITE (XERN1, '(I8)') LRW call XERMSG ('SLATEC', 'DDEABM', 'THE LENGTH OF THE RWORK ' // & 'ARRAY MUST BE AT LEAST 130 + 21*NEQ.$$' // & 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) IDID=-33 end if ! if (LIW < 51) THEN WRITE (XERN1, '(I8)') LIW call XERMSG ('SLATEC', 'DDEABM', 'THE LENGTH OF THE IWORK ' // & 'ARRAY MUST BE AT LEAST 51.$$YOU HAVE CALLED THE CODE ' // & 'WITH LIW = ' // XERN1, 2, 1) IDID=-33 end if ! ! COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY ! IYPOUT = 21 ITSTAR = NEQ + 21 IYP = 1 + ITSTAR IYY = NEQ + IYP IWT = NEQ + IYY IP = NEQ + IWT IPHI = NEQ + IP IALPHA = (NEQ*16) + IPHI IBETA = 12 + IALPHA IPSI = 12 + IBETA IV = 12 + IPSI IW = 12 + IV ISIG = 12 + IW IG = 13 + ISIG IGI = 13 + IG IXOLD = 11 + IGI IHOLD = 1 + IXOLD ITOLD = 1 + IHOLD IDELSN = 1 + ITOLD ITWOU = 1 + IDELSN IFOURU = 1 + ITWOU ! RWORK(ITSTAR) = T if (INFO(1) == 0) go to 50 START = IWORK(21) /= (-1) PHASE1 = IWORK(22) /= (-1) NORND = IWORK(23) /= (-1) STIFF = IWORK(24) /= (-1) INTOUT = IWORK(25) /= (-1) ! 50 call DDES(DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(IYPOUT), & RWORK(IYP),RWORK(IYY),RWORK(IWT),RWORK(IP),RWORK(IPHI), & RWORK(IALPHA),RWORK(IBETA),RWORK(IPSI),RWORK(IV), & RWORK(IW),RWORK(ISIG),RWORK(IG),RWORK(IGI),RWORK(11), & RWORK(12),RWORK(13),RWORK(IXOLD),RWORK(IHOLD), & RWORK(ITOLD),RWORK(IDELSN),RWORK(1),RWORK(ITWOU), & RWORK(IFOURU),START,PHASE1,NORND,STIFF,INTOUT,IWORK(26), & IWORK(27),IWORK(28),IWORK(29),IWORK(30),IWORK(31), & IWORK(32),IWORK(33),IWORK(34),IWORK(35),IWORK(45), & RPAR,IPAR) ! IWORK(21) = -1 if (START) IWORK(21) = 1 IWORK(22) = -1 if (PHASE1) IWORK(22) = 1 IWORK(23) = -1 if (NORND) IWORK(23) = 1 IWORK(24) = -1 if (STIFF) IWORK(24) = 1 IWORK(25) = -1 if (INTOUT) IWORK(25) = 1 ! if (IDID /= (-2)) IWORK(LIW) = IWORK(LIW) + 1 if (T /= RWORK(ITSTAR)) IWORK(LIW) = 0 ! return end subroutine DDEBDF (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, & RWORK, LRW, IWORK, LIW, RPAR, IPAR, DJAC) ! !! DDEBDF solves an initial value problem in ordinary differential ... ! equations using backward differentiation formulas. It is ... ! intended primarily for stiff problems. ! !***LIBRARY SLATEC (DEPAC) !***CATEGORY I1A2 !***TYPE DOUBLE PRECISION (DEBDF-S, DDEBDF-D) !***KEYWORDS BACKWARD DIFFERENTIATION FORMULAS, DEPAC, ! INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, STIFF !***AUTHOR Shampine, L. F., (SNLA) ! Watts, H. A., (SNLA) !***DESCRIPTION ! ! This is the backward differentiation code in the package of ! differential equation solvers DEPAC, consisting of the codes ! DDERKF, DDEABM, and DDEBDF. Design of the package was by ! L. F. Shampine and H. A. Watts. It is documented in ! SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE ! Solvers. ! DDEBDF is a driver for a modification of the code LSODE written by ! A. C. Hindmarsh ! Lawrence Livermore Laboratory ! Livermore, California 94550 ! ! ********************************************************************** ! ** DEPAC PACKAGE OVERVIEW ** ! ********************************************************************** ! ! You have a choice of three differential equation solvers from ! DEPAC. The following brief descriptions are meant to aid you ! in choosing the most appropriate code for your problem. ! ! DDERKF is a fifth order Runge-Kutta code. It is the simplest of ! the three choices, both algorithmically and in the use of the ! code. DDERKF is primarily designed to solve non-stiff and mild- ! ly stiff differential equations when derivative evaluations are ! not expensive. It should generally not be used to get high ! accuracy results nor answers at a great many specific points. ! Because DDERKF has very low overhead costs, it will usually ! result in the least expensive integration when solving ! problems requiring a modest amount of accuracy and having ! equations that are not costly to evaluate. DDERKF attempts to ! discover when it is not suitable for the task posed. ! ! DDEABM is a variable order (one through twelve) Adams code. Its ! complexity lies somewhere between that of DDERKF and DDEBDF. ! DDEABM is primarily designed to solve non-stiff and mildly ! stiff differential equations when derivative evaluations are ! expensive, high accuracy results are needed or answers at ! many specific points are required. DDEABM attempts to discover ! when it is not suitable for the task posed. ! ! DDEBDF is a variable order (one through five) backward ! differentiation formula code. It is the most complicated of ! the three choices. DDEBDF is primarily designed to solve stiff ! differential equations at crude to moderate tolerances. ! If the problem is very stiff at all, DDERKF and DDEABM will be ! quite inefficient compared to DDEBDF. However, DDEBDF will be ! inefficient compared to DDERKF and DDEABM on non-stiff problems ! because it uses much more storage, has a much larger overhead, ! and the low order formulas will not give high accuracies ! efficiently. ! ! The concept of stiffness cannot be described in a few words. ! If you do not know the problem to be stiff, try either DDERKF ! or DDEABM. Both of these codes will inform you of stiffness ! when the cost of solving such problems becomes important. ! ! ********************************************************************** ! ** ABSTRACT ** ! ********************************************************************** ! ! Subroutine DDEBDF uses the backward differentiation formulas of ! orders one through five to integrate a system of NEQ first order ! ordinary differential equations of the form ! DU/DX = DF(X,U) ! when the vector Y(*) of initial values for U(*) at X=T is given. ! The subroutine integrates from T to TOUT. It is easy to continue the ! integration to get results at additional TOUT. This is the interval ! mode of operation. It is also easy for the routine to return with ! the solution at each intermediate step on the way to TOUT. This is ! the intermediate-output mode of operation. ! ! ********************************************************************** ! * Description of The Arguments To DDEBDF (An Overview) * ! ********************************************************************** ! ! The Parameters are: ! ! DF -- This is the name of a subroutine which you provide to ! define the differential equations. ! ! NEQ -- This is the number of (first order) differential ! equations to be integrated. ! ! T -- This is a DOUBLE PRECISION value of the independent ! variable. ! ! Y(*) -- This DOUBLE PRECISION array contains the solution ! components at T. ! ! TOUT -- This is a DOUBLE PRECISION point at which a solution is ! desired. ! ! INFO(*) -- The basic task of the code is to integrate the ! differential equations from T to TOUT and return an ! answer at TOUT. INFO(*) is an INTEGER array which is used ! to communicate exactly how you want this task to be ! carried out. ! ! RTOL, ATOL -- These DOUBLE PRECISION quantities ! represent relative and absolute error tolerances which you ! provide to indicate how accurately you wish the solution ! to be computed. You may choose them to be both scalars ! or else both vectors. ! ! IDID -- This scalar quantity is an indicator reporting what ! the code did. You must monitor this INTEGER variable to ! decide what action to take next. ! ! RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of ! length LRW which provides the code with needed storage ! space. ! ! IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW ! which provides the code with needed storage space and an ! across call flag. ! ! RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter ! arrays which you can use for communication between your ! calling program and the DF subroutine (and the DJAC ! subroutine). ! ! DJAC -- This is the name of a subroutine which you may choose to ! provide for defining the Jacobian matrix of partial ! derivatives DF/DU. ! ! Quantities which are used as input items are ! NEQ, T, Y(*), TOUT, INFO(*), ! RTOL, ATOL, RWORK(1), LRW, ! IWORK(1), IWORK(2), and LIW. ! ! Quantities which may be altered by the code are ! T, Y(*), INFO(1), RTOL, ATOL, ! IDID, RWORK(*) and IWORK(*). ! ! ********************************************************************** ! * INPUT -- What To Do On The First Call To DDEBDF * ! ********************************************************************** ! ! The first call of the code is defined to be the start of each new ! problem. Read through the descriptions of all the following items, ! provide sufficient storage space for designated arrays, set ! appropriate variables for the initialization of the problem, and ! give information about how you want the problem to be solved. ! ! ! DF -- Provide a subroutine of the form ! DF(X,U,UPRIME,RPAR,IPAR) ! to define the system of first order differential equations ! which is to be solved. For the given values of X and the ! vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must ! evaluate the NEQ components of the system of differential ! equations DU/DX=DF(X,U) and store the derivatives in the ! array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for ! equations I=1,...,NEQ. ! ! Subroutine DF must not alter X or U(*). You must declare ! the name DF in an external statement in your program that ! calls DDEBDF. You must dimension U and UPRIME in DF. ! ! RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter ! arrays which you can use for communication between your ! calling program and subroutine DF. They are not used or ! altered by DDEBDF. If you do not need RPAR or IPAR, ! ignore these parameters by treating them as dummy ! arguments. If you do choose to use them, dimension them in ! your calling program and in DF as arrays of appropriate ! length. ! ! NEQ -- Set it to the number of differential equations. ! (NEQ >= 1) ! ! T -- Set it to the initial point of the integration. ! You must use a program variable for T because the code ! changes its value. ! ! Y(*) -- Set this vector to the initial values of the NEQ solution ! components at the initial point. You must dimension Y at ! least NEQ in your calling program. ! ! TOUT -- Set it to the first point at which a solution is desired. ! You can take TOUT = T, in which case the code ! will evaluate the derivative of the solution at T and ! return. Integration either forward in T (TOUT > T) ! or backward in T (TOUT < T) is permitted. ! ! The code advances the solution from T to TOUT using ! step sizes which are automatically selected so as to ! achieve the desired accuracy. If you wish, the code will ! return with the solution and its derivative following ! each intermediate step (intermediate-output mode) so that ! you can monitor them, but you still must provide TOUT in ! accord with the basic aim of the code. ! ! The first step taken by the code is a critical one ! because it must reflect how fast the solution changes near ! the initial point. The code automatically selects an ! initial step size which is practically always suitable for ! the problem. By using the fact that the code will not ! step past TOUT in the first step, you could, if necessary, ! restrict the length of the initial step size. ! ! For some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP. When you have declared a TSTOP point (see INFO(4) ! and RWORK(1)), you have told the code not to integrate ! past TSTOP. In this case any TOUT beyond TSTOP is invalid ! input. ! ! INFO(*) -- Use the INFO array to give the code more details about ! how you want your problem solved. This array should be ! dimensioned of length 15 to accommodate other members of ! DEPAC or possible future extensions, though DDEBDF uses ! only the first six entries. You must respond to all of ! the following items which are arranged as questions. The ! simplest use of the code corresponds to answering all ! questions as YES ,i.e. setting all entries of INFO to 0. ! ! INFO(1) -- This parameter enables the code to initialize ! itself. You must set it to indicate the start of every ! new problem. ! ! **** Is this the first call for this problem ... ! YES -- Set INFO(1) = 0 ! NO -- Not applicable here. ! See below for continuation calls. **** ! ! INFO(2) -- How much accuracy you want of your solution ! is specified by the error tolerances RTOL and ATOL. ! The simplest use is to take them both to be scalars. ! To obtain more flexibility, they can both be vectors. ! The code must be told your choice. ! ! **** Are both error tolerances RTOL, ATOL scalars ... ! YES -- Set INFO(2) = 0 ! and input scalars for both RTOL and ATOL ! NO -- Set INFO(2) = 1 ! and input arrays for both RTOL and ATOL **** ! ! INFO(3) -- The code integrates from T in the direction ! of TOUT by steps. If you wish, it will return the ! computed solution and derivative at the next ! intermediate step (the intermediate-output mode) or ! TOUT, whichever comes first. This is a good way to ! proceed if you want to see the behavior of the solution. ! If you must have solutions at a great many specific ! TOUT points, this code will compute them efficiently. ! ! **** Do you want the solution only at ! TOUT (and NOT at the next intermediate step) ... ! YES -- Set INFO(3) = 0 ! NO -- Set INFO(3) = 1 **** ! ! INFO(4) -- To handle solutions at a great many specific ! values TOUT efficiently, this code may integrate past ! TOUT and interpolate to obtain the result at TOUT. ! Sometimes it is not possible to integrate beyond some ! point TSTOP because the equation changes there or it is ! not defined past TSTOP. Then you must tell the code ! not to go past. ! ! **** Can the integration be carried out without any ! restrictions on the independent variable T ... ! YES -- Set INFO(4)=0 ! NO -- Set INFO(4)=1 ! and define the stopping point TSTOP by ! setting RWORK(1)=TSTOP **** ! ! INFO(5) -- To solve stiff problems it is necessary to use the ! Jacobian matrix of partial derivatives of the system ! of differential equations. If you do not provide a ! subroutine to evaluate it analytically (see the ! description of the item DJAC in the call list), it will ! be approximated by numerical differencing in this code. ! Although it is less trouble for you to have the code ! compute partial derivatives by numerical differencing, ! the solution will be more reliable if you provide the ! derivatives via DJAC. Sometimes numerical differencing ! is cheaper than evaluating derivatives in DJAC and ! sometimes it is not - this depends on your problem. ! ! If your problem is linear, i.e. has the form ! DU/DX = DF(X,U) = J(X)*U + G(X) for some matrix J(X) ! and vector G(X), the Jacobian matrix DF/DU = J(X). ! Since you must provide a subroutine to evaluate DF(X,U) ! analytically, it is little extra trouble to provide ! subroutine DJAC for evaluating J(X) analytically. ! Furthermore, in such cases, numerical differencing is ! much more expensive than analytic evaluation. ! ! **** Do you want the code to evaluate the partial ! derivatives automatically by numerical differences ... ! YES -- Set INFO(5)=0 ! NO -- Set INFO(5)=1 ! and provide subroutine DJAC for evaluating the ! Jacobian matrix **** ! ! INFO(6) -- DDEBDF will perform much better if the Jacobian ! matrix is banded and the code is told this. In this ! case, the storage needed will be greatly reduced, ! numerical differencing will be performed more cheaply, ! and a number of important algorithms will execute much ! faster. The differential equation is said to have ! half-bandwidths ML (lower) and MU (upper) if equation I ! involves only unknowns Y(J) with ! I-ML <= J <= I+MU ! for all I=1,2,...,NEQ. Thus, ML and MU are the widths ! of the lower and upper parts of the band, respectively, ! with the main diagonal being excluded. If you do not ! indicate that the equation has a banded Jacobian, ! the code works with a full matrix of NEQ**2 elements ! (stored in the conventional way). Computations with ! banded matrices cost less time and storage than with ! full matrices if 2*ML+MU < NEQ. If you tell the ! code that the Jacobian matrix has a banded structure and ! you want to provide subroutine DJAC to compute the ! partial derivatives, then you must be careful to store ! the elements of the Jacobian matrix in the special form ! indicated in the description of DJAC. ! ! **** Do you want to solve the problem using a full ! (dense) Jacobian matrix (and not a special banded ! structure) ... ! YES -- Set INFO(6)=0 ! NO -- Set INFO(6)=1 ! and provide the lower (ML) and upper (MU) ! bandwidths by setting ! IWORK(1)=ML ! IWORK(2)=MU **** ! ! RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) ! error tolerances to tell the code how accurately you want ! the solution to be computed. They must be defined as ! program variables because the code may change them. You ! have two choices -- ! Both RTOL and ATOL are scalars. (INFO(2)=0) ! Both RTOL and ATOL are vectors. (INFO(2)=1) ! In either case all components must be non-negative. ! ! The tolerances are used by the code in a local error test ! at each step which requires roughly that ! ABS(LOCAL ERROR) <= RTOL*ABS(Y)+ATOL ! for each vector component. ! (More specifically, a root-mean-square norm is used to ! measure the size of vectors, and the error test uses the ! magnitude of the solution at the beginning of the step.) ! ! The true (global) error is the difference between the true ! solution of the initial value problem and the computed ! approximation. Practically all present day codes, ! including this one, control the local error at each step ! and do not even attempt to control the global error ! directly. Roughly speaking, they produce a solution Y(T) ! which satisfies the differential equations with a ! residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , ! and, almost always, R(T) is bounded by the error ! tolerances. Usually, but not always, the true accuracy of ! the computed Y is comparable to the error tolerances. This ! code will usually, but not always, deliver a more accurate ! solution if you reduce the tolerances and integrate again. ! By comparing two such solutions you can get a fairly ! reliable idea of the true error in the solution at the ! bigger tolerances. ! ! Setting ATOL=0. results in a pure relative error test on ! that component. Setting RTOL=0. results in a pure abso- ! lute error test on that component. A mixed test with non- ! zero RTOL and ATOL corresponds roughly to a relative error ! test when the solution component is much bigger than ATOL ! and to an absolute error test when the solution component ! is smaller than the threshold ATOL. ! ! Proper selection of the absolute error control parameters ! ATOL requires you to have some idea of the scale of the ! solution components. To acquire this information may mean ! that you will have to solve the problem more than once. In ! the absence of scale information, you should ask for some ! relative accuracy in all the components (by setting RTOL ! values non-zero) and perhaps impose extremely small ! absolute error tolerances to protect against the danger of ! a solution component becoming zero. ! ! The code will not attempt to compute a solution at an ! accuracy unreasonable for the machine being used. It will ! advise you if you ask for too much accuracy and inform ! you as to the maximum accuracy it believes possible. ! ! RWORK(*) -- Dimension this DOUBLE PRECISION work array of length ! LRW in your calling program. ! ! RWORK(1) -- If you have set INFO(4)=0, you can ignore this ! optional input parameter. Otherwise you must define a ! stopping point TSTOP by setting RWORK(1) = TSTOP. ! (For some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP.) ! ! LRW -- Set it to the declared length of the RWORK array. ! You must have ! LRW >= 250+10*NEQ+NEQ**2 ! for the full (dense) Jacobian case (when INFO(6)=0), or ! LRW >= 250+10*NEQ+(2*ML+MU+1)*NEQ ! for the banded Jacobian case (when INFO(6)=1). ! ! IWORK(*) -- Dimension this INTEGER work array of length LIW in ! your calling program. ! ! IWORK(1), IWORK(2) -- If you have set INFO(6)=0, you can ignore ! these optional input parameters. Otherwise you must define ! the half-bandwidths ML (lower) and MU (upper) of the ! Jacobian matrix by setting IWORK(1) = ML and ! IWORK(2) = MU. (The code will work with a full matrix ! of NEQ**2 elements unless it is told that the problem has ! a banded Jacobian, in which case the code will work with ! a matrix containing at most (2*ML+MU+1)*NEQ elements.) ! ! LIW -- Set it to the declared length of the IWORK array. ! You must have LIW >= 56+NEQ. ! ! RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and ! INTEGER type, respectively. You can use them for ! communication between your program that calls DDEBDF and ! the DF subroutine (and the DJAC subroutine). They are not ! used or altered by DDEBDF. If you do not need RPAR or ! IPAR, ignore these parameters by treating them as dummy ! arguments. If you do choose to use them, dimension them in ! your calling program and in DF (and in DJAC) as arrays of ! appropriate length. ! ! DJAC -- If you have set INFO(5)=0, you can ignore this parameter ! by treating it as a dummy argument. (For some compilers ! you may have to write a dummy subroutine named DJAC in ! order to avoid problems associated with missing external ! routine names.) Otherwise, you must provide a subroutine ! of the form ! DJAC(X,U,PD,NROWPD,RPAR,IPAR) ! to define the Jacobian matrix of partial derivatives DF/DU ! of the system of differential equations DU/DX = DF(X,U). ! For the given values of X and the vector ! U(*)=(U(1),U(2),...,U(NEQ)), the subroutine must evaluate ! the non-zero partial derivatives DF(I)/DU(J) for each ! differential equation I=1,...,NEQ and each solution ! component J=1,...,NEQ , and store these values in the ! matrix PD. The elements of PD are set to zero before each ! call to DJAC so only non-zero elements need to be defined. ! ! Subroutine DJAC must not alter X, U(*), or NROWPD. You ! must declare the name DJAC in an external statement in ! your program that calls DDEBDF. NROWPD is the row ! dimension of the PD matrix and is assigned by the code. ! Therefore you must dimension PD in DJAC according to ! DIMENSION PD(NROWPD,1) ! You must also dimension U in DJAC. ! ! The way you must store the elements into the PD matrix ! depends on the structure of the Jacobian which you ! indicated by INFO(6). ! *** INFO(6)=0 -- Full (Dense) Jacobian *** ! When you evaluate the (non-zero) partial derivative ! of equation I with respect to variable J, you must ! store it in PD according to ! PD(I,J) = * DF(I)/DU(J) * ! *** INFO(6)=1 -- Banded Jacobian with ML Lower and MU ! Upper Diagonal Bands (refer to INFO(6) description of ! ML and MU) *** ! When you evaluate the (non-zero) partial derivative ! of equation I with respect to variable J, you must ! store it in PD according to ! IROW = I - J + ML + MU + 1 ! PD(IROW,J) = * DF(I)/DU(J) * ! ! RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter ! arrays which you can use for communication between your ! calling program and your Jacobian subroutine DJAC. They ! are not altered by DDEBDF. If you do not need RPAR or ! IPAR, ignore these parameters by treating them as dummy ! arguments. If you do choose to use them, dimension them ! in your calling program and in DJAC as arrays of ! appropriate length. ! ! ********************************************************************** ! * OUTPUT -- After any return from DDEBDF * ! ********************************************************************** ! ! The principal aim of the code is to return a computed solution at ! TOUT, although it is also possible to obtain intermediate results ! along the way. To find out whether the code achieved its goal ! or if the integration process was interrupted before the task was ! completed, you must check the IDID parameter. ! ! ! T -- The solution was successfully advanced to the ! output value of T. ! ! Y(*) -- Contains the computed solution approximation at T. ! You may also be interested in the approximate derivative ! of the solution at T. It is contained in ! RWORK(21),...,RWORK(20+NEQ). ! ! IDID -- Reports what the code did ! ! *** Task Completed *** ! Reported by positive values of IDID ! ! IDID = 1 -- A step was successfully taken in the ! intermediate-output mode. The code has not ! yet reached TOUT. ! ! IDID = 2 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping exactly to TOUT. ! ! IDID = 3 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping past TOUT. ! Y(*) is obtained by interpolation. ! ! *** Task Interrupted *** ! Reported by negative values of IDID ! ! IDID = -1 -- A large amount of work has been expended. ! (500 steps attempted) ! ! IDID = -2 -- The error tolerances are too stringent. ! ! IDID = -3 -- The local error test cannot be satisfied ! because you specified a zero component in ATOL ! and the corresponding computed solution ! component is zero. Thus, a pure relative error ! test is impossible for this component. ! ! IDID = -4,-5 -- Not applicable for this code but used ! by other members of DEPAC. ! ! IDID = -6 -- DDEBDF had repeated convergence test failures ! on the last attempted step. ! ! IDID = -7 -- DDEBDF had repeated error test failures on ! the last attempted step. ! ! IDID = -8,..,-32 -- Not applicable for this code but ! used by other members of DEPAC or possible ! future extensions. ! ! *** Task Terminated *** ! Reported by the value of IDID=-33 ! ! IDID = -33 -- The code has encountered trouble from which ! it cannot recover. A message is printed ! explaining the trouble and control is returned ! to the calling program. For example, this ! occurs when invalid input is detected. ! ! RTOL, ATOL -- These quantities remain unchanged except when ! IDID = -2. In this case, the error tolerances have been ! increased by the code to values which are estimated to be ! appropriate for continuing the integration. However, the ! reported solution at T was obtained using the input values ! of RTOL and ATOL. ! ! RWORK, IWORK -- Contain information which is usually of no ! interest to the user but necessary for subsequent calls. ! However, you may find use for ! ! RWORK(11)--which contains the step size H to be ! attempted on the next step. ! ! RWORK(12)--If the tolerances have been increased by the ! code (IDID = -2) , they were multiplied by the ! value in RWORK(12). ! ! RWORK(13)--which contains the current value of the ! independent variable, i.e. the farthest point ! integration has reached. This will be ! different from T only when interpolation has ! been performed (IDID=3). ! ! RWORK(20+I)--which contains the approximate derivative ! of the solution component Y(I). In DDEBDF, it ! is never obtained by calling subroutine DF to ! evaluate the differential equation using T and ! Y(*), except at the initial point of ! integration. ! ! ********************************************************************** ! ** INPUT -- What To Do To Continue The Integration ** ! ** (calls after the first) ** ! ********************************************************************** ! ! This code is organized so that subsequent calls to continue the ! integration involve little (if any) additional effort on your ! part. You must monitor the IDID parameter in order to determine ! what to do next. ! ! Recalling that the principal task of the code is to integrate ! from T to TOUT (the interval mode), usually all you will need ! to do is specify a new TOUT upon reaching the current TOUT. ! ! Do not alter any quantity not specifically permitted below, ! in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or ! the differential equation in subroutine DF. Any such alteration ! constitutes a new problem and must be treated as such, i.e. ! you must start afresh. ! ! You cannot change from vector to scalar error control or vice ! versa (INFO(2)) but you can change the size of the entries of ! RTOL, ATOL. Increasing a tolerance makes the equation easier ! to integrate. Decreasing a tolerance will make the equation ! harder to integrate and should generally be avoided. ! ! You can switch from the intermediate-output mode to the ! interval mode (INFO(3)) or vice versa at any time. ! ! If it has been necessary to prevent the integration from going ! past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the ! code will not integrate to any TOUT beyond the currently ! specified TSTOP. Once TSTOP has been reached you must change ! the value of TSTOP or set INFO(4)=0. You may change INFO(4) ! or TSTOP at any time but you must supply the value of TSTOP in ! RWORK(1) whenever you set INFO(4)=1. ! ! Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) ! unless you are going to restart the code. ! ! The parameter INFO(1) is used by the code to indicate the ! beginning of a new problem and to indicate whether integration ! is to be continued. You must input the value INFO(1) = 0 ! when starting a new problem. You must input the value ! INFO(1) = 1 if you wish to continue after an interrupted task. ! Do not set INFO(1) = 0 on a continuation call unless you ! want the code to restart at the current T. ! ! *** Following a Completed Task *** ! If ! IDID = 1, call the code again to continue the integration ! another step in the direction of TOUT. ! ! IDID = 2 or 3, define a new TOUT and call the code again. ! TOUT must be different from T. You cannot change ! the direction of integration without restarting. ! ! *** Following an Interrupted Task *** ! To show the code that you realize the task was ! interrupted and that you want to continue, you ! must take appropriate action and reset INFO(1) = 1 ! If ! IDID = -1, the code has attempted 500 steps. ! If you want to continue, set INFO(1) = 1 and ! call the code again. An additional 500 steps ! will be allowed. ! ! IDID = -2, the error tolerances RTOL, ATOL have been ! increased to values the code estimates appropriate ! for continuing. You may want to change them ! yourself. If you are sure you want to continue ! with relaxed error tolerances, set INFO(1)=1 and ! call the code again. ! ! IDID = -3, a solution component is zero and you set the ! corresponding component of ATOL to zero. If you ! are sure you want to continue, you must first ! alter the error criterion to use positive values ! for those components of ATOL corresponding to zero ! solution components, then set INFO(1)=1 and call ! the code again. ! ! IDID = -4,-5 --- cannot occur with this code but used ! by other members of DEPAC. ! ! IDID = -6, repeated convergence test failures occurred ! on the last attempted step in DDEBDF. An inaccu- ! rate Jacobian may be the problem. If you are ! absolutely certain you want to continue, restart ! the integration at the current T by setting ! INFO(1)=0 and call the code again. ! ! IDID = -7, repeated error test failures occurred on the ! last attempted step in DDEBDF. A singularity in ! the solution may be present. You should re- ! examine the problem being solved. If you are ! absolutely certain you want to continue, restart ! the integration at the current T by setting ! INFO(1)=0 and call the code again. ! ! IDID = -8,..,-32 --- cannot occur with this code but ! used by other members of DDEPAC or possible future ! extensions. ! ! *** Following a Terminated Task *** ! If ! IDID = -33, you cannot continue the solution of this ! problem. An attempt to do so will result in your ! run being terminated. ! ! ********************************************************************** ! ! ***** Warning ***** ! ! If DDEBDF is to be used in an overlay situation, you must save and ! restore certain items used internally by DDEBDF (values in the ! common block DDEBD1). This can be accomplished as follows. ! ! To save the necessary values upon return from DDEBDF, simply call ! DSVCO(RWORK(22+NEQ),IWORK(21+NEQ)). ! ! To restore the necessary values before the next call to DDEBDF, ! simply call DRSCO(RWORK(22+NEQ),IWORK(21+NEQ)). ! !***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user ! oriented package of ODE solvers, Report SAND79-2374, ! Sandia Laboratories, 1979. !***ROUTINES CALLED DLSOD, XERMSG !***COMMON BLOCKS DDEBD1 !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891024 Changed references from DVNORM to DHVNRM. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900510 Convert XERRWV calls to XERMSG calls, make Prologue comments ! consistent with DEBDF. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DDEBDF INTEGER IACOR, IBAND, IBEGIN, ICOMI, ICOMR, IDELSN, IDID, IER, & IEWT, IINOUT, IINTEG, IJAC, ILRW, INFO, INIT, & IOWNS, IPAR, IQUIT, ISAVF, ITOL, ITSTAR, ITSTOP, IWM, & IWORK, IYH, IYPOUT, JSTART, KFLAG, KSTEPS, L, LIW, LRW, & MAXORD, METH, MITER, ML, MU, N, NEQ, NFE, NJE, NQ, NQU, & NST DOUBLE PRECISION ATOL, EL0, H, HMIN, HMXI, HU, ROWNS, RPAR, & RTOL, RWORK, T, TN, TOLD, TOUT, UROUND, Y LOGICAL INTOUT CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3 ! DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), & RPAR(*),IPAR(*) ! COMMON /DDEBD1/ TOLD,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, & IQUIT,INIT,IYH,IEWT,IACOR,ISAVF,IWM,KSTEPS,IBEGIN, & ITOL,IINTEG,ITSTOP,IJAC,IBAND,IOWNS(6),IER,JSTART, & KFLAG,L,METH,MITER,MAXORD,N,NQ,NST,NFE,NJE,NQU ! EXTERNAL DF, DJAC ! ! CHECK FOR AN APPARENT INFINITE LOOP ! !***FIRST EXECUTABLE STATEMENT DDEBDF if (INFO(1) == 0) IWORK(LIW) = 0 ! if (IWORK(LIW) >= 5) THEN if (T == RWORK(21+NEQ)) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DDEBDF', & 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // & 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // & ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // & 'WAY YOU HAVE SET PARAMETERS FOR THE call TO THE ' // & 'CODE, PARTICULARLY INFO(1).', 13, 2) return ENDIF end if ! IDID = 0 ! ! CHECK VALIDITY OF INFO PARAMETERS ! if (INFO(1) /= 0 .AND. INFO(1) /= 1) THEN WRITE (XERN1, '(I8)') INFO(1) call XERMSG ('SLATEC', 'DDEBDF', 'INFO(1) MUST BE SET TO 0 ' // & 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // & 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // & 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE ' // & 'CODE WITH INFO(1) = ' // XERN1, 3, 1) IDID = -33 end if ! if (INFO(2) /= 0 .AND. INFO(2) /= 1) THEN WRITE (XERN1, '(I8)') INFO(2) call XERMSG ('SLATEC', 'DDEBDF', 'INFO(2) MUST BE 0 OR 1 ' // & 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // & 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // & XERN1, 4, 1) IDID = -33 end if ! if (INFO(3) /= 0 .AND. INFO(3) /= 1) THEN WRITE (XERN1, '(I8)') INFO(3) call XERMSG ('SLATEC', 'DDEBDF', 'INFO(3) MUST BE 0 OR 1 ' // & 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // & 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // & 'WITH INFO(3) = ' // XERN1, 5, 1) IDID = -33 end if ! if (INFO(4) /= 0 .AND. INFO(4) /= 1) THEN WRITE (XERN1, '(I8)') INFO(4) call XERMSG ('SLATEC', 'DDEBDF', 'INFO(4) MUST BE 0 OR 1 ' // & 'INDICATING WHETHER OR NOT THE INTEGRATION INTERVAL IS ' // & 'TO BE RESTRICTED BY A POINT TSTOP. YOU HAVE CALLED ' // & 'THE CODE WITH INFO(4) = ' // XERN1, 14, 1) IDID = -33 end if ! if (INFO(5) /= 0 .AND. INFO(5) /= 1) THEN WRITE (XERN1, '(I8)') INFO(5) call XERMSG ('SLATEC', 'DDEBDF', 'INFO(5) MUST BE 0 OR 1 ' // & 'INDICATING WHETHER THE CODE IS TOLD TO FORM THE ' // & 'JACOBIAN MATRIX BY NUMERICAL DIFFERENCING OR YOU ' // & 'PROVIDE A SUBROUTINE TO EVALUATE IT ANALYTICALLY. ' // & 'YOU HAVE CALLED THE CODE WITH INFO(5) = ' // XERN1, 15, 1) IDID = -33 end if ! if (INFO(6) /= 0 .AND. INFO(6) /= 1) THEN WRITE (XERN1, '(I8)') INFO(6) call XERMSG ('SLATEC', 'DDEBDF', 'INFO(6) MUST BE 0 OR 1 ' // & 'INDICATING WHETHER THE CODE IS TOLD TO TREAT THE ' // & 'JACOBIAN AS A FULL (DENSE) MATRIX OR AS HAVING A ' // & 'SPECIAL BANDED STRUCTURE. YOU HAVE CALLED THE CODE ' // & 'WITH INFO(6) = ' // XERN1, 16, 1) IDID = -33 end if ! ILRW = NEQ if (INFO(6) /= 0) THEN ! ! CHECK BANDWIDTH PARAMETERS ! ML = IWORK(1) MU = IWORK(2) ILRW = 2*ML + MU + 1 ! if (ML < 0 .OR. ML >= NEQ .OR. MU < 0 .OR. MU >= NEQ) THEN WRITE (XERN1, '(I8)') ML WRITE (XERN2, '(I8)') MU call XERMSG ('SLATEC', 'DDEBDF', 'YOU HAVE SET INFO(6) ' // & '= 1, TELLING THE CODE THAT THE JACOBIAN MATRIX HAS ' // & 'A SPECIAL BANDED STRUCTURE. HOWEVER, THE LOWER ' // & '(UPPER) BANDWIDTHS ML (MU) VIOLATE THE CONSTRAINTS ' // & 'ML,MU >= 0 AND ML,MU < NEQ. YOU HAVE CALLED ' // & 'THE CODE WITH ML = ' // XERN1 // ' AND MU = ' // XERN2, & 17, 1) IDID = -33 ENDIF end if ! ! CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION ! if (LRW < 250 + (10 + ILRW)*NEQ) THEN WRITE (XERN1, '(I8)') LRW if (INFO(6) == 0) THEN call XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY RWORK ' // & 'MUST BE AT LEAST 250 + 10*NEQ + NEQ*NEQ.$$' // & 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) ELSE call XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY RWORK ' // & 'MUST BE AT LEAST 250 + 10*NEQ + (2*ML+MU+1)*NEQ.$$' // & 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 18, 1) ENDIF IDID = -33 end if ! if (LIW < 56 + NEQ) THEN WRITE (XERN1, '(I8)') LIW call XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY IWORK ' // & 'BE AT LEAST 56 + NEQ. YOU HAVE CALLED THE CODE WITH ' // & 'LIW = ' // XERN1, 2, 1) IDID = -33 end if ! ! COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ! ARRAY AND RESTORE COMMON BLOCK DATA ! ICOMI = 21 + NEQ IINOUT = ICOMI + 33 ! IYPOUT = 21 ITSTAR = 21 + NEQ ICOMR = 22 + NEQ ! if (INFO(1) /= 0) INTOUT = IWORK(IINOUT) /= (-1) ! call DRSCO(RWORK(ICOMR),IWORK(ICOMI)) ! IYH = ICOMR + 218 IEWT = IYH + 6*NEQ ISAVF = IEWT + NEQ IACOR = ISAVF + NEQ IWM = IACOR + NEQ IDELSN = IWM + 2 + ILRW*NEQ ! IBEGIN = INFO(1) ITOL = INFO(2) IINTEG = INFO(3) ITSTOP = INFO(4) IJAC = INFO(5) IBAND = INFO(6) RWORK(ITSTAR) = T ! call DLSOD(DF,NEQ,T,Y,TOUT,RTOL,ATOL,IDID,RWORK(IYPOUT), & RWORK(IYH),RWORK(IYH),RWORK(IEWT),RWORK(ISAVF), & RWORK(IACOR),RWORK(IWM),IWORK(1),DJAC,INTOUT, & RWORK(1),RWORK(12),RWORK(IDELSN),RPAR,IPAR) ! IWORK(IINOUT) = -1 if (INTOUT) IWORK(IINOUT) = 1 ! if (IDID /= (-2)) IWORK(LIW) = IWORK(LIW) + 1 if (T /= RWORK(ITSTAR)) IWORK(LIW) = 0 ! call DSVCO(RWORK(ICOMR),IWORK(ICOMI)) RWORK(11) = H RWORK(13) = TN INFO(1) = IBEGIN ! return end subroutine DDERKF (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, & RWORK, LRW, IWORK, LIW, RPAR, IPAR) ! !! DDERKF solves an initial value problem in ordinary differential ... ! equations using a Runge-Kutta-Fehlberg scheme. ! !***LIBRARY SLATEC (DEPAC) !***CATEGORY I1A1A !***TYPE DOUBLE PRECISION (DERKF-S, DDERKF-D) !***KEYWORDS DEPAC, INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, RKF, ! RUNGE-KUTTA-FEHLBERG METHODS !***AUTHOR Watts, H. A., (SNLA) ! Shampine, L. F., (SNLA) !***DESCRIPTION ! ! This is the Runge-Kutta code in the package of differential equation ! solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF. ! Design of the package was by L. F. Shampine and H. A. Watts. ! It is documented in ! SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE ! Solvers. ! DDERKF is a driver for a modification of the code RKF45 written by ! H. A. Watts and L. F. Shampine ! Sandia Laboratories ! Albuquerque, New Mexico 87185 ! ! ********************************************************************** ! ** DDEPAC PACKAGE OVERVIEW ** ! ********************************************************************** ! ! You have a choice of three differential equation solvers from ! DDEPAC. The following brief descriptions are meant to aid you ! in choosing the most appropriate code for your problem. ! ! DDERKF is a fifth order Runge-Kutta code. It is the simplest of ! the three choices, both algorithmically and in the use of the ! code. DDERKF is primarily designed to solve non-stiff and mild- ! ly stiff differential equations when derivative evaluations are ! not expensive. It should generally not be used to get high ! accuracy results nor answers at a great many specific points. ! Because DDERKF has very low overhead costs, it will usually ! result in the least expensive integration when solving ! problems requiring a modest amount of accuracy and having ! equations that are not costly to evaluate. DDERKF attempts to ! discover when it is not suitable for the task posed. ! ! DDEABM is a variable order (one through twelve) Adams code. Its ! complexity lies somewhere between that of DDERKF and DDEBDF. ! DDEABM is primarily designed to solve non-stiff and mildly ! stiff differential equations when derivative evaluations are ! expensive, high accuracy results are needed or answers at ! many specific points are required. DDEABM attempts to discover ! when it is not suitable for the task posed. ! ! DDEBDF is a variable order (one through five) backward ! differentiation formula code. It is the most complicated of ! the three choices. DDEBDF is primarily designed to solve stiff ! differential equations at crude to moderate tolerances. ! If the problem is very stiff at all, DDERKF and DDEABM will be ! quite inefficient compared to DDEBDF. However, DDEBDF will be ! inefficient compared to DDERKF and DDEABM on non-stiff problems ! because it uses much more storage, has a much larger overhead, ! and the low order formulas will not give high accuracies ! efficiently. ! ! The concept of stiffness cannot be described in a few words. ! If you do not know the problem to be stiff, try either DDERKF ! or DDEABM. Both of these codes will inform you of stiffness ! when the cost of solving such problems becomes important. ! ! ********************************************************************** ! ** ABSTRACT ** ! ********************************************************************** ! ! Subroutine DDERKF uses a Runge-Kutta-Fehlberg (4,5) method to ! integrate a system of NEQ first order ordinary differential ! equations of the form ! DU/DX = DF(X,U) ! when the vector Y(*) of initial values for U(*) at X=T is given. ! The subroutine integrates from T to TOUT. It is easy to continue the ! integration to get results at additional TOUT. This is the interval ! mode of operation. It is also easy for the routine to return with ! the solution at each intermediate step on the way to TOUT. This is ! the intermediate-output mode of operation. ! ! DDERKF uses subprograms DRKFS, DFEHL, DHSTRT, DHVNRM, D1MACH, and ! the error handling routine XERMSG. The only machine dependent ! parameters to be assigned appear in D1MACH. ! ! ********************************************************************** ! ** DESCRIPTION OF THE ARGUMENTS TO DDERKF (AN OVERVIEW) ** ! ********************************************************************** ! ! The Parameters are: ! ! DF -- This is the name of a subroutine which you provide to ! define the differential equations. ! ! NEQ -- This is the number of (first order) differential ! equations to be integrated. ! ! T -- This is a DOUBLE PRECISION value of the independent ! variable. ! ! Y(*) -- This DOUBLE PRECISION array contains the solution ! components at T. ! ! TOUT -- This is a DOUBLE PRECISION point at which a solution is ! desired. ! ! INFO(*) -- The basic task of the code is to integrate the ! differential equations from T to TOUT and return an ! answer at TOUT. INFO(*) is an INTEGER array which is used ! to communicate exactly how you want this task to be ! carried out. ! ! RTOL, ATOL -- These DOUBLE PRECISION quantities represent ! relative and absolute error tolerances which you provide ! to indicate how accurately you wish the solution to be ! computed. You may choose them to be both scalars or else ! both vectors. ! ! IDID -- This scalar quantity is an indicator reporting what ! the code did. You must monitor this INTEGER variable to ! decide what action to take next. ! ! RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of ! length LRW which provides the code with needed storage ! space. ! ! IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW ! which provides the code with needed storage space and an ! across call flag. ! ! RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter ! arrays which you can use for communication between your ! calling program and the DF subroutine. ! ! Quantities which are used as input items are ! NEQ, T, Y(*), TOUT, INFO(*), ! RTOL, ATOL, LRW and LIW. ! ! Quantities which may be altered by the code are ! T, Y(*), INFO(1), RTOL, ATOL, ! IDID, RWORK(*) and IWORK(*). ! ! ********************************************************************** ! ** INPUT -- What to do On The First Call To DDERKF ** ! ********************************************************************** ! ! The first call of the code is defined to be the start of each new ! problem. Read through the descriptions of all the following items, ! provide sufficient storage space for designated arrays, set ! appropriate variables for the initialization of the problem, and ! give information about how you want the problem to be solved. ! ! ! DF -- Provide a subroutine of the form ! DF(X,U,UPRIME,RPAR,IPAR) ! to define the system of first order differential equations ! which is to be solved. For the given values of X and the ! vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must ! evaluate the NEQ components of the system of differential ! equations DU/DX=DF(X,U) and store the derivatives in the ! array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for ! equations I=1,...,NEQ. ! ! Subroutine DF must not alter X or U(*). You must declare ! the name DF in an external statement in your program that ! calls DDERKF. You must dimension U and UPRIME in DF. ! ! RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter ! arrays which you can use for communication between your ! calling program and subroutine DF. They are not used or ! altered by DDERKF. If you do not need RPAR or IPAR, ! ignore these parameters by treating them as dummy ! arguments. If you do choose to use them, dimension them in ! your calling program and in DF as arrays of appropriate ! length. ! ! NEQ -- Set it to the number of differential equations. ! (NEQ >= 1) ! ! T -- Set it to the initial point of the integration. ! You must use a program variable for T because the code ! changes its value. ! ! Y(*) -- Set this vector to the initial values of the NEQ solution ! components at the initial point. You must dimension Y at ! least NEQ in your calling program. ! ! TOUT -- Set it to the first point at which a solution ! is desired. You can take TOUT = T, in which case the code ! will evaluate the derivative of the solution at T and ! return. Integration either forward in T (TOUT > T) or ! backward in T (TOUT < T) is permitted. ! ! The code advances the solution from T to TOUT using ! step sizes which are automatically selected so as to ! achieve the desired accuracy. If you wish, the code will ! return with the solution and its derivative following ! each intermediate step (intermediate-output mode) so that ! you can monitor them, but you still must provide TOUT in ! accord with the basic aim of the code. ! ! The first step taken by the code is a critical one ! because it must reflect how fast the solution changes near ! the initial point. The code automatically selects an ! initial step size which is practically always suitable for ! the problem. By using the fact that the code will not ! step past TOUT in the first step, you could, if necessary, ! restrict the length of the initial step size. ! ! For some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP. Since DDERKF will never step past a TOUT point, ! you need only make sure that no TOUT lies beyond TSTOP. ! ! INFO(*) -- Use the INFO array to give the code more details about ! how you want your problem solved. This array should be ! dimensioned of length 15 to accommodate other members of ! DEPAC or possible future extensions, though DDERKF uses ! only the first three entries. You must respond to all of ! the following items which are arranged as questions. The ! simplest use of the code corresponds to answering all ! questions as YES ,i.e. setting all entries of INFO to 0. ! ! INFO(1) -- This parameter enables the code to initialize ! itself. You must set it to indicate the start of every ! new problem. ! ! **** Is this the first call for this problem ... ! YES -- Set INFO(1) = 0 ! NO -- Not applicable here. ! See below for continuation calls. **** ! ! INFO(2) -- How much accuracy you want of your solution ! is specified by the error tolerances RTOL and ATOL. ! The simplest use is to take them both to be scalars. ! To obtain more flexibility, they can both be vectors. ! The code must be told your choice. ! ! **** Are both error tolerances RTOL, ATOL scalars ... ! YES -- Set INFO(2) = 0 ! and input scalars for both RTOL and ATOL ! NO -- Set INFO(2) = 1 ! and input arrays for both RTOL and ATOL **** ! ! INFO(3) -- The code integrates from T in the direction ! of TOUT by steps. If you wish, it will return the ! computed solution and derivative at the next ! intermediate step (the intermediate-output mode). ! This is a good way to proceed if you want to see the ! behavior of the solution. If you must have solutions at ! a great many specific TOUT points, this code is ! INEFFICIENT. The code DDEABM in DEPAC handles this task ! more efficiently. ! ! **** Do you want the solution only at ! TOUT (and not at the next intermediate step) ... ! YES -- Set INFO(3) = 0 ! NO -- Set INFO(3) = 1 **** ! ! RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) ! error tolerances to tell the code how accurately you want ! the solution to be computed. They must be defined as ! program variables because the code may change them. You ! have two choices -- ! Both RTOL and ATOL are scalars. (INFO(2)=0) ! Both RTOL and ATOL are vectors. (INFO(2)=1) ! In either case all components must be non-negative. ! ! The tolerances are used by the code in a local error test ! at each step which requires roughly that ! ABS(LOCAL ERROR) <= RTOL*ABS(Y)+ATOL ! for each vector component. ! (More specifically, a maximum norm is used to measure ! the size of vectors, and the error test uses the average ! of the magnitude of the solution at the beginning and end ! of the step.) ! ! The true (global) error is the difference between the true ! solution of the initial value problem and the computed ! approximation. Practically all present day codes, ! including this one, control the local error at each step ! and do not even attempt to control the global error ! directly. Roughly speaking, they produce a solution Y(T) ! which satisfies the differential equations with a ! residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , ! and, almost always, R(T) is bounded by the error ! tolerances. Usually, but not always, the true accuracy of ! the computed Y is comparable to the error tolerances. This ! code will usually, but not always, deliver a more accurate ! solution if you reduce the tolerances and integrate again. ! By comparing two such solutions you can get a fairly ! reliable idea of the true error in the solution at the ! bigger tolerances. ! ! Setting ATOL=0. results in a pure relative error test on ! that component. Setting RTOL=0. yields a pure absolute ! error test on that component. A mixed test with non-zero ! RTOL and ATOL corresponds roughly to a relative error ! test when the solution component is much bigger than ATOL ! and to an absolute error test when the solution component ! is smaller than the threshold ATOL. ! ! Proper selection of the absolute error control parameters ! ATOL requires you to have some idea of the scale of the ! solution components. To acquire this information may mean ! that you will have to solve the problem more than once. In ! the absence of scale information, you should ask for some ! relative accuracy in all the components (by setting RTOL ! values non-zero) and perhaps impose extremely small ! absolute error tolerances to protect against the danger of ! a solution component becoming zero. ! ! The code will not attempt to compute a solution at an ! accuracy unreasonable for the machine being used. It will ! advise you if you ask for too much accuracy and inform ! you as to the maximum accuracy it believes possible. ! If you want relative accuracies smaller than about ! 10**(-8), you should not ordinarily use DDERKF. The code ! DDEABM in DEPAC obtains stringent accuracies more ! efficiently. ! ! RWORK(*) -- Dimension this DOUBLE PRECISION work array of length ! LRW in your calling program. ! ! LRW -- Set it to the declared length of the RWORK array. ! You must have LRW >= 33+7*NEQ ! ! IWORK(*) -- Dimension this INTEGER work array of length LIW in ! your calling program. ! ! LIW -- Set it to the declared length of the IWORK array. ! You must have LIW >= 34 ! ! RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and ! INTEGER type, respectively. You can use them for ! communication between your program that calls DDERKF and ! the DF subroutine. They are not used or altered by ! DDERKF. If you do not need RPAR or IPAR, ignore these ! parameters by treating them as dummy arguments. If you do ! choose to use them, dimension them in your calling program ! and in DF as arrays of appropriate length. ! ! ********************************************************************** ! ** OUTPUT -- After any return from DDERKF ** ! ********************************************************************** ! ! The principal aim of the code is to return a computed solution at ! TOUT, although it is also possible to obtain intermediate results ! along the way. To find out whether the code achieved its goal ! or if the integration process was interrupted before the task was ! completed, you must check the IDID parameter. ! ! ! T -- The solution was successfully advanced to the ! output value of T. ! ! Y(*) -- Contains the computed solution approximation at T. ! You may also be interested in the approximate derivative ! of the solution at T. It is contained in ! RWORK(21),...,RWORK(20+NEQ). ! ! IDID -- Reports what the code did ! ! *** Task Completed *** ! Reported by positive values of IDID ! ! IDID = 1 -- A step was successfully taken in the ! intermediate-output mode. The code has not ! yet reached TOUT. ! ! IDID = 2 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping exactly to TOUT. ! ! *** Task Interrupted *** ! Reported by negative values of IDID ! ! IDID = -1 -- A large amount of work has been expended. ! (500 steps attempted) ! ! IDID = -2 -- The error tolerances are too stringent. ! ! IDID = -3 -- The local error test cannot be satisfied ! because you specified a zero component in ATOL ! and the corresponding computed solution ! component is zero. Thus, a pure relative error ! test is impossible for this component. ! ! IDID = -4 -- The problem appears to be stiff. ! ! IDID = -5 -- DDERKF is being used very inefficiently ! because the natural step size is being ! restricted by too frequent output. ! ! IDID = -6,-7,..,-32 -- Not applicable for this code but ! used by other members of DEPAC or possible ! future extensions. ! ! *** Task Terminated *** ! Reported by the value of IDID=-33 ! ! IDID = -33 -- The code has encountered trouble from which ! it cannot recover. A message is printed ! explaining the trouble and control is returned ! to the calling program. For example, this ! occurs when invalid input is detected. ! ! RTOL, ATOL -- These quantities remain unchanged except when ! IDID = -2. In this case, the error tolerances have been ! increased by the code to values which are estimated to be ! appropriate for continuing the integration. However, the ! reported solution at T was obtained using the input values ! of RTOL and ATOL. ! ! RWORK, IWORK -- Contain information which is usually of no ! interest to the user but necessary for subsequent calls. ! However, you may find use for ! ! RWORK(11)--which contains the step size H to be ! attempted on the next step. ! ! RWORK(12)--If the tolerances have been increased by the ! code (IDID = -2) , they were multiplied by the ! value in RWORK(12). ! ! RWORK(20+I)--which contains the approximate derivative ! of the solution component Y(I). In DDERKF, it ! is always obtained by calling subroutine DF to ! evaluate the differential equation using T and ! Y(*). ! ! ********************************************************************** ! ** INPUT -- What To Do To Continue The Integration ** ! ** (calls after the first) ** ! ********************************************************************** ! ! This code is organized so that subsequent calls to continue the ! integration involve little (if any) additional effort on your ! part. You must monitor the IDID parameter to determine ! what to do next. ! ! Recalling that the principal task of the code is to integrate ! from T to TOUT (the interval mode), usually all you will need ! to do is specify a new TOUT upon reaching the current TOUT. ! ! Do not alter any quantity not specifically permitted below, ! in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or ! the differential equation in subroutine DF. Any such alteration ! constitutes a new problem and must be treated as such, i.e. ! you must start afresh. ! ! You cannot change from vector to scalar error control or vice ! versa (INFO(2)) but you can change the size of the entries of ! RTOL, ATOL. Increasing a tolerance makes the equation easier ! to integrate. Decreasing a tolerance will make the equation ! harder to integrate and should generally be avoided. ! ! You can switch from the intermediate-output mode to the ! interval mode (INFO(3)) or vice versa at any time. ! ! The parameter INFO(1) is used by the code to indicate the ! beginning of a new problem and to indicate whether integration ! is to be continued. You must input the value INFO(1) = 0 ! when starting a new problem. You must input the value ! INFO(1) = 1 if you wish to continue after an interrupted task. ! Do not set INFO(1) = 0 on a continuation call unless you ! want the code to restart at the current T. ! ! *** Following a Completed Task *** ! If ! IDID = 1, call the code again to continue the integration ! another step in the direction of TOUT. ! ! IDID = 2, define a new TOUT and call the code again. ! TOUT must be different from T. You cannot change ! the direction of integration without restarting. ! ! *** Following an Interrupted Task *** ! To show the code that you realize the task was ! interrupted and that you want to continue, you ! must take appropriate action and reset INFO(1) = 1 ! If ! IDID = -1, the code has attempted 500 steps. ! If you want to continue, set INFO(1) = 1 and ! call the code again. An additional 500 steps ! will be allowed. ! ! IDID = -2, the error tolerances RTOL, ATOL have been ! increased to values the code estimates appropriate ! for continuing. You may want to change them ! yourself. If you are sure you want to continue ! with relaxed error tolerances, set INFO(1)=1 and ! call the code again. ! ! IDID = -3, a solution component is zero and you set the ! corresponding component of ATOL to zero. If you ! are sure you want to continue, you must first ! alter the error criterion to use positive values ! for those components of ATOL corresponding to zero ! solution components, then set INFO(1)=1 and call ! the code again. ! ! IDID = -4, the problem appears to be stiff. It is very ! inefficient to solve such problems with DDERKF. ! The code DDEBDF in DEPAC handles this task ! efficiently. If you are absolutely sure you want ! to continue with DDERKF, set INFO(1)=1 and call ! the code again. ! ! IDID = -5, you are using DDERKF very inefficiently by ! choosing output points TOUT so close together that ! the step size is repeatedly forced to be rather ! smaller than necessary. If you are willing to ! accept solutions at the steps chosen by the code, ! a good way to proceed is to use the intermediate ! output mode (setting INFO(3)=1). If you must have ! solutions at so many specific TOUT points, the ! code DDEABM in DEPAC handles this task ! efficiently. If you want to continue with DDERKF, ! set INFO(1)=1 and call the code again. ! ! IDID = -6,-7,..,-32 --- cannot occur with this code but ! used by other members of DEPAC or possible future ! extensions. ! ! *** Following a Terminated Task *** ! If ! IDID = -33, you cannot continue the solution of this ! problem. An attempt to do so will result in your ! run being terminated. ! ! ********************************************************************** ! *Long Description: ! ! ********************************************************************** ! ** DEPAC Package Overview ** ! ********************************************************************** ! ! .... You have a choice of three differential equation solvers from ! .... DEPAC. The following brief descriptions are meant to aid you in ! .... choosing the most appropriate code for your problem. ! ! .... DDERKF is a fifth order Runge-Kutta code. It is the simplest of ! .... the three choices, both algorithmically and in the use of the ! .... code. DDERKF is primarily designed to solve non-stiff and ! .... mildly stiff differential equations when derivative evaluations ! .... are not expensive. It should generally not be used to get high ! .... accuracy results nor answers at a great many specific points. ! .... Because DDERKF has very low overhead costs, it will usually ! .... result in the least expensive integration when solving ! .... problems requiring a modest amount of accuracy and having ! .... equations that are not costly to evaluate. DDERKF attempts to ! .... discover when it is not suitable for the task posed. ! ! .... DDEABM is a variable order (one through twelve) Adams code. ! .... Its complexity lies somewhere between that of DDERKF and ! .... DDEBDF. DDEABM is primarily designed to solve non-stiff and ! .... mildly stiff differential equations when derivative evaluations ! .... are expensive, high accuracy results are needed or answers at ! .... many specific points are required. DDEABM attempts to discover ! .... when it is not suitable for the task posed. ! ! .... DDEBDF is a variable order (one through five) backward ! .... differentiation formula code. it is the most complicated of ! .... the three choices. DDEBDF is primarily designed to solve stiff ! .... differential equations at crude to moderate tolerances. ! .... If the problem is very stiff at all, DDERKF and DDEABM will be ! .... quite inefficient compared to DDEBDF. However, DDEBDF will be ! .... inefficient compared to DDERKF and DDEABM on non-stiff problems ! .... because it uses much more storage, has a much larger overhead, ! .... and the low order formulas will not give high accuracies ! .... efficiently. ! ! .... The concept of stiffness cannot be described in a few words. ! .... If you do not know the problem to be stiff, try either DDERKF ! .... or DDEABM. Both of these codes will inform you of stiffness ! .... when the cost of solving such problems becomes important. ! ! ********************************************************************* ! !***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user ! oriented package of ODE solvers, Report SAND79-2374, ! Sandia Laboratories, 1979. ! L. F. Shampine and H. A. Watts, Practical solution of ! ordinary differential equations by Runge-Kutta ! methods, Report SAND76-0585, Sandia Laboratories, ! 1976. !***ROUTINES CALLED DRKFS, XERMSG !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891024 Changed references from DVNORM to DHVNRM. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls, make Prologue comments ! consistent with DERKF. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DDERKF ! INTEGER IDID, INFO, IPAR, IWORK, KDI, KF1, KF2, KF3, KF4, KF5, & KH, KRER, KTF, KTO, KTSTAR, KU, KYP, KYS, LIW, LRW, NEQ DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y LOGICAL STIFF,NONSTF ! DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), & RPAR(*),IPAR(*) CHARACTER*8 XERN1 CHARACTER*16 XERN3 ! EXTERNAL DF ! ! CHECK FOR AN APPARENT INFINITE LOOP ! !***FIRST EXECUTABLE STATEMENT DDERKF if (INFO(1) == 0) IWORK(LIW) = 0 if (IWORK(LIW) >= 5) THEN if (T == RWORK(21+NEQ)) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DDERKF', & 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // & 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // & ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // & 'WAY YOU HAVE SET PARAMETERS FOR THE call TO THE ' // & 'CODE, PARTICULARLY INFO(1).', 13, 2) return ENDIF end if ! ! CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION ! IDID = 0 if (LRW < 30 + 7*NEQ) THEN WRITE (XERN1, '(I8)') LRW call XERMSG ('SLATEC', 'DDERKF', 'LENGTH OF RWORK ARRAY ' // & 'MUST BE AT LEAST 30 + 7*NEQ. YOU HAVE CALLED THE ' // & 'CODE WITH LRW = ' // XERN1, 1, 1) IDID = -33 end if ! if (LIW < 34) THEN WRITE (XERN1, '(I8)') LIW call XERMSG ('SLATEC', 'DDERKF', 'LENGTH OF IWORK ARRAY ' // & 'MUST BE AT LEAST 34. YOU HAVE CALLED THE CODE WITH ' // & 'LIW = ' // XERN1, 2, 1) IDID = -33 end if ! ! COMPUTE INDICES FOR THE SPLITTING OF THE RWORK ARRAY ! KH = 11 KTF = 12 KYP = 21 KTSTAR = KYP + NEQ KF1 = KTSTAR + 1 KF2 = KF1 + NEQ KF3 = KF2 + NEQ KF4 = KF3 + NEQ KF5 = KF4 + NEQ KYS = KF5 + NEQ KTO = KYS + NEQ KDI = KTO + 1 KU = KDI + 1 KRER = KU + 1 ! ! ********************************************************************** ! THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG ! CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE ! ARRAYS. if THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, ! S/HE MUST USE DRKFS DIRECTLY. ! ********************************************************************** ! RWORK(KTSTAR) = T if (INFO(1) /= 0) THEN STIFF = (IWORK(25) == 0) NONSTF = (IWORK(26) == 0) end if ! call DRKFS(DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(KH), & RWORK(KTF),RWORK(KYP),RWORK(KF1),RWORK(KF2),RWORK(KF3), & RWORK(KF4),RWORK(KF5),RWORK(KYS),RWORK(KTO),RWORK(KDI), & RWORK(KU),RWORK(KRER),IWORK(21),IWORK(22),IWORK(23), & IWORK(24),STIFF,NONSTF,IWORK(27),IWORK(28),RPAR,IPAR) ! IWORK(25) = 1 if (STIFF) IWORK(25) = 0 IWORK(26) = 1 if (NONSTF) IWORK(26) = 0 ! if (IDID /= (-2)) IWORK(LIW) = IWORK(LIW) + 1 if (T /= RWORK(KTSTAR)) IWORK(LIW) = 0 ! return end subroutine DDES (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, & YPOUT, YP, YY, WT, P, PHI, ALPHA, BETA, PSI, V, W, SIG, G, GI, & H, EPS, X, XOLD, HOLD, TOLD, DELSGN, TSTOP, TWOU, FOURU, START, & PHASE1, NORND, STIFF, INTOUT, NS, KORD, KOLD, INIT, KSTEPS, & KLE4, IQUIT, KPREV, IVC, IV, KGI, RPAR, IPAR) ! !! DDES is subsidiary to DDEABM. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (DES-S, DDES-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DDEABM merely allocates storage for DDES to relieve the user of the ! inconvenience of a long call list. Consequently DDES is used as ! described in the comments for DDEABM . ! !***SEE ALSO DDEABM !***ROUTINES CALLED D1MACH, DINTP, DSTEPS, XERMSG !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls, cvt GOTOs to ! IF-THEN-ELSE. (RWC) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DDES ! INTEGER IDID, INFO, INIT, IPAR, IQUIT, IV, IVC, K, KGI, KLE4, & KOLD, KORD, KPREV, KSTEPS, L, LTOL, MAXNUM, NATOLP, NEQ, & NRTOLP, NS DOUBLE PRECISION A, ABSDEL, ALPHA, ATOL, BETA, D1MACH, & DEL, DELSGN, DT, EPS, FOURU, G, GI, H, & HA, HOLD, P, PHI, PSI, RPAR, RTOL, SIG, T, TOLD, TOUT, & TSTOP, TWOU, U, V, W, WT, X, XOLD, Y, YP, YPOUT, YY LOGICAL STIFF,CRASH,START,PHASE1,NORND,INTOUT ! DIMENSION Y(*),YY(*),WT(*),PHI(NEQ,16),P(*),YP(*), & YPOUT(*),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13), & GI(11),IV(10),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) CHARACTER*8 XERN1 CHARACTER*16 XERN3, XERN4 ! EXTERNAL DF ! !....................................................................... ! ! THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE ! NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER ! IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE ! WORK. ! SAVE MAXNUM DATA MAXNUM/500/ ! !....................................................................... ! !***FIRST EXECUTABLE STATEMENT DDES if (INFO(1) == 0) THEN ! ! ON THE FIRST call , PERFORM INITIALIZATION -- ! DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE ! FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE ! VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. ! U=D1MACH(4) ! -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS TWOU=2.D0*U FOURU=4.D0*U ! -- SET TERMINATION FLAG IQUIT=0 ! -- SET INITIALIZATION INDICATOR INIT=0 ! -- SET COUNTER FOR ATTEMPTED STEPS KSTEPS=0 ! -- SET INDICATOR FOR INTERMEDIATE-OUTPUT INTOUT= .FALSE. ! -- SET INDICATOR FOR STIFFNESS DETECTION STIFF= .FALSE. ! -- SET STEP COUNTER FOR STIFFNESS DETECTION KLE4=0 ! -- SET INDICATORS FOR STEPS CODE START= .TRUE. PHASE1= .TRUE. NORND= .TRUE. ! -- RESET INFO(1) FOR SUBSEQUENT CALLS INFO(1)=1 end if ! !....................................................................... ! ! CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY ! if (INFO(1) /= 0 .AND. INFO(1) /= 1) THEN WRITE (XERN1, '(I8)') INFO(1) call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(1) MUST BE ' // & 'SET TO 0 FOR THE START OF A NEW PROBLEM, AND MUST BE ' // & 'SET TO 1 FOLLOWING AN INTERRUPTED TASK. YOU ARE ' // & 'ATTEMPTING TO CONTINUE THE INTEGRATION ILLEGALLY BY ' // & 'CALLING THE CODE WITH INFO(1) = ' // XERN1, 3, 1) IDID=-33 end if ! if (INFO(2) /= 0 .AND. INFO(2) /= 1) THEN WRITE (XERN1, '(I8)') INFO(2) call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(2) MUST BE ' // & '0 OR 1 INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // & 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // & XERN1, 4, 1) IDID=-33 end if ! if (INFO(3) /= 0 .AND. INFO(3) /= 1) THEN WRITE (XERN1, '(I8)') INFO(3) call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(3) MUST BE ' // & '0 OR 1 INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT ' // & 'MODE OF INTEGRATION, RESPECTIVELY. YOU HAVE CALLED ' // & 'THE CODE WITH INFO(3) = ' // XERN1, 5, 1) IDID=-33 end if ! if (INFO(4) /= 0 .AND. INFO(4) /= 1) THEN WRITE (XERN1, '(I8)') INFO(4) call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(4) MUST BE ' // & '0 OR 1 INDICATING WHETHER OR NOT THE INTEGRATION ' // & 'INTERVAL IS TO BE RESTRICTED BY A POINT TSTOP. YOU ' // & 'HAVE CALLED THE CODE WITH INFO(4) = ' // XERN1, 14, 1) IDID=-33 end if ! if (NEQ < 1) THEN WRITE (XERN1, '(I8)') NEQ call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE NUMBER OF ' // & 'EQUATIONS NEQ MUST BE A POSITIVE INTEGER. YOU HAVE ' // & 'CALLED THE CODE WITH NEQ = ' // XERN1, 6, 1) IDID=-33 end if ! NRTOLP = 0 NATOLP = 0 DO 90 K=1,NEQ if (NRTOLP == 0 .AND. RTOL(K) < 0.D0) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') RTOL(K) call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE RELATIVE ' // & 'ERROR TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU ' // & 'HAVE CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // & XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // & 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) IDID = -33 NRTOLP = 1 ENDIF ! if (NATOLP == 0 .AND. ATOL(K) < 0.D0) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') ATOL(K) call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE ABSOLUTE ' // & 'ERROR TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU ' // & 'HAVE CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // & XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // & 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) IDID = -33 NATOLP = 1 ENDIF ! if (INFO(2) == 0) go to 100 if (NATOLP > 0 .AND. NRTOLP > 0) go to 100 90 CONTINUE ! 100 if (INFO(4) == 1) THEN if (SIGN(1.D0,TOUT-T) /= SIGN(1.D0,TSTOP-T) & .OR. ABS(TOUT-T) > ABS(TSTOP-T)) THEN WRITE (XERN3, '(1PE15.6)') TOUT WRITE (XERN4, '(1PE15.6)') TSTOP call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // & 'CALLED THE CODE WITH TOUT = ' // XERN3 // ' BUT ' // & 'YOU HAVE ALSO TOLD THE CODE (INFO(4) = 1) NOT TO ' // & 'INTEGRATE PAST THE POINT TSTOP = ' // XERN4 // & ' THESE INSTRUCTIONS CONFLICT.', 14, 1) IDID=-33 ENDIF end if ! ! CHECK SOME CONTINUATION POSSIBILITIES ! if (INIT /= 0) THEN if (T == TOUT) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // & 'CALLED THE CODE WITH T = TOUT = ' // XERN3 // & '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 9, 1) IDID=-33 ENDIF ! if (T /= TOLD) THEN WRITE (XERN3, '(1PE15.6)') TOLD WRITE (XERN4, '(1PE15.6)') T call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // & 'CHANGED THE VALUE OF T FROM ' // XERN3 // ' TO ' // & XERN4 //' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', & 10, 1) IDID=-33 ENDIF ! if (INIT /= 1) THEN if (DELSGN*(TOUT-T) < 0.D0) THEN WRITE (XERN3, '(1PE15.6)') TOUT call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, BY ' // & 'CALLING THE CODE WITH TOUT = ' // XERN3 // & ' YOU ARE ATTEMPTING TO CHANGE THE DIRECTION OF ' // & 'INTEGRATION.$$THIS IS NOT ALLOWED WITHOUT ' // & 'RESTARTING.', 11, 1) IDID=-33 ENDIF ENDIF end if ! ! INVALID INPUT DETECTED ! if (IDID == (-33)) THEN if (IQUIT /= (-33)) THEN IQUIT = -33 INFO(1) = -1 ELSE call XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INVALID ' // & 'INPUT WAS DETECTED ON SUCCESSIVE ENTRIES. IT IS ' // & 'IMPOSSIBLE TO PROCEED BECAUSE YOU HAVE NOT ' // & 'CORRECTED THE PROBLEM, SO EXECUTION IS BEING ' // & 'TERMINATED.', 12, 2) ENDIF return end if ! !....................................................................... ! ! RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS ! ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, ! THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE ! FOURU WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE ! DO 180 K=1,NEQ if (RTOL(K)+ATOL(K) > 0.D0) go to 170 RTOL(K)=FOURU IDID=-2 170 if (INFO(2) == 0) go to 190 180 CONTINUE ! 190 if (IDID /= (-2)) go to 200 ! RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A ! SMALL POSITIVE VALUE INFO(1)=-1 return ! ! BRANCH ON STATUS OF INITIALIZATION INDICATOR ! INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE ! AND DIRECTION NOT YET SET ! INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET ! INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED ! 200 if (INIT == 0) go to 210 if (INIT == 1) go to 220 go to 240 ! !....................................................................... ! ! MORE INITIALIZATION -- ! -- EVALUATE INITIAL DERIVATIVES ! 210 INIT=1 A=T call DF(A,Y,YP,RPAR,IPAR) if (T /= TOUT) go to 220 IDID=2 DO 215 L = 1,NEQ 215 YPOUT(L) = YP(L) TOLD=T return ! ! -- SET INDEPENDENT AND DEPENDENT VARIABLES ! X AND YY(*) FOR STEPS ! -- SET SIGN OF INTEGRATION DIRECTION ! -- INITIALIZE THE STEP SIZE ! 220 INIT = 2 X = T DO 230 L = 1,NEQ 230 YY(L) = Y(L) DELSGN = SIGN(1.0D0,TOUT-T) H = SIGN(MAX(FOURU*ABS(X),ABS(TOUT-X)),TOUT-X) ! !....................................................................... ! ! ON EACH call SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL ! OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT ! 240 DEL = TOUT - T ABSDEL = ABS(DEL) ! !....................................................................... ! ! if ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN ! 250 if ( ABS(X-T) < ABSDEL) go to 260 call DINTP(X,YY,TOUT,Y,YPOUT,NEQ,KOLD,PHI,IVC,IV,KGI,GI, & ALPHA,G,W,XOLD,P) IDID = 3 if (X /= TOUT) go to 255 IDID = 2 INTOUT = .FALSE. 255 T = TOUT TOLD = T return ! ! if CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, ! EXTRAPOLATE AND RETURN ! 260 if (INFO(4) /= 1) go to 280 if (ABS(TSTOP-X) >= FOURU*ABS(X)) go to 280 DT = TOUT - X DO 270 L = 1,NEQ 270 Y(L) = YY(L) + DT*YP(L) call DF(TOUT,Y,YPOUT,RPAR,IPAR) IDID = 3 T = TOUT TOLD = T return ! 280 if (INFO(3) == 0 .OR. .NOT.INTOUT) go to 300 ! ! INTERMEDIATE-OUTPUT MODE ! IDID = 1 DO 290 L = 1,NEQ Y(L)=YY(L) 290 YPOUT(L) = YP(L) T = X TOLD = T INTOUT = .FALSE. return ! !....................................................................... ! ! MONITOR NUMBER OF STEPS ATTEMPTED ! 300 if (KSTEPS <= MAXNUM) go to 330 ! ! A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED IDID=-1 KSTEPS=0 if (.NOT. STIFF) go to 310 ! ! PROBLEM APPEARS TO BE STIFF IDID=-4 STIFF= .FALSE. KLE4=0 ! 310 DO 320 L = 1,NEQ Y(L) = YY(L) 320 YPOUT(L) = YP(L) T = X TOLD = T INFO(1) = -1 INTOUT = .FALSE. return ! !....................................................................... ! ! LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP ! 330 HA = ABS(H) if (INFO(4) /= 1) go to 340 HA = MIN(HA,ABS(TSTOP-X)) 340 H = SIGN(HA,H) EPS = 1.0D0 LTOL = 1 DO 350 L = 1,NEQ if (INFO(2) == 1) LTOL = L WT(L) = RTOL(LTOL)*ABS(YY(L)) + ATOL(LTOL) if (WT(L) <= 0.0D0) go to 360 350 CONTINUE go to 380 ! ! RELATIVE ERROR CRITERION INAPPROPRIATE 360 IDID = -3 DO 370 L = 1,NEQ Y(L) = YY(L) 370 YPOUT(L) = YP(L) T = X TOLD = T INFO(1) = -1 INTOUT = .FALSE. return ! 380 call DSTEPS(DF,NEQ,YY,X,H,EPS,WT,START,HOLD,KORD,KOLD,CRASH,PHI,P, & YP,PSI,ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND,KSTEPS, & TWOU,FOURU,XOLD,KPREV,IVC,IV,KGI,GI,RPAR,IPAR) ! !....................................................................... ! if ( .NOT.CRASH) go to 420 ! ! TOLERANCES TOO SMALL IDID = -2 RTOL(1) = EPS*RTOL(1) ATOL(1) = EPS*ATOL(1) if (INFO(2) == 0) go to 400 DO 390 L = 2,NEQ RTOL(L) = EPS*RTOL(L) 390 ATOL(L) = EPS*ATOL(L) 400 DO 410 L = 1,NEQ Y(L) = YY(L) 410 YPOUT(L) = YP(L) T = X TOLD = T INFO(1) = -1 INTOUT = .FALSE. return ! ! (STIFFNESS TEST) COUNT NUMBER OF CONSECUTIVE STEPS TAKEN WITH THE ! ORDER OF THE METHOD BEING LESS OR EQUAL TO FOUR ! 420 KLE4 = KLE4 + 1 if ( KOLD > 4) KLE4 = 0 if ( KLE4 >= 50) STIFF = .TRUE. INTOUT = .TRUE. go to 250 end subroutine DDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, UROUND, USERS, & Y, YWT, H, MNTOLD, MTROLD, NFE, RC, YH, A, CONVRG, EL, FAC, & IER, IPVT, NQ, NWAIT, RH, RMAX, SAVE2, TQ, TREND, ISWFLG, & JSTATE) ! !! DDNTL sets parameters on the first call to DDSTP, on an internal restart, ... ! or when the user has altered MINT, MITER, and/or H. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE DOUBLE PRECISION (SDNTL-S, DDNTL-D, CDNTL-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! On the first call, the order is set to 1 and the initial derivatives ! are calculated. RMAX is the maximum ratio by which H can be ! increased in one step. It is initially RMINIT to compensate ! for the small initial H, but then is normally equal to RMNORM. ! If a failure occurs (in corrector convergence or error test), RMAX ! is set at RMFAIL for the next increase. ! If the caller has changed MINT, or if JTASK = 0, DDCST is called ! to set the coefficients of the method. If the caller has changed H, ! YH must be rescaled. If H or MINT has been changed, NWAIT is ! reset to NQ + 2 to prevent further increases in H for that many ! steps. Also, RC is reset. RC is the ratio of new to old values of ! the coefficient L(0)*H. If the caller has changed MITER, RC is ! set to 0 to force the partials to be updated, if partials are used. ! !***ROUTINES CALLED DDCST, DDSCL, DGBFA, DGBSL, DGEFA, DGESL, DNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDNTL INTEGER I, IFLAG, IMPL, INFO, ISWFLG, JSTATE, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, MU, N, NDE, NFE, & NQ, NWAIT DOUBLE PRECISION A(MATDIM,*), EL(13,12), EPS, FAC(*), H, HMAX, & HOLD, OLDL0, RC, RH, RMAX, RMINIT, SAVE1(*), SAVE2(*), DNRM2, & SUM, T, TQ(3,12), TREND, UROUND, Y(*), YH(N,*), YWT(*) INTEGER IPVT(*) LOGICAL CONVRG, IER PARAMETER(RMINIT = 10000.D0) !***FIRST EXECUTABLE STATEMENT DDNTL IER = .FALSE. if (JTASK >= 0) THEN if (JTASK == 0) THEN call DDCST (MAXORD, MINT, ISWFLG, EL, TQ) RMAX = RMINIT end if RC = 0.D0 CONVRG = .FALSE. TREND = 1.D0 NQ = 1 NWAIT = 3 call F (N, T, Y, SAVE2) if (N == 0) THEN JSTATE = 6 return end if NFE = NFE + 1 if (IMPL /= 0) THEN if (MITER == 3) THEN IFLAG = 0 call USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, IMPL, N, & NDE, IFLAG) if (IFLAG == -1) THEN IER = .TRUE. return end if if (N == 0) THEN JSTATE = 10 return end if ELSE if (IMPL == 1) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call DGEFA (A, MATDIM, N, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call DGESL (A, MATDIM, N, IPVT, SAVE2, 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call DGBFA (A, MATDIM, N, ML, MU, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call DGBSL (A, MATDIM, N, ML, MU, IPVT, SAVE2, 0) end if ELSE if (IMPL == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 150 I = 1,NDE if (A(I,1) == 0.D0) THEN IER = .TRUE. return ELSE SAVE2(I) = SAVE2(I)/A(I,1) end if 150 CONTINUE DO 155 I = NDE+1,N 155 A(I,1) = 0.D0 ELSE if (IMPL == 3) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call DGEFA (A, MATDIM, NDE, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call DGESL (A, MATDIM, NDE, IPVT, SAVE2, 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call DGBFA (A, MATDIM, NDE, ML, MU, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call DGBSL (A, MATDIM, NDE, ML, MU, IPVT, SAVE2, 0) end if end if end if DO 170 I = 1,NDE 170 SAVE1(I) = SAVE2(I)/MAX(1.D0, YWT(I)) SUM = DNRM2(NDE, SAVE1, 1)/SQRT(DBLE(NDE)) if (SUM > EPS/ABS(H)) H = SIGN(EPS/SUM, H) DO 180 I = 1,N 180 YH(I,2) = H*SAVE2(I) if (MITER == 2 .OR. MITER == 5 .OR. ISWFLG == 3) THEN DO 20 I = 1,N 20 FAC(I) = SQRT(UROUND) end if ELSE if (MITER /= MTROLD) THEN MTROLD = MITER RC = 0.D0 CONVRG = .FALSE. end if if (MINT /= MNTOLD) THEN MNTOLD = MINT OLDL0 = EL(1,NQ) call DDCST (MAXORD, MINT, ISWFLG, EL, TQ) RC = RC*EL(1,NQ)/OLDL0 NWAIT = NQ + 2 end if if (H /= HOLD) THEN NWAIT = NQ + 2 RH = H/HOLD call DDSCL (HMAX, N, NQ, RMAX, HOLD, RC, RH, YH) end if end if return end subroutine DDNTP (H, K, N, NQ, T, TOUT, YH, Y) ! !! DDNTP interpolates the K-th derivative of Y at TOUT, using the data ... ! in the YH array. If K has a value greater than NQ, the NQ-th derivative ... ! is calculated. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE DOUBLE PRECISION (SDNTP-S, DDNTP-D, CDNTP-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDNTP INTEGER I, J, JJ, K, KK, KUSED, N, NQ DOUBLE PRECISION FACTOR, H, R, T, TOUT, Y(*), YH(N,*) !***FIRST EXECUTABLE STATEMENT DDNTP if (K == 0) THEN DO 10 I = 1,N 10 Y(I) = YH(I,NQ+1) R = ((TOUT - T)/H) DO 20 JJ = 1,NQ J = NQ + 1 - JJ DO 20 I = 1,N 20 Y(I) = YH(I,J) + R*Y(I) ELSE KUSED = MIN(K, NQ) FACTOR = 1.D0 DO 40 KK = 1,KUSED 40 FACTOR = FACTOR*(NQ+1-KK) DO 50 I = 1,N 50 Y(I) = FACTOR*YH(I,NQ+1) R = ((TOUT - T)/H) DO 80 JJ = KUSED+1,NQ J = KUSED + 1 + NQ - JJ FACTOR = 1.D0 DO 60 KK = 1,KUSED 60 FACTOR = FACTOR*(J-KK) DO 70 I = 1,N 70 Y(I) = FACTOR*YH(I,J) + R*Y(I) 80 CONTINUE DO 100 I = 1,N 100 Y(I) = Y(I)*H**(-KUSED) end if return end subroutine DDOGLG (N, R, LR, DIAG, QTB, DELTA, X, WA1, WA2) ! !! DDOGLG is subsidiary to DNSQ and DNSQE. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (DOGLEG-S, DDOGLG-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an M by N matrix A, an N by N nonsingular diagonal ! matrix D, an M-vector B, and a positive number DELTA, the ! problem is to determine the convex combination X of the ! Gauss-Newton and scaled gradient directions that minimizes ! (A*X - B) in the least squares sense, subject to the ! restriction that the Euclidean norm of D*X be at most DELTA. ! ! This subroutine completes the solution of the problem ! if it is provided with the necessary information from the ! QR factorization of A. That is, if A = Q*R, where Q has ! orthogonal columns and R is an upper triangular matrix, ! then DDOGLG expects the full upper triangle of R and ! the first N components of (Q transpose)*B. ! ! The subroutine statement is ! ! SUBROUTINE DDOGLG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) ! ! where ! ! N is a positive integer input variable set to the order of R. ! ! R is an input array of length LR which must contain the upper ! triangular matrix R stored by rows. ! ! LR is a positive integer input variable not less than ! (N*(N+1))/2. ! ! DIAG is an input array of length N which must contain the ! diagonal elements of the matrix D. ! ! QTB is an input array of length N which must contain the first ! N elements of the vector (Q transpose)*B. ! ! DELTA is a positive input variable which specifies an upper ! bound on the Euclidean norm of D*X. ! ! X is an output array of length N which contains the desired ! convex combination of the Gauss-Newton direction and the ! scaled gradient direction. ! ! WA1 and WA2 are work arrays of length N. ! !***SEE ALSO DNSQ, DNSQE !***ROUTINES CALLED D1MACH, DENORM !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DDOGLG DOUBLE PRECISION D1MACH,DENORM INTEGER I, J, JJ, JP1, K, L, LR, N DOUBLE PRECISION ALPHA, BNORM, DELTA, DIAG(*), EPSMCH, GNORM, & ONE, QNORM, QTB(*), R(*), SGNORM, SUM, TEMP, WA1(*), & WA2(*), X(*), ZERO SAVE ONE, ZERO DATA ONE,ZERO /1.0D0,0.0D0/ ! ! EPSMCH IS THE MACHINE PRECISION. ! !***FIRST EXECUTABLE STATEMENT DDOGLG EPSMCH = D1MACH(4) ! ! FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION. ! 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 = ZERO if (N < 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 /= ZERO) go to 40 L = J DO 30 I = 1, J TEMP = MAX(TEMP,ABS(R(L))) L = L + N - I 30 CONTINUE TEMP = EPSMCH*TEMP if (TEMP == ZERO) TEMP = EPSMCH 40 CONTINUE X(J) = (QTB(J) - SUM)/TEMP 50 CONTINUE ! ! TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE. ! DO 60 J = 1, N WA1(J) = ZERO WA2(J) = DIAG(J)*X(J) 60 CONTINUE QNORM = DENORM(N,WA2) if (QNORM <= DELTA) go to 140 ! ! THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE. ! NEXT, CALCULATE THE SCALED GRADIENT DIRECTION. ! 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 ! ! CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR ! THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO. ! GNORM = DENORM(N,WA1) SGNORM = ZERO ALPHA = DELTA/QNORM if (GNORM == ZERO) go to 120 ! ! CALCULATE THE POINT ALONG THE SCALED GRADIENT ! AT WHICH THE QUADRATIC IS MINIMIZED. ! DO 90 J = 1, N WA1(J) = (WA1(J)/GNORM)/DIAG(J) 90 CONTINUE L = 1 DO 110 J = 1, N SUM = ZERO DO 100 I = J, N SUM = SUM + R(L)*WA1(I) L = L + 1 100 CONTINUE WA2(J) = SUM 110 CONTINUE TEMP = DENORM(N,WA2) SGNORM = (GNORM/TEMP)/TEMP ! ! TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE. ! ALPHA = ZERO if (SGNORM >= DELTA) go to 120 ! ! THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE. ! FINALLY, CALCULATE THE POINT ALONG THE DOGLEG ! AT WHICH THE QUADRATIC IS MINIMIZED. ! BNORM = DENORM(N,QTB) TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA) TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 & + SQRT((TEMP-(DELTA/QNORM))**2 & +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2)) ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP 120 CONTINUE ! ! FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON ! DIRECTION AND THE SCALED GRADIENT DIRECTION. ! TEMP = (ONE - ALPHA)*MIN(SGNORM,DELTA) DO 130 J = 1, N X(J) = TEMP*WA1(J) + ALPHA*X(J) 130 CONTINUE 140 CONTINUE return ! ! LAST CARD OF SUBROUTINE DDOGLG. ! end DOUBLE PRECISION FUNCTION DDOT (N, DX, INCX, DY, INCY) ! !! DDOT computes the inner product of two vectors. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A4 !***TYPE DOUBLE PRECISION (SDOT-S, DDOT-D, CDOTU-C) !***KEYWORDS BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! DY double precision vector with N elements ! INCY storage spacing between elements of DY ! ! --Output-- ! DDOT double precision dot product (zero if N <= 0) ! ! Returns the dot product of double precision DX and DY. ! DDOT = sum for I = 0 to N-1 of DX(LX+I*INCX) * DY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DDOT DOUBLE PRECISION DX(*), DY(*) !***FIRST EXECUTABLE STATEMENT DDOT DDOT = 0.0D0 if (N <= 0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IX = 1 IY = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N DDOT = DDOT + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE return ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 5. ! 20 M = MOD(N,5) if (M == 0) go to 40 DO 30 I = 1,M DDOT = DDOT + DX(I)*DY(I) 30 CONTINUE if (N < 5) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DDOT = DDOT + 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 return ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX DDOT = DDOT + DX(I)*DY(I) 70 CONTINUE return end subroutine DDPSC (KSGN, N, NQ, YH) ! !! DDPSC computes the predicted YH values by effectively multiplying ... ! the YH array by the Pascal triangle matrix when KSGN is +1, and ... ! performs the inverse function when KSGN is -1. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE DOUBLE PRECISION (SDPSC-S, DDPSC-D, CDPSC-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDPSC INTEGER I, J, J1, J2, KSGN, N, NQ DOUBLE PRECISION YH(N,*) !***FIRST EXECUTABLE STATEMENT DDPSC if (KSGN > 0) THEN DO 10 J1 = 1,NQ DO 10 J2 = J1,NQ J = NQ - J2 + J1 DO 10 I = 1,N 10 YH(I,J) = YH(I,J) + YH(I,J+1) ELSE DO 30 J1 = 1,NQ DO 30 J2 = J1,NQ J = NQ - J2 + J1 DO 30 I = 1,N 30 YH(I,J) = YH(I,J) - YH(I,J+1) end if return end subroutine DDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, & MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, NFE, NJE, & A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, BND, JSTATE) ! !! DDPST evaluates the Jacobian matrix of the right hand side of the ... ! differential equations. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE DOUBLE PRECISION (SDPST-S, DDPST-D, CDPST-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! If MITER is 1, 2, 4, or 5, the matrix ! P = I - L(0)*H*Jacobian is stored in DFDY and subjected to LU ! decomposition, with the results also stored in DFDY. ! !***ROUTINES CALLED DGBFA, DGEFA, DNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDPST INTEGER I, IFLAG, IMAX, IMPL, INFO, ISWFLG, J, J2, JSTATE, K, & MATDIM, MITER, ML, MU, MW, N, NDE, NFE, NJE, NQ DOUBLE PRECISION A(MATDIM,*), BL, BND, BP, BR, BU, DFDY(MATDIM,*), & DFDYMX, DIFF, DY, EL(13,12), FAC(*), FACMAX, FACMIN, FACTOR, & H, SAVE1(*), SAVE2(*), SCALE, DNRM2, T, UROUND, Y(*), & YH(N,*), YJ, YS, YWT(*) INTEGER IPVT(*) LOGICAL IER PARAMETER(FACMAX = .5D0, BU = 0.5D0) !***FIRST EXECUTABLE STATEMENT DDPST NJE = NJE + 1 IER = .FALSE. if (MITER == 1 .OR. MITER == 2) THEN if (MITER == 1) THEN call JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) if (N == 0) THEN JSTATE = 8 return end if if (ISWFLG == 3) BND = DNRM2(N*N, DFDY, 1) FACTOR = -EL(1,NQ)*H DO 110 J = 1,N DO 110 I = 1,N 110 DFDY(I,J) = FACTOR*DFDY(I,J) ELSE if (MITER == 2) THEN BR = UROUND**(.875D0) BL = UROUND**(.75D0) BP = UROUND**(-.15D0) FACMIN = UROUND**(.78D0) DO 170 J = 1,N YS = MAX(ABS(YWT(J)), ABS(Y(J))) 120 DY = FAC(J)*YS if (DY == 0.D0) THEN if (FAC(J) < FACMAX) THEN FAC(J) = MIN(100.D0*FAC(J), FACMAX) go to 120 ELSE DY = YS end if end if if (NQ == 1) THEN DY = SIGN(DY, SAVE2(J)) ELSE DY = SIGN(DY, YH(J,3)) end if DY = (Y(J) + DY) - Y(J) YJ = Y(J) Y(J) = Y(J) + DY call F (N, T, Y, SAVE1) if (N == 0) THEN JSTATE = 6 return end if Y(J) = YJ FACTOR = -EL(1,NQ)*H/DY DO 140 I = 1,N 140 DFDY(I,J) = (SAVE1(I) - SAVE2(I))*FACTOR ! Step 1 DIFF = ABS(SAVE2(1) - SAVE1(1)) IMAX = 1 DO 150 I = 2,N if (ABS(SAVE2(I) - SAVE1(I)) > DIFF) THEN IMAX = I DIFF = ABS(SAVE2(I) - SAVE1(I)) end if 150 CONTINUE ! Step 2 if (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) > 0.D0) THEN SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) ! Step 3 if (DIFF > BU*SCALE) THEN FAC(J) = MAX(FACMIN, FAC(J)*.5D0) ELSE if (BR*SCALE <= DIFF .AND. DIFF <= BL*SCALE) THEN FAC(J) = MIN(FAC(J)*2.D0, FACMAX) ! Step 4 ELSE if (DIFF < BR*SCALE) THEN FAC(J) = MIN(BP*FAC(J), FACMAX) end if end if 170 CONTINUE if (ISWFLG == 3) BND = DNRM2(N*N, DFDY, 1)/(-EL(1,NQ)*H) NFE = NFE + N end if if (IMPL == 0) THEN DO 190 I = 1,N 190 DFDY(I,I) = DFDY(I,I) + 1.D0 ELSE if (IMPL == 1) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 210 J = 1,N DO 210 I = 1,N 210 DFDY(I,J) = DFDY(I,J) + A(I,J) ELSE if (IMPL == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 230 I = 1,NDE 230 DFDY(I,I) = DFDY(I,I) + A(I,1) ELSE if (IMPL == 3) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 220 J = 1,NDE DO 220 I = 1,NDE 220 DFDY(I,J) = DFDY(I,J) + A(I,J) end if call DGEFA (DFDY, MATDIM, N, IPVT, INFO) if (INFO /= 0) IER = .TRUE. ELSE if (MITER == 4 .OR. MITER == 5) THEN if (MITER == 4) THEN call JACOBN (N, T, Y, DFDY(ML+1,1), MATDIM, ML, MU) if (N == 0) THEN JSTATE = 8 return end if FACTOR = -EL(1,NQ)*H MW = ML + MU + 1 DO 260 J = 1,N DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) 260 DFDY(I,J) = FACTOR*DFDY(I,J) ELSE if (MITER == 5) THEN BR = UROUND**(.875D0) BL = UROUND**(.75D0) BP = UROUND**(-.15D0) FACMIN = UROUND**(.78D0) MW = ML + MU + 1 J2 = MIN(MW, N) DO 340 J = 1,J2 DO 290 K = J,N,MW YS = MAX(ABS(YWT(K)), ABS(Y(K))) 280 DY = FAC(K)*YS if (DY == 0.D0) THEN if (FAC(K) < FACMAX) THEN FAC(K) = MIN(100.D0*FAC(K), FACMAX) go to 280 ELSE DY = YS end if end if if (NQ == 1) THEN DY = SIGN(DY, SAVE2(K)) ELSE DY = SIGN(DY, YH(K,3)) end if DY = (Y(K) + DY) - Y(K) DFDY(MW,K) = Y(K) 290 Y(K) = Y(K) + DY call F (N, T, Y, SAVE1) if (N == 0) THEN JSTATE = 6 return end if DO 330 K = J,N,MW Y(K) = DFDY(MW,K) YS = MAX(ABS(YWT(K)), ABS(Y(K))) DY = FAC(K)*YS if (DY == 0.D0) DY = YS if (NQ == 1) THEN DY = SIGN(DY, SAVE2(K)) ELSE DY = SIGN(DY, YH(K,3)) end if DY = (Y(K) + DY) - Y(K) FACTOR = -EL(1,NQ)*H/DY DO 300 I = MAX(ML+1, MW+1-K), MIN(MW+N-K, MW+ML) 300 DFDY(I,K) = FACTOR*(SAVE1(I+K-MW) - SAVE2(I+K-MW)) ! Step 1 IMAX = MAX(1, K - MU) DIFF = ABS(SAVE2(IMAX) - SAVE1(IMAX)) DO 310 I = MAX(1, K - MU)+1, MIN(K + ML, N) if (ABS(SAVE2(I) - SAVE1(I)) > DIFF) THEN IMAX = I DIFF = ABS(SAVE2(I) - SAVE1(I)) end if 310 CONTINUE ! Step 2 if (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) > 0.D0) THEN SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) ! Step 3 if (DIFF > BU*SCALE) THEN FAC(J) = MAX(FACMIN, FAC(J)*.5D0) ELSE if (BR*SCALE <= DIFF .AND. DIFF <= BL*SCALE) THEN FAC(J) = MIN(FAC(J)*2.D0, FACMAX) ! Step 4 ELSE if (DIFF < BR*SCALE) THEN FAC(K) = MIN(BP*FAC(K), FACMAX) end if end if 330 CONTINUE 340 CONTINUE NFE = NFE + J2 end if if (ISWFLG == 3) THEN DFDYMX = 0.D0 DO 345 J = 1,N DO 345 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) 345 DFDYMX = MAX(DFDYMX, ABS(DFDY(I,J))) BND = 0.D0 if (DFDYMX /= 0.D0) THEN DO 350 J = 1,N DO 350 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) 350 BND = BND + (DFDY(I,J)/DFDYMX)**2 BND = DFDYMX*SQRT(BND)/(-EL(1,NQ)*H) end if end if if (IMPL == 0) THEN DO 360 J = 1,N 360 DFDY(MW,J) = DFDY(MW,J) + 1.D0 ELSE if (IMPL == 1) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 380 J = 1,N DO 380 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) 380 DFDY(I,J) = DFDY(I,J) + A(I,J) ELSE if (IMPL == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 400 J = 1,NDE 400 DFDY(MW,J) = DFDY(MW,J) + A(J,1) ELSE if (IMPL == 3) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 390 J = 1,NDE DO 390 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) 390 DFDY(I,J) = DFDY(I,J) + A(I,J) end if call DGBFA (DFDY, MATDIM, N, ML, MU, IPVT, INFO) if (INFO /= 0) IER = .TRUE. ELSE if (MITER == 3) THEN IFLAG = 1 call USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, & N, NDE, IFLAG) if (IFLAG == -1) THEN IER = .TRUE. return end if if (N == 0) THEN JSTATE = 10 return end if end if return end subroutine DDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, & IERFLG) ! !! DDRIV1 solves N (200 or fewer) ordinary differential equations ... ! of the form dY(I)/dT = F(Y(I),T), given the initial conditions ! Y(I) = YI. DDRIV1 uses double precision arithmetic. ! !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE DOUBLE PRECISION (SDRIV1-S, DDRIV1-D, CDRIV1-C) !***KEYWORDS DOUBLE PRECISION, GEAR'S METHOD, INITIAL VALUE PROBLEMS, ! ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! Version 92.1 ! ! I. CHOOSING THE CORRECT ROUTINE ................................... ! ! SDRIV ! DDRIV ! CDRIV ! These are the generic names for three packages for solving ! initial value problems for ordinary differential equations. ! SDRIV uses single precision arithmetic. DDRIV uses double ! precision arithmetic. CDRIV allows complex-valued ! differential equations, integrated with respect to a single, ! real, independent variable. ! ! As an aid in selecting the proper program, the following is a ! discussion of the important options or restrictions associated with ! each program: ! ! A. DDRIV1 should be tried first for those routine problems with ! no more than 200 differential equations (DDRIV2 and DDRIV3 ! have no such restriction.) Internally this routine has two ! important technical defaults: ! 1. Numerical approximation of the Jacobian matrix of the ! right hand side is used. ! 2. The stiff solver option is used. ! Most users of DDRIV1 should not have to concern themselves ! with these details. ! ! B. DDRIV2 should be considered for those problems for which ! DDRIV1 is inadequate. For example, DDRIV1 may have difficulty ! with problems having zero initial conditions and zero ! derivatives. In this case DDRIV2, with an appropriate value ! of the parameter EWT, should perform more efficiently. DDRIV2 ! provides three important additional options: ! 1. The nonstiff equation solver (as well as the stiff ! solver) is available. ! 2. The root-finding option is available. ! 3. The program can dynamically select either the non-stiff ! or the stiff methods. ! Internally this routine also defaults to the numerical ! approximation of the Jacobian matrix of the right hand side. ! ! C. DDRIV3 is the most flexible, and hence the most complex, of ! the programs. Its important additional features include: ! 1. The ability to exploit band structure in the Jacobian ! matrix. ! 2. The ability to solve some implicit differential ! equations, i.e., those having the form: ! A(Y,T)*dY/dT = F(Y,T). ! 3. The option of integrating in the one step mode. ! 4. The option of allowing the user to provide a routine ! which computes the analytic Jacobian matrix of the right ! hand side. ! 5. The option of allowing the user to provide a routine ! which does all the matrix algebra associated with ! corrections to the solution components. ! ! II. PARAMETERS .................................................... ! ! (REMEMBER--To run DDRIV1 correctly in double precision, ALL ! non-integer arguments in the call sequence, including ! arrays, MUST be declared double precision.) ! ! The user should use parameter names in the call sequence of DDRIV1 ! for those quantities whose value may be altered by DDRIV1. The ! parameters in the call sequence are: ! ! N = (Input) The number of differential equations, N <= 200 ! ! T = The independent variable. On input for the first call, T ! is the initial point. On output, T is the point at which ! the solution is given. ! ! Y = The vector of dependent variables. Y is used as input on ! the first call, to set the initial values. On output, Y ! is the computed solution vector. This array Y is passed ! in the call sequence of the user-provided routine F. Thus ! parameters required by F can be stored in this array in ! components N+1 and above. (Note: Changes by the user to ! the first N components of this array will take effect only ! after a restart, i.e., after setting MSTATE to +1(-1).) ! ! F = A subroutine supplied by the user. The name must be ! declared EXTERNAL in the user's calling program. This ! subroutine is of the form: ! SUBROUTINE F (N, T, Y, YDOT) ! DOUBLE PRECISION Y(*), YDOT(*) ! . ! . ! YDOT(1) = ... ! . ! . ! YDOT(N) = ... ! END (Sample) ! This computes YDOT = F(Y,T), the right hand side of the ! differential equations. Here Y is a vector of length at ! least N. The actual length of Y is determined by the ! user's declaration in the program which calls DDRIV1. ! Thus the dimensioning of Y in F, while required by FORTRAN ! convention, does not actually allocate any storage. When ! this subroutine is called, the first N components of Y are ! intermediate approximations to the solution components. ! The user should not alter these values. Here YDOT is a ! vector of length N. The user should only compute YDOT(I) ! for I from 1 to N. Normally a return from F passes ! control back to DDRIV1. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls DDRIV1, he should set N to zero. ! DDRIV1 will signal this by returning a value of MSTATE ! equal to +5(-5). Altering the value of N in F has no ! effect on the value of N in the call sequence of DDRIV1. ! ! TOUT = (Input) The point at which the solution is desired. ! ! MSTATE = An integer describing the status of integration. The user ! must initialize MSTATE to +1 or -1. If MSTATE is ! positive, the routine will integrate past TOUT and ! interpolate the solution. This is the most efficient ! mode. If MSTATE is negative, the routine will adjust its ! internal step to reach TOUT exactly (useful if a ! singularity exists beyond TOUT.) The meaning of the ! magnitude of MSTATE: ! 1 (Input) Means the first call to the routine. This ! value must be set by the user. On all subsequent ! calls the value of MSTATE should be tested by the ! user. Unless DDRIV1 is to be reinitialized, only the ! sign of MSTATE may be changed by the user. (As a ! convenience to the user who may wish to put out the ! initial conditions, DDRIV1 can be called with ! MSTATE=+1(-1), and TOUT=T. In this case the program ! will return with MSTATE unchanged, i.e., ! MSTATE=+1(-1).) ! 2 (Output) Means a successful integration. If a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance TOUT and call ! again. All other parameters are automatically set. ! 3 (Output)(Unsuccessful) Means the integrator has taken ! 1000 steps without reaching TOUT. The user can ! continue the integration by simply calling DDRIV1 ! again. ! 4 (Output)(Unsuccessful) Means too much accuracy has ! been requested. EPS has been increased to a value ! the program estimates is appropriate. The user can ! continue the integration by simply calling DDRIV1 ! again. ! 5 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE F. ! 6 (Output)(Successful) For MSTATE negative, T is beyond ! TOUT. The solution was obtained by interpolation. ! The user can continue the integration by simply ! advancing TOUT and calling DDRIV1 again. ! 7 (Output)(Unsuccessful) The solution could not be ! obtained. The value of IERFLG (see description ! below) for a "Recoverable" situation indicates the ! type of difficulty encountered: either an illegal ! value for a parameter or an inability to continue the ! solution. For this condition the user should take ! corrective action and reset MSTATE to +1(-1) before ! calling DDRIV1 again. Otherwise the program will ! terminate the run. ! ! EPS = On input, the requested relative accuracy in all solution ! components. On output, the adjusted relative accuracy if ! the input value was too small. The value of EPS should be ! set as large as is reasonable, because the amount of work ! done by DDRIV1 increases as EPS decreases. ! ! WORK ! LENW = (Input) ! WORK is an array of LENW double precision words used ! internally for temporary storage. The user must allocate ! space for this array in the calling program by a statement ! such as ! DOUBLE PRECISION WORK(...) ! The length of WORK should be at least N*N + 11*N + 300 ! and LENW should be set to the value used. The contents of ! WORK should not be disturbed between calls to DDRIV1. ! ! IERFLG = An error flag. The error number associated with a ! diagnostic message (see Section IV-A below) is the same as ! the corresponding value of IERFLG. The meaning of IERFLG: ! 0 The routine completed successfully. (No message is ! issued.) ! 3 (Warning) The number of steps required to reach TOUT ! exceeds 1000 . ! 4 (Warning) The value of EPS is too small. ! 11 (Warning) For MSTATE negative, T is beyond TOUT. ! The solution was obtained by interpolation. ! 15 (Warning) The integration step size is below the ! roundoff level of T. (The program issues this ! message as a warning but does not return control to ! the user.) ! 21 (Recoverable) N is greater than 200 . ! 22 (Recoverable) N is not positive. ! 26 (Recoverable) The magnitude of MSTATE is either 0 or ! greater than 7 . ! 27 (Recoverable) EPS is less than zero. ! 32 (Recoverable) Insufficient storage has been allocated ! for the WORK array. ! 41 (Recoverable) The integration step size has gone ! to zero. ! 42 (Recoverable) The integration step size has been ! reduced about 50 times without advancing the ! solution. The problem setup may not be correct. ! 999 (Fatal) The magnitude of MSTATE is 7 . ! ! III. USAGE ........................................................ ! ! PROGRAM SAMPLE ! EXTERNAL F ! DOUBLE PRECISION ALFA, EPS, T, TOUT ! C N is the number of equations ! PARAMETER(ALFA = 1.D0, N = 3, LENW = N*N + 11*N + 300) ! DOUBLE PRECISION WORK(LENW), Y(N+1) ! C Initial point ! T = 0.00001D0 ! C Set initial conditions ! Y(1) = 10.D0 ! Y(2) = 0.D0 ! Y(3) = 10.D0 ! C Pass parameter ! Y(4) = ALFA ! TOUT = T ! MSTATE = 1 ! EPS = .001D0 ! 10 call DDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, ! 8 IERFLG) ! if (MSTATE > 2) STOP ! WRITE(*, '(4E12.3)') TOUT, (Y(I), I=1,3) ! TOUT = 10.D0*TOUT ! if (TOUT < 50.D0) go to 10 ! END ! ! SUBROUTINE F (N, T, Y, YDOT) ! DOUBLE PRECISION ALFA, T, Y(*), YDOT(*) ! ALFA = Y(N+1) ! YDOT(1) = 1.D0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) ! YDOT(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) ! YDOT(3) = 1.D0 - Y(3)*(Y(1) + Y(2)) ! END ! ! IV. OTHER COMMUNICATION TO THE USER ............................... ! ! A. The solver communicates to the user through the parameters ! above. In addition it writes diagnostic messages through the ! standard error handling program XERMSG. A complete description ! of XERMSG is given in "Guide to the SLATEC Common Mathematical ! Library" by Kirby W. Fong et al.. At installations which do not ! have this error handling package the short but serviceable ! routine, XERMSG, available with this package, can be used. That ! program uses the file named OUTPUT to transmit messages. ! ! B. The number of evaluations of the right hand side can be found ! in the WORK array in the location determined by: ! LENW - (N + 50) + 4 ! ! V. REMARKS ........................................................ ! ! For other information, see Section IV of the writeup for DDRIV3. ! !***REFERENCES C. W. Gear, Numerical Initial Value Problems in ! Ordinary Differential Equations, Prentice-Hall, 1971. !***ROUTINES CALLED DDRIV3, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDRIV1 EXTERNAL F DOUBLE PRECISION EPS, EWTCOM(1), HMAX, T, TOUT, WORK(*), Y(*) INTEGER I, IDLIW, IERFLG, IERROR, IMPL, LENIW, LENW, LENWCM, & LNWCHK, MINT, MITER, ML, MSTATE, MU, MXN, MXORD, MXSTEP, & N, NDE, NROOT, NSTATE, NTASK PARAMETER(MXN = 200, IDLIW = 50) INTEGER IWORK(IDLIW+MXN) CHARACTER INTGR1*8 PARAMETER(NROOT = 0, IERROR = 2, MINT = 2, MITER = 2, IMPL = 0, & MXORD = 5, MXSTEP = 1000) DATA EWTCOM(1) /1.D0/ !***FIRST EXECUTABLE STATEMENT DDRIV1 if (ABS(MSTATE) == 0 .OR. ABS(MSTATE) > 7) THEN WRITE(INTGR1, '(I8)') MSTATE IERFLG = 26 call XERMSG('SLATEC', 'DDRIV1', & 'Illegal input. The magnitude of MSTATE, '//INTGR1// & ', is not in the range 1 to 6 .', IERFLG, 1) MSTATE = SIGN(7, MSTATE) return ELSE if (ABS(MSTATE) == 7) THEN IERFLG = 999 call XERMSG('SLATEC', 'DDRIV1', & 'Illegal input. The magnitude of MSTATE is 7 .', IERFLG, 2) return end if if (N > MXN) THEN WRITE(INTGR1, '(I8)') N IERFLG = 21 call XERMSG('SLATEC', 'DDRIV1', & 'Illegal input. The number of equations, '//INTGR1// & ', is greater than the maximum allowed: 200 .', IERFLG, 1) MSTATE = SIGN(7, MSTATE) return end if if (MSTATE > 0) THEN NSTATE = MSTATE NTASK = 1 ELSE NSTATE = - MSTATE NTASK = 3 end if HMAX = 2.D0*ABS(TOUT - T) LENIW = N + IDLIW LENWCM = LENW - LENIW if (LENWCM < (N*N + 10*N + 250)) THEN LNWCHK = N*N + 10*N + 250 + LENIW WRITE(INTGR1, '(I8)') LNWCHK IERFLG = 32 call XERMSG('SLATEC', 'DDRIV1', & 'Insufficient storage allocated for the work array. '// & 'The required storage is at least '//INTGR1//' .', IERFLG, 1) MSTATE = SIGN(7, MSTATE) return end if if (NSTATE /= 1) THEN DO 20 I = 1,LENIW 20 IWORK(I) = WORK(I+LENWCM) end if call DDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, & IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, & LENWCM, IWORK, LENIW, F, F, NDE, MXSTEP, F, F, & IERFLG) DO 40 I = 1,LENIW 40 WORK(I+LENWCM) = IWORK(I) if (NSTATE <= 4) THEN MSTATE = SIGN(NSTATE, MSTATE) ELSE if (NSTATE == 6) THEN MSTATE = SIGN(5, MSTATE) ELSE if (IERFLG == 11) THEN MSTATE = SIGN(6, MSTATE) ELSE if (IERFLG > 11) THEN MSTATE = SIGN(7, MSTATE) end if return end subroutine DDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, & MINT, WORK, LENW, IWORK, LENIW, G, IERFLG) ! !! DDRIV2 solves N ordinary differential equations of the form ... ! dY(I)/dT = F(Y(I),T), given the initial conditions Y(I) = YI. ... ! The program has options to allow the solution of both stiff and ... ! non-stiff differential equations. DDRIV2 uses double precision arithmetic. ! !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE DOUBLE PRECISION (SDRIV2-S, DDRIV2-D, CDRIV2-C) !***KEYWORDS DOUBLE PRECISION, GEAR'S METHOD, INITIAL VALUE PROBLEMS, ! ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! I. PARAMETERS ..................................................... ! ! (REMEMBER--To run DDRIV2 correctly in double precision, ALL ! non-integer arguments in the call sequence, including ! arrays, MUST be declared double precision.) ! ! The user should use parameter names in the call sequence of DDRIV2 ! for those quantities whose value may be altered by DDRIV2. The ! parameters in the call sequence are: ! ! N = (Input) The number of differential equations. ! ! T = The independent variable. On input for the first call, T ! is the initial point. On output, T is the point at which ! the solution is given. ! ! Y = The vector of dependent variables. Y is used as input on ! the first call, to set the initial values. On output, Y ! is the computed solution vector. This array Y is passed ! in the call sequence of the user-provided routines F and ! G. Thus parameters required by F and G can be stored in ! this array in components N+1 and above. (Note: Changes ! by the user to the first N components of this array will ! take effect only after a restart, i.e., after setting ! MSTATE to +1(-1).) ! ! F = A subroutine supplied by the user. The name must be ! declared EXTERNAL in the user's calling program. This ! subroutine is of the form: ! SUBROUTINE F (N, T, Y, YDOT) ! DOUBLE PRECISION Y(*), YDOT(*) ! . ! . ! YDOT(1) = ... ! . ! . ! YDOT(N) = ... ! END (Sample) ! This computes YDOT = F(Y,T), the right hand side of the ! differential equations. Here Y is a vector of length at ! least N. The actual length of Y is determined by the ! user's declaration in the program which calls DDRIV2. ! Thus the dimensioning of Y in F, while required by FORTRAN ! convention, does not actually allocate any storage. When ! this subroutine is called, the first N components of Y are ! intermediate approximations to the solution components. ! The user should not alter these values. Here YDOT is a ! vector of length N. The user should only compute YDOT(I) ! for I from 1 to N. Normally a return from F passes ! control back to DDRIV2. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls DDRIV2, he should set N to zero. ! DDRIV2 will signal this by returning a value of MSTATE ! equal to +6(-6). Altering the value of N in F has no ! effect on the value of N in the call sequence of DDRIV2. ! ! TOUT = (Input) The point at which the solution is desired. ! ! MSTATE = An integer describing the status of integration. The user ! must initialize MSTATE to +1 or -1. If MSTATE is ! positive, the routine will integrate past TOUT and ! interpolate the solution. This is the most efficient ! mode. If MSTATE is negative, the routine will adjust its ! internal step to reach TOUT exactly (useful if a ! singularity exists beyond TOUT.) The meaning of the ! magnitude of MSTATE: ! 1 (Input) Means the first call to the routine. This ! value must be set by the user. On all subsequent ! calls the value of MSTATE should be tested by the ! user. Unless DDRIV2 is to be reinitialized, only the ! sign of MSTATE may be changed by the user. (As a ! convenience to the user who may wish to put out the ! initial conditions, DDRIV2 can be called with ! MSTATE=+1(-1), and TOUT=T. In this case the program ! will return with MSTATE unchanged, i.e., ! MSTATE=+1(-1).) ! 2 (Output) Means a successful integration. If a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance TOUT and call ! again. All other parameters are automatically set. ! 3 (Output)(Unsuccessful) Means the integrator has taken ! 1000 steps without reaching TOUT. The user can ! continue the integration by simply calling DDRIV2 ! again. Other than an error in problem setup, the ! most likely cause for this condition is trying to ! integrate a stiff set of equations with the non-stiff ! integrator option. (See description of MINT below.) ! 4 (Output)(Unsuccessful) Means too much accuracy has ! been requested. EPS has been increased to a value ! the program estimates is appropriate. The user can ! continue the integration by simply calling DDRIV2 ! again. ! 5 (Output) A root was found at a point less than TOUT. ! The user can continue the integration toward TOUT by ! simply calling DDRIV2 again. ! 6 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE F. ! 7 (Output)(Unsuccessful) N has been set to zero in ! FUNCTION G. See description of G below. ! 8 (Output)(Successful) For MSTATE negative, T is beyond ! TOUT. The solution was obtained by interpolation. ! The user can continue the integration by simply ! advancing TOUT and calling DDRIV2 again. ! 9 (Output)(Unsuccessful) The solution could not be ! obtained. The value of IERFLG (see description ! below) for a "Recoverable" situation indicates the ! type of difficulty encountered: either an illegal ! value for a parameter or an inability to continue the ! solution. For this condition the user should take ! corrective action and reset MSTATE to +1(-1) before ! calling DDRIV2 again. Otherwise the program will ! terminate the run. ! ! NROOT = (Input) The number of equations whose roots are desired. ! If NROOT is zero, the root search is not active. This ! option is useful for obtaining output at points which are ! not known in advance, but depend upon the solution, e.g., ! when some solution component takes on a specified value. ! The root search is carried out using the user-written ! function G (see description of G below.) DDRIV2 attempts ! to find the value of T at which one of the equations ! changes sign. DDRIV2 can find at most one root per ! equation per internal integration step, and will then ! return the solution either at TOUT or at a root, whichever ! occurs first in the direction of integration. The initial ! point is never reported as a root. The index of the ! equation whose root is being reported is stored in the ! sixth element of IWORK. ! NOTE: NROOT is never altered by this program. ! ! EPS = On input, the requested relative accuracy in all solution ! components. EPS = 0 is allowed. On output, the adjusted ! relative accuracy if the input value was too small. The ! value of EPS should be set as large as is reasonable, ! because the amount of work done by DDRIV2 increases as ! EPS decreases. ! ! EWT = (Input) Problem zero, i.e., the smallest physically ! meaningful value for the solution. This is used inter- ! nally to compute an array YWT(I) = MAX(ABS(Y(I)), EWT). ! One step error estimates divided by YWT(I) are kept less ! than EPS. Setting EWT to zero provides pure relative ! error control. However, setting EWT smaller than ! necessary can adversely affect the running time. ! ! MINT = (Input) The integration method flag. ! MINT = 1 Means the Adams methods, and is used for ! non-stiff problems. ! MINT = 2 Means the stiff methods of Gear (i.e., the ! backward differentiation formulas), and is ! used for stiff problems. ! MINT = 3 Means the program dynamically selects the ! Adams methods when the problem is non-stiff ! and the Gear methods when the problem is ! stiff. ! MINT may not be changed without restarting, i.e., setting ! the magnitude of MSTATE to 1. ! ! WORK ! LENW = (Input) ! WORK is an array of LENW double precision words used ! internally for temporary storage. The user must allocate ! space for this array in the calling program by a statement ! such as ! DOUBLE PRECISION WORK(...) ! The length of WORK should be at least ! 16*N + 2*NROOT + 250 if MINT is 1, or ! N*N + 10*N + 2*NROOT + 250 if MINT is 2, or ! N*N + 17*N + 2*NROOT + 250 if MINT is 3, ! and LENW should be set to the value used. The contents of ! WORK should not be disturbed between calls to DDRIV2. ! ! IWORK ! LENIW = (Input) ! IWORK is an integer array of length LENIW used internally ! for temporary storage. The user must allocate space for ! this array in the calling program by a statement such as ! INTEGER IWORK(...) ! The length of IWORK should be at least ! 50 if MINT is 1, or ! N+50 if MINT is 2 or 3, ! and LENIW should be set to the value used. The contents ! of IWORK should not be disturbed between calls to DDRIV2. ! ! G = A double precision FORTRAN function supplied by the user ! if NROOT is not 0. In this case, the name must be ! declared EXTERNAL in the user's calling program. G is ! repeatedly called with different values of IROOT to ! obtain the value of each of the NROOT equations for which ! a root is desired. G is of the form: ! DOUBLE PRECISION FUNCTION G (N, T, Y, IROOT) ! DOUBLE PRECISION Y(*) ! go to (10, ...), IROOT ! 10 G = ... ! . ! . ! END (Sample) ! Here, Y is a vector of length at least N, whose first N ! components are the solution components at the point T. ! The user should not alter these values. The actual length ! of Y is determined by the user's declaration in the ! program which calls DDRIV2. Thus the dimensioning of Y in ! G, while required by FORTRAN convention, does not actually ! allocate any storage. Normally a return from G passes ! control back to DDRIV2. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls DDRIV2, he should set N to zero. ! DDRIV2 will signal this by returning a value of MSTATE ! equal to +7(-7). In this case, the index of the equation ! being evaluated is stored in the sixth element of IWORK. ! Altering the value of N in G has no effect on the value of ! N in the call sequence of DDRIV2. ! ! IERFLG = An error flag. The error number associated with a ! diagnostic message (see Section II-A below) is the same as ! the corresponding value of IERFLG. The meaning of IERFLG: ! 0 The routine completed successfully. (No message is ! issued.) ! 3 (Warning) The number of steps required to reach TOUT ! exceeds MXSTEP. ! 4 (Warning) The value of EPS is too small. ! 11 (Warning) For MSTATE negative, T is beyond TOUT. ! The solution was obtained by interpolation. ! 15 (Warning) The integration step size is below the ! roundoff level of T. (The program issues this ! message as a warning but does not return control to ! the user.) ! 22 (Recoverable) N is not positive. ! 23 (Recoverable) MINT is less than 1 or greater than 3 . ! 26 (Recoverable) The magnitude of MSTATE is either 0 or ! greater than 9 . ! 27 (Recoverable) EPS is less than zero. ! 32 (Recoverable) Insufficient storage has been allocated ! for the WORK array. ! 33 (Recoverable) Insufficient storage has been allocated ! for the IWORK array. ! 41 (Recoverable) The integration step size has gone ! to zero. ! 42 (Recoverable) The integration step size has been ! reduced about 50 times without advancing the ! solution. The problem setup may not be correct. ! 999 (Fatal) The magnitude of MSTATE is 9 . ! ! II. OTHER COMMUNICATION TO THE USER ............................... ! ! A. The solver communicates to the user through the parameters ! above. In addition it writes diagnostic messages through the ! standard error handling program XERMSG. A complete description ! of XERMSG is given in "Guide to the SLATEC Common Mathematical ! Library" by Kirby W. Fong et al.. At installations which do not ! have this error handling package the short but serviceable ! routine, XERMSG, available with this package, can be used. That ! program uses the file named OUTPUT to transmit messages. ! ! B. The first three elements of WORK and the first five elements of ! IWORK will contain the following statistical data: ! AVGH The average step size used. ! HUSED The step size last used (successfully). ! AVGORD The average order used. ! IMXERR The index of the element of the solution vector that ! contributed most to the last error test. ! NQUSED The order last used (successfully). ! NSTEP The number of steps taken since last initialization. ! NFE The number of evaluations of the right hand side. ! NJE The number of evaluations of the Jacobian matrix. ! ! III. REMARKS ...................................................... ! ! A. On any return from DDRIV2 all information necessary to continue ! the calculation is contained in the call sequence parameters, ! including the work arrays. Thus it is possible to suspend one ! problem, integrate another, and then return to the first. ! ! B. If this package is to be used in an overlay situation, the user ! must declare in the primary overlay the variables in the call ! sequence to DDRIV2. ! ! C. When the routine G is not required, difficulties associated with ! an unsatisfied external can be avoided by using the name of the ! routine which calculates the right hand side of the differential ! equations in place of G in the call sequence of DDRIV2. ! ! IV. USAGE ......................................................... ! ! PROGRAM SAMPLE ! EXTERNAL F ! PARAMETER(MINT = 1, NROOT = 0, N = ..., ! 8 LENW = 16*N + 2*NROOT + 250, LENIW = 50) ! C N is the number of equations ! DOUBLE PRECISION EPS, EWT, T, TOUT, WORK(LENW), Y(N) ! INTEGER IWORK(LENIW) ! OPEN(FILE='TAPE6', UNIT=6, STATUS='NEW') ! C Initial point ! T = 0. ! C Set initial conditions ! DO 10 I = 1,N ! 10 Y(I) = ... ! TOUT = T ! EWT = ... ! MSTATE = 1 ! EPS = ... ! 20 call DDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, ! 8 MINT, WORK, LENW, IWORK, LENIW, F, IERFLG) ! C Next to last argument is not ! C F if rootfinding is used. ! if (MSTATE > 2) STOP ! WRITE(6, 100) TOUT, (Y(I), I=1,N) ! TOUT = TOUT + 1. ! if (TOUT <= 10.) go to 20 ! 100 FORMAT(...) ! END (Sample) ! !***REFERENCES C. W. Gear, Numerical Initial Value Problems in ! Ordinary Differential Equations, Prentice-Hall, 1971. !***ROUTINES CALLED DDRIV3, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDRIV2 EXTERNAL F, G DOUBLE PRECISION EPS, EWT, EWTCOM(1), G, HMAX, T, TOUT, & WORK(*), Y(*) INTEGER IWORK(*) INTEGER IERFLG, IERROR, IMPL, LENIW, LENW, MINT, MITER, ML, & MSTATE, MU, MXORD, MXSTEP, N, NDE, NROOT, NSTATE, NTASK CHARACTER INTGR1*8 PARAMETER(IMPL = 0, MXSTEP = 1000) !***FIRST EXECUTABLE STATEMENT DDRIV2 if (ABS(MSTATE) == 9) THEN IERFLG = 999 call XERMSG('SLATEC', 'DDRIV2', & 'Illegal input. The magnitude of MSTATE IS 9 .', & IERFLG, 2) return ELSE if (ABS(MSTATE) == 0 .OR. ABS(MSTATE) > 9) THEN WRITE(INTGR1, '(I8)') MSTATE IERFLG = 26 call XERMSG('SLATEC', 'DDRIV2', & 'Illegal input. The magnitude of MSTATE, '//INTGR1// & ' is not in the range 1 to 8 .', IERFLG, 1) MSTATE = SIGN(9, MSTATE) return end if if (MINT < 1 .OR. MINT > 3) THEN WRITE(INTGR1, '(I8)') MINT IERFLG = 23 call XERMSG('SLATEC', 'DDRIV2', & 'Illegal input. Improper value for the integration method '// & 'flag, '//INTGR1//' .', IERFLG, 1) MSTATE = SIGN(9, MSTATE) return end if if (MSTATE >= 0) THEN NSTATE = MSTATE NTASK = 1 ELSE NSTATE = - MSTATE NTASK = 3 end if EWTCOM(1) = EWT if (EWT /= 0.D0) THEN IERROR = 3 ELSE IERROR = 2 end if if (MINT == 1) THEN MITER = 0 MXORD = 12 ELSE if (MINT == 2) THEN MITER = 2 MXORD = 5 ELSE if (MINT == 3) THEN MITER = 2 MXORD = 12 end if HMAX = 2.D0*ABS(TOUT - T) call DDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, & IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, & LENW, IWORK, LENIW, F, F, NDE, MXSTEP, G, F, IERFLG) if (NSTATE <= 7) THEN MSTATE = SIGN(NSTATE, MSTATE) ELSE if (NSTATE == 11) THEN MSTATE = SIGN(8, MSTATE) ELSE if (NSTATE > 11) THEN MSTATE = SIGN(9, MSTATE) end if return end subroutine DDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, & EWT, IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, & LENW, IWORK, LENIW, JACOBN, FA, NDE, MXSTEP, G, USERS, IERFLG) ! !! DDRIV3 solves N ordinary differential equations of the form ... ! dY(I)/dT = F(Y(I),T), given the ! initial conditions Y(I) = YI. The program has options to ! allow the solution of both stiff and non-stiff differential ! equations. Other important options are available. DDRIV3 ! uses double precision arithmetic. !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE DOUBLE PRECISION (SDRIV3-S, DDRIV3-D, CDRIV3-C) !***KEYWORDS DOUBLE PRECISION, GEAR'S METHOD, INITIAL VALUE PROBLEMS, ! ODE, ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, STIFF !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! I. ABSTRACT ....................................................... ! ! The primary function of DDRIV3 is to solve N ordinary differential ! equations of the form dY(I)/dT = F(Y(I),T), given the initial ! conditions Y(I) = YI. The program has options to allow the ! solution of both stiff and non-stiff differential equations. In ! addition, DDRIV3 may be used to solve: ! 1. The initial value problem, A*dY(I)/dT = F(Y(I),T), where A is ! a non-singular matrix depending on Y and T. ! 2. The hybrid differential/algebraic initial value problem, ! A*dY(I)/dT = F(Y(I),T), where A is a vector (whose values may ! depend upon Y and T) some of whose components will be zero ! corresponding to those equations which are algebraic rather ! than differential. ! DDRIV3 is to be called once for each output point of T. ! ! II. PARAMETERS .................................................... ! (REMEMBER--To run DDRIV3 correctly in double precision, ALL ! non-integer arguments in the call sequence, including ! arrays, MUST be declared double precision.) ! ! The user should use parameter names in the call sequence of DDRIV3 ! for those quantities whose value may be altered by DDRIV3. The ! parameters in the call sequence are: ! ! N = (Input) The number of dependent functions whose solution ! is desired. N must not be altered during a problem. ! ! T = The independent variable. On input for the first call, T ! is the initial point. On output, T is the point at which ! the solution is given. ! ! Y = The vector of dependent variables. Y is used as input on ! the first call, to set the initial values. On output, Y ! is the computed solution vector. This array Y is passed ! in the call sequence of the user-provided routines F, ! JACOBN, FA, USERS, and G. Thus parameters required by ! those routines can be stored in this array in components ! N+1 and above. (Note: Changes by the user to the first ! N components of this array will take effect only after a ! restart, i.e., after setting NSTATE to 1 .) ! ! F = A subroutine supplied by the user. The name must be ! declared EXTERNAL in the user's calling program. This ! subroutine is of the form: ! SUBROUTINE F (N, T, Y, YDOT) ! DOUBLE PRECISION Y(*), YDOT(*) ! . ! . ! YDOT(1) = ... ! . ! . ! YDOT(N) = ... ! END (Sample) ! This computes YDOT = F(Y,T), the right hand side of the ! differential equations. Here Y is a vector of length at ! least N. The actual length of Y is determined by the ! user's declaration in the program which calls DDRIV3. ! Thus the dimensioning of Y in F, while required by FORTRAN ! convention, does not actually allocate any storage. When ! this subroutine is called, the first N components of Y are ! intermediate approximations to the solution components. ! The user should not alter these values. Here YDOT is a ! vector of length N. The user should only compute YDOT(I) ! for I from 1 to N. Normally a return from F passes ! control back to DDRIV3. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls DDRIV3, he should set N to zero. ! DDRIV3 will signal this by returning a value of NSTATE ! equal to 6 . Altering the value of N in F has no effect ! on the value of N in the call sequence of DDRIV3. ! ! NSTATE = An integer describing the status of integration. The ! meaning of NSTATE is as follows: ! 1 (Input) Means the first call to the routine. This ! value must be set by the user. On all subsequent ! calls the value of NSTATE should be tested by the ! user, but must not be altered. (As a convenience to ! the user who may wish to put out the initial ! conditions, DDRIV3 can be called with NSTATE=1, and ! TOUT=T. In this case the program will return with ! NSTATE unchanged, i.e., NSTATE=1.) ! 2 (Output) Means a successful integration. If a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance TOUT and call ! again. All other parameters are automatically set. ! 3 (Output)(Unsuccessful) Means the integrator has taken ! MXSTEP steps without reaching TOUT. The user can ! continue the integration by simply calling DDRIV3 ! again. ! 4 (Output)(Unsuccessful) Means too much accuracy has ! been requested. EPS has been increased to a value ! the program estimates is appropriate. The user can ! continue the integration by simply calling DDRIV3 ! again. ! 5 (Output) A root was found at a point less than TOUT. ! The user can continue the integration toward TOUT by ! simply calling DDRIV3 again. ! 6 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE F. ! 7 (Output)(Unsuccessful) N has been set to zero in ! FUNCTION G. See description of G below. ! 8 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE JACOBN. See description of JACOBN below. ! 9 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE FA. See description of FA below. ! 10 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE USERS. See description of USERS below. ! 11 (Output)(Successful) For NTASK = 2 or 3, T is beyond ! TOUT. The solution was obtained by interpolation. ! The user can continue the integration by simply ! advancing TOUT and calling DDRIV3 again. ! 12 (Output)(Unsuccessful) The solution could not be ! obtained. The value of IERFLG (see description ! below) for a "Recoverable" situation indicates the ! type of difficulty encountered: either an illegal ! value for a parameter or an inability to continue the ! solution. For this condition the user should take ! corrective action and reset NSTATE to 1 before ! calling DDRIV3 again. Otherwise the program will ! terminate the run. ! ! TOUT = (Input) The point at which the solution is desired. The ! position of TOUT relative to T on the first call ! determines the direction of integration. ! ! NTASK = (Input) An index specifying the manner of returning the ! solution, according to the following: ! NTASK = 1 Means DDRIV3 will integrate past TOUT and ! interpolate the solution. This is the most ! efficient mode. ! NTASK = 2 Means DDRIV3 will return the solution after ! each internal integration step, or at TOUT, ! whichever comes first. In the latter case, ! the program integrates exactly to TOUT. ! NTASK = 3 Means DDRIV3 will adjust its internal step to ! reach TOUT exactly (useful if a singularity ! exists beyond TOUT.) ! ! NROOT = (Input) The number of equations whose roots are desired. ! If NROOT is zero, the root search is not active. This ! option is useful for obtaining output at points which are ! not known in advance, but depend upon the solution, e.g., ! when some solution component takes on a specified value. ! The root search is carried out using the user-written ! function G (see description of G below.) DDRIV3 attempts ! to find the value of T at which one of the equations ! changes sign. DDRIV3 can find at most one root per ! equation per internal integration step, and will then ! return the solution either at TOUT or at a root, whichever ! occurs first in the direction of integration. The initial ! point is never reported as a root. The index of the ! equation whose root is being reported is stored in the ! sixth element of IWORK. ! NOTE: NROOT is never altered by this program. ! ! EPS = On input, the requested relative accuracy in all solution ! components. EPS = 0 is allowed. On output, the adjusted ! relative accuracy if the input value was too small. The ! value of EPS should be set as large as is reasonable, ! because the amount of work done by DDRIV3 increases as EPS ! decreases. ! ! EWT = (Input) Problem zero, i.e., the smallest, nonzero, ! physically meaningful value for the solution. (Array, ! possibly of length one. See following description of ! IERROR.) Setting EWT smaller than necessary can adversely ! affect the running time. ! ! IERROR = (Input) Error control indicator. A value of 3 is ! suggested for most problems. Other choices and detailed ! explanations of EWT and IERROR are given below for those ! who may need extra flexibility. ! ! These last three input quantities EPS, EWT and IERROR ! control the accuracy of the computed solution. EWT and ! IERROR are used internally to compute an array YWT. One ! step error estimates divided by YWT(I) are kept less than ! EPS in root mean square norm. ! IERROR (Set by the user) = ! 1 Means YWT(I) = 1. (Absolute error control) ! EWT is ignored. ! 2 Means YWT(I) = ABS(Y(I)), (Relative error control) ! EWT is ignored. ! 3 Means YWT(I) = MAX(ABS(Y(I)), EWT(1)). ! 4 Means YWT(I) = MAX(ABS(Y(I)), EWT(I)). ! This choice is useful when the solution components ! have differing scales. ! 5 Means YWT(I) = EWT(I). ! If IERROR is 3, EWT need only be dimensioned one. ! If IERROR is 4 or 5, the user must dimension EWT at least ! N, and set its values. ! ! MINT = (Input) The integration method indicator. ! MINT = 1 Means the Adams methods, and is used for ! non-stiff problems. ! MINT = 2 Means the stiff methods of Gear (i.e., the ! backward differentiation formulas), and is ! used for stiff problems. ! MINT = 3 Means the program dynamically selects the ! Adams methods when the problem is non-stiff ! and the Gear methods when the problem is ! stiff. When using the Adams methods, the ! program uses a value of MITER=0; when using ! the Gear methods, the program uses the value ! of MITER provided by the user. Only a value ! of IMPL = 0 and a value of MITER = 1, 2, 4, or ! 5 is allowed for this option. The user may ! not alter the value of MINT or MITER without ! restarting, i.e., setting NSTATE to 1. ! ! MITER = (Input) The iteration method indicator. ! MITER = 0 Means functional iteration. This value is ! suggested for non-stiff problems. ! MITER = 1 Means chord method with analytic Jacobian. ! In this case, the user supplies subroutine ! JACOBN (see description below). ! MITER = 2 Means chord method with Jacobian calculated ! internally by finite differences. ! MITER = 3 Means chord method with corrections computed ! by the user-written routine USERS (see ! description of USERS below.) This option ! allows all matrix algebra and storage ! decisions to be made by the user. When using ! a value of MITER = 3, the subroutine FA is ! not required, even if IMPL is not 0. For ! further information on using this option, see ! Section IV-E below. ! MITER = 4 Means the same as MITER = 1 but the A and ! Jacobian matrices are assumed to be banded. ! MITER = 5 Means the same as MITER = 2 but the A and ! Jacobian matrices are assumed to be banded. ! ! IMPL = (Input) The implicit method indicator. ! IMPL = 0 Means solving dY(I)/dT = F(Y(I),T). ! IMPL = 1 Means solving A*dY(I)/dT = F(Y(I),T), non- ! singular A (see description of FA below.) ! Only MINT = 1 or 2, and MITER = 1, 2, 3, 4, ! or 5 are allowed for this option. ! IMPL = 2,3 Means solving certain systems of hybrid ! differential/algebraic equations (see ! description of FA below.) Only MINT = 2 and ! MITER = 1, 2, 3, 4, or 5, are allowed for ! this option. ! The value of IMPL must not be changed during a problem. ! ! ML = (Input) The lower half-bandwidth in the case of a banded ! A or Jacobian matrix. (I.e., maximum(R-C) for nonzero ! A(R,C).) ! ! MU = (Input) The upper half-bandwidth in the case of a banded ! A or Jacobian matrix. (I.e., maximum(C-R).) ! ! MXORD = (Input) The maximum order desired. This is <= 12 for ! the Adams methods and <= 5 for the Gear methods. Normal ! value is 12 and 5, respectively. If MINT is 3, the ! maximum order used will be MIN(MXORD, 12) when using the ! Adams methods, and MIN(MXORD, 5) when using the Gear ! methods. MXORD must not be altered during a problem. ! ! HMAX = (Input) The maximum magnitude of the step size that will ! be used for the problem. This is useful for ensuring that ! important details are not missed. If this is not the ! case, a large value, such as the interval length, is ! suggested. ! ! WORK ! LENW = (Input) ! WORK is an array of LENW double precision words used ! internally for temporary storage. The user must allocate ! space for this array in the calling program by a statement ! such as ! DOUBLE PRECISION WORK(...) ! The following table gives the required minimum value for ! the length of WORK, depending on the value of IMPL and ! MITER. LENW should be set to the value used. The ! contents of WORK should not be disturbed between calls to ! DDRIV3. ! ! IMPL = 0 1 2 3 ! --------------------------------------------------------- ! MITER = 0 (MXORD+4)*N Not allowed Not allowed Not allowed ! + 2*NROOT ! + 250 ! ! 1,2 N*N + 2*N*N + N*N + N*(N + NDE) ! (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N ! + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT ! + 250 + 250 + 250 + 250 ! ! 3 (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N ! + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT ! + 250 + 250 + 250 + 250 ! ! 4,5 (2*ML+MU+1) 2*(2*ML+MU+1) (2*ML+MU+1) (2*ML+MU+1)* ! *N + *N + *N + (N+NDE) + ! (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N ! + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT ! + 250 + 250 + 250 + 250 ! --------------------------------------------------------- ! ! IWORK ! LENIW = (Input) ! IWORK is an integer array of length LENIW used internally ! for temporary storage. The user must allocate space for ! this array in the calling program by a statement such as ! INTEGER IWORK(...) ! The length of IWORK should be at least ! 50 if MITER is 0 or 3, or ! N+50 if MITER is 1, 2, 4, or 5, or MINT is 3, ! and LENIW should be set to the value used. The contents ! of IWORK should not be disturbed between calls to DDRIV3. ! ! JACOBN = A subroutine supplied by the user, if MITER is 1 or 4. ! If this is the case, the name must be declared EXTERNAL in ! the user's calling program. Given a system of N ! differential equations, it is meaningful to speak about ! the partial derivative of the I-th right hand side with ! respect to the J-th dependent variable. In general there ! are N*N such quantities. Often however the equations can ! be ordered so that the I-th differential equation only ! involves dependent variables with index near I, e.g., I+1, ! I-2. Such a system is called banded. If, for all I, the ! I-th equation depends on at most the variables ! Y(I-ML), Y(I-ML+1), ... , Y(I), Y(I+1), ... , Y(I+MU) ! then we call ML+MU+1 the bandwidth of the system. In a ! banded system many of the partial derivatives above are ! automatically zero. For the cases MITER = 1, 2, 4, and 5, ! some of these partials are needed. For the cases ! MITER = 2 and 5 the necessary derivatives are ! approximated numerically by DDRIV3, and we only ask the ! user to tell DDRIV3 the value of ML and MU if the system ! is banded. For the cases MITER = 1 and 4 the user must ! derive these partials algebraically and encode them in ! subroutine JACOBN. By computing these derivatives the ! user can often save 20-30 per cent of the computing time. ! Usually, however, the accuracy is not much affected and ! most users will probably forego this option. The optional ! user-written subroutine JACOBN has the form: ! SUBROUTINE JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) ! DOUBLE PRECISION Y(*), DFDY(MATDIM,*) ! . ! . ! Calculate values of DFDY ! . ! . ! END (Sample) ! Here Y is a vector of length at least N. The actual ! length of Y is determined by the user's declaration in the ! program which calls DDRIV3. Thus the dimensioning of Y in ! JACOBN, while required by FORTRAN convention, does not ! actually allocate any storage. When this subroutine is ! called, the first N components of Y are intermediate ! approximations to the solution components. The user ! should not alter these values. If the system is not ! banded (MITER=1), the partials of the I-th equation with ! respect to the J-th dependent function are to be stored in ! DFDY(I,J). Thus partials of the I-th equation are stored ! in the I-th row of DFDY. If the system is banded ! (MITER=4), then the partials of the I-th equation with ! respect to Y(J) are to be stored in DFDY(K,J), where ! K=I-J+MU+1 . Normally a return from JACOBN passes control ! back to DDRIV3. However, if the user would like to abort ! the calculation, i.e., return control to the program which ! calls DDRIV3, he should set N to zero. DDRIV3 will signal ! this by returning a value of NSTATE equal to +8(-8). ! Altering the value of N in JACOBN has no effect on the ! value of N in the call sequence of DDRIV3. ! ! FA = A subroutine supplied by the user if IMPL is not zero, and ! MITER is not 3. If so, the name must be declared EXTERNAL ! in the user's calling program. This subroutine computes ! the array A, where A*dY(I)/dT = F(Y(I),T). ! There are three cases: ! ! IMPL=1. ! Subroutine FA is of the form: ! SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) ! DOUBLE PRECISION Y(*), A(MATDIM,*) ! . ! . ! Calculate ALL values of A ! . ! . ! END (Sample) ! In this case A is assumed to be a nonsingular matrix, ! with the same structure as DFDY (see JACOBN description ! above). Programming considerations prevent complete ! generality. If MITER is 1 or 2, A is assumed to be full ! and the user must compute and store all values of ! A(I,J), I,J=1, ... ,N. If MITER is 4 or 5, A is assumed ! to be banded with lower and upper half bandwidth ML and ! MU. The left hand side of the I-th equation is a linear ! combination of dY(I-ML)/dT, dY(I-ML+1)/dT, ... , ! dY(I)/dT, ... , dY(I+MU-1)/dT, dY(I+MU)/dT. Thus in the ! I-th equation, the coefficient of dY(J)/dT is to be ! stored in A(K,J), where K=I-J+MU+1. ! NOTE: The array A will be altered between calls to FA. ! ! IMPL=2. ! Subroutine FA is of the form: ! SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) ! DOUBLE PRECISION Y(*), A(*) ! . ! . ! Calculate non-zero values of A(1),...,A(NDE) ! . ! . ! END (Sample) ! In this case it is assumed that the system is ordered by ! the user so that the differential equations appear ! first, and the algebraic equations appear last. The ! algebraic equations must be written in the form: ! 0 = F(Y(I),T). When using this option it is up to the ! user to provide initial values for the Y(I) that satisfy ! the algebraic equations as well as possible. It is ! further assumed that A is a vector of length NDE. All ! of the components of A, which may depend on T, Y(I), ! etc., must be set by the user to non-zero values. ! ! IMPL=3. ! Subroutine FA is of the form: ! SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) ! DOUBLE PRECISION Y(*), A(MATDIM,*) ! . ! . ! Calculate ALL values of A ! . ! . ! END (Sample) ! In this case A is assumed to be a nonsingular NDE by NDE ! matrix with the same structure as DFDY (see JACOBN ! description above). Programming considerations prevent ! complete generality. If MITER is 1 or 2, A is assumed ! to be full and the user must compute and store all ! values of A(I,J), I,J=1, ... ,NDE. If MITER is 4 or 5, ! A is assumed to be banded with lower and upper half ! bandwidths ML and MU. The left hand side of the I-th ! equation is a linear combination of dY(I-ML)/dT, ! dY(I-ML+1)/dT, ... , dY(I)/dT, ... , dY(I+MU-1)/dT, ! dY(I+MU)/dT. Thus in the I-th equation, the coefficient ! of dY(J)/dT is to be stored in A(K,J), where K=I-J+MU+1. ! It is assumed that the system is ordered by the user so ! that the differential equations appear first, and the ! algebraic equations appear last. The algebraic ! equations must be written in the form 0 = F(Y(I),T). ! When using this option it is up to the user to provide ! initial values for the Y(I) that satisfy the algebraic ! equations as well as possible. ! NOTE: For IMPL = 3, the array A will be altered between ! calls to FA. ! Here Y is a vector of length at least N. The actual ! length of Y is determined by the user's declaration in the ! program which calls DDRIV3. Thus the dimensioning of Y in ! FA, while required by FORTRAN convention, does not ! actually allocate any storage. When this subroutine is ! called, the first N components of Y are intermediate ! approximations to the solution components. The user ! should not alter these values. FA is always called ! immediately after calling F, with the same values of T ! and Y. Normally a return from FA passes control back to ! DDRIV3. However, if the user would like to abort the ! calculation, i.e., return control to the program which ! calls DDRIV3, he should set N to zero. DDRIV3 will signal ! this by returning a value of NSTATE equal to +9(-9). ! Altering the value of N in FA has no effect on the value ! of N in the call sequence of DDRIV3. ! ! NDE = (Input) The number of differential equations. This is ! required only for IMPL = 2 or 3, with NDE < N. ! ! MXSTEP = (Input) The maximum number of internal steps allowed on ! one call to DDRIV3. ! ! G = A double precision FORTRAN function supplied by the user ! if NROOT is not 0. In this case, the name must be ! declared EXTERNAL in the user's calling program. G is ! repeatedly called with different values of IROOT to obtain ! the value of each of the NROOT equations for which a root ! is desired. G is of the form: ! DOUBLE PRECISION FUNCTION G (N, T, Y, IROOT) ! DOUBLE PRECISION Y(*) ! go to (10, ...), IROOT ! 10 G = ... ! . ! . ! END (Sample) ! Here, Y is a vector of length at least N, whose first N ! components are the solution components at the point T. ! The user should not alter these values. The actual length ! of Y is determined by the user's declaration in the ! program which calls DDRIV3. Thus the dimensioning of Y in ! G, while required by FORTRAN convention, does not actually ! allocate any storage. Normally a return from G passes ! control back to DDRIV3. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls DDRIV3, he should set N to zero. ! DDRIV3 will signal this by returning a value of NSTATE ! equal to +7(-7). In this case, the index of the equation ! being evaluated is stored in the sixth element of IWORK. ! Altering the value of N in G has no effect on the value of ! N in the call sequence of DDRIV3. ! ! USERS = A subroutine supplied by the user, if MITER is 3. ! If this is the case, the name must be declared EXTERNAL in ! the user's calling program. The routine USERS is called ! by DDRIV3 when certain linear systems must be solved. The ! user may choose any method to form, store and solve these ! systems in order to obtain the solution result that is ! returned to DDRIV3. In particular, this allows sparse ! matrix methods to be used. The call sequence for this ! routine is: ! ! SUBROUTINE USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, ! 8 IMPL, N, NDE, IFLAG) ! DOUBLE PRECISION Y(*), YH(*), YWT(*), SAVE1(*), ! 8 SAVE2(*), T, H, EL ! ! The input variable IFLAG indicates what action is to be ! taken. Subroutine USERS should perform the following ! operations, depending on the value of IFLAG and IMPL. ! ! IFLAG = 0 ! IMPL = 0. USERS is not called. ! IMPL = 1, 2 or 3. Solve the system A*X = SAVE2, ! returning the result in SAVE2. The array SAVE1 can ! be used as a work array. For IMPL = 1, there are N ! components to the system, and for IMPL = 2 or 3, ! there are NDE components to the system. ! ! IFLAG = 1 ! IMPL = 0. Compute, decompose and store the matrix ! (I - H*EL*J), where I is the identity matrix and J ! is the Jacobian matrix of the right hand side. The ! array SAVE1 can be used as a work array. ! IMPL = 1, 2 or 3. Compute, decompose and store the ! matrix (A - H*EL*J). The array SAVE1 can be used as ! a work array. ! ! IFLAG = 2 ! IMPL = 0. Solve the system ! (I - H*EL*J)*X = H*SAVE2 - YH - SAVE1, ! returning the result in SAVE2. ! IMPL = 1, 2 or 3. Solve the system ! (A - H*EL*J)*X = H*SAVE2 - A*(YH + SAVE1) ! returning the result in SAVE2. ! The array SAVE1 should not be altered. ! If IFLAG is 0 and IMPL is 1 or 2 and the matrix A is ! singular, or if IFLAG is 1 and one of the matrices ! (I - H*EL*J), (A - H*EL*J) is singular, the INTEGER ! variable IFLAG is to be set to -1 before RETURNing. ! Normally a return from USERS passes control back to ! DDRIV3. However, if the user would like to abort the ! calculation, i.e., return control to the program which ! calls DDRIV3, he should set N to zero. DDRIV3 will signal ! this by returning a value of NSTATE equal to +10(-10). ! Altering the value of N in USERS has no effect on the ! value of N in the call sequence of DDRIV3. ! ! IERFLG = An error flag. The error number associated with a ! diagnostic message (see Section III-A below) is the same ! as the corresponding value of IERFLG. The meaning of ! IERFLG: ! 0 The routine completed successfully. (No message is ! issued.) ! 3 (Warning) The number of steps required to reach TOUT ! exceeds MXSTEP. ! 4 (Warning) The value of EPS is too small. ! 11 (Warning) For NTASK = 2 or 3, T is beyond TOUT. ! The solution was obtained by interpolation. ! 15 (Warning) The integration step size is below the ! roundoff level of T. (The program issues this ! message as a warning but does not return control to ! the user.) ! 22 (Recoverable) N is not positive. ! 23 (Recoverable) MINT is less than 1 or greater than 3 . ! 24 (Recoverable) MITER is less than 0 or greater than ! 5 . ! 25 (Recoverable) IMPL is less than 0 or greater than 3 . ! 26 (Recoverable) The value of NSTATE is less than 1 or ! greater than 12 . ! 27 (Recoverable) EPS is less than zero. ! 28 (Recoverable) MXORD is not positive. ! 29 (Recoverable) For MINT = 3, either MITER = 0 or 3, or ! IMPL = 0 . ! 30 (Recoverable) For MITER = 0, IMPL is not 0 . ! 31 (Recoverable) For MINT = 1, IMPL is 2 or 3 . ! 32 (Recoverable) Insufficient storage has been allocated ! for the WORK array. ! 33 (Recoverable) Insufficient storage has been allocated ! for the IWORK array. ! 41 (Recoverable) The integration step size has gone ! to zero. ! 42 (Recoverable) The integration step size has been ! reduced about 50 times without advancing the ! solution. The problem setup may not be correct. ! 43 (Recoverable) For IMPL greater than 0, the matrix A ! is singular. ! 999 (Fatal) The value of NSTATE is 12 . ! ! III. OTHER COMMUNICATION TO THE USER .............................. ! ! A. The solver communicates to the user through the parameters ! above. In addition it writes diagnostic messages through the ! standard error handling program XERMSG. A complete description ! of XERMSG is given in "Guide to the SLATEC Common Mathematical ! Library" by Kirby W. Fong et al.. At installations which do not ! have this error handling package the short but serviceable ! routine, XERMSG, available with this package, can be used. That ! program uses the file named OUTPUT to transmit messages. ! ! B. The first three elements of WORK and the first five elements of ! IWORK will contain the following statistical data: ! AVGH The average step size used. ! HUSED The step size last used (successfully). ! AVGORD The average order used. ! IMXERR The index of the element of the solution vector that ! contributed most to the last error test. ! NQUSED The order last used (successfully). ! NSTEP The number of steps taken since last initialization. ! NFE The number of evaluations of the right hand side. ! NJE The number of evaluations of the Jacobian matrix. ! ! IV. REMARKS ....................................................... ! ! A. Other routines used: ! DDNTP, DDZRO, DDSTP, DDNTL, DDPST, DDCOR, DDCST, ! DDPSC, and DDSCL; ! DGEFA, DGESL, DGBFA, DGBSL, and DNRM2 (from LINPACK) ! D1MACH (from the Bell Laboratories Machine Constants Package) ! XERMSG (from the SLATEC Common Math Library) ! The last seven routines above, not having been written by the ! present authors, are not explicitly part of this package. ! ! B. On any return from DDRIV3 all information necessary to continue ! the calculation is contained in the call sequence parameters, ! including the work arrays. Thus it is possible to suspend one ! problem, integrate another, and then return to the first. ! ! C. If this package is to be used in an overlay situation, the user ! must declare in the primary overlay the variables in the call ! sequence to DDRIV3. ! ! D. Changing parameters during an integration. ! The value of NROOT, EPS, EWT, IERROR, MINT, MITER, or HMAX may ! be altered by the user between calls to DDRIV3. For example, if ! too much accuracy has been requested (the program returns with ! NSTATE = 4 and an increased value of EPS) the user may wish to ! increase EPS further. In general, prudence is necessary when ! making changes in parameters since such changes are not ! implemented until the next integration step, which is not ! necessarily the next call to DDRIV3. This can happen if the ! program has already integrated to a point which is beyond the ! new point TOUT. ! ! E. As the price for complete control of matrix algebra, the DDRIV3 ! USERS option puts all responsibility for Jacobian matrix ! evaluation on the user. It is often useful to approximate ! numerically all or part of the Jacobian matrix. However this ! must be done carefully. The FORTRAN sequence below illustrates ! the method we recommend. It can be inserted directly into ! subroutine USERS to approximate Jacobian elements in rows I1 ! to I2 and columns J1 to J2. ! DOUBLE PRECISION DFDY(N,N), EPSJ, H, R, D1MACH, ! 8 SAVE1(N), SAVE2(N), T, UROUND, Y(N), YJ, YWT(N) ! UROUND = D1MACH(4) ! EPSJ = SQRT(UROUND) ! DO 30 J = J1,J2 ! R = EPSJ*MAX(ABS(YWT(J)), ABS(Y(J))) ! if (R == 0.D0) R = YWT(J) ! YJ = Y(J) ! Y(J) = Y(J) + R ! call F (N, T, Y, SAVE1) ! if (N == 0) RETURN ! Y(J) = YJ ! DO 20 I = I1,I2 ! 20 DFDY(I,J) = (SAVE1(I) - SAVE2(I))/R ! 30 CONTINUE ! Many problems give rise to structured sparse Jacobians, e.g., ! block banded. It is possible to approximate them with fewer ! function evaluations than the above procedure uses; see Curtis, ! Powell and Reid, J. Inst. Maths Applics, (1974), Vol. 13, ! pp. 117-119. ! ! F. When any of the routines JACOBN, FA, G, or USERS, is not ! required, difficulties associated with unsatisfied externals can ! be avoided by using the name of the routine which calculates the ! right hand side of the differential equations in place of the ! corresponding name in the call sequence of DDRIV3. ! !***REFERENCES C. W. Gear, Numerical Initial Value Problems in ! Ordinary Differential Equations, Prentice-Hall, 1971. !***ROUTINES CALLED D1MACH, DDNTP, DDSTP, DDZRO, DGBFA, DGBSL, DGEFA, ! DGESL, DNRM2, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDRIV3 EXTERNAL F, JACOBN, FA, G, USERS DOUBLE PRECISION AE, BIG, EPS, EWT(*), G, GLAST, GNOW, H, HMAX, & HSIGN, HUSED, NROUND, RE, D1MACH, SIZE, DNRM2, SUM, T, TLAST, & TOUT, TROOT, UROUND, WORK(*), Y(*) INTEGER I, IA, IAVGH, IAVGRD, ICNVRG, IDFDY, IEL, IERFLG, IERROR, & IFAC, IFLAG, IGNOW, IH, IHMAX, IHOLD, IHSIGN, IHUSED, & IJROOT, IJSTPL, IJTASK, IMNT, IMNTLD, IMPL, IMTR, IMTRLD, & IMTRSV, IMXERR, IMXORD, IMXRDS, INDMXR, INDPRT, INDPVT, & INDTRT, INFE, INFO, INJE, INQ, INQUSE, INROOT, INRTLD, & INSTEP, INWAIT, IRC, IRMAX, IROOT, IMACH1, IMACH4, ISAVE1, & ISAVE2, IT, ITOUT, ITQ, ITREND, ITROOT, IWORK(*), IYH, & IYWT, J, JSTATE, JTROOT, LENCHK, LENIW, LENW, LIWCHK, & MATDIM, MAXORD, MINT, MITER, ML, MU, MXORD, MXSTEP, N, & NDE, NDECOM, NPAR, NROOT, NSTATE, NSTEPL, NTASK LOGICAL CONVRG CHARACTER INTGR1*8, INTGR2*8, RL1*16, RL2*16 PARAMETER(NROUND = 20.D0) PARAMETER(IAVGH = 1, IHUSED = 2, IAVGRD = 3, & IEL = 4, IH = 160, IHMAX = 161, IHOLD = 162, & IHSIGN = 163, IRC = 164, IRMAX = 165, IT = 166, & ITOUT = 167, ITQ = 168, ITREND = 204, IMACH1 = 205, & IMACH4 = 206, IYH = 251, & INDMXR = 1, INQUSE = 2, INSTEP = 3, INFE = 4, INJE = 5, & INROOT = 6, ICNVRG = 7, IJROOT = 8, IJTASK = 9, & IMNTLD = 10, IMTRLD = 11, INQ = 12, INRTLD = 13, & INDTRT = 14, INWAIT = 15, IMNT = 16, IMTRSV = 17, & IMTR = 18, IMXRDS = 19, IMXORD = 20, INDPRT = 21, & IJSTPL = 22, INDPVT = 51) !***FIRST EXECUTABLE STATEMENT DDRIV3 if (NSTATE == 12) THEN IERFLG = 999 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. The value of NSTATE is 12 .', IERFLG, 2) return ELSE if (NSTATE < 1 .OR. NSTATE > 12) THEN WRITE(INTGR1, '(I8)') NSTATE IERFLG = 26 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. Improper value for NSTATE(= '//INTGR1//').', & IERFLG, 1) NSTATE = 12 return end if NPAR = N if (EPS < 0.D0) THEN WRITE(RL1, '(D16.8)') EPS IERFLG = 27 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. EPS, '//RL1//', is negative.', IERFLG, 1) NSTATE = 12 return end if if (N <= 0) THEN WRITE(INTGR1, '(I8)') N IERFLG = 22 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. Number of equations, '//INTGR1// & ', is not positive.', IERFLG, 1) NSTATE = 12 return end if if (MXORD <= 0) THEN WRITE(INTGR1, '(I8)') MXORD IERFLG = 28 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. Maximum order, '//INTGR1// & ', is not positive.', IERFLG, 1) NSTATE = 12 return end if if (MINT < 1 .OR. MINT > 3) THEN WRITE(INTGR1, '(I8)') MINT IERFLG = 23 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. Improper value for the integration method '// & 'flag, '//INTGR1//' .', IERFLG, 1) NSTATE = 12 return ELSE if (MITER < 0 .OR. MITER > 5) THEN WRITE(INTGR1, '(I8)') MITER IERFLG = 24 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. Improper value for MITER(= '//INTGR1//').', & IERFLG, 1) NSTATE = 12 return ELSE if (IMPL < 0 .OR. IMPL > 3) THEN WRITE(INTGR1, '(I8)') IMPL IERFLG = 25 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. Improper value for IMPL(= '//INTGR1//').', & IERFLG, 1) NSTATE = 12 return ELSE if (MINT == 3 .AND. & (MITER == 0 .OR. MITER == 3 .OR. IMPL /= 0)) THEN WRITE(INTGR1, '(I8)') MITER WRITE(INTGR2, '(I8)') IMPL IERFLG = 29 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. For MINT = 3, the value of MITER, '//INTGR1// & ', and/or IMPL, '//INTGR2//', is not allowed.', IERFLG, 1) NSTATE = 12 return ELSE if ((IMPL >= 1 .AND. IMPL <= 3) .AND. MITER == 0) THEN WRITE(INTGR1, '(I8)') IMPL IERFLG = 30 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. For MITER = 0, the value of IMPL, '//INTGR1// & ', is not allowed.', IERFLG, 1) NSTATE = 12 return ELSE if ((IMPL == 2 .OR. IMPL == 3) .AND. MINT == 1) THEN WRITE(INTGR1, '(I8)') IMPL IERFLG = 31 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. For MINT = 1, the value of IMPL, '//INTGR1// & ', is not allowed.', IERFLG, 1) NSTATE = 12 return end if if (MITER == 0 .OR. MITER == 3) THEN LIWCHK = INDPVT - 1 ELSE if (MITER == 1 .OR. MITER == 2 .OR. MITER == 4 .OR. & MITER == 5) THEN LIWCHK = INDPVT + N - 1 end if if (LENIW < LIWCHK) THEN WRITE(INTGR1, '(I8)') LIWCHK IERFLG = 33 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. Insufficient storage allocated for the '// & 'IWORK array. Based on the value of the input parameters '// & 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) NSTATE = 12 return end if ! Allocate the WORK array ! IYH is the index of YH in WORK if (MINT == 1 .OR. MINT == 3) THEN MAXORD = MIN(MXORD, 12) ELSE if (MINT == 2) THEN MAXORD = MIN(MXORD, 5) end if IDFDY = IYH + (MAXORD + 1)*N ! IDFDY is the index of DFDY ! if (MITER == 0 .OR. MITER == 3) THEN IYWT = IDFDY ELSE if (MITER == 1 .OR. MITER == 2) THEN IYWT = IDFDY + N*N ELSE if (MITER == 4 .OR. MITER == 5) THEN IYWT = IDFDY + (2*ML + MU + 1)*N end if ! IYWT is the index of YWT ISAVE1 = IYWT + N ! ISAVE1 is the index of SAVE1 ISAVE2 = ISAVE1 + N ! ISAVE2 is the index of SAVE2 IGNOW = ISAVE2 + N ! IGNOW is the index of GNOW ITROOT = IGNOW + NROOT ! ITROOT is the index of TROOT IFAC = ITROOT + NROOT ! IFAC is the index of FAC if (MITER == 2 .OR. MITER == 5 .OR. MINT == 3) THEN IA = IFAC + N ELSE IA = IFAC end if ! IA is the index of A if (IMPL == 0 .OR. MITER == 3) THEN LENCHK = IA - 1 ELSE if (IMPL == 1 .AND. (MITER == 1 .OR. MITER == 2)) THEN LENCHK = IA - 1 + N*N ELSE if (IMPL == 1 .AND. (MITER == 4 .OR. MITER == 5)) THEN LENCHK = IA - 1 + (2*ML + MU + 1)*N ELSE if (IMPL == 2 .AND. MITER /= 3) THEN LENCHK = IA - 1 + N ELSE if (IMPL == 3 .AND. (MITER == 1 .OR. MITER == 2)) THEN LENCHK = IA - 1 + N*NDE ELSE if (IMPL == 3 .AND. (MITER == 4 .OR. MITER == 5)) THEN LENCHK = IA - 1 + (2*ML + MU + 1)*NDE end if if (LENW < LENCHK) THEN WRITE(INTGR1, '(I8)') LENCHK IERFLG = 32 call XERMSG('SLATEC', 'DDRIV3', & 'Illegal input. Insufficient storage allocated for the '// & 'WORK array. Based on the value of the input parameters '// & 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) NSTATE = 12 return end if if (MITER == 0 .OR. MITER == 3) THEN MATDIM = 1 ELSE if (MITER == 1 .OR. MITER == 2) THEN MATDIM = N ELSE if (MITER == 4 .OR. MITER == 5) THEN MATDIM = 2*ML + MU + 1 end if if (IMPL == 0 .OR. IMPL == 1) THEN NDECOM = N ELSE if (IMPL == 2 .OR. IMPL == 3) THEN NDECOM = NDE end if if (NSTATE == 1) THEN ! Initialize parameters if (MINT == 1 .OR. MINT == 3) THEN IWORK(IMXORD) = MIN(MXORD, 12) ELSE if (MINT == 2) THEN IWORK(IMXORD) = MIN(MXORD, 5) end if IWORK(IMXRDS) = MXORD if (MINT == 1 .OR. MINT == 2) THEN IWORK(IMNT) = MINT IWORK(IMTR) = MITER IWORK(IMNTLD) = MINT IWORK(IMTRLD) = MITER ELSE if (MINT == 3) THEN IWORK(IMNT) = 1 IWORK(IMTR) = 0 IWORK(IMNTLD) = IWORK(IMNT) IWORK(IMTRLD) = IWORK(IMTR) IWORK(IMTRSV) = MITER end if WORK(IHMAX) = HMAX UROUND = D1MACH (4) WORK(IMACH4) = UROUND WORK(IMACH1) = D1MACH (1) if (NROOT /= 0) THEN RE = UROUND AE = WORK(IMACH1) end if H = (TOUT - T)*(1.D0 - 4.D0*UROUND) H = SIGN(MIN(ABS(H), HMAX), H) WORK(IH) = H HSIGN = SIGN(1.D0, H) WORK(IHSIGN) = HSIGN IWORK(IJTASK) = 0 WORK(IAVGH) = 0.D0 WORK(IHUSED) = 0.D0 WORK(IAVGRD) = 0.D0 IWORK(INDMXR) = 0 IWORK(INQUSE) = 0 IWORK(INSTEP) = 0 IWORK(IJSTPL) = 0 IWORK(INFE) = 0 IWORK(INJE) = 0 IWORK(INROOT) = 0 WORK(IT) = T IWORK(ICNVRG) = 0 IWORK(INDPRT) = 0 ! Set initial conditions DO 30 I = 1,N 30 WORK(I+IYH-1) = Y(I) if (T == TOUT) RETURN go to 180 ELSE UROUND = WORK(IMACH4) if (NROOT /= 0) THEN RE = UROUND AE = WORK(IMACH1) end if end if ! On a continuation, check ! that output points have ! been or will be overtaken. if (IWORK(ICNVRG) == 1) THEN CONVRG = .TRUE. ELSE CONVRG = .FALSE. end if T = WORK(IT) H = WORK(IH) HSIGN = WORK(IHSIGN) if (IWORK(IJTASK) == 0) go to 180 ! ! IWORK(IJROOT) flags unreported ! roots, and is set to the value of ! NTASK when a root was last selected. ! It is set to zero when all roots ! have been reported. IWORK(INROOT) ! contains the index and WORK(ITOUT) ! contains the value of the root last ! selected to be reported. ! IWORK(INRTLD) contains the value of ! NROOT and IWORK(INDTRT) contains ! the value of ITROOT when the array ! of roots was last calculated. if (NROOT /= 0) THEN if (IWORK(IJROOT) > 0) THEN ! TOUT has just been reported. ! If TROOT <= TOUT, report TROOT. if (NSTATE /= 5) THEN if (TOUT*HSIGN >= WORK(ITOUT)*HSIGN) THEN TROOT = WORK(ITOUT) call DDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) T = TROOT NSTATE = 5 IERFLG = 0 go to 580 end if ! A root has just been reported. ! Select the next root. ELSE TROOT = T IROOT = 0 DO 50 I = 1,IWORK(INRTLD) JTROOT = I + IWORK(INDTRT) - 1 if (WORK(JTROOT)*HSIGN <= TROOT*HSIGN) THEN ! ! Check for multiple roots. ! if (WORK(JTROOT) == WORK(ITOUT) .AND. & I > IWORK(INROOT)) THEN IROOT = I TROOT = WORK(JTROOT) go to 60 end if if (WORK(JTROOT)*HSIGN > WORK(ITOUT)*HSIGN) THEN IROOT = I TROOT = WORK(JTROOT) end if end if 50 CONTINUE 60 IWORK(INROOT) = IROOT WORK(ITOUT) = TROOT IWORK(IJROOT) = NTASK if (NTASK == 1) THEN if (IROOT == 0) THEN IWORK(IJROOT) = 0 ELSE if (TOUT*HSIGN >= TROOT*HSIGN) THEN call DDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), & Y) NSTATE = 5 T = TROOT IERFLG = 0 go to 580 end if end if ELSE if (NTASK == 2 .OR. NTASK == 3) THEN ! ! If there are no more roots, or the ! user has altered TOUT to be less ! than a root, set IJROOT to zero. ! if (IROOT == 0 .OR. (TOUT*HSIGN < TROOT*HSIGN)) THEN IWORK(IJROOT) = 0 ELSE call DDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), & Y) NSTATE = 5 IERFLG = 0 T = TROOT go to 580 end if end if end if end if end if ! if (NTASK == 1) THEN NSTATE = 2 if (T*HSIGN >= TOUT*HSIGN) THEN call DDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT IERFLG = 0 go to 580 end if ELSE if (NTASK == 2) THEN ! Check if TOUT has ! been reset < T if (T*HSIGN > TOUT*HSIGN) THEN WRITE(RL1, '(D16.8)') T WRITE(RL2, '(D16.8)') TOUT IERFLG = 11 call XERMSG('SLATEC', 'DDRIV3', & 'While integrating exactly to TOUT, T, '//RL1// & ', was beyond TOUT, '//RL2//' . Solution obtained by '// & 'interpolation.', IERFLG, 0) NSTATE = 11 call DDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT go to 580 end if ! Determine if TOUT has been overtaken ! if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT NSTATE = 2 IERFLG = 0 go to 560 end if ! If there are no more roots ! to report, report T. if (NSTATE == 5) THEN NSTATE = 2 IERFLG = 0 go to 560 end if NSTATE = 2 ! See if TOUT will ! be overtaken. if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.D0 - 4.D0*UROUND) WORK(IH) = H if (H == 0.D0) go to 670 IWORK(IJTASK) = -1 end if ELSE if (NTASK == 3) THEN NSTATE = 2 if (T*HSIGN > TOUT*HSIGN) THEN WRITE(RL1, '(D16.8)') T WRITE(RL2, '(D16.8)') TOUT IERFLG = 11 call XERMSG('SLATEC', 'DDRIV3', & 'While integrating exactly to TOUT, T, '//RL1// & ', was beyond TOUT, '//RL2//' . Solution obtained by '// & 'interpolation.', IERFLG, 0) NSTATE = 11 call DDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT go to 580 end if if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT IERFLG = 0 go to 560 end if if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.D0 - 4.D0*UROUND) WORK(IH) = H if (H == 0.D0) go to 670 IWORK(IJTASK) = -1 end if end if ! Implement changes in MINT, MITER, and/or HMAX. ! if ((MINT /= IWORK(IMNTLD) .OR. MITER /= IWORK(IMTRLD)) .AND. & MINT /= 3 .AND. IWORK(IMNTLD) /= 3) IWORK(IJTASK) = -1 if (HMAX /= WORK(IHMAX)) THEN H = SIGN(MIN(ABS(H), HMAX), H) if (H /= WORK(IH)) THEN IWORK(IJTASK) = -1 WORK(IH) = H end if WORK(IHMAX) = HMAX end if ! 180 NSTEPL = IWORK(INSTEP) DO 190 I = 1,N 190 Y(I) = WORK(I+IYH-1) if (NROOT /= 0) THEN DO 200 I = 1,NROOT WORK(I+IGNOW-1) = G (NPAR, T, Y, I) if (NPAR == 0) THEN IWORK(INROOT) = I NSTATE = 7 return end if 200 CONTINUE end if if (IERROR == 1) THEN DO 230 I = 1,N 230 WORK(I+IYWT-1) = 1.D0 go to 410 ELSE if (IERROR == 5) THEN DO 250 I = 1,N 250 WORK(I+IYWT-1) = EWT(I) go to 410 end if ! Reset YWT array. Looping point. 260 if (IERROR == 2) THEN DO 280 I = 1,N if (Y(I) == 0.D0) go to 290 280 WORK(I+IYWT-1) = ABS(Y(I)) go to 410 290 if (IWORK(IJTASK) == 0) THEN call F (NPAR, T, Y, WORK(ISAVE2)) if (NPAR == 0) THEN NSTATE = 6 return end if IWORK(INFE) = IWORK(INFE) + 1 if (MITER == 3 .AND. IMPL /= 0) THEN IFLAG = 0 call USERS (Y, WORK(IYH), WORK(IYWT), WORK(ISAVE1), & WORK(ISAVE2), T, H, WORK(IEL), IMPL, NPAR, & NDECOM, IFLAG) if (IFLAG == -1) go to 690 if (NPAR == 0) THEN NSTATE = 10 return end if ELSE if (IMPL == 1) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call DGEFA (WORK(IA), MATDIM, N, IWORK(INDPVT), INFO) if (INFO /= 0) go to 690 call DGESL (WORK(IA), MATDIM, N, IWORK(INDPVT), & WORK(ISAVE2), 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call DGBFA (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), & INFO) if (INFO /= 0) go to 690 call DGBSL (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), & WORK(ISAVE2), 0) end if ELSE if (IMPL == 2) THEN call FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if DO 340 I = 1,NDECOM if (WORK(I+IA-1) == 0.D0) go to 690 340 WORK(I+ISAVE2-1) = WORK(I+ISAVE2-1)/WORK(I+IA-1) ELSE if (IMPL == 3) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call DGEFA (WORK(IA), MATDIM, NDE, IWORK(INDPVT), INFO) if (INFO /= 0) go to 690 call DGESL (WORK(IA), MATDIM, NDE, IWORK(INDPVT), & WORK(ISAVE2), 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call DGBFA (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), & INFO) if (INFO /= 0) go to 690 call DGBSL (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), & WORK(ISAVE2), 0) end if end if end if DO 360 J = I,N if (Y(J) /= 0.D0) THEN WORK(J+IYWT-1) = ABS(Y(J)) ELSE if (IWORK(IJTASK) == 0) THEN WORK(J+IYWT-1) = ABS(H*WORK(J+ISAVE2-1)) ELSE WORK(J+IYWT-1) = ABS(WORK(J+IYH+N-1)) end if end if if (WORK(J+IYWT-1) == 0.D0) WORK(J+IYWT-1) = UROUND 360 CONTINUE ELSE if (IERROR == 3) THEN DO 380 I = 1,N 380 WORK(I+IYWT-1) = MAX(EWT(1), ABS(Y(I))) ELSE if (IERROR == 4) THEN DO 400 I = 1,N 400 WORK(I+IYWT-1) = MAX(EWT(I), ABS(Y(I))) end if ! 410 DO 420 I = 1,N 420 WORK(I+ISAVE2-1) = Y(I)/WORK(I+IYWT-1) SUM = DNRM2(N, WORK(ISAVE2), 1)/SQRT(DBLE(N)) SUM = MAX(1.D0, SUM) if (EPS < SUM*UROUND) THEN EPS = SUM*UROUND*(1.D0 + 10.D0*UROUND) WRITE(RL1, '(D16.8)') T WRITE(RL2, '(D16.8)') EPS IERFLG = 4 call XERMSG('SLATEC', 'DDRIV3', & 'At T, '//RL1//', the requested accuracy, EPS, was not '// & 'obtainable with the machine precision. EPS has been '// & 'increased to '//RL2//' .', IERFLG, 0) NSTATE = 4 go to 560 end if if (ABS(H) >= UROUND*ABS(T)) THEN IWORK(INDPRT) = 0 ELSE if (IWORK(INDPRT) == 0) THEN WRITE(RL1, '(D16.8)') T WRITE(RL2, '(D16.8)') H IERFLG = 15 call XERMSG('SLATEC', 'DDRIV3', & 'At T, '//RL1//', the step size, '//RL2//', is smaller '// & 'than the roundoff level of T. This may occur if there is '// & 'an abrupt change in the right hand side of the '// & 'differential equations.', IERFLG, 0) IWORK(INDPRT) = 1 end if if (NTASK /= 2) THEN if ((IWORK(INSTEP)-NSTEPL) == MXSTEP) THEN WRITE(RL1, '(D16.8)') T WRITE(INTGR1, '(I8)') MXSTEP WRITE(RL2, '(D16.8)') TOUT IERFLG = 3 call XERMSG('SLATEC', 'DDRIV3', & 'At T, '//RL1//', '//INTGR1//' steps have been taken '// & 'without reaching TOUT, '//RL2//' .', IERFLG, 0) NSTATE = 3 go to 560 end if end if ! ! call DDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, ! 8 MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, ! 8 USERS, AVGH, AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, ! 8 NFE, NJE, NQUSED, NSTEP, T, Y, YH, A, CONVRG, ! 8 DFDY, EL, FAC, HOLD, IPVT, JSTATE, JSTEPL, NQ, NWAIT, ! 8 RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, MTRSV, ! 8 MXRDSV) ! call DDSTP (EPS, F, FA, WORK(IHMAX), IMPL, IERROR, JACOBN, & MATDIM, IWORK(IMXORD), IWORK(IMNT), IWORK(IMTR), ML, & MU, NPAR, NDECOM, WORK(IYWT), UROUND, USERS, & WORK(IAVGH), WORK(IAVGRD), WORK(IH), HUSED, & IWORK(IJTASK), IWORK(IMNTLD), IWORK(IMTRLD), & IWORK(INFE), IWORK(INJE), IWORK(INQUSE), & IWORK(INSTEP), WORK(IT), Y, WORK(IYH), WORK(IA), & CONVRG, WORK(IDFDY), WORK(IEL), WORK(IFAC), & WORK(IHOLD), IWORK(INDPVT), JSTATE, IWORK(IJSTPL), & IWORK(INQ), IWORK(INWAIT), WORK(IRC), WORK(IRMAX), & WORK(ISAVE1), WORK(ISAVE2), WORK(ITQ), WORK(ITREND), & MINT, IWORK(IMTRSV), IWORK(IMXRDS)) T = WORK(IT) H = WORK(IH) if (CONVRG) THEN IWORK(ICNVRG) = 1 ELSE IWORK(ICNVRG) = 0 end if go to (470, 670, 680, 690, 690, 660, 660, 660, 660, 660), JSTATE 470 IWORK(IJTASK) = 1 ! Determine if a root has been overtaken if (NROOT /= 0) THEN IROOT = 0 DO 500 I = 1,NROOT GLAST = WORK(I+IGNOW-1) GNOW = G (NPAR, T, Y, I) if (NPAR == 0) THEN IWORK(INROOT) = I NSTATE = 7 return end if WORK(I+IGNOW-1) = GNOW if (GLAST*GNOW > 0.D0) THEN WORK(I+ITROOT-1) = T + H ELSE if (GNOW == 0.D0) THEN WORK(I+ITROOT-1) = T IROOT = I ELSE if (GLAST == 0.D0) THEN WORK(I+ITROOT-1) = T + H ELSE if (ABS(HUSED) >= UROUND*ABS(T)) THEN TLAST = T - HUSED IROOT = I TROOT = T call DDZRO (AE, G, H, NPAR, IWORK(INQ), IROOT, RE, T, & WORK(IYH), UROUND, TROOT, TLAST, & GNOW, GLAST, Y) DO 480 J = 1,N 480 Y(J) = WORK(IYH+J-1) if (NPAR == 0) THEN IWORK(INROOT) = I NSTATE = 7 return end if WORK(I+ITROOT-1) = TROOT ELSE WORK(I+ITROOT-1) = T IROOT = I end if end if end if end if 500 CONTINUE if (IROOT == 0) THEN IWORK(IJROOT) = 0 ! Select the first root ELSE IWORK(IJROOT) = NTASK IWORK(INRTLD) = NROOT IWORK(INDTRT) = ITROOT TROOT = T + H DO 510 I = 1,NROOT if (WORK(I+ITROOT-1)*HSIGN < TROOT*HSIGN) THEN TROOT = WORK(I+ITROOT-1) IROOT = I end if 510 CONTINUE IWORK(INROOT) = IROOT WORK(ITOUT) = TROOT if (TROOT*HSIGN <= TOUT*HSIGN) THEN call DDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) NSTATE = 5 T = TROOT IERFLG = 0 go to 580 end if end if end if ! Test for NTASK condition to be satisfied NSTATE = 2 if (NTASK == 1) THEN if (T*HSIGN < TOUT*HSIGN) go to 260 call DDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT IERFLG = 0 go to 580 ! TOUT is assumed to have been attained ! exactly if T is within twenty roundoff ! units of TOUT, relative to MAX(TOUT, T). ! ELSE if (NTASK == 2) THEN if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT ELSE if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.D0 - 4.D0*UROUND) WORK(IH) = H if (H == 0.D0) go to 670 IWORK(IJTASK) = -1 end if end if ELSE if (NTASK == 3) THEN if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT ELSE if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.D0 - 4.D0*UROUND) WORK(IH) = H if (H == 0.D0) go to 670 IWORK(IJTASK) = -1 end if go to 260 end if end if IERFLG = 0 ! All returns are made through this ! section. IMXERR is determined. 560 DO 570 I = 1,N 570 Y(I) = WORK(I+IYH-1) 580 if (IWORK(IJTASK) == 0) RETURN BIG = 0.D0 IMXERR = 1 DO 590 I = 1,N ! SIZE = ABS(ERROR(I)/YWT(I)) SIZE = ABS(WORK(I+ISAVE1-1)/WORK(I+IYWT-1)) if (BIG < SIZE) THEN BIG = SIZE IMXERR = I end if 590 CONTINUE IWORK(INDMXR) = IMXERR WORK(IHUSED) = HUSED return ! 660 NSTATE = JSTATE return ! Fatal errors are processed here ! 670 WRITE(RL1, '(D16.8)') T IERFLG = 41 call XERMSG('SLATEC', 'DDRIV3', & 'At T, '//RL1//', the attempted step size has gone to '// & 'zero. Often this occurs if the problem setup is incorrect.', & IERFLG, 1) NSTATE = 12 return ! 680 WRITE(RL1, '(D16.8)') T IERFLG = 42 call XERMSG('SLATEC', 'DDRIV3', & 'At T, '//RL1//', the step size has been reduced about 50 '// & 'times without advancing the solution. Often this occurs '// & 'if the problem setup is incorrect.', IERFLG, 1) NSTATE = 12 return ! 690 WRITE(RL1, '(D16.8)') T IERFLG = 43 call XERMSG('SLATEC', 'DDRIV3', & 'At T, '//RL1//', while solving A*YDOT = F, A is singular.', & IERFLG, 1) NSTATE = 12 return end subroutine DDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) ! !! DDSCL rescales the YH array whenever the step size is changed. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE DOUBLE PRECISION (SDSCL-S, DDSCL-D, CDSCL-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDSCL INTEGER I, J, N, NQ DOUBLE PRECISION H, HMAX, RC, RH, RMAX, R1, YH(N,*) !***FIRST EXECUTABLE STATEMENT DDSCL if (H < 1.D0) THEN RH = MIN(ABS(H)*RH, ABS(H)*RMAX, HMAX)/ABS(H) ELSE RH = MIN(RH, RMAX, HMAX/ABS(H)) end if R1 = 1.D0 DO 10 J = 1,NQ R1 = R1*RH DO 10 I = 1,N 10 YH(I,J+1) = YH(I,J+1)*R1 H = H*RH RC = RC*RH return end subroutine DDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, USERS, AVGH, & AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, NFE, NJE, NQUSED, & NSTEP, T, Y, YH, A, CONVRG, DFDY, EL, FAC, HOLD, IPVT, JSTATE, & JSTEPL, NQ, NWAIT, RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, & MTRSV, MXRDSV) ! !! DDSTP performs one step of the integration of an initial value problem ... ! for a system of ordinary differential equations. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE DOUBLE PRECISION (SDSTP-S, DDSTP-D, CDSTP-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! Communication with DDSTP is done with the following variables: ! ! YH An N by MAXORD+1 array containing the dependent variables ! and their scaled derivatives. MAXORD, the maximum order ! used, is currently 12 for the Adams methods and 5 for the ! Gear methods. YH(I,J+1) contains the J-th derivative of ! Y(I), scaled by H**J/factorial(J). Only Y(I), ! 1 <= I <= N, need be set by the calling program on ! the first entry. The YH array should not be altered by ! the calling program. When referencing YH as a ! 2-dimensional array, use a column length of N, as this is ! the value used in DDSTP. ! DFDY A block of locations used for partial derivatives if MITER ! is not 0. If MITER is 1 or 2 its length must be at least ! N*N. If MITER is 4 or 5 its length must be at least ! (2*ML+MU+1)*N. ! YWT An array of N locations used in convergence and error tests ! SAVE1 ! SAVE2 Arrays of length N used for temporary storage. ! IPVT An integer array of length N used by the linear system ! solvers for the storage of row interchange information. ! A A block of locations used to store the matrix A, when using ! the implicit method. If IMPL is 1, A is a MATDIM by N ! array. If MITER is 1 or 2 MATDIM is N, and if MITER is 4 ! or 5 MATDIM is 2*ML+MU+1. If IMPL is 2 its length is N. ! If IMPL is 3, A is a MATDIM by NDE array. ! JTASK An integer used on input. ! It has the following values and meanings: ! == 0 Perform the first step. This value enables ! the subroutine to initialize itself. ! > 0 Take a new step continuing from the last. ! Assumes the last step was successful and ! user has not changed any parameters. ! < 0 Take a new step with a new value of H and/or ! MINT and/or MITER. ! JSTATE A completion code with the following meanings: ! 1 The step was successful. ! 2 A solution could not be obtained with H /= 0. ! 3 A solution was not obtained in MXTRY attempts. ! 4 For IMPL /= 0, the matrix A is singular. ! On a return with JSTATE > 1, the values of T and ! the YH array are as of the beginning of the last ! step, and H is the last step size attempted. ! !***ROUTINES CALLED DDCOR, DDCST, DDNTL, DDPSC, DDPST, DDSCL, DNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDSTP EXTERNAL F, JACOBN, FA, USERS INTEGER I, IERROR, IMPL, IPVT(*), ISWFLG, ITER, J, JSTATE, JSTEPL, & JTASK, MATDIM, MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, & MTRSV, MU, MXFAIL, MXITER, MXRDSV, MXTRY, N, NDE, NDJSTP, & NFAIL, NFE, NJE, NQ, NQUSED, NSTEP, NSV, NTRY, NWAIT DOUBLE PRECISION A(MATDIM,*), AVGH, AVGORD, BIAS1, BIAS2, BIAS3, & BND, CTEST, D, DENOM, DFDY(MATDIM,*), D1, EL(13,12), EPS, & ERDN, ERUP, ETEST, FAC(*), H, HMAX, HN, HOLD, HS, HUSED, & NUMER, RC, RCTEST, RH, RH1, RH2, RH3, RMAX, RMFAIL, RMNORM, & SAVE1(*), SAVE2(*), DNRM2, T, TOLD, TQ(3,12), TREND, TRSHLD, & UROUND, Y(*), YH(N,*), YWT(*), Y0NRM LOGICAL CONVRG, EVALFA, EVALJC, IER, SWITCH PARAMETER(BIAS1 = 1.3D0, BIAS2 = 1.2D0, BIAS3 = 1.4D0, MXFAIL = 3, & MXITER = 3, MXTRY = 50, RCTEST = .3D0, RMFAIL = 2.D0, & RMNORM = 10.D0, TRSHLD = 1.D0) PARAMETER (NDJSTP = 10) DATA IER /.FALSE./ !***FIRST EXECUTABLE STATEMENT DDSTP NSV = N BND = 0.D0 SWITCH = .FALSE. NTRY = 0 TOLD = T NFAIL = 0 if (JTASK <= 0) THEN call DDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, & UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, & YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, & RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) if (N == 0) go to 440 if (H == 0.D0) go to 400 if (IER) go to 420 end if 100 NTRY = NTRY + 1 if (NTRY > MXTRY) go to 410 T = T + H call DDPSC (1, N, NQ, YH) EVALJC = (((ABS(RC - 1.D0) > RCTEST) .OR. & (NSTEP >= JSTEPL + NDJSTP)) .AND. (MITER /= 0)) EVALFA = .NOT. EVALJC ! 110 ITER = 0 DO 115 I = 1,N 115 Y(I) = YH(I,1) call F (N, T, Y, SAVE2) if (N == 0) THEN JSTATE = 6 go to 430 end if NFE = NFE + 1 if (EVALJC .OR. IER) THEN call DDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, & MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, & NFE, NJE, A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, & BND, JSTATE) if (N == 0) go to 430 if (IER) go to 160 CONVRG = .FALSE. RC = 1.D0 JSTEPL = NSTEP end if DO 125 I = 1,N 125 SAVE1(I) = 0.D0 ! Up to MXITER corrector iterations are taken. ! Convergence is tested by requiring the r.m.s. ! norm of changes to be less than EPS. The sum of ! the corrections is accumulated in the vector ! SAVE1(I). It is approximately equal to the L-th ! derivative of Y multiplied by ! H**L/(factorial(L-1)*EL(L,NQ)), and is thus ! proportional to the actual errors to the lowest ! power of H present (H**L). The YH array is not ! altered in the correction loop. The norm of the ! iterate difference is stored in D. If ! ITER > 0, an estimate of the convergence rate ! constant is stored in TREND, and this is used in ! the convergence test. ! 130 call DDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, MITER, & ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, & SAVE1, SAVE2, A, D, JSTATE) if (N == 0) go to 430 if (ISWFLG == 3 .AND. MINT == 1) THEN if (ITER == 0) THEN NUMER = DNRM2(N, SAVE1, 1) DO 132 I = 1,N 132 DFDY(1,I) = SAVE1(I) Y0NRM = DNRM2(N, YH, 1) ELSE DENOM = NUMER DO 134 I = 1,N 134 DFDY(1,I) = SAVE1(I) - DFDY(1,I) NUMER = DNRM2(N, DFDY, MATDIM) if (EL(1,NQ)*NUMER <= 100.D0*UROUND*Y0NRM) THEN if (RMAX == RMFAIL) THEN SWITCH = .TRUE. go to 170 end if end if DO 136 I = 1,N 136 DFDY(1,I) = SAVE1(I) if (DENOM /= 0.D0) & BND = MAX(BND, NUMER/(DENOM*ABS(H)*EL(1,NQ))) end if end if if (ITER > 0) TREND = MAX(.9D0*TREND, D/D1) D1 = D CTEST = MIN(2.D0*TREND, 1.D0)*D if (CTEST <= EPS) go to 170 ITER = ITER + 1 if (ITER < MXITER) THEN DO 140 I = 1,N 140 Y(I) = YH(I,1) + EL(1,NQ)*SAVE1(I) call F (N, T, Y, SAVE2) if (N == 0) THEN JSTATE = 6 go to 430 end if NFE = NFE + 1 go to 130 end if ! The corrector iteration failed to converge in ! MXITER tries. If partials are involved but are ! not up to date, they are reevaluated for the next ! try. Otherwise the YH array is retracted to its ! values before prediction, and H is reduced, if ! possible. If not, a no-convergence exit is taken. if (CONVRG) THEN EVALJC = .TRUE. EVALFA = .FALSE. go to 110 end if 160 T = TOLD call DDPSC (-1, N, NQ, YH) NWAIT = NQ + 2 if (JTASK /= 0 .AND. JTASK /= 2) RMAX = RMFAIL if (ITER == 0) THEN RH = .3D0 ELSE RH = .9D0*(EPS/CTEST)**(.2D0) end if if (RH*H == 0.D0) go to 400 call DDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) go to 100 ! The corrector has converged. CONVRG is set ! to .TRUE. if partial derivatives were used, ! to indicate that they may need updating on ! subsequent steps. The error test is made. 170 CONVRG = (MITER /= 0) if (IERROR == 1 .OR. IERROR == 5) THEN DO 180 I = 1,NDE 180 SAVE2(I) = SAVE1(I)/YWT(I) ELSE DO 185 I = 1,NDE 185 SAVE2(I) = SAVE1(I)/MAX(ABS(Y(I)), YWT(I)) end if ETEST = DNRM2(NDE, SAVE2, 1)/(TQ(2,NQ)*SQRT(DBLE(NDE))) ! ! The error test failed. NFAIL keeps track of ! multiple failures. Restore T and the YH ! array to their previous values, and prepare ! to try the step again. Compute the optimum ! step size for this or one lower order. if (ETEST > EPS) THEN T = TOLD call DDPSC (-1, N, NQ, YH) NFAIL = NFAIL + 1 if (NFAIL < MXFAIL .OR. NQ == 1) THEN if (JTASK /= 0 .AND. JTASK /= 2) RMAX = RMFAIL RH2 = 1.D0/(BIAS2*(ETEST/EPS)**(1.D0/(NQ+1))) if (NQ > 1) THEN if (IERROR == 1 .OR. IERROR == 5) THEN DO 190 I = 1,NDE 190 SAVE2(I) = YH(I,NQ+1)/YWT(I) ELSE DO 195 I = 1,NDE 195 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), YWT(I)) end if ERDN = DNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(DBLE(NDE))) RH1 = 1.D0/MAX(1.D0, BIAS1*(ERDN/EPS)**(1.D0/NQ)) if (RH2 < RH1) THEN NQ = NQ - 1 RC = RC*EL(1,NQ)/EL(1,NQ+1) RH = RH1 ELSE RH = RH2 end if ELSE RH = RH2 end if NWAIT = NQ + 2 if (RH*H == 0.D0) go to 400 call DDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) go to 100 end if ! Control reaches this section if the error test has ! failed MXFAIL or more times. It is assumed that the ! derivatives that have accumulated in the YH array have ! errors of the wrong order. Hence the first derivative ! is recomputed, the order is set to 1, and the step is ! retried. NFAIL = 0 JTASK = 2 DO 215 I = 1,N 215 Y(I) = YH(I,1) call DDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, & UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, & YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, & RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) RMAX = RMNORM if (N == 0) go to 440 if (H == 0.D0) go to 400 if (IER) go to 420 go to 100 end if ! After a successful step, update the YH array. NSTEP = NSTEP + 1 HUSED = H NQUSED = NQ AVGH = ((NSTEP-1)*AVGH + H)/NSTEP AVGORD = ((NSTEP-1)*AVGORD + NQ)/NSTEP DO 230 J = 1,NQ+1 DO 230 I = 1,N 230 YH(I,J) = YH(I,J) + EL(J,NQ)*SAVE1(I) DO 235 I = 1,N 235 Y(I) = YH(I,1) ! If ISWFLG is 3, consider ! changing integration methods. if (ISWFLG == 3) THEN if (BND /= 0.D0) THEN if (MINT == 1 .AND. NQ <= 5) THEN HN = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.D0/(NQ+1))) HN = MIN(HN, 1.D0/(2.D0*EL(1,NQ)*BND)) HS = ABS(H)/MAX(UROUND, & (ETEST/(EPS*EL(NQ+1,1)))**(1.D0/(NQ+1))) if (HS > 1.2D0*HN) THEN MINT = 2 MNTOLD = MINT MITER = MTRSV MTROLD = MITER MAXORD = MIN(MXRDSV, 5) RC = 0.D0 RMAX = RMNORM TREND = 1.D0 call DDCST (MAXORD, MINT, ISWFLG, EL, TQ) NWAIT = NQ + 2 end if ELSE if (MINT == 2) THEN HS = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.D0/(NQ+1))) HN = ABS(H)/MAX(UROUND, & (ETEST*EL(NQ+1,1)/EPS)**(1.D0/(NQ+1))) HN = MIN(HN, 1.D0/(2.D0*EL(1,NQ)*BND)) if (HN >= HS) THEN MINT = 1 MNTOLD = MINT MITER = 0 MTROLD = MITER MAXORD = MIN(MXRDSV, 12) RMAX = RMNORM TREND = 1.D0 CONVRG = .FALSE. call DDCST (MAXORD, MINT, ISWFLG, EL, TQ) NWAIT = NQ + 2 end if end if end if end if if (SWITCH) THEN MINT = 2 MNTOLD = MINT MITER = MTRSV MTROLD = MITER MAXORD = MIN(MXRDSV, 5) NQ = MIN(NQ, MAXORD) RC = 0.D0 RMAX = RMNORM TREND = 1.D0 call DDCST (MAXORD, MINT, ISWFLG, EL, TQ) NWAIT = NQ + 2 end if ! Consider changing H if NWAIT = 1. Otherwise ! decrease NWAIT by 1. If NWAIT is then 1 and ! NQ < MAXORD, then SAVE1 is saved for use in ! a possible order increase on the next step. ! if (JTASK == 0 .OR. JTASK == 2) THEN RH = 1.D0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.D0/(NQ+1))) if (RH > TRSHLD) call DDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) ELSE if (NWAIT > 1) THEN NWAIT = NWAIT - 1 if (NWAIT == 1 .AND. NQ < MAXORD) THEN DO 250 I = 1,NDE 250 YH(I,MAXORD+1) = SAVE1(I) end if ! If a change in H is considered, an increase or decrease in ! order by one is considered also. A change in H is made ! only if it is by a factor of at least TRSHLD. Factors ! RH1, RH2, and RH3 are computed, by which H could be ! multiplied at order NQ - 1, order NQ, or order NQ + 1, ! respectively. The largest of these is determined and the ! new order chosen accordingly. If the order is to be ! increased, we compute one additional scaled derivative. ! If there is a change of order, reset NQ and the ! coefficients. In any case H is reset according to RH and ! the YH array is rescaled. ELSE if (NQ == 1) THEN RH1 = 0.D0 ELSE if (IERROR == 1 .OR. IERROR == 5) THEN DO 270 I = 1,NDE 270 SAVE2(I) = YH(I,NQ+1)/YWT(I) ELSE DO 275 I = 1,NDE 275 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), YWT(I)) end if ERDN = DNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(DBLE(NDE))) RH1 = 1.D0/MAX(UROUND, BIAS1*(ERDN/EPS)**(1.D0/NQ)) end if RH2 = 1.D0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.D0/(NQ+1))) if (NQ == MAXORD) THEN RH3 = 0.D0 ELSE if (IERROR == 1 .OR. IERROR == 5) THEN DO 290 I = 1,NDE 290 SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/YWT(I) ELSE DO 295 I = 1,NDE SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/ & MAX(ABS(Y(I)), YWT(I)) 295 CONTINUE end if ERUP = DNRM2(NDE, SAVE2, 1)/(TQ(3,NQ)*SQRT(DBLE(NDE))) RH3 = 1.D0/MAX(UROUND, BIAS3*(ERUP/EPS)**(1.D0/(NQ+2))) end if if (RH1 > RH2 .AND. RH1 >= RH3) THEN RH = RH1 if (RH <= TRSHLD) go to 380 NQ = NQ - 1 RC = RC*EL(1,NQ)/EL(1,NQ+1) ELSE if (RH2 >= RH1 .AND. RH2 >= RH3) THEN RH = RH2 if (RH <= TRSHLD) go to 380 ELSE RH = RH3 if (RH <= TRSHLD) go to 380 DO 360 I = 1,N 360 YH(I,NQ+2) = SAVE1(I)*EL(NQ+1,NQ)/(NQ+1) NQ = NQ + 1 RC = RC*EL(1,NQ)/EL(1,NQ-1) end if if (ISWFLG == 3 .AND. MINT == 1) THEN if (BND /= 0.D0) RH = MIN(RH, 1.D0/(2.D0*EL(1,NQ)*BND*ABS(H))) end if call DDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) RMAX = RMNORM 380 NWAIT = NQ + 2 end if ! All returns are made through this section. H is saved ! in HOLD to allow the caller to change H on the next step JSTATE = 1 HOLD = H return ! 400 JSTATE = 2 HOLD = H DO 405 I = 1,N 405 Y(I) = YH(I,1) return ! 410 JSTATE = 3 HOLD = H return ! 420 JSTATE = 4 HOLD = H return ! 430 T = TOLD call DDPSC (-1, NSV, NQ, YH) DO 435 I = 1,NSV 435 Y(I) = YH(I,1) 440 HOLD = H return end subroutine DDZRO (AE, F, H, N, NQ, IROOT, RE, T, YH, UROUND, B, C, & FB, FC, Y) ! !! DDZRO searches for a zero of a function F(N, T, Y, IROOT) ... ! between the given values B and C until the width of the ... ! interval (B, C) has collapsed to within a tolerance ... ! specified by the stopping criterion, ... ! ABS(B - C) <= 2.*(RW*ABS(B) + AE). ! !***LIBRARY SLATEC (SDRIVE) !***TYPE DOUBLE PRECISION (SDZRO-S, DDZRO-D, CDZRO-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! This is a special purpose version of ZEROIN, modified for use with ! the DDRIV package. ! ! Sandia Mathematical Program Library ! Mathematical Computing Services Division 5422 ! Sandia Laboratories ! P. O. Box 5800 ! Albuquerque, New Mexico 87115 ! Control Data 6600 Version 4.5, 1 November 1971 ! ! PARAMETERS ! F - Name of the external function, which returns a ! double precision result. This name must be in an ! EXTERNAL statement in the calling program. ! B - One end of the interval (B, C). The value returned for ! B usually is the better approximation to a zero of F. ! C - The other end of the interval (B, C). ! RE - Relative error used for RW in the stopping criterion. ! If the requested RE is less than machine precision, ! then RW is set to approximately machine precision. ! AE - Absolute error used in the stopping criterion. If the ! given interval (B, C) contains the origin, then a ! nonzero value should be chosen for AE. ! !***REFERENCES L. F. Shampine and H. A. Watts, ZEROIN, a root-solving ! routine, SC-TM-70-631, Sept 1970. ! T. J. Dekker, Finding a zero by means of successive ! linear interpolation, Constructive Aspects of the ! Fundamental Theorem of Algebra, edited by B. Dejon ! and P. Henrici, 1969. !***ROUTINES CALLED DDNTP !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE DDZRO INTEGER IC, IROOT, KOUNT, N, NQ DOUBLE PRECISION A, ACBS, ACMB, AE, B, C, CMB, ER, F, FA, FB, FC, & H, P, Q, RE, RW, T, TOL, UROUND, Y(*), YH(N,*) !***FIRST EXECUTABLE STATEMENT DDZRO ER = 4.D0*UROUND RW = MAX(RE, ER) IC = 0 ACBS = ABS(B - C) A = C FA = FC KOUNT = 0 ! Perform interchange 10 if (ABS(FC) < ABS(FB)) THEN A = B FA = FB B = C FB = FC C = A FC = FA end if CMB = 0.5D0*(C - B) ACMB = ABS(CMB) TOL = RW*ABS(B) + AE ! Test stopping criterion if (ACMB <= TOL) RETURN if (KOUNT > 50) RETURN ! Calculate new iterate implicitly as ! B + P/Q, where we arrange P >= 0. ! The implicit form is used to prevent overflow. P = (B - A)*FB Q = FA - FB if (P < 0.D0) THEN P = -P Q = -Q end if ! Update A and check for satisfactory reduction ! in the size of our bounding interval. A = B FA = FB IC = IC + 1 if (IC >= 4) THEN if (8.D0*ACMB >= ACBS) THEN ! Bisect B = 0.5D0*(C + B) go to 20 end if IC = 0 end if ACBS = ACMB ! Test for too small a change if (P <= ABS(Q)*TOL) THEN ! Increment by tolerance B = B + SIGN(TOL, CMB) ! Root ought to be between ! B and (C + B)/2. ELSE if (P < CMB*Q) THEN ! Interpolate B = B + P/Q ELSE ! Bisect B = 0.5D0*(C + B) end if ! Have completed computation ! for new iterate B. 20 call DDNTP (H, 0, N, NQ, T, B, YH, Y) FB = F(N, B, Y, IROOT) if (N == 0) RETURN if (FB == 0.D0) RETURN KOUNT = KOUNT + 1 ! ! Decide whether next step is interpolation or extrapolation ! if (SIGN(1.0D0, FB) == SIGN(1.0D0, FC)) THEN C = A FC = FA end if go to 10 end DOUBLE PRECISION FUNCTION DE1 (X) ! !! DE1 computes the exponential integral E1(X). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C5 !***TYPE DOUBLE PRECISION (E1-S, DE1-D) !***KEYWORDS E1 FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DE1 calculates the double precision exponential integral, E1(X), for ! positive double precision argument X and the Cauchy principal value ! for negative X. If principal values are used everywhere, then, for ! all X, ! ! E1(X) = -Ei(-X) ! or ! Ei(X) = -E1(-X). ! ! ! Series for AE10 on the interval -3.12500E-02 to 0. ! with weighted error 4.62E-32 ! log weighted error 31.34 ! significant figures required 29.70 ! decimal places required 32.18 ! ! ! Series for AE11 on the interval -1.25000E-01 to -3.12500E-02 ! with weighted error 2.22E-32 ! log weighted error 31.65 ! significant figures required 30.75 ! decimal places required 32.54 ! ! ! Series for AE12 on the interval -2.50000E-01 to -1.25000E-01 ! with weighted error 5.19E-32 ! log weighted error 31.28 ! significant figures required 30.82 ! decimal places required 32.09 ! ! ! Series for E11 on the interval -4.00000E+00 to -1.00000E+00 ! with weighted error 8.49E-34 ! log weighted error 33.07 ! significant figures required 34.13 ! decimal places required 33.80 ! ! ! Series for E12 on the interval -1.00000E+00 to 1.00000E+00 ! with weighted error 8.08E-33 ! log weighted error 32.09 ! approx significant figures required 30.4 ! decimal places required 32.79 ! ! ! Series for AE13 on the interval 2.50000E-01 to 1.00000E+00 ! with weighted error 6.65E-32 ! log weighted error 31.18 ! significant figures required 30.69 ! decimal places required 32.03 ! ! ! Series for AE14 on the interval 0. to 2.50000E-01 ! with weighted error 5.07E-32 ! log weighted error 31.30 ! significant figures required 30.40 ! decimal places required 32.20 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891115 Modified prologue description. (WRB) ! 891115 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE DE1 DOUBLE PRECISION X, AE10CS(50), AE11CS(60), AE12CS(41), E11CS(29), & E12CS(25), AE13CS(50), AE14CS(64), XMAX, XMAXT, D1MACH, DCSEVL LOGICAL FIRST SAVE AE10CS, AE11CS, AE12CS, E11CS, E12CS, AE13CS, AE14CS, & NTAE10, NTAE11, NTAE12, NTE11, NTE12, NTAE13, NTAE14, XMAX, & FIRST DATA AE10CS( 1) / +.3284394579616699087873844201881D-1 / DATA AE10CS( 2) / -.1669920452031362851476184343387D-1 / DATA AE10CS( 3) / +.2845284724361346807424899853252D-3 / DATA AE10CS( 4) / -.7563944358516206489487866938533D-5 / DATA AE10CS( 5) / +.2798971289450859157504843180879D-6 / DATA AE10CS( 6) / -.1357901828534531069525563926255D-7 / DATA AE10CS( 7) / +.8343596202040469255856102904906D-9 / DATA AE10CS( 8) / -.6370971727640248438275242988532D-10 / DATA AE10CS( 9) / +.6007247608811861235760831561584D-11 / DATA AE10CS( 10) / -.7022876174679773590750626150088D-12 / DATA AE10CS( 11) / +.1018302673703687693096652346883D-12 / DATA AE10CS( 12) / -.1761812903430880040406309966422D-13 / DATA AE10CS( 13) / +.3250828614235360694244030353877D-14 / DATA AE10CS( 14) / -.5071770025505818678824872259044D-15 / DATA AE10CS( 15) / +.1665177387043294298172486084156D-16 / DATA AE10CS( 16) / +.3166753890797514400677003536555D-16 / DATA AE10CS( 17) / -.1588403763664141515133118343538D-16 / DATA AE10CS( 18) / +.4175513256138018833003034618484D-17 / DATA AE10CS( 19) / -.2892347749707141906710714478852D-18 / DATA AE10CS( 20) / -.2800625903396608103506340589669D-18 / DATA AE10CS( 21) / +.1322938639539270903707580023781D-18 / DATA AE10CS( 22) / -.1804447444177301627283887833557D-19 / DATA AE10CS( 23) / -.7905384086522616076291644817604D-20 / DATA AE10CS( 24) / +.4435711366369570103946235838027D-20 / DATA AE10CS( 25) / -.4264103994978120868865309206555D-21 / DATA AE10CS( 26) / -.3920101766937117541553713162048D-21 / DATA AE10CS( 27) / +.1527378051343994266343752326971D-21 / DATA AE10CS( 28) / +.1024849527049372339310308783117D-22 / DATA AE10CS( 29) / -.2134907874771433576262711405882D-22 / DATA AE10CS( 30) / +.3239139475160028267061694700366D-23 / DATA AE10CS( 31) / +.2142183762299889954762643168296D-23 / DATA AE10CS( 32) / -.8234609419601018414700348082312D-24 / DATA AE10CS( 33) / -.1524652829645809479613694401140D-24 / DATA AE10CS( 34) / +.1378208282460639134668480364325D-24 / DATA AE10CS( 35) / +.2131311202833947879523224999253D-26 / DATA AE10CS( 36) / -.2012649651526484121817466763127D-25 / DATA AE10CS( 37) / +.1995535662263358016106311782673D-26 / DATA AE10CS( 38) / +.2798995808984003464948686520319D-26 / DATA AE10CS( 39) / -.5534511845389626637640819277823D-27 / DATA AE10CS( 40) / -.3884995396159968861682544026146D-27 / DATA AE10CS( 41) / +.1121304434507359382850680354679D-27 / DATA AE10CS( 42) / +.5566568152423740948256563833514D-28 / DATA AE10CS( 43) / -.2045482929810499700448533938176D-28 / DATA AE10CS( 44) / -.8453813992712336233411457493674D-29 / DATA AE10CS( 45) / +.3565758433431291562816111116287D-29 / DATA AE10CS( 46) / +.1383653872125634705539949098871D-29 / DATA AE10CS( 47) / -.6062167864451372436584533764778D-30 / DATA AE10CS( 48) / -.2447198043989313267437655119189D-30 / DATA AE10CS( 49) / +.1006850640933998348011548180480D-30 / DATA AE10CS( 50) / +.4623685555014869015664341461674D-31 / DATA AE11CS( 1) / +.20263150647078889499401236517381D+0 / DATA AE11CS( 2) / -.73655140991203130439536898728034D-1 / DATA AE11CS( 3) / +.63909349118361915862753283840020D-2 / DATA AE11CS( 4) / -.60797252705247911780653153363999D-3 / DATA AE11CS( 5) / -.73706498620176629330681411493484D-4 / DATA AE11CS( 6) / +.48732857449450183453464992488076D-4 / DATA AE11CS( 7) / -.23837064840448290766588489460235D-5 / DATA AE11CS( 8) / -.30518612628561521027027332246121D-5 / DATA AE11CS( 9) / +.17050331572564559009688032992907D-6 / DATA AE11CS( 10) / +.23834204527487747258601598136403D-6 / DATA AE11CS( 11) / +.10781772556163166562596872364020D-7 / DATA AE11CS( 12) / -.17955692847399102653642691446599D-7 / DATA AE11CS( 13) / -.41284072341950457727912394640436D-8 / DATA AE11CS( 14) / +.68622148588631968618346844526664D-9 / DATA AE11CS( 15) / +.53130183120506356147602009675961D-9 / DATA AE11CS( 16) / +.78796880261490694831305022893515D-10 / DATA AE11CS( 17) / -.26261762329356522290341675271232D-10 / DATA AE11CS( 18) / -.15483687636308261963125756294100D-10 / DATA AE11CS( 19) / -.25818962377261390492802405122591D-11 / DATA AE11CS( 20) / +.59542879191591072658903529959352D-12 / DATA AE11CS( 21) / +.46451400387681525833784919321405D-12 / DATA AE11CS( 22) / +.11557855023255861496288006203731D-12 / DATA AE11CS( 23) / -.10475236870835799012317547189670D-14 / DATA AE11CS( 24) / -.11896653502709004368104489260929D-13 / DATA AE11CS( 25) / -.47749077490261778752643019349950D-14 / DATA AE11CS( 26) / -.81077649615772777976249734754135D-15 / DATA AE11CS( 27) / +.13435569250031554199376987998178D-15 / DATA AE11CS( 28) / +.14134530022913106260248873881287D-15 / DATA AE11CS( 29) / +.49451592573953173115520663232883D-16 / DATA AE11CS( 30) / +.79884048480080665648858587399367D-17 / DATA AE11CS( 31) / -.14008632188089809829248711935393D-17 / DATA AE11CS( 32) / -.14814246958417372107722804001680D-17 / DATA AE11CS( 33) / -.55826173646025601904010693937113D-18 / DATA AE11CS( 34) / -.11442074542191647264783072544598D-18 / DATA AE11CS( 35) / +.25371823879566853500524018479923D-20 / DATA AE11CS( 36) / +.13205328154805359813278863389097D-19 / DATA AE11CS( 37) / +.62930261081586809166287426789485D-20 / DATA AE11CS( 38) / +.17688270424882713734999261332548D-20 / DATA AE11CS( 39) / +.23266187985146045209674296887432D-21 / DATA AE11CS( 40) / -.67803060811125233043773831844113D-22 / DATA AE11CS( 41) / -.59440876959676373802874150531891D-22 / DATA AE11CS( 42) / -.23618214531184415968532592503466D-22 / DATA AE11CS( 43) / -.60214499724601478214168478744576D-23 / DATA AE11CS( 44) / -.65517906474348299071370444144639D-24 / DATA AE11CS( 45) / +.29388755297497724587042038699349D-24 / DATA AE11CS( 46) / +.22601606200642115173215728758510D-24 / DATA AE11CS( 47) / +.89534369245958628745091206873087D-25 / DATA AE11CS( 48) / +.24015923471098457555772067457706D-25 / DATA AE11CS( 49) / +.34118376888907172955666423043413D-26 / DATA AE11CS( 50) / -.71617071694630342052355013345279D-27 / DATA AE11CS( 51) / -.75620390659281725157928651980799D-27 / DATA AE11CS( 52) / -.33774612157467324637952920780800D-27 / DATA AE11CS( 53) / -.10479325703300941711526430332245D-27 / DATA AE11CS( 54) / -.21654550252170342240854880201386D-28 / DATA AE11CS( 55) / -.75297125745288269994689298432000D-30 / DATA AE11CS( 56) / +.19103179392798935768638084000426D-29 / DATA AE11CS( 57) / +.11492104966530338547790728833706D-29 / DATA AE11CS( 58) / +.43896970582661751514410359193600D-30 / DATA AE11CS( 59) / +.12320883239205686471647157725866D-30 / DATA AE11CS( 60) / +.22220174457553175317538581162666D-31 / DATA AE12CS( 1) / +.63629589796747038767129887806803D+0 / DATA AE12CS( 2) / -.13081168675067634385812671121135D+0 / DATA AE12CS( 3) / -.84367410213053930014487662129752D-2 / DATA AE12CS( 4) / +.26568491531006685413029428068906D-2 / DATA AE12CS( 5) / +.32822721781658133778792170142517D-3 / DATA AE12CS( 6) / -.23783447771430248269579807851050D-4 / DATA AE12CS( 7) / -.11439804308100055514447076797047D-4 / DATA AE12CS( 8) / -.14405943433238338455239717699323D-5 / DATA AE12CS( 9) / +.52415956651148829963772818061664D-8 / DATA AE12CS( 10) / +.38407306407844323480979203059716D-7 / DATA AE12CS( 11) / +.85880244860267195879660515759344D-8 / DATA AE12CS( 12) / +.10219226625855003286339969553911D-8 / DATA AE12CS( 13) / +.21749132323289724542821339805992D-10 / DATA AE12CS( 14) / -.22090238142623144809523503811741D-10 / DATA AE12CS( 15) / -.63457533544928753294383622208801D-11 / DATA AE12CS( 16) / -.10837746566857661115340539732919D-11 / DATA AE12CS( 17) / -.11909822872222586730262200440277D-12 / DATA AE12CS( 18) / -.28438682389265590299508766008661D-14 / DATA AE12CS( 19) / +.25080327026686769668587195487546D-14 / DATA AE12CS( 20) / +.78729641528559842431597726421265D-15 / DATA AE12CS( 21) / +.15475066347785217148484334637329D-15 / DATA AE12CS( 22) / +.22575322831665075055272608197290D-16 / DATA AE12CS( 23) / +.22233352867266608760281380836693D-17 / DATA AE12CS( 24) / +.16967819563544153513464194662399D-19 / DATA AE12CS( 25) / -.57608316255947682105310087304533D-19 / DATA AE12CS( 26) / -.17591235774646878055625369408853D-19 / DATA AE12CS( 27) / -.36286056375103174394755328682666D-20 / DATA AE12CS( 28) / -.59235569797328991652558143488000D-21 / DATA AE12CS( 29) / -.76030380926310191114429136895999D-22 / DATA AE12CS( 30) / -.62547843521711763842641428479999D-23 / DATA AE12CS( 31) / +.25483360759307648606037606400000D-24 / DATA AE12CS( 32) / +.25598615731739857020168874666666D-24 / DATA AE12CS( 33) / +.71376239357899318800207052800000D-25 / DATA AE12CS( 34) / +.14703759939567568181578956800000D-25 / DATA AE12CS( 35) / +.25105524765386733555198634666666D-26 / DATA AE12CS( 36) / +.35886666387790890886583637333333D-27 / DATA AE12CS( 37) / +.39886035156771301763317759999999D-28 / DATA AE12CS( 38) / +.21763676947356220478805333333333D-29 / DATA AE12CS( 39) / -.46146998487618942367607466666666D-30 / DATA AE12CS( 40) / -.20713517877481987707153066666666D-30 / DATA AE12CS( 41) / -.51890378563534371596970666666666D-31 / DATA E11CS( 1) / -.16113461655571494025720663927566180D+2 / DATA E11CS( 2) / +.77940727787426802769272245891741497D+1 / DATA E11CS( 3) / -.19554058188631419507127283812814491D+1 / DATA E11CS( 4) / +.37337293866277945611517190865690209D+0 / DATA E11CS( 5) / -.56925031910929019385263892220051166D-1 / DATA E11CS( 6) / +.72110777696600918537847724812635813D-2 / DATA E11CS( 7) / -.78104901449841593997715184089064148D-3 / DATA E11CS( 8) / +.73880933562621681878974881366177858D-4 / DATA E11CS( 9) / -.62028618758082045134358133607909712D-5 / DATA E11CS( 10) / +.46816002303176735524405823868362657D-6 / DATA E11CS( 11) / -.32092888533298649524072553027228719D-7 / DATA E11CS( 12) / +.20151997487404533394826262213019548D-8 / DATA E11CS( 13) / -.11673686816697793105356271695015419D-9 / DATA E11CS( 14) / +.62762706672039943397788748379615573D-11 / DATA E11CS( 15) / -.31481541672275441045246781802393600D-12 / DATA E11CS( 16) / +.14799041744493474210894472251733333D-13 / DATA E11CS( 17) / -.65457091583979673774263401588053333D-15 / DATA E11CS( 18) / +.27336872223137291142508012748799999D-16 / DATA E11CS( 19) / -.10813524349754406876721727624533333D-17 / DATA E11CS( 20) / +.40628328040434303295300348586666666D-19 / DATA E11CS( 21) / -.14535539358960455858914372266666666D-20 / DATA E11CS( 22) / +.49632746181648636830198442666666666D-22 / DATA E11CS( 23) / -.16208612696636044604866560000000000D-23 / DATA E11CS( 24) / +.50721448038607422226431999999999999D-25 / DATA E11CS( 25) / -.15235811133372207813973333333333333D-26 / DATA E11CS( 26) / +.44001511256103618696533333333333333D-28 / DATA E11CS( 27) / -.12236141945416231594666666666666666D-29 / DATA E11CS( 28) / +.32809216661066001066666666666666666D-31 / DATA E11CS( 29) / -.84933452268306432000000000000000000D-33 / DATA E12CS( 1) / -.3739021479220279511668698204827D-1 / DATA E12CS( 2) / +.4272398606220957726049179176528D-1 / DATA E12CS( 3) / -.130318207984970054415392055219726D+0 / DATA E12CS( 4) / +.144191240246988907341095893982137D-1 / DATA E12CS( 5) / -.134617078051068022116121527983553D-2 / DATA E12CS( 6) / +.107310292530637799976115850970073D-3 / DATA E12CS( 7) / -.742999951611943649610283062223163D-5 / DATA E12CS( 8) / +.453773256907537139386383211511827D-6 / DATA E12CS( 9) / -.247641721139060131846547423802912D-7 / DATA E12CS( 10) / +.122076581374590953700228167846102D-8 / DATA E12CS( 11) / -.548514148064092393821357398028261D-10 / DATA E12CS( 12) / +.226362142130078799293688162377002D-11 / DATA E12CS( 13) / -.863589727169800979404172916282240D-13 / DATA E12CS( 14) / +.306291553669332997581032894881279D-14 / DATA E12CS( 15) / -.101485718855944147557128906734933D-15 / DATA E12CS( 16) / +.315482174034069877546855328426666D-17 / DATA E12CS( 17) / -.923604240769240954484015923200000D-19 / DATA E12CS( 18) / +.255504267970814002440435029333333D-20 / DATA E12CS( 19) / -.669912805684566847217882453333333D-22 / DATA E12CS( 20) / +.166925405435387319431987199999999D-23 / DATA E12CS( 21) / -.396254925184379641856000000000000D-25 / DATA E12CS( 22) / +.898135896598511332010666666666666D-27 / DATA E12CS( 23) / -.194763366993016433322666666666666D-28 / DATA E12CS( 24) / +.404836019024630033066666666666666D-30 / DATA E12CS( 25) / -.807981567699845120000000000000000D-32 / DATA AE13CS( 1) / -.60577324664060345999319382737747D+0 / DATA AE13CS( 2) / -.11253524348366090030649768852718D+0 / DATA AE13CS( 3) / +.13432266247902779492487859329414D-1 / DATA AE13CS( 4) / -.19268451873811457249246838991303D-2 / DATA AE13CS( 5) / +.30911833772060318335586737475368D-3 / DATA AE13CS( 6) / -.53564132129618418776393559795147D-4 / DATA AE13CS( 7) / +.98278128802474923952491882717237D-5 / DATA AE13CS( 8) / -.18853689849165182826902891938910D-5 / DATA AE13CS( 9) / +.37494319356894735406964042190531D-6 / DATA AE13CS( 10) / -.76823455870552639273733465680556D-7 / DATA AE13CS( 11) / +.16143270567198777552956300060868D-7 / DATA AE13CS( 12) / -.34668022114907354566309060226027D-8 / DATA AE13CS( 13) / +.75875420919036277572889747054114D-9 / DATA AE13CS( 14) / -.16886433329881412573514526636703D-9 / DATA AE13CS( 15) / +.38145706749552265682804250927272D-10 / DATA AE13CS( 16) / -.87330266324446292706851718272334D-11 / DATA AE13CS( 17) / +.20236728645867960961794311064330D-11 / DATA AE13CS( 18) / -.47413283039555834655210340820160D-12 / DATA AE13CS( 19) / +.11221172048389864324731799928920D-12 / DATA AE13CS( 20) / -.26804225434840309912826809093395D-13 / DATA AE13CS( 21) / +.64578514417716530343580369067212D-14 / DATA AE13CS( 22) / -.15682760501666478830305702849194D-14 / DATA AE13CS( 23) / +.38367865399315404861821516441408D-15 / DATA AE13CS( 24) / -.94517173027579130478871048932556D-16 / DATA AE13CS( 25) / +.23434812288949573293896666439133D-16 / DATA AE13CS( 26) / -.58458661580214714576123194419882D-17 / DATA AE13CS( 27) / +.14666229867947778605873617419195D-17 / DATA AE13CS( 28) / -.36993923476444472706592538274474D-18 / DATA AE13CS( 29) / +.93790159936721242136014291817813D-19 / DATA AE13CS( 30) / -.23893673221937873136308224087381D-19 / DATA AE13CS( 31) / +.61150624629497608051934223837866D-20 / DATA AE13CS( 32) / -.15718585327554025507719853288106D-20 / DATA AE13CS( 33) / +.40572387285585397769519294491306D-21 / DATA AE13CS( 34) / -.10514026554738034990566367122773D-21 / DATA AE13CS( 35) / +.27349664930638667785806003131733D-22 / DATA AE13CS( 36) / -.71401604080205796099355574271999D-23 / DATA AE13CS( 37) / +.18705552432235079986756924211199D-23 / DATA AE13CS( 38) / -.49167468166870480520478020949333D-24 / DATA AE13CS( 39) / +.12964988119684031730916087125333D-24 / DATA AE13CS( 40) / -.34292515688362864461623940437333D-25 / DATA AE13CS( 41) / +.90972241643887034329104820906666D-26 / DATA AE13CS( 42) / -.24202112314316856489934847999999D-26 / DATA AE13CS( 43) / +.64563612934639510757670475093333D-27 / DATA AE13CS( 44) / -.17269132735340541122315987626666D-27 / DATA AE13CS( 45) / +.46308611659151500715194231466666D-28 / DATA AE13CS( 46) / -.12448703637214131241755170133333D-28 / DATA AE13CS( 47) / +.33544574090520678532907007999999D-29 / DATA AE13CS( 48) / -.90598868521070774437543935999999D-30 / DATA AE13CS( 49) / +.24524147051474238587273216000000D-30 / DATA AE13CS( 50) / -.66528178733552062817107967999999D-31 / DATA AE14CS( 1) / -.1892918000753016825495679942820D+0 / DATA AE14CS( 2) / -.8648117855259871489968817056824D-1 / DATA AE14CS( 3) / +.7224101543746594747021514839184D-2 / DATA AE14CS( 4) / -.8097559457557386197159655610181D-3 / DATA AE14CS( 5) / +.1099913443266138867179251157002D-3 / DATA AE14CS( 6) / -.1717332998937767371495358814487D-4 / DATA AE14CS( 7) / +.2985627514479283322825342495003D-5 / DATA AE14CS( 8) / -.5659649145771930056560167267155D-6 / DATA AE14CS( 9) / +.1152680839714140019226583501663D-6 / DATA AE14CS( 10) / -.2495030440269338228842128765065D-7 / DATA AE14CS( 11) / +.5692324201833754367039370368140D-8 / DATA AE14CS( 12) / -.1359957664805600338490030939176D-8 / DATA AE14CS( 13) / +.3384662888760884590184512925859D-9 / DATA AE14CS( 14) / -.8737853904474681952350849316580D-10 / DATA AE14CS( 15) / +.2331588663222659718612613400470D-10 / DATA AE14CS( 16) / -.6411481049213785969753165196326D-11 / DATA AE14CS( 17) / +.1812246980204816433384359484682D-11 / DATA AE14CS( 18) / -.5253831761558460688819403840466D-12 / DATA AE14CS( 19) / +.1559218272591925698855028609825D-12 / DATA AE14CS( 20) / -.4729168297080398718476429369466D-13 / DATA AE14CS( 21) / +.1463761864393243502076199493808D-13 / DATA AE14CS( 22) / -.4617388988712924102232173623604D-14 / DATA AE14CS( 23) / +.1482710348289369323789239660371D-14 / DATA AE14CS( 24) / -.4841672496239229146973165734417D-15 / DATA AE14CS( 25) / +.1606215575700290408116571966188D-15 / DATA AE14CS( 26) / -.5408917538957170947895023784252D-16 / DATA AE14CS( 27) / +.1847470159346897881370231402310D-16 / DATA AE14CS( 28) / -.6395830792759094470500610425050D-17 / DATA AE14CS( 29) / +.2242780721699759457250233276170D-17 / DATA AE14CS( 30) / -.7961369173983947552744555308646D-18 / DATA AE14CS( 31) / +.2859308111540197459808619929272D-18 / DATA AE14CS( 32) / -.1038450244701137145900697137446D-18 / DATA AE14CS( 33) / +.3812040607097975780866841008319D-19 / DATA AE14CS( 34) / -.1413795417717200768717562723696D-19 / DATA AE14CS( 35) / +.5295367865182740958305442594815D-20 / DATA AE14CS( 36) / -.2002264245026825902137211131439D-20 / DATA AE14CS( 37) / +.7640262751275196014736848610918D-21 / DATA AE14CS( 38) / -.2941119006868787883311263523362D-21 / DATA AE14CS( 39) / +.1141823539078927193037691483586D-21 / DATA AE14CS( 40) / -.4469308475955298425247020718489D-22 / DATA AE14CS( 41) / +.1763262410571750770630491408520D-22 / DATA AE14CS( 42) / -.7009968187925902356351518262340D-23 / DATA AE14CS( 43) / +.2807573556558378922287757507515D-23 / DATA AE14CS( 44) / -.1132560944981086432141888891562D-23 / DATA AE14CS( 45) / +.4600574684375017946156764233727D-24 / DATA AE14CS( 46) / -.1881448598976133459864609148108D-24 / DATA AE14CS( 47) / +.7744916111507730845444328478037D-25 / DATA AE14CS( 48) / -.3208512760585368926702703826261D-25 / DATA AE14CS( 49) / +.1337445542910839760619930421384D-25 / DATA AE14CS( 50) / -.5608671881802217048894771735210D-26 / DATA AE14CS( 51) / +.2365839716528537483710069473279D-26 / DATA AE14CS( 52) / -.1003656195025305334065834526856D-26 / DATA AE14CS( 53) / +.4281490878094161131286642556927D-27 / DATA AE14CS( 54) / -.1836345261815318199691326958250D-27 / DATA AE14CS( 55) / +.7917798231349540000097468678144D-28 / DATA AE14CS( 56) / -.3431542358742220361025015775231D-28 / DATA AE14CS( 57) / +.1494705493897103237475066008917D-28 / DATA AE14CS( 58) / -.6542620279865705439739042420053D-29 / DATA AE14CS( 59) / +.2877581395199171114340487353685D-29 / DATA AE14CS( 60) / -.1271557211796024711027981200042D-29 / DATA AE14CS( 61) / +.5644615555648722522388044622506D-30 / DATA AE14CS( 62) / -.2516994994284095106080616830293D-30 / DATA AE14CS( 63) / +.1127259818927510206370368804181D-30 / DATA AE14CS( 64) / -.5069814875800460855562584719360D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DE1 if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NTAE10 = INITDS (AE10CS, 50, ETA) NTAE11 = INITDS (AE11CS, 60, ETA) NTAE12 = INITDS (AE12CS, 41, ETA) NTE11 = INITDS (E11CS, 29, ETA) NTE12 = INITDS (E12CS, 25, ETA) NTAE13 = INITDS (AE13CS, 50, ETA) NTAE14 = INITDS (AE14CS, 64, ETA) ! XMAXT = -LOG(D1MACH(1)) XMAX = XMAXT - LOG(XMAXT) end if FIRST = .FALSE. ! if (X > (-1.D0)) go to 50 if (X > (-32.D0)) go to 20 DE1 = EXP(-X)/X * (1.D0 + DCSEVL (64.D0/X+1.D0, AE10CS, NTAE10)) return ! 20 if (X > (-8.D0)) go to 30 DE1 = EXP(-X)/X * (1.D0 + DCSEVL ((64.D0/X+5.D0)/3.D0, AE11CS, & NTAE11)) return ! 30 if (X > (-4.D0)) go to 40 DE1 = EXP(-X)/X * (1.D0 + DCSEVL (16.D0/X+3.D0, AE12CS, NTAE12)) return ! 40 DE1 = -LOG(-X) + DCSEVL ((2.D0*X+5.D0)/3.D0, E11CS, NTE11) return ! 50 if (X > 1.0D0) go to 60 if (X == 0.D0) call XERMSG ('SLATEC', 'DE1', 'X IS 0', 2, 2) DE1 = (-LOG(ABS(X)) - 0.6875D0 + X) + DCSEVL (X, E12CS, NTE12) return ! 60 if (X > 4.0D0) go to 70 DE1 = EXP(-X)/X * (1.D0 + DCSEVL ((8.D0/X-5.D0)/3.D0, AE13CS, & NTAE13)) return ! 70 if (X > XMAX) go to 80 DE1 = EXP(-X)/X * (1.D0 + DCSEVL (8.D0/X-1.D0, AE14CS, NTAE14)) return ! 80 call XERMSG ('SLATEC', 'DE1', 'X SO BIG E1 UNDERFLOWS', 1, 1) DE1 = 0.D0 return ! end subroutine DEABM (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, & RWORK, LRW, IWORK, LIW, RPAR, IPAR) ! !! DEABM solves an initial value problem in ordinary differential ... ! equations using an Adams-Bashforth method. ! !***LIBRARY SLATEC (DEPAC) !***CATEGORY I1A1B !***TYPE SINGLE PRECISION (DEABM-S, DDEABM-D) !***KEYWORDS ADAMS-BASHFORTH METHOD, DEPAC, INITIAL VALUE PROBLEMS, ! ODE, ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR !***AUTHOR Shampine, L. F., (SNLA) ! Watts, H. A., (SNLA) !***DESCRIPTION ! ! This is the Adams code in the package of differential equation ! solvers DEPAC, consisting of the codes DERKF, DEABM, and DEBDF. ! Design of the package was by L. F. Shampine and H. A. Watts. ! It is documented in ! SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE ! Solvers. ! DEABM is a driver for a modification of the code ODE written by ! L. F. Shampine and M. K. Gordon ! Sandia Laboratories ! Albuquerque, New Mexico 87185 ! ! ********************************************************************** ! ** DEPAC PACKAGE OVERVIEW ** ! ************************************************** ! ! You have a choice of three differential equation solvers from ! DEPAC. The following brief descriptions are meant to aid you ! in choosing the most appropriate code for your problem. ! ! DERKF is a fifth order Runge-Kutta code. It is the simplest of ! the three choices, both algorithmically and in the use of the ! code. DERKF is primarily designed to solve non-stiff and mild- ! ly stiff differential equations when derivative evaluations are ! not expensive. It should generally not be used to get high ! accuracy results nor answers at a great many specific points. ! Because DERKF has very low overhead costs, it will usually ! result in the least expensive integration when solving ! problems requiring a modest amount of accuracy and having ! equations that are not costly to evaluate. DERKF attempts to ! discover when it is not suitable for the task posed. ! ! DEABM is a variable order (one through twelve) Adams code. ! Its complexity lies somewhere between that of DERKF and DEBDF. ! DEABM is primarily designed to solve non-stiff and mildly stiff ! differential equations when derivative evaluations are ! expensive, high accuracy results are needed or answers at ! many specific points are required. DEABM attempts to discover ! when it is not suitable for the task posed. ! ! DEBDF is a variable order (one through five) backward ! differentiation formula code. It is the most complicated of ! the three choices. DEBDF is primarily designed to solve stiff ! differential equations at crude to moderate tolerances. ! If the problem is very stiff at all, DERKF and DEABM will be ! quite inefficient compared to DEBDF. However, DEBDF will be ! inefficient compared to DERKF and DEABM on non-stiff problems ! because it uses much more storage, has a much larger overhead, ! and the low order formulas will not give high accuracies ! efficiently. ! ! The concept of stiffness cannot be described in a few words. ! If you do not know the problem to be stiff, try either DERKF ! or DEABM. Both of these codes will inform you of stiffness ! when the cost of solving such problems becomes important. ! ! ********************************************************************** ! ** ABSTRACT ** ! ************** ! ! Subroutine DEABM uses the Adams-Bashforth-Moulton predictor- ! corrector formulas of orders one through twelve to integrate a ! system of NEQ first order ordinary differential equations of the ! form ! DU/DX = F(X,U) ! when the vector Y(*) of initial values for U(*) at X=T is given. The ! subroutine integrates from T to TOUT. It is easy to continue the ! integration to get results at additional TOUT. This is the interval ! mode of operation. It is also easy for the routine to return with ! the solution at each intermediate step on the way to TOUT. This is ! the intermediate-output mode of operation. ! ! DEABM uses subprograms DES, STEPS, SINTRP, HSTART, HVNRM, R1MACH and ! the error handling routine XERMSG. The only machine dependent ! parameters to be assigned appear in R1MACH. ! ! ********************************************************************** ! ** DESCRIPTION OF THE ARGUMENTS TO DEABM (AN OVERVIEW) ** ! ********************************************************* ! ! The parameters are ! ! F -- This is the name of a subroutine which you provide to ! define the differential equations. ! ! NEQ -- This is the number of (first order) differential ! equations to be integrated. ! ! T -- This is a value of the independent variable. ! ! Y(*) -- This array contains the solution components at T. ! ! TOUT -- This is a point at which a solution is desired. ! ! INFO(*) -- The basic task of the code is to integrate the ! differential equations from T to TOUT and return an ! answer at TOUT. INFO(*) is an integer array which is used ! to communicate exactly how you want this task to be ! carried out. ! ! RTOL, ATOL -- These quantities represent relative and absolute ! error tolerances which you provide to indicate how ! accurately you wish the solution to be computed. You may ! choose them to be both scalars or else both vectors. ! ! IDID -- This scalar quantity is an indicator reporting what ! the code did. You must monitor this integer variable to ! decide what action to take next. ! ! RWORK(*), LRW -- RWORK(*) is a real work array of length LRW ! which provides the code with needed storage space. ! ! IWORK(*), LIW -- IWORK(*) is an integer work array of length LIW ! which provides the code with needed storage space and an ! across call flag. ! ! RPAR, IPAR -- These are real and integer parameter arrays which ! you can use for communication between your calling ! program and the F subroutine. ! ! Quantities which are used as input items are ! NEQ, T, Y(*), TOUT, INFO(*), ! RTOL, ATOL, RWORK(1), LRW and LIW. ! ! Quantities which may be altered by the code are ! T, Y(*), INFO(1), RTOL, ATOL, ! IDID, RWORK(*) and IWORK(*). ! ! ********************************************************************** ! ** INPUT -- WHAT TO DO ON THE FIRST call TO DEABM ** ! **************************************************** ! ! The first call of the code is defined to be the start of each new ! problem. Read through the descriptions of all the following items, ! provide sufficient storage space for designated arrays, set ! appropriate variables for the initialization of the problem, and ! give information about how you want the problem to be solved. ! ! ! F -- Provide a subroutine of the form ! F(X,U,UPRIME,RPAR,IPAR) ! to define the system of first order differential equations ! which is to be solved. For the given values of X and the ! vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must ! evaluate the NEQ components of the system of differential ! equations DU/DX = F(X,U) and store the derivatives in ! array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for ! equations I=1,...,NEQ. ! ! Subroutine F must not alter X or U(*). You must declare ! the name F in an external statement in your program that ! calls DEABM. You must dimension U and UPRIME in F. ! ! RPAR and IPAR are real and integer parameter arrays which ! you can use for communication between your calling program ! and subroutine F. They are not used or altered by DEABM. ! If you do not need RPAR or IPAR, ignore these parameters ! by treating them as dummy arguments. If you do choose to ! use them, dimension them in your calling program and in F ! as arrays of appropriate length. ! ! NEQ -- Set it to the number of differential equations. ! (NEQ >= 1) ! ! T -- Set it to the initial point of the integration. ! You must use a program variable for T because the code ! changes its value. ! ! Y(*) -- Set this vector to the initial values of the NEQ solution ! components at the initial point. You must dimension Y at ! least NEQ in your calling program. ! ! TOUT -- Set it to the first point at which a solution ! is desired. You can take TOUT = T, in which case the code ! will evaluate the derivative of the solution at T and ! return. Integration either forward in T (TOUT > T) ! or backward in T (TOUT < T) is permitted. ! ! The code advances the solution from T to TOUT using ! step sizes which are automatically selected so as to ! achieve the desired accuracy. If you wish, the code will ! return with the solution and its derivative following ! each intermediate step (intermediate-output mode) so that ! you can monitor them, but you still must provide TOUT in ! accord with the basic aim of the code. ! ! The first step taken by the code is a critical one ! because it must reflect how fast the solution changes near ! the initial point. The code automatically selects an ! initial step size which is practically always suitable for ! the problem. By using the fact that the code will not ! step past TOUT in the first step, you could, if necessary, ! restrict the length of the initial step size. ! ! For some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP. When you have declared a TSTOP point (see INFO(4) ! and RWORK(1)), you have told the code not to integrate ! past TSTOP. In this case any TOUT beyond TSTOP is invalid ! input. ! ! INFO(*) -- Use the INFO array to give the code more details about ! how you want your problem solved. This array should be ! dimensioned of length 15 to accommodate other members of ! DEPAC or possible future extensions, though DEABM uses ! only the first four entries. You must respond to all of ! the following items which are arranged as questions. The ! simplest use of the code corresponds to answering all ! questions as YES ,i.e. setting all entries of INFO to 0. ! ! INFO(1) -- This parameter enables the code to initialize ! itself. You must set it to indicate the start of every ! new problem. ! ! **** Is this the first call for this problem ... ! YES -- Set INFO(1) = 0 ! NO -- Not applicable here. ! See below for continuation calls. **** ! ! INFO(2) -- How much accuracy you want of your solution ! is specified by the error tolerances RTOL and ATOL. ! The simplest use is to take them both to be scalars. ! To obtain more flexibility, they can both be vectors. ! The code must be told your choice. ! ! **** Are both error tolerances RTOL, ATOL scalars ... ! YES -- Set INFO(2) = 0 ! and input scalars for both RTOL and ATOL ! NO -- Set INFO(2) = 1 ! and input arrays for both RTOL and ATOL **** ! ! INFO(3) -- The code integrates from T in the direction ! of TOUT by steps. If you wish, it will return the ! computed solution and derivative at the next ! intermediate step (the intermediate-output mode) or ! TOUT, whichever comes first. This is a good way to ! proceed if you want to see the behavior of the solution. ! If you must have solutions at a great many specific ! TOUT points, this code will compute them efficiently. ! ! **** Do you want the solution only at ! TOUT (and not at the next intermediate step) ... ! YES -- Set INFO(3) = 0 ! NO -- Set INFO(3) = 1 **** ! ! INFO(4) -- To handle solutions at a great many specific ! values TOUT efficiently, this code may integrate past ! TOUT and interpolate to obtain the result at TOUT. ! Sometimes it is not possible to integrate beyond some ! point TSTOP because the equation changes there or it is ! not defined past TSTOP. Then you must tell the code ! not to go past. ! ! **** Can the integration be carried out without any ! restrictions on the independent variable T ... ! YES -- Set INFO(4)=0 ! NO -- Set INFO(4)=1 ! and define the stopping point TSTOP by ! setting RWORK(1)=TSTOP **** ! ! RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) ! error tolerances to tell the code how accurately you want ! the solution to be computed. They must be defined as ! program variables because the code may change them. You ! have two choices -- ! both RTOL and ATOL are scalars. (INFO(2)=0) ! both RTOL and ATOL are vectors. (INFO(2)=1) ! In either case all components must be non-negative. ! ! The tolerances are used by the code in a local error test ! at each step which requires roughly that ! ABS(LOCAL ERROR) <= RTOL*ABS(Y)+ATOL ! for each vector component. ! (More specifically, a Euclidean norm is used to measure ! the size of vectors, and the error test uses the magnitude ! of the solution at the beginning of the step.) ! ! The true (global) error is the difference between the true ! solution of the initial value problem and the computed ! approximation. Practically all present day codes, ! including this one, control the local error at each step ! and do not even attempt to control the global error ! directly. Roughly speaking, they produce a solution Y(T) ! which satisfies the differential equations with a ! residual R(T), DY(T)/DT = F(T,Y(T)) + R(T) , ! and, almost always, R(T) is bounded by the error ! tolerances. Usually, but not always, the true accuracy of ! the computed Y is comparable to the error tolerances. This ! code will usually, but not always, deliver a more accurate ! solution if you reduce the tolerances and integrate again. ! By comparing two such solutions you can get a fairly ! reliable idea of the true error in the solution at the ! bigger tolerances. ! ! Setting ATOL=0.0 results in a pure relative error test on ! that component. Setting RTOL=0.0 results in a pure abso- ! lute error test on that component. A mixed test with non- ! zero RTOL and ATOL corresponds roughly to a relative error ! test when the solution component is much bigger than ATOL ! and to an absolute error test when the solution component ! is smaller than the threshold ATOL. ! ! Proper selection of the absolute error control parameters ! ATOL requires you to have some idea of the scale of the ! solution components. To acquire this information may mean ! that you will have to solve the problem more than once. ! In the absence of scale information, you should ask for ! some relative accuracy in all the components (by setting ! RTOL values non-zero) and perhaps impose extremely small ! absolute error tolerances to protect against the danger of ! a solution component becoming zero. ! ! The code will not attempt to compute a solution at an ! accuracy unreasonable for the machine being used. It will ! advise you if you ask for too much accuracy and inform ! you as to the maximum accuracy it believes possible. ! ! RWORK(*) -- Dimension this real work array of length LRW in your ! calling program. ! ! RWORK(1) -- If you have set INFO(4)=0, you can ignore this ! optional input parameter. Otherwise you must define a ! stopping point TSTOP by setting RWORK(1) = TSTOP. ! (for some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP.) ! ! LRW -- Set it to the declared length of the RWORK array. ! You must have LRW >= 130+21*NEQ ! ! IWORK(*) -- Dimension this integer work array of length LIW in ! your calling program. ! ! LIW -- Set it to the declared length of the IWORK array. ! You must have LIW >= 51 ! ! RPAR, IPAR -- These are parameter arrays, of real and integer ! type, respectively. You can use them for communication ! between your program that calls DEABM and the F ! subroutine. They are not used or altered by DEABM. If ! you do not need RPAR or IPAR, ignore these parameters by ! treating them as dummy arguments. If you do choose to use ! them, dimension them in your calling program and in F as ! arrays of appropriate length. ! ! ********************************************************************** ! ** OUTPUT -- AFTER ANY RETURN FROM DEABM ** ! ******************************************* ! ! The principal aim of the code is to return a computed solution at ! TOUT, although it is also possible to obtain intermediate results ! along the way. To find out whether the code achieved its goal ! or if the integration process was interrupted before the task was ! completed, you must check the IDID parameter. ! ! ! T -- The solution was successfully advanced to the ! output value of T. ! ! Y(*) -- Contains the computed solution approximation at T. ! You may also be interested in the approximate derivative ! of the solution at T. It is contained in ! RWORK(21),...,RWORK(20+NEQ). ! ! IDID -- Reports what the code did ! ! *** Task Completed *** ! reported by positive values of IDID ! ! IDID = 1 -- A step was successfully taken in the ! intermediate-output mode. The code has not ! yet reached TOUT. ! ! IDID = 2 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping exactly to TOUT. ! ! IDID = 3 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping past TOUT. ! Y(*) is obtained by interpolation. ! ! *** Task Interrupted *** ! reported by negative values of IDID ! ! IDID = -1 -- A large amount of work has been expended. ! (500 steps attempted) ! ! IDID = -2 -- The error tolerances are too stringent. ! ! IDID = -3 -- The local error test cannot be satisfied ! because you specified a zero component in ATOL ! and the corresponding computed solution ! component is zero. Thus, a pure relative error ! test is impossible for this component. ! ! IDID = -4 -- The problem appears to be stiff. ! ! IDID = -5,-6,-7,..,-32 -- Not applicable for this code ! but used by other members of DEPAC or possible ! future extensions. ! ! *** Task Terminated *** ! reported by the value of IDID=-33 ! ! IDID = -33 -- The code has encountered trouble from which ! it cannot recover. A message is printed ! explaining the trouble and control is returned ! to the calling program. For example, this ! occurs when invalid input is detected. ! ! RTOL, ATOL -- These quantities remain unchanged except when ! IDID = -2. In this case, the error tolerances have been ! increased by the code to values which are estimated to be ! appropriate for continuing the integration. However, the ! reported solution at T was obtained using the input values ! of RTOL and ATOL. ! ! RWORK, IWORK -- Contain information which is usually of no ! interest to the user but necessary for subsequent calls. ! However, you may find use for ! ! RWORK(11)--Which contains the step size H to be ! attempted on the next step. ! ! RWORK(12)--If the tolerances have been increased by the ! code (IDID = -2) , they were multiplied by the ! value in RWORK(12). ! ! RWORK(13)--Which contains the current value of the ! independent variable, i.e. the farthest point ! integration has reached. This will be dif- ! ferent from T only when interpolation has been ! performed (IDID=3). ! ! RWORK(20+I)--Which contains the approximate derivative of ! the solution component Y(I). In DEABM, it is ! obtained by calling subroutine F to evaluate ! the differential equation using T and Y(*) when ! IDID=1 or 2, and by interpolation when IDID=3. ! ! ********************************************************************** ! ** INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ** ! ** (CALLS AFTER THE FIRST) ** ! ***************************************************** ! ! This code is organized so that subsequent calls to continue the ! integration involve little (if any) additional effort on your ! part. You must monitor the IDID parameter in order to ! determine what to do next. ! ! Recalling that the principal task of the code is to integrate ! from T to TOUT (the interval mode), usually all you will need ! to do is specify a new TOUT upon reaching the current TOUT. ! ! Do not alter any quantity not specifically permitted below, ! in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or ! the differential equation in subroutine F. Any such alteration ! constitutes a new problem and must be treated as such, i.e. ! you must start afresh. ! ! You cannot change from vector to scalar error control or vice ! versa (INFO(2)) but you can change the size of the entries of ! RTOL, ATOL. Increasing a tolerance makes the equation easier ! to integrate. Decreasing a tolerance will make the equation ! harder to integrate and should generally be avoided. ! ! You can switch from the intermediate-output mode to the ! interval mode (INFO(3)) or vice versa at any time. ! ! If it has been necessary to prevent the integration from going ! past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the ! code will not integrate to any TOUT beyond the currently ! specified TSTOP. Once TSTOP has been reached you must change ! the value of TSTOP or set INFO(4)=0. You may change INFO(4) ! or TSTOP at any time but you must supply the value of TSTOP in ! RWORK(1) whenever you set INFO(4)=1. ! ! The parameter INFO(1) is used by the code to indicate the ! beginning of a new problem and to indicate whether integration ! is to be continued. You must input the value INFO(1) = 0 ! when starting a new problem. You must input the value ! INFO(1) = 1 if you wish to continue after an interrupted task. ! Do not set INFO(1) = 0 on a continuation call unless you ! want the code to restart at the current T. ! ! *** Following a Completed Task *** ! If ! IDID = 1, call the code again to continue the integration ! another step in the direction of TOUT. ! ! IDID = 2 or 3, define a new TOUT and call the code again. ! TOUT must be different from T. You cannot change ! the direction of integration without restarting. ! ! *** Following an Interrupted Task *** ! To show the code that you realize the task was ! interrupted and that you want to continue, you ! must take appropriate action and reset INFO(1) = 1 ! If ! IDID = -1, the code has attempted 500 steps. ! If you want to continue, set INFO(1) = 1 and ! call the code again. An additional 500 steps ! will be allowed. ! ! IDID = -2, the error tolerances RTOL, ATOL have been ! increased to values the code estimates appropriate ! for continuing. You may want to change them ! yourself. If you are sure you want to continue ! with relaxed error tolerances, set INFO(1)=1 and ! call the code again. ! ! IDID = -3, a solution component is zero and you set the ! corresponding component of ATOL to zero. If you ! are sure you want to continue, you must first ! alter the error criterion to use positive values ! for those components of ATOL corresponding to zero ! solution components, then set INFO(1)=1 and call ! the code again. ! ! IDID = -4, the problem appears to be stiff. It is very ! inefficient to solve such problems with DEABM. The ! code DEBDF in DEPAC handles this task efficiently. ! If you are absolutely sure you want to continue ! with DEABM, set INFO(1)=1 and call the code again. ! ! IDID = -5,-6,-7,..,-32 --- cannot occur with this code ! but used by other members of DEPAC or possible ! future extensions. ! ! *** Following a Terminated Task *** ! If ! IDID = -33, you cannot continue the solution of this ! problem. An attempt to do so will result in your ! run being terminated. ! ! ********************************************************************** ! !***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user ! oriented package of ODE solvers, Report SAND79-2374, ! Sandia Laboratories, 1979. !***ROUTINES CALLED DES, XERMSG !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891024 Changed references from VNORM to HVNRM. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DEABM ! LOGICAL START,PHASE1,NORND,STIFF,INTOUT ! DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), & RPAR(*),IPAR(*) ! CHARACTER*8 XERN1 CHARACTER*16 XERN3 ! EXTERNAL F ! ! CHECK FOR AN APPARENT INFINITE LOOP ! !***FIRST EXECUTABLE STATEMENT DEABM if ( INFO(1) == 0 ) IWORK(LIW) = 0 if (IWORK(LIW) >= 5) THEN if (T == RWORK(21 + NEQ)) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DEABM', & 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // & 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // & ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // & 'WAY YOU HAVE SET PARAMETERS FOR THE call TO THE ' // & 'CODE, PARTICULARLY INFO(1).', 13, 2) return ENDIF end if ! ! CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION ! IDID=0 if (LRW < 130+21*NEQ) THEN WRITE (XERN1, '(I8)') LRW call XERMSG ('SLATEC', 'DEABM', 'THE LENGTH OF THE RWORK ' // & 'ARRAY MUST BE AT LEAST 130 + 21*NEQ.$$' // & 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) IDID=-33 end if ! if (LIW < 51) THEN WRITE (XERN1, '(I8)') LIW call XERMSG ('SLATEC', 'DEABM', 'THE LENGTH OF THE IWORK ' // & 'ARRAY MUST BE AT LEAST 51.$$YOU HAVE CALLED THE CODE ' // & 'WITH LIW = ' // XERN1, 2, 1) IDID=-33 end if ! ! COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY ! IYPOUT = 21 ITSTAR = NEQ + 21 IYP = 1 + ITSTAR IYY = NEQ + IYP IWT = NEQ + IYY IP = NEQ + IWT IPHI = NEQ + IP IALPHA = (NEQ*16) + IPHI IBETA = 12 + IALPHA IPSI = 12 + IBETA IV = 12 + IPSI IW = 12 + IV ISIG = 12 + IW IG = 13 + ISIG IGI = 13 + IG IXOLD = 11 + IGI IHOLD = 1 + IXOLD ITOLD = 1 + IHOLD IDELSN = 1 + ITOLD ITWOU = 1 + IDELSN IFOURU = 1 + ITWOU ! RWORK(ITSTAR) = T if (INFO(1) == 0) go to 50 START = IWORK(21) /= (-1) PHASE1 = IWORK(22) /= (-1) NORND = IWORK(23) /= (-1) STIFF = IWORK(24) /= (-1) INTOUT = IWORK(25) /= (-1) ! 50 call DES(F,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(IYPOUT), & RWORK(IYP),RWORK(IYY),RWORK(IWT),RWORK(IP),RWORK(IPHI), & RWORK(IALPHA),RWORK(IBETA),RWORK(IPSI),RWORK(IV), & RWORK(IW),RWORK(ISIG),RWORK(IG),RWORK(IGI),RWORK(11), & RWORK(12),RWORK(13),RWORK(IXOLD),RWORK(IHOLD), & RWORK(ITOLD),RWORK(IDELSN),RWORK(1),RWORK(ITWOU), & RWORK(IFOURU),START,PHASE1,NORND,STIFF,INTOUT,IWORK(26), & IWORK(27),IWORK(28),IWORK(29),IWORK(30),IWORK(31), & IWORK(32),IWORK(33),IWORK(34),IWORK(35),IWORK(45), & RPAR,IPAR) ! IWORK(21) = -1 if (START) IWORK(21) = 1 IWORK(22) = -1 if (PHASE1) IWORK(22) = 1 IWORK(23) = -1 if (NORND) IWORK(23) = 1 IWORK(24) = -1 if (STIFF) IWORK(24) = 1 IWORK(25) = -1 if (INTOUT) IWORK(25) = 1 ! if (IDID /= (-2)) IWORK(LIW) = IWORK(LIW) + 1 if (T /= RWORK(ITSTAR)) IWORK(LIW) = 0 ! return end subroutine DEBDF (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, & RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) ! !! DEBDF solves an initial value problem in ordinary differential ... ! equations using backward differentiation formulas. It is ... ! intended primarily for stiff problems. ! !***LIBRARY SLATEC (DEPAC) !***CATEGORY I1A2 !***TYPE SINGLE PRECISION (DEBDF-S, DDEBDF-D) !***KEYWORDS BACKWARD DIFFERENTIATION FORMULAS, DEPAC, ! INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, STIFF !***AUTHOR Shampine, L. F., (SNLA) ! Watts, H. A., (SNLA) !***DESCRIPTION ! ! This is the backward differentiation code in the package of ! differential equation solvers DEPAC, consisting of the codes ! DERKF, DEABM, and DEBDF. Design of the package was by ! L. F. Shampine and H. A. Watts. It is documented in ! SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE ! Solvers. ! DEBDF is a driver for a modification of the code LSODE written by ! A. C. Hindmarsh ! Lawrence Livermore Laboratory ! Livermore, California 94550 ! ! ********************************************************************** ! ** DEPAC PACKAGE OVERVIEW ** ! ********************************************************************** ! ! You have a choice of three differential equation solvers from ! DEPAC. The following brief descriptions are meant to aid you ! in choosing the most appropriate code for your problem. ! ! DERKF is a fifth order Runge-Kutta code. It is the simplest of ! the three choices, both algorithmically and in the use of the ! code. DERKF is primarily designed to solve non-stiff and mild- ! ly stiff differential equations when derivative evaluations are ! not expensive. It should generally not be used to get high ! accuracy results nor answers at a great many specific points. ! Because DERKF has very low overhead costs, it will usually ! result in the least expensive integration when solving ! problems requiring a modest amount of accuracy and having ! equations that are not costly to evaluate. DERKF attempts to ! discover when it is not suitable for the task posed. ! ! DEABM is a variable order (one through twelve) Adams code. ! Its complexity lies somewhere between that of DERKF and DEBDF. ! DEABM is primarily designed to solve non-stiff and mildly ! stiff differential equations when derivative evaluations are ! expensive, high accuracy results are needed or answers at ! many specific points are required. DEABM attempts to discover ! when it is not suitable for the task posed. ! ! DEBDF is a variable order (one through five) backward ! differentiation formula code. It is the most complicated of ! the three choices. DEBDF is primarily designed to solve stiff ! differential equations at crude to moderate tolerances. ! If the problem is very stiff at all, DERKF and DEABM will be ! quite inefficient compared to DEBDF. However, DEBDF will be ! inefficient compared to DERKF and DEABM on non-stiff problems ! because it uses much more storage, has a much larger overhead, ! and the low order formulas will not give high accuracies ! efficiently. ! ! The concept of stiffness cannot be described in a few words. ! If you do not know the problem to be stiff, try either DERKF ! or DEABM. Both of these codes will inform you of stiffness ! when the cost of solving such problems becomes important. ! ! ********************************************************************** ! ** ABSTRACT ** ! ********************************************************************** ! ! Subroutine DEBDF uses the backward differentiation formulas of ! orders one through five to integrate a system of NEQ first order ! ordinary differential equations of the form ! DU/DX = F(X,U) ! when the vector Y(*) of initial values for U(*) at X=T is given. The ! subroutine integrates from T to TOUT. It is easy to continue the ! integration to get results at additional TOUT. This is the interval ! mode of operation. It is also easy for the routine to return with ! The solution at each intermediate step on the way to TOUT. This is ! the intermediate-output mode of operation. ! ! ********************************************************************** ! ** DESCRIPTION OF THE ARGUMENTS TO DEBDF (AN OVERVIEW) ** ! ********************************************************************** ! ! The Parameters are: ! ! F -- This is the name of a subroutine which you provide to ! define the differential equations. ! ! NEQ -- This is the number of (first order) differential ! equations to be integrated. ! ! T -- This is a value of the independent variable. ! ! Y(*) -- This array contains the solution components at T. ! ! TOUT -- This is a point at which a solution is desired. ! ! INFO(*) -- The basic task of the code is to integrate the ! differential equations from T to TOUT and return an ! answer at TOUT. INFO(*) is an INTEGER array which is used ! to communicate exactly how you want this task to be ! carried out. ! ! RTOL, ATOL -- These quantities ! represent relative and absolute error tolerances which you ! provide to indicate how accurately you wish the solution ! to be computed. You may choose them to be both scalars ! or else both vectors. ! ! IDID -- This scalar quantity is an indicator reporting what ! the code did. You must monitor this INTEGER variable to ! decide what action to take next. ! ! RWORK(*), LRW -- RWORK(*) is a REAL work array of ! length LRW which provides the code with needed storage ! space. ! ! IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW ! which provides the code with needed storage space and an ! across call flag. ! ! RPAR, IPAR -- These are REAL and INTEGER parameter ! arrays which you can use for communication between your ! calling program and the F subroutine (and the JAC ! subroutine). ! ! JAC -- This is the name of a subroutine which you may choose to ! provide for defining the Jacobian matrix of partial ! derivatives DF/DU. ! ! Quantities which are used as input items are ! NEQ, T, Y(*), TOUT, INFO(*), ! RTOL, ATOL, RWORK(1), LRW, ! IWORK(1), IWORK(2), and LIW. ! ! Quantities which may be altered by the code are ! T, Y(*), INFO(1), RTOL, ATOL, ! IDID, RWORK(*) and IWORK(*). ! ! ********************************************************************** ! * INPUT -- What To Do On The First Call To DEBDF * ! ********************************************************************** ! ! The first call of the code is defined to be the start of each new ! problem. Read through the descriptions of all the following items, ! provide sufficient storage space for designated arrays, set ! appropriate variables for the initialization of the problem, and ! give information about how you want the problem to be solved. ! ! ! F -- provide a subroutine of the form ! F(X,U,UPRIME,RPAR,IPAR) ! to define the system of first order differential equations ! which is to be solved. For the given values of X and the ! vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must ! evaluate the NEQ components of the system of differential ! equations DU/DX=F(X,U) and store the derivatives in the ! array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for ! equations I=1,...,NEQ. ! ! Subroutine F must not alter X or U(*). You must declare ! the name F in an external statement in your program that ! calls DEBDF. You must dimension U and UPRIME in F. ! ! RPAR and IPAR are REAL and INTEGER parameter arrays which ! you can use for communication between your calling program ! and subroutine F. They are not used or altered by DEBDF. ! If you do not need RPAR or IPAR, ignore these parameters ! by treating them as dummy arguments. If you do choose to ! use them, dimension them in your calling program and in F ! as arrays of appropriate length. ! ! NEQ -- Set it to the number of differential equations. ! (NEQ >= 1) ! ! T -- Set it to the initial point of the integration. ! You must use a program variable for T because the code ! changes its value. ! ! Y(*) -- Set this vector to the initial values of the NEQ solution ! components at the initial point. You must dimension Y at ! least NEQ in your calling program. ! ! TOUT -- Set it to the first point at which a solution is desired. ! You can take TOUT = T, in which case the code ! will evaluate the derivative of the solution at T and ! return. Integration either forward in T (TOUT > T) ! or backward in T (TOUT < T) is permitted. ! ! The code advances the solution from T to TOUT using ! step sizes which are automatically selected so as to ! achieve the desired accuracy. If you wish, the code will ! return with the solution and its derivative following ! each intermediate step (intermediate-output mode) so that ! you can monitor them, but you still must provide TOUT in ! accord with the basic aim of the code. ! ! The first step taken by the code is a critical one ! because it must reflect how fast the solution changes near ! the initial point. The code automatically selects an ! initial step size which is practically always suitable for ! the problem. By using the fact that the code will not ! step past TOUT in the first step, you could, if necessary, ! restrict the length of the initial step size. ! ! For some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP. When you have declared a TSTOP point (see INFO(4) ! and RWORK(1)), you have told the code not to integrate ! past TSTOP. In this case any TOUT beyond TSTOP is invalid ! input. ! ! INFO(*) -- Use the INFO array to give the code more details about ! how you want your problem solved. This array should be ! dimensioned of length 15 to accommodate other members of ! DEPAC or possible future extensions, though DEBDF uses ! only the first six entries. You must respond to all of ! the following items which are arranged as questions. The ! simplest use of the code corresponds to answering all ! questions as YES ,i.e. setting all entries of INFO to 0. ! ! INFO(1) -- This parameter enables the code to initialize ! itself. You must set it to indicate the start of every ! new problem. ! ! **** Is this the first call for this problem ... ! YES -- Set INFO(1) = 0 ! NO -- Not applicable here. ! See below for continuation calls. **** ! ! INFO(2) -- How much accuracy you want of your solution ! is specified by the error tolerances RTOL and ATOL. ! The simplest use is to take them both to be scalars. ! To obtain more flexibility, they can both be vectors. ! The code must be told your choice. ! ! **** Are both error tolerances RTOL, ATOL scalars ... ! YES -- Set INFO(2) = 0 ! and input scalars for both RTOL and ATOL ! NO -- Set INFO(2) = 1 ! and input arrays for both RTOL and ATOL **** ! ! INFO(3) -- The code integrates from T in the direction ! of TOUT by steps. If you wish, it will return the ! computed solution and derivative at the next ! intermediate step (the intermediate-output mode) or ! TOUT, whichever comes first. This is a good way to ! proceed if you want to see the behavior of the solution. ! If you must have solutions at a great many specific ! TOUT points, this code will compute them efficiently. ! ! **** Do you want the solution only at ! TOUT (and NOT at the next intermediate step) ... ! YES -- Set INFO(3) = 0 ! NO -- Set INFO(3) = 1 **** ! ! INFO(4) -- To handle solutions at a great many specific ! values TOUT efficiently, this code may integrate past ! TOUT and interpolate to obtain the result at TOUT. ! Sometimes it is not possible to integrate beyond some ! point TSTOP because the equation changes there or it is ! not defined past TSTOP. Then you must tell the code ! not to go past. ! ! **** Can the integration be carried out without any ! restrictions on the independent variable T ... ! YES -- Set INFO(4)=0 ! NO -- Set INFO(4)=1 ! and define the stopping point TSTOP by ! setting RWORK(1)=TSTOP **** ! ! INFO(5) -- To solve stiff problems it is necessary to use the ! Jacobian matrix of partial derivatives of the system ! of differential equations. If you do not provide a ! subroutine to evaluate it analytically (see the ! description of the item JAC in the call list), it will ! be approximated by numerical differencing in this code. ! Although it is less trouble for you to have the code ! compute partial derivatives by numerical differencing, ! the solution will be more reliable if you provide the ! derivatives via JAC. Sometimes numerical differencing ! is cheaper than evaluating derivatives in JAC and ! sometimes it is not - this depends on your problem. ! ! If your problem is linear, i.e. has the form ! DU/DX = F(X,U) = J(X)*U + G(X) for some matrix J(X) ! and vector G(X), the Jacobian matrix DF/DU = J(X). ! Since you must provide a subroutine to evaluate F(X,U) ! analytically, it is little extra trouble to provide ! subroutine JAC for evaluating J(X) analytically. ! Furthermore, in such cases, numerical differencing is ! much more expensive than analytic evaluation. ! ! **** Do you want the code to evaluate the partial ! derivatives automatically by numerical differences ... ! YES -- Set INFO(5)=0 ! NO -- Set INFO(5)=1 ! and provide subroutine JAC for evaluating the ! Jacobian matrix **** ! ! INFO(6) -- DEBDF will perform much better if the Jacobian ! matrix is banded and the code is told this. In this ! case, the storage needed will be greatly reduced, ! numerical differencing will be performed more cheaply, ! and a number of important algorithms will execute much ! faster. The differential equation is said to have ! half-bandwidths ML (lower) and MU (upper) if equation I ! involves only unknowns Y(J) with ! I-ML <= J <= I+MU ! for all I=1,2,...,NEQ. Thus, ML and MU are the widths ! of the lower and upper parts of the band, respectively, ! with the main diagonal being excluded. If you do not ! indicate that the equation has a banded Jacobian, ! the code works with a full matrix of NEQ**2 elements ! (stored in the conventional way). Computations with ! banded matrices cost less time and storage than with ! full matrices if 2*ML+MU < NEQ. If you tell the ! code that the Jacobian matrix has a banded structure and ! you want to provide subroutine JAC to compute the ! partial derivatives, then you must be careful to store ! the elements of the Jacobian matrix in the special form ! indicated in the description of JAC. ! ! **** Do you want to solve the problem using a full ! (dense) Jacobian matrix (and not a special banded ! structure) ... ! YES -- Set INFO(6)=0 ! NO -- Set INFO(6)=1 ! and provide the lower (ML) and upper (MU) ! bandwidths by setting ! IWORK(1)=ML ! IWORK(2)=MU **** ! ! RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) ! error tolerances to tell the code how accurately you want ! the solution to be computed. They must be defined as ! program variables because the code may change them. You ! have two choices -- ! Both RTOL and ATOL are scalars. (INFO(2)=0) ! Both RTOL and ATOL are vectors. (INFO(2)=1) ! In either case all components must be non-negative. ! ! The tolerances are used by the code in a local error test ! at each step which requires roughly that ! ABS(LOCAL ERROR) <= RTOL*ABS(Y)+ATOL ! for each vector component. ! (More specifically, a root-mean-square norm is used to ! measure the size of vectors, and the error test uses the ! magnitude of the solution at the beginning of the step.) ! ! The true (global) error is the difference between the true ! solution of the initial value problem and the computed ! approximation. Practically all present day codes, ! including this one, control the local error at each step ! and do not even attempt to control the global error ! directly. Roughly speaking, they produce a solution Y(T) ! which satisfies the differential equations with a ! residual R(T), DY(T)/DT = F(T,Y(T)) + R(T) , ! and, almost always, R(T) is bounded by the error ! tolerances. Usually, but not always, the true accuracy of ! the computed Y is comparable to the error tolerances. This ! code will usually, but not always, deliver a more accurate ! solution if you reduce the tolerances and integrate again. ! By comparing two such solutions you can get a fairly ! reliable idea of the true error in the solution at the ! bigger tolerances. ! ! Setting ATOL=0. results in a pure relative error test on ! that component. Setting RTOL=0. results in a pure abso- ! lute error test on that component. A mixed test with non- ! zero RTOL and ATOL corresponds roughly to a relative error ! test when the solution component is much bigger than ATOL ! and to an absolute error test when the solution component ! is smaller than the threshold ATOL. ! ! Proper selection of the absolute error control parameters ! ATOL requires you to have some idea of the scale of the ! solution components. To acquire this information may mean ! that you will have to solve the problem more than once. In ! the absence of scale information, you should ask for some ! relative accuracy in all the components (by setting RTOL ! values non-zero) and perhaps impose extremely small ! absolute error tolerances to protect against the danger of ! a solution component becoming zero. ! ! The code will not attempt to compute a solution at an ! accuracy unreasonable for the machine being used. It will ! advise you if you ask for too much accuracy and inform ! you as to the maximum accuracy it believes possible. ! ! RWORK(*) -- Dimension this REAL work array of length LRW in your ! calling program. ! ! RWORK(1) -- If you have set INFO(4)=0, you can ignore this ! optional input parameter. Otherwise you must define a ! stopping point TSTOP by setting RWORK(1) = TSTOP. ! (For some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP.) ! ! LRW -- Set it to the declared length of the RWORK array. ! You must have ! LRW >= 250+10*NEQ+NEQ**2 ! for the full (dense) Jacobian case (when INFO(6)=0), or ! LRW >= 250+10*NEQ+(2*ML+MU+1)*NEQ ! for the banded Jacobian case (when INFO(6)=1). ! ! IWORK(*) -- Dimension this INTEGER work array of length LIW in ! your calling program. ! ! IWORK(1), IWORK(2) -- If you have set INFO(6)=0, you can ignore ! these optional input parameters. Otherwise you must define ! the half-bandwidths ML (lower) and MU (upper) of the ! Jacobian matrix by setting IWORK(1) = ML and ! IWORK(2) = MU. (The code will work with a full matrix ! of NEQ**2 elements unless it is told that the problem has ! a banded Jacobian, in which case the code will work with ! a matrix containing at most (2*ML+MU+1)*NEQ elements.) ! ! LIW -- Set it to the declared length of the IWORK array. ! You must have LIW >= 56+NEQ. ! ! RPAR, IPAR -- These are parameter arrays, of REAL and INTEGER ! type, respectively. You can use them for communication ! between your program that calls DEBDF and the F ! subroutine (and the JAC subroutine). They are not used or ! altered by DEBDF. If you do not need RPAR or IPAR, ignore ! these parameters by treating them as dummy arguments. If ! you do choose to use them, dimension them in your calling ! program and in F (and in JAC) as arrays of appropriate ! length. ! ! JAC -- If you have set INFO(5)=0, you can ignore this parameter ! by treating it as a dummy argument. (For some compilers ! you may have to write a dummy subroutine named JAC in ! order to avoid problems associated with missing external ! routine names.) Otherwise, you must provide a subroutine ! of the form ! JAC(X,U,PD,NROWPD,RPAR,IPAR) ! to define the Jacobian matrix of partial derivatives DF/DU ! of the system of differential equations DU/DX = F(X,U). ! For the given values of X and the vector ! U(*)=(U(1),U(2),...,U(NEQ)), the subroutine must evaluate ! the non-zero partial derivatives DF(I)/DU(J) for each ! differential equation I=1,...,NEQ and each solution ! component J=1,...,NEQ , and store these values in the ! matrix PD. The elements of PD are set to zero before each ! call to JAC so only non-zero elements need to be defined. ! ! Subroutine JAC must not alter X, U(*), or NROWPD. You ! must declare the name JAC in an EXTERNAL statement in your ! program that calls DEBDF. NROWPD is the row dimension of ! the PD matrix and is assigned by the code. Therefore you ! must dimension PD in JAC according to ! DIMENSION PD(NROWPD,1) ! You must also dimension U in JAC. ! ! The way you must store the elements into the PD matrix ! depends on the structure of the Jacobian which you ! indicated by INFO(6). ! *** INFO(6)=0 -- Full (Dense) Jacobian *** ! When you evaluate the (non-zero) partial derivative ! of equation I with respect to variable J, you must ! store it in PD according to ! PD(I,J) = * DF(I)/DU(J) * ! *** INFO(6)=1 -- Banded Jacobian with ML Lower and MU ! Upper Diagonal Bands (refer to INFO(6) description of ! ML and MU) *** ! When you evaluate the (non-zero) partial derivative ! of equation I with respect to variable J, you must ! store it in PD according to ! IROW = I - J + ML + MU + 1 ! PD(IROW,J) = * DF(I)/DU(J) * ! ! RPAR and IPAR are REAL and INTEGER parameter ! arrays which you can use for communication between your ! calling program and your Jacobian subroutine JAC. They ! are not altered by DEBDF. If you do not need RPAR or ! IPAR, ignore these parameters by treating them as dummy ! arguments. If you do choose to use them, dimension them ! in your calling program and in JAC as arrays of ! appropriate length. ! ! ********************************************************************** ! * OUTPUT -- After any return from DDEBDF * ! ********************************************************************** ! ! The principal aim of the code is to return a computed solution at ! TOUT, although it is also possible to obtain intermediate results ! along the way. To find out whether the code achieved its goal ! or if the integration process was interrupted before the task was ! completed, you must check the IDID parameter. ! ! ! T -- The solution was successfully advanced to the ! output value of T. ! ! Y(*) -- Contains the computed solution approximation at T. ! You may also be interested in the approximate derivative ! of the solution at T. It is contained in ! RWORK(21),...,RWORK(20+NEQ). ! ! IDID -- Reports what the code did ! ! *** Task Completed *** ! Reported by positive values of IDID ! ! IDID = 1 -- A step was successfully taken in the ! intermediate-output mode. The code has not ! yet reached TOUT. ! ! IDID = 2 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping exactly to TOUT. ! ! IDID = 3 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping past TOUT. ! Y(*) is obtained by interpolation. ! ! *** Task Interrupted *** ! Reported by negative values of IDID ! ! IDID = -1 -- A large amount of work has been expended. ! (500 steps attempted) ! ! IDID = -2 -- The error tolerances are too stringent. ! ! IDID = -3 -- The local error test cannot be satisfied ! because you specified a zero component in ATOL ! and the corresponding computed solution ! component is zero. Thus, a pure relative error ! test is impossible for this component. ! ! IDID = -4,-5 -- Not applicable for this code but used ! by other members of DEPAC. ! ! IDID = -6 -- DEBDF had repeated convergence test failures ! on the last attempted step. ! ! IDID = -7 -- DEBDF had repeated error test failures on ! the last attempted step. ! ! IDID = -8,..,-32 -- Not applicable for this code but ! used by other members of DEPAC or possible ! future extensions. ! ! *** Task Terminated *** ! Reported by the value of IDID=-33 ! ! IDID = -33 -- The code has encountered trouble from which ! it cannot recover. A message is printed ! explaining the trouble and control is returned ! to the calling program. For example, this ! occurs when invalid input is detected. ! ! RTOL, ATOL -- These quantities remain unchanged except when ! IDID = -2. In this case, the error tolerances have been ! increased by the code to values which are estimated to be ! appropriate for continuing the integration. However, the ! reported solution at T was obtained using the input values ! of RTOL and ATOL. ! ! RWORK, IWORK -- Contain information which is usually of no ! interest to the user but necessary for subsequent calls. ! However, you may find use for ! ! RWORK(11)--which contains the step size H to be ! attempted on the next step. ! ! RWORK(12)--If the tolerances have been increased by the ! code (IDID = -2) , they were multiplied by the ! value in RWORK(12). ! ! RWORK(13)--which contains the current value of the ! independent variable, i.e. the farthest point ! integration has reached. This will be ! different from T only when interpolation has ! been performed (IDID=3). ! ! RWORK(20+I)--which contains the approximate derivative ! of the solution component Y(I). In DEBDF, it ! is never obtained by calling subroutine F to ! evaluate the differential equation using T and ! Y(*), except at the initial point of ! integration. ! ! ********************************************************************** ! ** INPUT -- What To Do To Continue The Integration ** ! ** (calls after the first) ** ! ********************************************************************** ! ! This code is organized so that subsequent calls to continue the ! integration involve little (if any) additional effort on your ! part. You must monitor the IDID parameter in order to determine ! what to do next. ! ! Recalling that the principal task of the code is to integrate ! from T to TOUT (the interval mode), usually all you will need ! to do is specify a new TOUT upon reaching the current TOUT. ! ! Do not alter any quantity not specifically permitted below, ! in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or ! the differential equation in subroutine F. Any such alteration ! constitutes a new problem and must be treated as such, i.e. ! you must start afresh. ! ! You cannot change from vector to scalar error control or vice ! versa (INFO(2)) but you can change the size of the entries of ! RTOL, ATOL. Increasing a tolerance makes the equation easier ! to integrate. Decreasing a tolerance will make the equation ! harder to integrate and should generally be avoided. ! ! You can switch from the intermediate-output mode to the ! interval mode (INFO(3)) or vice versa at any time. ! ! If it has been necessary to prevent the integration from going ! past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the ! code will not integrate to any TOUT beyond the currently ! specified TSTOP. Once TSTOP has been reached you must change ! the value of TSTOP or set INFO(4)=0. You may change INFO(4) ! or TSTOP at any time but you must supply the value of TSTOP in ! RWORK(1) whenever you set INFO(4)=1. ! ! Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) ! unless you are going to restart the code. ! ! The parameter INFO(1) is used by the code to indicate the ! beginning of a new problem and to indicate whether integration ! is to be continued. You must input the value INFO(1) = 0 ! when starting a new problem. You must input the value ! INFO(1) = 1 if you wish to continue after an interrupted task. ! Do not set INFO(1) = 0 on a continuation call unless you ! want the code to restart at the current T. ! ! *** Following a Completed Task *** ! If ! IDID = 1, call the code again to continue the integration ! another step in the direction of TOUT. ! ! IDID = 2 or 3, define a new TOUT and call the code again. ! TOUT must be different from T. You cannot change ! the direction of integration without restarting. ! ! *** Following an Interrupted Task *** ! To show the code that you realize the task was ! interrupted and that you want to continue, you ! must take appropriate action and reset INFO(1) = 1 ! If ! IDID = -1, the code has attempted 500 steps. ! If you want to continue, set INFO(1) = 1 and ! call the code again. An additional 500 steps ! will be allowed. ! ! IDID = -2, the error tolerances RTOL, ATOL have been ! increased to values the code estimates appropriate ! for continuing. You may want to change them ! yourself. If you are sure you want to continue ! with relaxed error tolerances, set INFO(1)=1 and ! call the code again. ! ! IDID = -3, a solution component is zero and you set the ! corresponding component of ATOL to zero. If you ! are sure you want to continue, you must first ! alter the error criterion to use positive values ! for those components of ATOL corresponding to zero ! solution components, then set INFO(1)=1 and call ! the code again. ! ! IDID = -4,-5 --- cannot occur with this code but used ! by other members of DEPAC. ! ! IDID = -6, repeated convergence test failures occurred ! on the last attempted step in DEBDF. An inaccu- ! rate Jacobian may be the problem. If you are ! absolutely certain you want to continue, restart ! the integration at the current T by setting ! INFO(1)=0 and call the code again. ! ! IDID = -7, repeated error test failures occurred on the ! last attempted step in DEBDF. A singularity in ! the solution may be present. You should re- ! examine the problem being solved. If you are ! absolutely certain you want to continue, restart ! the integration at the current T by setting ! INFO(1)=0 and call the code again. ! ! IDID = -8,..,-32 --- cannot occur with this code but ! used by other members of DEPAC or possible future ! extensions. ! ! *** Following a Terminated Task *** ! If ! IDID = -33, you cannot continue the solution of this ! problem. An attempt to do so will result in your ! run being terminated. ! ! ********************************************************************** ! ! ***** Warning ***** ! ! If DEBDF is to be used in an overlay situation, you must save and ! restore certain items used internally by DEBDF (values in the ! common block DEBDF1). This can be accomplished as follows. ! ! To save the necessary values upon return from DEBDF, simply call ! SVCO(RWORK(22+NEQ),IWORK(21+NEQ)). ! ! To restore the necessary values before the next call to DEBDF, ! simply call RSCO(RWORK(22+NEQ),IWORK(21+NEQ)). ! !***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user ! oriented package of ODE solvers, Report SAND79-2374, ! Sandia Laboratories, 1979. !***ROUTINES CALLED LSOD, XERMSG !***COMMON BLOCKS DEBDF1 !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891024 Changed references from VNORM to HVNRM. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900510 Convert XERRWV calls to XERMSG calls, change Prologue ! comments to agree with DDEBDF. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DEBDF ! ! LOGICAL INTOUT CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3 ! DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), & RPAR(*),IPAR(*) ! COMMON /DEBDF1/ TOLD, ROWNS(210), & EL0, H, HMIN, HMXI, HU, TN, UROUND, & IQUIT, INIT, IYH, IEWT, IACOR, ISAVF, IWM, KSTEPS, & IBEGIN, ITOL, IINTEG, ITSTOP, IJAC, IBAND, IOWNS(6), & IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, & NJE, NQU ! EXTERNAL F, JAC ! ! CHECK FOR AN APPARENT INFINITE LOOP ! !***FIRST EXECUTABLE STATEMENT DEBDF if (INFO(1) == 0) IWORK(LIW) = 0 ! if (IWORK(LIW) >= 5) THEN if (T == RWORK(21+NEQ)) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DEBDF', & 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // & 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // & ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // & 'WAY YOU HAVE SET PARAMETERS FOR THE call TO THE ' // & 'CODE PARTICULARLY INFO(1).', 13, 2) return ENDIF end if ! IDID = 0 ! ! CHECK VALIDITY OF INFO PARAMETERS ! if (INFO(1) /= 0 .AND. INFO(1) /= 1) THEN WRITE (XERN1, '(I8)') INFO(1) call XERMSG ('SLATEC', 'DEBDF', 'INFO(1) MUST BE SET TO 0 ' // & 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // & 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // & 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE ' // & 'CODE WITH INFO(1) = ' // XERN1, 3, 1) IDID = -33 end if ! if (INFO(2) /= 0 .AND. INFO(2) /= 1) THEN WRITE (XERN1, '(I8)') INFO(2) call XERMSG ('SLATEC', 'DEBDF', 'INFO(2) MUST BE 0 OR 1 ' // & 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // & 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // & XERN1, 4, 1) IDID = -33 end if ! if (INFO(3) /= 0 .AND. INFO(3) /= 1) THEN WRITE (XERN1, '(I8)') INFO(3) call XERMSG ('SLATEC', 'DEBDF', 'INFO(3) MUST BE 0 OR 1 ' // & 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // & 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // & 'WITH INFO(3) = ' // XERN1, 5, 1) IDID = -33 end if ! if (INFO(4) /= 0 .AND. INFO(4) /= 1) THEN WRITE (XERN1, '(I8)') INFO(4) call XERMSG ('SLATEC', 'DEBDF', 'INFO(4) MUST BE 0 OR 1 ' // & 'INDICATING WHETHER OR NOT THE INTEGRATION INTERVAL IS ' // & 'TO BE RESTRICTED BY A POINT TSTOP. YOU HAVE CALLED ' // & 'THE CODE WITH INFO(4) = ' // XERN1, 14, 1) IDID = -33 end if ! if (INFO(5) /= 0 .AND. INFO(5) /= 1) THEN WRITE (XERN1, '(I8)') INFO(5) call XERMSG ('SLATEC', 'DEBDF', 'INFO(5) MUST BE 0 OR 1 ' // & 'INDICATING WHETHER THE CODE IS TOLD TO FORM THE ' // & 'JACOBIAN MATRIX BY NUMERICAL DIFFERENCING OR YOU ' // & 'PROVIDE A SUBROUTINE TO EVALUATE IT ANALYTICALLY. ' // & 'YOU HAVE CALLED THE CODE WITH INFO(5) = ' // XERN1, 15, 1) IDID = -33 end if ! if (INFO(6) /= 0 .AND. INFO(6) /= 1) THEN WRITE (XERN1, '(I8)') INFO(6) call XERMSG ('SLATEC', 'DEBDF', 'INFO(6) MUST BE 0 OR 1 ' // & 'INDICATING WHETHER THE CODE IS TOLD TO TREAT THE ' // & 'JACOBIAN AS A FULL (DENSE) MATRIX OR AS HAVING A ' // & 'SPECIAL BANDED STRUCTURE. YOU HAVE CALLED THE CODE ' // & 'WITH INFO(6) = ' // XERN1, 16, 1) IDID = -33 end if ! ILRW = NEQ if (INFO(6) /= 0) THEN ! ! CHECK BANDWIDTH PARAMETERS ! ML = IWORK(1) MU = IWORK(2) ILRW = 2*ML + MU + 1 ! if (ML < 0 .OR. ML >= NEQ .OR. MU < 0 .OR. MU >= NEQ) THEN WRITE (XERN1, '(I8)') ML WRITE (XERN2, '(I8)') MU call XERMSG ('SLATEC', 'DEBDF', 'YOU HAVE SET INFO(6) ' // & '= 1, TELLING THE CODE THAT THE JACOBIAN MATRIX HAS ' // & 'A SPECIAL BANDED STRUCTURE. HOWEVER, THE LOWER ' // & '(UPPER) BANDWIDTHS ML (MU) VIOLATE THE CONSTRAINTS ' // & 'ML,MU >= 0 AND ML,MU < NEQ. YOU HAVE CALLED ' // & 'THE CODE WITH ML = ' // XERN1 // ' AND MU = ' // XERN2, & 17, 1) IDID = -33 ENDIF end if ! ! CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION ! if (LRW < 250 + (10 + ILRW)*NEQ) THEN WRITE (XERN1, '(I8)') LRW if (INFO(6) == 0) THEN call XERMSG ('SLATEC', 'DEBDF', 'LENGTH OF ARRAY RWORK ' // & 'MUST BE AT LEAST 250 + 10*NEQ + NEQ*NEQ.$$' // & 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) ELSE call XERMSG ('SLATEC', 'DEBDF', 'LENGTH OF ARRAY RWORK ' // & 'MUST BE AT LEAST 250 + 10*NEQ + (2*ML+MU+1)*NEQ.$$' // & 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 18, 1) ENDIF IDID = -33 end if ! if (LIW < 56 + NEQ) THEN WRITE (XERN1, '(I8)') LIW call XERMSG ('SLATEC', 'DEBDF', 'LENGTH OF ARRAY IWORK ' // & 'BE AT LEAST 56 + NEQ. YOU HAVE CALLED THE CODE WITH ' // & 'LIW = ' // XERN1, 2, 1) IDID = -33 end if ! ! COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ! ARRAY AND RESTORE COMMON BLOCK DATA ! ICOMI = 21 + NEQ IINOUT = ICOMI + 33 ! IYPOUT = 21 ITSTAR = 21 + NEQ ICOMR = 22 + NEQ ! if (INFO(1) /= 0) INTOUT = IWORK(IINOUT) /= (-1) ! call RSCO(RWORK(ICOMR),IWORK(ICOMI)) ! IYH = ICOMR + 218 IEWT = IYH + 6*NEQ ISAVF = IEWT + NEQ IACOR = ISAVF + NEQ IWM = IACOR + NEQ IDELSN = IWM + 2 + ILRW*NEQ ! IBEGIN = INFO(1) ITOL = INFO(2) IINTEG = INFO(3) ITSTOP = INFO(4) IJAC = INFO(5) IBAND = INFO(6) RWORK(ITSTAR) = T ! call LSOD(F,NEQ,T,Y,TOUT,RTOL,ATOL,IDID,RWORK(IYPOUT), & RWORK(IYH),RWORK(IYH),RWORK(IEWT),RWORK(ISAVF), & RWORK(IACOR),RWORK(IWM),IWORK(1),JAC,INTOUT, & RWORK(1),RWORK(12),RWORK(IDELSN),RPAR,IPAR) ! IWORK(IINOUT) = -1 if (INTOUT) IWORK(IINOUT) = 1 ! if (IDID /= (-2)) IWORK(LIW) = IWORK(LIW) + 1 if (T /= RWORK(ITSTAR)) IWORK(LIW) = 0 ! call SVCO(RWORK(ICOMR),IWORK(ICOMI)) RWORK(11) = H RWORK(13) = TN INFO(1) = IBEGIN ! return end subroutine DEFC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, & MDEIN, MDEOUT, COEFF, LW, W) ! !! DEFC fits a piecewise polynomial curve to discrete data. ! ! The piecewise polynomials are represented as B-splines. ! The fitting is done in a weighted least squares sense. ! !***LIBRARY SLATEC !***CATEGORY K1A1A1, K1A2A, L8A3 !***TYPE DOUBLE PRECISION (EFC-S, DEFC-D) !***KEYWORDS B-SPLINE, CONSTRAINED LEAST SQUARES, CURVE FITTING !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! This subprogram fits a piecewise polynomial curve ! to discrete data. The piecewise polynomials are ! represented as B-splines. ! The fitting is done in a weighted least squares sense. ! ! The data can be processed in groups of modest size. ! The size of the group is chosen by the user. This feature ! may be necessary for purposes of using constrained curve fitting ! with subprogram DFC( ) on a very large data set. ! ! For a description of the B-splines and usage instructions to ! evaluate them, see ! ! C. W. de Boor, Package for Calculating with B-Splines. ! SIAM J. Numer. Anal., p. 441, (June, 1977). ! ! For further discussion of (constrained) curve fitting using ! B-splines, see ! ! R. J. Hanson, Constrained Least Squares Curve Fitting ! to Discrete Data Using B-Splines, a User's ! Guide. Sandia Labs. Tech. Rept. SAND-78-1291, ! December, (1978). ! ! Input.. All TYPE REAL variables are DOUBLE PRECISION ! NDATA,XDATA(*), ! YDATA(*), ! SDDATA(*) ! The NDATA discrete (X,Y) pairs and the Y value ! standard deviation or uncertainty, SD, are in ! the respective arrays XDATA(*), YDATA(*), and ! SDDATA(*). No sorting of XDATA(*) is ! required. Any non-negative value of NDATA is ! allowed. A negative value of NDATA is an ! error. A zero value for any entry of ! SDDATA(*) will weight that data point as 1. ! Otherwise the weight of that data point is ! the reciprocal of this entry. ! ! NORD,NBKPT, ! BKPT(*) ! The NBKPT knots of the B-spline of order NORD ! are in the array BKPT(*). Normally the ! problem data interval will be included between ! the limits BKPT(NORD) and BKPT(NBKPT-NORD+1). ! The additional end knots BKPT(I),I=1,..., ! NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are ! required to compute the functions used to fit ! the data. No sorting of BKPT(*) is required. ! Internal to DEFC( ) the extreme end knots may ! be reduced and increased respectively to ! accommodate any data values that are exterior ! to the given knot values. The contents of ! BKPT(*) is not changed. ! ! NORD must be in the range 1 <= NORD <= 20. ! The value of NBKPT must satisfy the condition ! NBKPT >= 2*NORD. ! Other values are considered errors. ! ! (The order of the spline is one more than the ! degree of the piecewise polynomial defined on ! each interval. This is consistent with the ! B-spline package convention. For example, ! NORD=4 when we are using piecewise cubics.) ! ! MDEIN ! An integer flag, with one of two possible ! values (1 or 2), that directs the subprogram ! action with regard to new data points provided ! by the user. ! ! =1 The first time that DEFC( ) has been ! entered. There are NDATA points to process. ! ! =2 This is another entry to DEFC(). The sub- ! program DEFC( ) has been entered with MDEIN=1 ! exactly once before for this problem. There ! are NDATA new additional points to merge and ! process with any previous points. ! (When using DEFC( ) with MDEIN=2 it is import- ! ant that the set of knots remain fixed at the ! same values for all entries to DEFC( ).) ! LW ! The amount of working storage actually ! allocated for the working array W(*). ! This quantity is compared with the ! actual amount of storage needed in DEFC( ). ! Insufficient storage allocated for W(*) is ! an error. This feature was included in DEFC ! because misreading the storage formula ! for W(*) might very well lead to subtle ! and hard-to-find programming bugs. ! ! The length of the array W(*) must satisfy ! ! LW >= (NBKPT-NORD+3)*(NORD+1)+ ! (NBKPT+1)*(NORD+1)+ ! 2*MAX(NDATA,NBKPT)+NBKPT+NORD**2 ! ! Output.. All TYPE REAL variables are DOUBLE PRECISION ! MDEOUT ! An output flag that indicates the status ! of the curve fit. ! ! =-1 A usage error of DEFC( ) occurred. The ! offending condition is noted with the SLATEC ! library error processor, XERMSG( ). In case ! the working array W(*) is not long enough, the ! minimal acceptable length is printed. ! ! =1 The B-spline coefficients for the fitted ! curve have been returned in array COEFF(*). ! ! =2 Not enough data has been processed to ! determine the B-spline coefficients. ! The user has one of two options. Continue ! to process more data until a unique set ! of coefficients is obtained, or use the ! subprogram DFC( ) to obtain a specific ! set of coefficients. The user should read ! the usage instructions for DFC( ) for further ! details if this second option is chosen. ! COEFF(*) ! If the output value of MDEOUT=1, this array ! contains the unknowns obtained from the least ! squares fitting process. These N=NBKPT-NORD ! parameters are the B-spline coefficients. ! For MDEOUT=2, not enough data was processed to ! uniquely determine the B-spline coefficients. ! In this case, and also when MDEOUT=-1, all ! values of COEFF(*) are set to zero. ! ! If the user is not satisfied with the fitted ! curve returned by DEFC( ), the constrained ! least squares curve fitting subprogram DFC( ) ! may be required. The work done within DEFC( ) ! to accumulate the data can be utilized by ! the user, if so desired. This involves ! saving the first (NBKPT-NORD+3)*(NORD+1) ! entries of W(*) and providing this data ! to DFC( ) with the "old problem" designation. ! The user should read the usage instructions ! for subprogram DFC( ) for further details. ! ! Working Array.. All TYPE REAL variables are DOUBLE PRECISION ! W(*) ! This array is typed DOUBLE PRECISION. ! Its length is specified as an input parameter ! in LW as noted above. The contents of W(*) ! must not be modified by the user between calls ! to DEFC( ) with values of MDEIN=1,2,2,... . ! The first (NBKPT-NORD+3)*(NORD+1) entries of ! W(*) are acceptable as direct input to DFC( ) ! for an "old problem" only when MDEOUT=1 or 2. ! ! Evaluating the ! Fitted Curve.. ! To evaluate derivative number IDER at XVAL, ! use the function subprogram DBVALU( ). ! ! F = DBVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER, ! XVAL,INBV,WORKB) ! ! The output of this subprogram will not be ! defined unless an output value of MDEOUT=1 ! was obtained from DEFC( ), XVAL is in the data ! interval, and IDER is nonnegative and < ! NORD. ! ! The first time DBVALU( ) is called, INBV=1 ! must be specified. This value of INBV is the ! overwritten by DBVALU( ). The array WORKB(*) ! must be of length at least 3*NORD, and must ! not be the same as the W(*) array used in the ! call to DEFC( ). ! ! DBVALU( ) expects the breakpoint array BKPT(*) ! to be sorted. ! !***REFERENCES R. J. Hanson, Constrained least squares curve fitting ! to discrete data using B-splines, a users guide, ! Report SAND78-1291, Sandia Laboratories, December ! 1978. !***ROUTINES CALLED DEFCMN !***REVISION HISTORY (YYMMDD) ! 800801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Change Prologue comments to refer to XERMSG. (RWC) ! 900607 Editorial changes to Prologue to make Prologues for EFC, ! DEFC, FC, and DFC look as much the same as possible. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DEFC ! ! SUBROUTINE FUNCTION/REMARKS ! ! DBSPVN( ) COMPUTE FUNCTION VALUES OF B-SPLINES. FROM ! THE B-SPLINE PACKAGE OF DE BOOR NOTED ABOVE. ! ! DBNDAC( ), BANDED LEAST SQUARES MATRIX PROCESSORS. ! DBNDSL( ) FROM LAWSON-HANSON, SOLVING LEAST ! SQUARES PROBLEMS. ! ! DSORT( ) DATA SORTING SUBROUTINE, FROM THE ! SANDIA MATH. LIBRARY, SAND77-1441. ! ! XERMSG( ) ERROR HANDLING ROUTINE ! FOR THE SLATEC MATH. LIBRARY. ! SEE SAND78-1189, BY R. E. JONES. ! ! DCOPY( ),DSCAL( ) SUBROUTINES FROM THE BLAS PACKAGE. ! ! WRITTEN BY R. HANSON, SANDIA NATL. LABS., ! ALB., N. M., AUGUST-SEPTEMBER, 1980. ! DOUBLE PRECISION BKPT(*),COEFF(*),W(*),SDDATA(*),XDATA(*),YDATA(*) INTEGER LW, MDEIN, MDEOUT, NBKPT, NDATA, NORD ! EXTERNAL DEFCMN ! INTEGER LBF, LBKPT, LG, LPTEMP, LWW, LXTEMP, MDG, MDW ! !***FIRST EXECUTABLE STATEMENT DEFC ! LWW=1 USAGE IN DEFCMN( ) OF W(*).. ! LWW,...,LG-1 W(*,*) ! ! LG,...,LXTEMP-1 G(*,*) ! ! LXTEMP,...,LPTEMP-1 XTEMP(*) ! ! LPTEMP,...,LBKPT-1 PTEMP(*) ! ! LBKPT,...,LBF BKPT(*) (LOCAL TO DEFCMN( )) ! ! LBF,...,LBF+NORD**2 BF(*,*) ! MDG = NBKPT+1 MDW = NBKPT-NORD+3 LWW = 1 LG = LWW + MDW*(NORD+1) LXTEMP = LG + MDG*(NORD+1) LPTEMP = LXTEMP + MAX(NDATA,NBKPT) LBKPT = LPTEMP + MAX(NDATA,NBKPT) LBF = LBKPT + NBKPT call DEFCMN(NDATA,XDATA,YDATA,SDDATA, & NORD,NBKPT,BKPT, & MDEIN,MDEOUT, & COEFF, & W(LBF),W(LXTEMP),W(LPTEMP),W(LBKPT), & W(LG),MDG,W(LWW),MDW,LW) return end subroutine DEFCMN (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, & BKPTIN, MDEIN, MDEOUT, COEFF, BF, XTEMP, PTEMP, BKPT, G, MDG, & W, MDW, LW) ! !! DEFCMN is subsidiary to DEFC. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (EFCMN-S, DEFCMN-D) !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! This is a companion subprogram to DEFC( ). ! This subprogram does weighted least squares fitting of data by ! B-spline curves. ! The documentation for DEFC( ) has complete usage instructions. ! !***SEE ALSO DEFC !***ROUTINES CALLED DBNDAC, DBNDSL, DCOPY, DFSPVN, DSCAL, DSORT, XERMSG !***REVISION HISTORY (YYMMDD) ! 800801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and extensively revised (WRB & RWC) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 900604 DP version created from SP version. (RWC) !***END PROLOGUE DEFCMN INTEGER LW, MDEIN, MDEOUT, MDG, MDW, NBKPT, NDATA, NORD DOUBLE PRECISION BF(NORD,*), BKPT(*), BKPTIN(*), COEFF(*), & G(MDG,*), PTEMP(*), SDDATA(*), W(MDW,*), XDATA(*), XTEMP(*), & YDATA(*) ! EXTERNAL DBNDAC, DBNDSL, DCOPY, DFSPVN, DSCAL, DSORT, XERMSG ! DOUBLE PRECISION DUMMY, RNORM, XMAX, XMIN, XVAL INTEGER I, IDATA, ILEFT, INTSEQ, IP, IR, IROW, L, MT, N, NB, & NORDM1, NORDP1, NP1 CHARACTER*8 XERN1, XERN2 ! !***FIRST EXECUTABLE STATEMENT DEFCMN ! ! Initialize variables and analyze input. ! N = NBKPT - NORD NP1 = N + 1 ! ! Initially set all output coefficients to zero. ! call dinit (N, 0.D0, COEFF, 1) MDEOUT = -1 if (NORD < 1 .OR. NORD > 20) THEN call XERMSG ('SLATEC', 'DEFCMN', & 'IN DEFC, THE ORDER OF THE B-SPLINE MUST BE 1 THRU 20.', & 3, 1) return end if ! if (NBKPT < 2*NORD) THEN call XERMSG ('SLATEC', 'DEFCMN', & 'IN DEFC, THE NUMBER OF KNOTS MUST BE AT LEAST TWICE ' // & 'THE B-SPLINE ORDER.', 4, 1) return end if ! if (NDATA < 0) THEN call XERMSG ('SLATEC', 'DEFCMN', & 'IN DEFC, THE NUMBER OF DATA POINTS MUST BE NONNEGATIVE.', & 5, 1) return end if ! NB = (NBKPT-NORD+3)*(NORD+1) + (NBKPT+1)*(NORD+1) + & 2*MAX(NBKPT,NDATA) + NBKPT + NORD**2 if (LW < NB) THEN WRITE (XERN1, '(I8)') NB WRITE (XERN2, '(I8)') LW call XERMSG ('SLATEC', 'DEFCMN', & 'IN DEFC, INSUFFICIENT STORAGE FOR W(*). CHECK FORMULA ' // & 'THAT READS LW >= ... . NEED = ' // XERN1 // & ' GIVEN = ' // XERN2, 6, 1) MDEOUT = -1 return end if ! if (MDEIN /= 1 .AND. MDEIN /= 2) THEN call XERMSG ('SLATEC', 'DEFCMN', & 'IN DEFC, INPUT VALUE OF MDEIN MUST BE 1-2.', 7, 1) return end if ! ! Sort the breakpoints. ! call DCOPY (NBKPT, BKPTIN, 1, BKPT, 1) call DSORT (BKPT, DUMMY, NBKPT, 1) ! ! Save interval containing knots. ! XMIN = BKPT(NORD) XMAX = BKPT(NP1) NORDM1 = NORD - 1 NORDP1 = NORD + 1 ! ! Process least squares equations. ! ! Sort data and an array of pointers. ! call DCOPY (NDATA, XDATA, 1, XTEMP, 1) DO 100 I = 1,NDATA PTEMP(I) = I 100 CONTINUE ! if (NDATA > 0) THEN call DSORT (XTEMP, PTEMP, NDATA, 2) XMIN = MIN(XMIN,XTEMP(1)) XMAX = MAX(XMAX,XTEMP(NDATA)) end if ! ! Fix breakpoint array if needed. This should only involve very ! minor differences with the input array of breakpoints. ! DO 110 I = 1,NORD BKPT(I) = MIN(BKPT(I),XMIN) 110 CONTINUE ! DO 120 I = NP1,NBKPT BKPT(I) = MAX(BKPT(I),XMAX) 120 CONTINUE ! ! Initialize parameters of banded matrix processor, DBNDAC( ). ! MT = 0 IP = 1 IR = 1 ILEFT = NORD INTSEQ = 1 DO 150 IDATA = 1,NDATA ! ! Sorted indices are in PTEMP(*). ! L = PTEMP(IDATA) XVAL = XDATA(L) ! ! When interval changes, process equations in the last block. ! if (XVAL >= BKPT(ILEFT+1)) THEN call DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) MT = 0 ! ! Move pointer up to have BKPT(ILEFT) <= XVAL, ILEFT <= N. ! DO 130 ILEFT = ILEFT,N if (XVAL < BKPT(ILEFT+1)) go to 140 if (MDEIN == 2) THEN ! ! Data is being sequentially accumulated. ! Transfer previously accumulated rows from W(*,*) to ! G(*,*) and process them. ! call DCOPY (NORDP1, W(INTSEQ,1), MDW, G(IR,1), MDG) call DBNDAC (G, MDG, NORD, IP, IR, 1, INTSEQ) INTSEQ = INTSEQ + 1 ENDIF 130 CONTINUE ENDIF ! ! Obtain B-spline function value. ! 140 call DFSPVN (BKPT, NORD, 1, XVAL, ILEFT, BF) ! ! Move row into place. ! IROW = IR + MT MT = MT + 1 call DCOPY (NORD, BF, 1, G(IROW,1), MDG) G(IROW,NORDP1) = YDATA(L) ! ! Scale data if uncertainty is nonzero. ! if (SDDATA(L) /= 0.D0) call DSCAL (NORDP1, 1.D0/SDDATA(L), & G(IROW,1), MDG) ! ! When staging work area is exhausted, process rows. ! if (IROW == MDG-1) THEN call DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) MT = 0 ENDIF 150 CONTINUE ! ! Process last block of equations. ! call DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) ! ! Finish processing any previously accumulated rows from W(*,*) ! to G(*,*). ! if (MDEIN == 2) THEN DO 160 I = INTSEQ,NP1 call DCOPY (NORDP1, W(I,1), MDW, G(IR,1), MDG) call DBNDAC (G, MDG, NORD, IP, IR, 1, MIN(N,I)) 160 CONTINUE end if ! ! Last call to adjust block positioning. ! call dinit ( NORDP1, 0.D0, G(IR,1), MDG) call DBNDAC (G, MDG, NORD, IP, IR, 1, NP1) ! ! Transfer accumulated rows from G(*,*) to W(*,*) for ! possible later sequential accumulation. ! DO 170 I = 1,NP1 call DCOPY (NORDP1, G(I,1), MDG, W(I,1), MDW) 170 CONTINUE ! ! Solve for coefficients when possible. ! DO 180 I = 1,N if (G(I,1) == 0.D0) THEN MDEOUT = 2 return ENDIF 180 CONTINUE ! ! All the diagonal terms in the accumulated triangular ! matrix are nonzero. The solution can be computed but ! it may be unsuitable for further use due to poor ! conditioning or the lack of constraints. No checking ! for either of these is done here. ! call DBNDSL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM) MDEOUT = 1 return end subroutine DEFE4 (COFX, IDMN, USOL, GRHS) ! !! DEFE4 is subsidiary to SEPX4. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (DEFE4-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine first approximates the truncation error given by ! TRUN1(X,Y)=DLX**2*TX+DLY**2*TY where ! TX=AFUN(X)*UXXXX/12.0+BFUN(X)*UXXX/6.0 on the interior and ! at the boundaries if periodic (here UXXX,UXXXX are the third ! and fourth partial derivatives of U with respect to X). ! TX is of the form AFUN(X)/3.0*(UXXXX/4.0+UXXX/DLX) ! at X=A or X=B if the boundary condition there is mixed. ! TX=0.0 along specified boundaries. TY has symmetric form ! in Y with X,AFUN(X),BFUN(X) replaced by Y,DFUN(Y),EFUN(Y). ! The second order solution in USOL is used to approximate ! (via second order finite differencing) the truncation error ! and the result is added to the right hand side in GRHS ! and then transferred to USOL to be used as a new right ! hand side when calling BLKTRI for a fourth order solution. ! !***SEE ALSO SEPX4 !***ROUTINES CALLED DX4, DY4 !***COMMON BLOCKS SPL4 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE DEFE4 ! COMMON /SPL4/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) EXTERNAL COFX !***FIRST EXECUTABLE STATEMENT DEFE4 DO 30 I=IS,MS XI = AIT+(I-1)*DLX call COFX (XI,AI,BI,CI) DO 30 J=JS,NS ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT (XI,YJ) ! call DX4(USOL,IDMN,I,J,UXXX,UXXXX) call DY4(USOL,IDMN,I,J,UYYY,UYYYY) TX = AI*UXXXX/12.0+BI*UXXX/6.0 TY=UYYYY/12.0 ! ! RESET FORM OF TRUNCATION if AT BOUNDARY WHICH IS NON-PERIODIC ! if (KSWX == 1 .OR. (I > 1 .AND. I < K)) go to 10 TX = AI/3.0*(UXXXX/4.0+UXXX/DLX) 10 if (KSWY == 1 .OR. (J > 1 .AND. J < L)) go to 20 TY = (UYYYY/4.0+UYYY/DLY)/3.0 20 GRHS(I,J)=GRHS(I,J)+DLY**2*(DLX**2*TX+DLY**2*TY) 30 CONTINUE ! ! RESET THE RIGHT HAND SIDE IN USOL ! DO 60 I=IS,MS DO 50 J=JS,NS USOL(I,J) = GRHS(I,J) 50 CONTINUE 60 CONTINUE return end subroutine DEFEHL (F, NEQ, T, Y, H, YP, F1, F2, F3, F4, F5, YS, & RPAR, IPAR) ! !! DEFEHL is subsidiary to DERKF. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (DEFEHL-S, DFEHL-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! Fehlberg Fourth-Fifth order Runge-Kutta Method ! ********************************************************************** ! ! DEFEHL integrates a system of NEQ first order ! ordinary differential equations of the form ! dU/DX = F(X,U) ! over one step when the vector Y(*) of initial values for U(*) and ! the vector YP(*) of initial derivatives, satisfying YP = F(T,Y), ! are given at the starting point X=T. ! ! DEFEHL advances the solution over the fixed step H and returns ! the fifth order (sixth order accurate locally) solution ! approximation at T+H in the array YS(*). ! F1,---,F5 are arrays of dimension NEQ which are needed ! for internal storage. ! The formulas have been grouped to control loss of significance. ! DEFEHL should be called with an H not smaller than 13 units of ! roundoff in T so that the various independent arguments can be ! distinguished. ! ! This subroutine has been written with all variables and statement ! numbers entirely compatible with DERKFS. For greater efficiency, ! the call to DEFEHL can be replaced by the module beginning with ! line 222 and extending to the last line just before the return ! statement. ! ! ********************************************************************** ! !***SEE ALSO DERKF !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced statement label. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DEFEHL ! ! DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), & YS(*),RPAR(*),IPAR(*) ! !***FIRST EXECUTABLE STATEMENT DEFEHL CH=H/4. DO 230 K=1,NEQ 230 YS(K)=Y(K)+CH*YP(K) call F(T+CH,YS,F1,RPAR,IPAR) ! CH=3.*H/32. DO 240 K=1,NEQ 240 YS(K)=Y(K)+CH*(YP(K)+3.*F1(K)) call F(T+3.*H/8.,YS,F2,RPAR,IPAR) ! CH=H/2197. DO 250 K=1,NEQ 250 YS(K)=Y(K)+CH*(1932.*YP(K)+(7296.*F2(K)-7200.*F1(K))) call F(T+12.*H/13.,YS,F3,RPAR,IPAR) ! CH=H/4104. DO 260 K=1,NEQ 260 YS(K)=Y(K)+CH*((8341.*YP(K)-845.*F3(K))+ & (29440.*F2(K)-32832.*F1(K))) call F(T+H,YS,F4,RPAR,IPAR) ! CH=H/20520. DO 270 K=1,NEQ 270 YS(K)=Y(K)+CH*((-6080.*YP(K)+(9295.*F3(K)-5643.*F4(K)))+ & (41040.*F1(K)-28352.*F2(K))) call F(T+H/2.,YS,F5,RPAR,IPAR) ! ! COMPUTE APPROXIMATE SOLUTION AT T+H ! CH=H/7618050. DO 290 K=1,NEQ 290 YS(K)=Y(K)+CH*((902880.*YP(K)+(3855735.*F3(K)-1371249.*F4(K)))+ & (3953664.*F2(K)+277020.*F5(K))) ! return end subroutine DEFER (COFX, COFY, IDMN, USOL, GRHS) ! !! DEFER is subsidiary to SEPELI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (DEFER-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine first approximates the truncation error given by ! TRUN1(X,Y)=DLX**2*TX+DLY**2*TY where ! TX=AFUN(X)*UXXXX/12.0+BFUN(X)*UXXX/6.0 on the interior and ! at the boundaries if periodic (here UXXX,UXXXX are the third ! and fourth partial derivatives of U with respect to X). ! TX is of the form AFUN(X)/3.0*(UXXXX/4.0+UXXX/DLX) ! at X=A or X=B if the boundary condition there is mixed. ! TX=0.0 along specified boundaries. TY has symmetric form ! in Y with X,AFUN(X),BFUN(X) replaced by Y,DFUN(Y),EFUN(Y). ! The second order solution in USOL is used to approximate ! (via second order finite differencing) the truncation error ! and the result is added to the right hand side in GRHS ! and then transferred to USOL to be used as a new right ! hand side when calling BLKTRI for a fourth order solution. ! !***SEE ALSO SEPELI !***ROUTINES CALLED DX, DY !***COMMON BLOCKS SPLPCM !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE DEFER ! COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) EXTERNAL COFX ,COFY !***FIRST EXECUTABLE STATEMENT DEFER DO 40 J=JS,NS YJ = CIT+(J-1)*DLY call COFY (YJ,DJ,EJ,FJ) DO 30 I=IS,MS XI = AIT+(I-1)*DLX call COFX (XI,AI,BI,CI) ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT (XI,YJ) ! call DX (USOL,IDMN,I,J,UXXX,UXXXX) call DY (USOL,IDMN,I,J,UYYY,UYYYY) TX = AI*UXXXX/12.0+BI*UXXX/6.0 TY = DJ*UYYYY/12.0+EJ*UYYY/6.0 ! ! RESET FORM OF TRUNCATION if AT BOUNDARY WHICH IS NON-PERIODIC ! if (KSWX == 1 .OR. (I > 1 .AND. I < K)) go to 10 TX = AI/3.0*(UXXXX/4.0+UXXX/DLX) 10 if (KSWY == 1 .OR. (J > 1 .AND. J < 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 ! ! RESET THE RIGHT HAND SIDE IN USOL ! DO 60 I=IS,MS DO 50 J=JS,NS USOL(I,J) = GRHS(I,J) 50 CONTINUE 60 CONTINUE return end DOUBLE PRECISION FUNCTION DEI (X) ! !! DEI computes the exponential integral Ei(X). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C5 !***TYPE DOUBLE PRECISION (EI-S, DEI-D) !***KEYWORDS EI FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DEI calculates the double precision exponential integral, Ei(X), for ! positive double precision argument X and the Cauchy principal value ! for negative X. If principal values are used everywhere, then, for ! all X, ! ! Ei(X) = -E1(-X) ! or ! E1(X) = -Ei(-X). ! !***REFERENCES (NONE) !***ROUTINES CALLED DE1 !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 891115 Modified prologue description. (WRB) ! 891115 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DEI DOUBLE PRECISION X, DE1 !***FIRST EXECUTABLE STATEMENT DEI DEI = -DE1(-X) ! return end DOUBLE PRECISION FUNCTION DENORM (N, X) ! !! DENORM is subsidiary to DNSQ and DNSQE. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (ENORM-S, DENORM-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an N-vector X, this function calculates the ! Euclidean norm of X. ! ! The Euclidean norm is computed by accumulating the sum of ! squares in three different sums. The sums of squares for the ! small and large components are scaled so that no overflows ! occur. Non-destructive underflows are permitted. Underflows ! and overflows do not occur in the computation of the unscaled ! sum of squares for the intermediate components. ! The definitions of small, intermediate and large components ! depend on two constants, RDWARF and RGIANT. The main ! restrictions on these constants are that RDWARF**2 not ! underflow and RGIANT**2 not overflow. The constants ! given here are suitable for every known computer. ! ! The function statement is ! ! DOUBLE PRECISION FUNCTION DENORM(N,X) ! ! where ! ! N is a positive integer input variable. ! ! X is an input array of length N. ! !***SEE ALSO DNSQ, DNSQE !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DENORM INTEGER I, N DOUBLE PRECISION AGIANT, FLOATN, ONE, RDWARF, RGIANT, S1, S2, S3, & X(*), X1MAX, X3MAX, XABS, ZERO SAVE ONE, ZERO, RDWARF, RGIANT DATA ONE,ZERO,RDWARF,RGIANT /1.0D0,0.0D0,3.834D-20,1.304D19/ !***FIRST EXECUTABLE STATEMENT DENORM S1 = ZERO S2 = ZERO S3 = ZERO X1MAX = ZERO X3MAX = ZERO FLOATN = N AGIANT = RGIANT/FLOATN DO 90 I = 1, N XABS = ABS(X(I)) if (XABS > RDWARF .AND. XABS < AGIANT) go to 70 if (XABS <= RDWARF) go to 30 ! ! SUM FOR LARGE COMPONENTS. ! if (XABS <= X1MAX) go to 10 S1 = ONE + S1*(X1MAX/XABS)**2 X1MAX = XABS go to 20 10 CONTINUE S1 = S1 + (XABS/X1MAX)**2 20 CONTINUE go to 60 30 CONTINUE ! ! SUM FOR SMALL COMPONENTS. ! if (XABS <= X3MAX) go to 40 S3 = ONE + S3*(X3MAX/XABS)**2 X3MAX = XABS go to 50 40 CONTINUE if (XABS /= ZERO) S3 = S3 + (XABS/X3MAX)**2 50 CONTINUE 60 CONTINUE go to 80 70 CONTINUE ! ! SUM FOR INTERMEDIATE COMPONENTS. ! S2 = S2 + XABS**2 80 CONTINUE 90 CONTINUE ! ! CALCULATION OF NORM. ! if (S1 == ZERO) go to 100 DENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX) go to 130 100 CONTINUE if (S2 == ZERO) go to 110 if (S2 >= X3MAX) & DENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) if (S2 < X3MAX) & DENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) go to 120 110 CONTINUE DENORM = X3MAX*SQRT(S3) 120 CONTINUE 130 CONTINUE return ! ! LAST CARD OF FUNCTION DENORM. ! end DOUBLE PRECISION FUNCTION DERFC (X) ! !! DERFC computes the complementary error function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C8A, L5A1E !***TYPE DOUBLE PRECISION (ERFC-S, DERFC-D) !***KEYWORDS COMPLEMENTARY ERROR FUNCTION, ERFC, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DERFC(X) calculates the double precision complementary error function ! for double precision argument X. ! ! Series for ERF on the interval 0. to 1.00000E+00 ! with weighted Error 1.28E-32 ! log weighted Error 31.89 ! significant figures required 31.05 ! decimal places required 32.55 ! ! Series for ERC2 on the interval 2.50000E-01 to 1.00000E+00 ! with weighted Error 2.67E-32 ! log weighted Error 31.57 ! significant figures required 30.31 ! decimal places required 32.42 ! ! Series for ERFC on the interval 0. to 2.50000E-01 ! with weighted error 1.53E-31 ! log weighted error 30.82 ! significant figures required 29.47 ! decimal places required 31.70 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE DERFC DOUBLE PRECISION X, ERFCS(21), ERFCCS(59), ERC2CS(49), SQEPS, & SQRTPI, XMAX, TXMAX, XSML, Y, D1MACH, DCSEVL LOGICAL FIRST SAVE ERFCS, ERC2CS, ERFCCS, SQRTPI, NTERF, & NTERFC, NTERC2, XSML, XMAX, SQEPS, FIRST DATA ERFCS( 1) / -.49046121234691808039984544033376D-1 / DATA ERFCS( 2) / -.14226120510371364237824741899631D+0 / DATA ERFCS( 3) / +.10035582187599795575754676712933D-1 / DATA ERFCS( 4) / -.57687646997674847650827025509167D-3 / DATA ERFCS( 5) / +.27419931252196061034422160791471D-4 / DATA ERFCS( 6) / -.11043175507344507604135381295905D-5 / DATA ERFCS( 7) / +.38488755420345036949961311498174D-7 / DATA ERFCS( 8) / -.11808582533875466969631751801581D-8 / DATA ERFCS( 9) / +.32334215826050909646402930953354D-10 / DATA ERFCS( 10) / -.79910159470045487581607374708595D-12 / DATA ERFCS( 11) / +.17990725113961455611967245486634D-13 / DATA ERFCS( 12) / -.37186354878186926382316828209493D-15 / DATA ERFCS( 13) / +.71035990037142529711689908394666D-17 / DATA ERFCS( 14) / -.12612455119155225832495424853333D-18 / DATA ERFCS( 15) / +.20916406941769294369170500266666D-20 / DATA ERFCS( 16) / -.32539731029314072982364160000000D-22 / DATA ERFCS( 17) / +.47668672097976748332373333333333D-24 / DATA ERFCS( 18) / -.65980120782851343155199999999999D-26 / DATA ERFCS( 19) / +.86550114699637626197333333333333D-28 / DATA ERFCS( 20) / -.10788925177498064213333333333333D-29 / DATA ERFCS( 21) / +.12811883993017002666666666666666D-31 / DATA ERC2CS( 1) / -.6960134660230950112739150826197D-1 / DATA ERC2CS( 2) / -.4110133936262089348982212084666D-1 / DATA ERC2CS( 3) / +.3914495866689626881561143705244D-2 / DATA ERC2CS( 4) / -.4906395650548979161280935450774D-3 / DATA ERC2CS( 5) / +.7157479001377036380760894141825D-4 / DATA ERC2CS( 6) / -.1153071634131232833808232847912D-4 / DATA ERC2CS( 7) / +.1994670590201997635052314867709D-5 / DATA ERC2CS( 8) / -.3642666471599222873936118430711D-6 / DATA ERC2CS( 9) / +.6944372610005012589931277214633D-7 / DATA ERC2CS( 10) / -.1371220902104366019534605141210D-7 / DATA ERC2CS( 11) / +.2788389661007137131963860348087D-8 / DATA ERC2CS( 12) / -.5814164724331161551864791050316D-9 / DATA ERC2CS( 13) / +.1238920491752753181180168817950D-9 / DATA ERC2CS( 14) / -.2690639145306743432390424937889D-10 / DATA ERC2CS( 15) / +.5942614350847910982444709683840D-11 / DATA ERC2CS( 16) / -.1332386735758119579287754420570D-11 / DATA ERC2CS( 17) / +.3028046806177132017173697243304D-12 / DATA ERC2CS( 18) / -.6966648814941032588795867588954D-13 / DATA ERC2CS( 19) / +.1620854541053922969812893227628D-13 / DATA ERC2CS( 20) / -.3809934465250491999876913057729D-14 / DATA ERC2CS( 21) / +.9040487815978831149368971012975D-15 / DATA ERC2CS( 22) / -.2164006195089607347809812047003D-15 / DATA ERC2CS( 23) / +.5222102233995854984607980244172D-16 / DATA ERC2CS( 24) / -.1269729602364555336372415527780D-16 / DATA ERC2CS( 25) / +.3109145504276197583836227412951D-17 / DATA ERC2CS( 26) / -.7663762920320385524009566714811D-18 / DATA ERC2CS( 27) / +.1900819251362745202536929733290D-18 / DATA ERC2CS( 28) / -.4742207279069039545225655999965D-19 / DATA ERC2CS( 29) / +.1189649200076528382880683078451D-19 / DATA ERC2CS( 30) / -.3000035590325780256845271313066D-20 / DATA ERC2CS( 31) / +.7602993453043246173019385277098D-21 / DATA ERC2CS( 32) / -.1935909447606872881569811049130D-21 / DATA ERC2CS( 33) / +.4951399124773337881000042386773D-22 / DATA ERC2CS( 34) / -.1271807481336371879608621989888D-22 / DATA ERC2CS( 35) / +.3280049600469513043315841652053D-23 / DATA ERC2CS( 36) / -.8492320176822896568924792422399D-24 / DATA ERC2CS( 37) / +.2206917892807560223519879987199D-24 / DATA ERC2CS( 38) / -.5755617245696528498312819507199D-25 / DATA ERC2CS( 39) / +.1506191533639234250354144051199D-25 / DATA ERC2CS( 40) / -.3954502959018796953104285695999D-26 / DATA ERC2CS( 41) / +.1041529704151500979984645051733D-26 / DATA ERC2CS( 42) / -.2751487795278765079450178901333D-27 / DATA ERC2CS( 43) / +.7290058205497557408997703680000D-28 / DATA ERC2CS( 44) / -.1936939645915947804077501098666D-28 / DATA ERC2CS( 45) / +.5160357112051487298370054826666D-29 / DATA ERC2CS( 46) / -.1378419322193094099389644800000D-29 / DATA ERC2CS( 47) / +.3691326793107069042251093333333D-30 / DATA ERC2CS( 48) / -.9909389590624365420653226666666D-31 / DATA ERC2CS( 49) / +.2666491705195388413323946666666D-31 / DATA ERFCCS( 1) / +.715179310202924774503697709496D-1 / DATA ERFCCS( 2) / -.265324343376067157558893386681D-1 / DATA ERFCCS( 3) / +.171115397792085588332699194606D-2 / DATA ERFCCS( 4) / -.163751663458517884163746404749D-3 / DATA ERFCCS( 5) / +.198712935005520364995974806758D-4 / DATA ERFCCS( 6) / -.284371241276655508750175183152D-5 / DATA ERFCCS( 7) / +.460616130896313036969379968464D-6 / DATA ERFCCS( 8) / -.822775302587920842057766536366D-7 / DATA ERFCCS( 9) / +.159214187277090112989358340826D-7 / DATA ERFCCS( 10) / -.329507136225284321486631665072D-8 / DATA ERFCCS( 11) / +.722343976040055546581261153890D-9 / DATA ERFCCS( 12) / -.166485581339872959344695966886D-9 / DATA ERFCCS( 13) / +.401039258823766482077671768814D-10 / DATA ERFCCS( 14) / -.100481621442573113272170176283D-10 / DATA ERFCCS( 15) / +.260827591330033380859341009439D-11 / DATA ERFCCS( 16) / -.699111056040402486557697812476D-12 / DATA ERFCCS( 17) / +.192949233326170708624205749803D-12 / DATA ERFCCS( 18) / -.547013118875433106490125085271D-13 / DATA ERFCCS( 19) / +.158966330976269744839084032762D-13 / DATA ERFCCS( 20) / -.472689398019755483920369584290D-14 / DATA ERFCCS( 21) / +.143587337678498478672873997840D-14 / DATA ERFCCS( 22) / -.444951056181735839417250062829D-15 / DATA ERFCCS( 23) / +.140481088476823343737305537466D-15 / DATA ERFCCS( 24) / -.451381838776421089625963281623D-16 / DATA ERFCCS( 25) / +.147452154104513307787018713262D-16 / DATA ERFCCS( 26) / -.489262140694577615436841552532D-17 / DATA ERFCCS( 27) / +.164761214141064673895301522827D-17 / DATA ERFCCS( 28) / -.562681717632940809299928521323D-18 / DATA ERFCCS( 29) / +.194744338223207851429197867821D-18 / DATA ERFCCS( 30) / -.682630564294842072956664144723D-19 / DATA ERFCCS( 31) / +.242198888729864924018301125438D-19 / DATA ERFCCS( 32) / -.869341413350307042563800861857D-20 / DATA ERFCCS( 33) / +.315518034622808557122363401262D-20 / DATA ERFCCS( 34) / -.115737232404960874261239486742D-20 / DATA ERFCCS( 35) / +.428894716160565394623737097442D-21 / DATA ERFCCS( 36) / -.160503074205761685005737770964D-21 / DATA ERFCCS( 37) / +.606329875745380264495069923027D-22 / DATA ERFCCS( 38) / -.231140425169795849098840801367D-22 / DATA ERFCCS( 39) / +.888877854066188552554702955697D-23 / DATA ERFCCS( 40) / -.344726057665137652230718495566D-23 / DATA ERFCCS( 41) / +.134786546020696506827582774181D-23 / DATA ERFCCS( 42) / -.531179407112502173645873201807D-24 / DATA ERFCCS( 43) / +.210934105861978316828954734537D-24 / DATA ERFCCS( 44) / -.843836558792378911598133256738D-25 / DATA ERFCCS( 45) / +.339998252494520890627359576337D-25 / DATA ERFCCS( 46) / -.137945238807324209002238377110D-25 / DATA ERFCCS( 47) / +.563449031183325261513392634811D-26 / DATA ERFCCS( 48) / -.231649043447706544823427752700D-26 / DATA ERFCCS( 49) / +.958446284460181015263158381226D-27 / DATA ERFCCS( 50) / -.399072288033010972624224850193D-27 / DATA ERFCCS( 51) / +.167212922594447736017228709669D-27 / DATA ERFCCS( 52) / -.704599152276601385638803782587D-28 / DATA ERFCCS( 53) / +.297976840286420635412357989444D-28 / DATA ERFCCS( 54) / -.126252246646061929722422632994D-28 / DATA ERFCCS( 55) / +.539543870454248793985299653154D-29 / DATA ERFCCS( 56) / -.238099288253145918675346190062D-29 / DATA ERFCCS( 57) / +.109905283010276157359726683750D-29 / DATA ERFCCS( 58) / -.486771374164496572732518677435D-30 / DATA ERFCCS( 59) / +.152587726411035756763200828211D-30 / DATA SQRTPI / 1.77245385090551602729816748334115D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DERFC if (FIRST) THEN ETA = 0.1*REAL(D1MACH(3)) NTERF = INITDS (ERFCS, 21, ETA) NTERFC = INITDS (ERFCCS, 59, ETA) NTERC2 = INITDS (ERC2CS, 49, ETA) ! XSML = -SQRT(-LOG(SQRTPI*D1MACH(3))) TXMAX = SQRT(-LOG(SQRTPI*D1MACH(1))) XMAX = TXMAX - 0.5D0*LOG(TXMAX)/TXMAX - 0.01D0 SQEPS = SQRT(2.0D0*D1MACH(3)) end if FIRST = .FALSE. ! if (X > XSML) go to 20 ! ! ERFC(X) = 1.0 - ERF(X) FOR X < XSML ! DERFC = 2.0D0 return ! 20 if (X > XMAX) go to 40 Y = ABS(X) if (Y > 1.0D0) go to 30 ! ! ERFC(X) = 1.0 - ERF(X) FOR ABS(X) <= 1.0 ! if (Y < SQEPS) DERFC = 1.0D0 - 2.0D0*X/SQRTPI if (Y >= SQEPS) DERFC = 1.0D0 - X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, & ERFCS, NTERF)) return ! ! ERFC(X) = 1.0 - ERF(X) FOR 1.0 < ABS(X) <= XMAX ! 30 Y = Y*Y if (Y <= 4.D0) DERFC = EXP(-Y)/ABS(X) * (0.5D0 + DCSEVL ( & (8.D0/Y-5.D0)/3.D0, ERC2CS, NTERC2) ) if (Y > 4.D0) DERFC = EXP(-Y)/ABS(X) * (0.5D0 + DCSEVL ( & 8.D0/Y-1.D0, ERFCCS, NTERFC) ) if (X < 0.D0) DERFC = 2.0D0 - DERFC return ! 40 call XERMSG ('SLATEC', 'DERFC', 'X SO BIG ERFC UNDERFLOWS', 1, 1) DERFC = 0.D0 return ! end DOUBLE PRECISION FUNCTION DERF (X) ! !! DERF computes the error function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C8A, L5A1E !***TYPE DOUBLE PRECISION (ERF-S, DERF-D) !***KEYWORDS ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DERF(X) calculates the double precision error function for double ! precision argument X. ! ! Series for ERF on the interval 0. to 1.00000E+00 ! with weighted error 1.28E-32 ! log weighted error 31.89 ! significant figures required 31.05 ! decimal places required 32.55 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, DERFC, INITDS !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900727 Added EXTERNAL statement. (WRB) ! 920618 Removed space from variable name. (RWC, WRB) !***END PROLOGUE DERF DOUBLE PRECISION X, ERFCS(21), SQEPS, SQRTPI, XBIG, Y, D1MACH, & DCSEVL, DERFC LOGICAL FIRST EXTERNAL DERFC SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST DATA ERFCS( 1) / -.49046121234691808039984544033376D-1 / DATA ERFCS( 2) / -.14226120510371364237824741899631D+0 / DATA ERFCS( 3) / +.10035582187599795575754676712933D-1 / DATA ERFCS( 4) / -.57687646997674847650827025509167D-3 / DATA ERFCS( 5) / +.27419931252196061034422160791471D-4 / DATA ERFCS( 6) / -.11043175507344507604135381295905D-5 / DATA ERFCS( 7) / +.38488755420345036949961311498174D-7 / DATA ERFCS( 8) / -.11808582533875466969631751801581D-8 / DATA ERFCS( 9) / +.32334215826050909646402930953354D-10 / DATA ERFCS( 10) / -.79910159470045487581607374708595D-12 / DATA ERFCS( 11) / +.17990725113961455611967245486634D-13 / DATA ERFCS( 12) / -.37186354878186926382316828209493D-15 / DATA ERFCS( 13) / +.71035990037142529711689908394666D-17 / DATA ERFCS( 14) / -.12612455119155225832495424853333D-18 / DATA ERFCS( 15) / +.20916406941769294369170500266666D-20 / DATA ERFCS( 16) / -.32539731029314072982364160000000D-22 / DATA ERFCS( 17) / +.47668672097976748332373333333333D-24 / DATA ERFCS( 18) / -.65980120782851343155199999999999D-26 / DATA ERFCS( 19) / +.86550114699637626197333333333333D-28 / DATA ERFCS( 20) / -.10788925177498064213333333333333D-29 / DATA ERFCS( 21) / +.12811883993017002666666666666666D-31 / DATA SQRTPI / 1.77245385090551602729816748334115D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DERF if (FIRST) THEN NTERF = INITDS (ERFCS, 21, 0.1*REAL(D1MACH(3))) XBIG = SQRT(-LOG(SQRTPI*D1MACH(3))) SQEPS = SQRT(2.0D0*D1MACH(3)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 1.D0) go to 20 ! ! ERF(X) = 1.0 - ERFC(X) FOR -1.0 <= X <= 1.0 ! if (Y <= SQEPS) DERF = 2.0D0*X*X/SQRTPI if (Y > SQEPS) DERF = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0, & ERFCS, NTERF)) return ! ! ERF(X) = 1.0 - ERFC(X) FOR ABS(X) > 1.0 ! 20 if (Y <= XBIG) DERF = SIGN (1.0D0-DERFC(Y), X) if (Y > XBIG) DERF = SIGN (1.0D0, X) ! return end subroutine DERKF (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, & RWORK, LRW, IWORK, LIW, RPAR, IPAR) ! !! DERKF solves an initial value problem in ordinary differential ... ! equations using a Runge-Kutta-Fehlberg scheme. ! !***LIBRARY SLATEC (DEPAC) !***CATEGORY I1A1A !***TYPE SINGLE PRECISION (DERKF-S, DDERKF-D) !***KEYWORDS DEPAC, INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, RKF, ! RUNGE-KUTTA-FEHLBERG METHODS !***AUTHOR Watts, H. A., (SNLA) ! Shampine, L. F., (SNLA) !***DESCRIPTION ! ! This is the Runge-Kutta code in the package of differential equation ! solvers DEPAC, consisting of the codes DERKF, DEABM, and DEBDF. ! Design of the package was by L. F. Shampine and H. A. Watts. ! It is documented in ! SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE ! Solvers. ! DERKF is a driver for a modification of the code RKF45 written by ! H. A. Watts and L. F. Shampine ! Sandia Laboratories ! Albuquerque, New Mexico 87185 ! ! ********************************************************************** ! ** DEPAC PACKAGE OVERVIEW ** ! ********************************************************************** ! ! You have a choice of three differential equation solvers from ! DEPAC. The following brief descriptions are meant to aid you ! in choosing the most appropriate code for your problem. ! ! DERKF is a fifth order Runge-Kutta code. It is the simplest of ! the three choices, both algorithmically and in the use of the ! code. DERKF is primarily designed to solve non-stiff and mild- ! ly stiff differential equations when derivative evaluations are ! not expensive. It should generally not be used to get high ! accuracy results nor answers at a great many specific points. ! Because DERKF has very low overhead costs, it will usually ! result in the least expensive integration when solving ! problems requiring a modest amount of accuracy and having ! equations that are not costly to evaluate. DERKF attempts to ! discover when it is not suitable for the task posed. ! ! DEABM is a variable order (one through twelve) Adams code. Its ! complexity lies somewhere between that of DERKF and DEBDF. ! DEABM is primarily designed to solve non-stiff and mildly ! stiff differential equations when derivative evaluations are ! expensive, high accuracy results are needed or answers at ! many specific points are required. DEABM attempts to discover ! when it is not suitable for the task posed. ! ! DEBDF is a variable order (one through five) backward ! differentiation formula code. It is the most complicated of ! the three choices. DEBDF is primarily designed to solve stiff ! differential equations at crude to moderate tolerances. ! If the problem is very stiff at all, DERKF and DEABM will be ! quite inefficient compared to DEBDF. However, DEBDF will be ! inefficient compared to DERKF and DEABM on non-stiff problems ! because it uses much more storage, has a much larger overhead, ! and the low order formulas will not give high accuracies ! efficiently. ! ! The concept of stiffness cannot be described in a few words. ! If you do not know the problem to be stiff, try either DERKF ! or DEABM. Both of these codes will inform you of stiffness ! when the cost of solving such problems becomes important. ! ! ********************************************************************** ! ** ABSTRACT ** ! ********************************************************************** ! ! Subroutine DERKF uses a Runge-Kutta-Fehlberg (4,5) method to ! integrate a system of NEQ first order ordinary differential ! equations of the form ! DU/DX = F(X,U) ! when the vector Y(*) of initial values for U(*) at X=T is given. ! The subroutine integrates from T to TOUT. It is easy to continue the ! integration to get results at additional TOUT. This is the interval ! mode of operation. It is also easy for the routine to return with ! the solution at each intermediate step on the way to TOUT. This is ! the intermediate-output mode of operation. ! ! DERKF uses subprograms DERKFS, DEFEHL, HSTART, HVNRM, R1MACH, and ! the error handling routine XERMSG. The only machine dependent ! parameters to be assigned appear in R1MACH. ! ! ********************************************************************** ! ** DESCRIPTION OF THE ARGUMENTS TO DERKF (AN OVERVIEW) ** ! ********************************************************************** ! ! The Parameters are: ! ! F -- This is the name of a subroutine which you provide to ! define the differential equations. ! ! NEQ -- This is the number of (first order) differential ! equations to be integrated. ! ! T -- This is a value of the independent variable. ! ! Y(*) -- This array contains the solution components at T. ! ! TOUT -- This is a point at which a solution is desired. ! ! INFO(*) -- The basic task of the code is to integrate the ! differential equations from T to TOUT and return an ! answer at TOUT. INFO(*) is an INTEGER array which is used ! to communicate exactly how you want this task to be ! carried out. ! ! RTOL, ATOL -- These quantities represent relative and absolute ! error tolerances which you provide to indicate how ! accurately you wish the solution to be computed. You may ! choose them to be both scalars or else both vectors. ! ! IDID -- This scalar quantity is an indicator reporting what ! the code did. You must monitor this INTEGER variable to ! decide what action to take next. ! ! RWORK(*), LRW -- RWORK(*) is a REAL work array of length LRW ! which provides the code with needed storage space. ! ! IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW ! which provides the code with needed storage space and an ! across call flag. ! ! RPAR, IPAR -- These are REAL and INTEGER parameter arrays which ! you can use for communication between your calling ! program and the F subroutine. ! ! Quantities which are used as input items are ! NEQ, T, Y(*), TOUT, INFO(*), ! RTOL, ATOL, LRW and LIW. ! ! Quantities which may be altered by the code are ! T, Y(*), INFO(1), RTOL, ATOL, ! IDID, RWORK(*) and IWORK(*). ! ! ********************************************************************** ! ** INPUT -- What to do On The First Call To DERKF ** ! ********************************************************************** ! ! The first call of the code is defined to be the start of each new ! problem. Read through the descriptions of all the following items, ! provide sufficient storage space for designated arrays, set ! appropriate variables for the initialization of the problem, and ! give information about how you want the problem to be solved. ! ! ! F -- Provide a subroutine of the form ! F(X,U,UPRIME,RPAR,IPAR) ! to define the system of first order differential equations ! which is to be solved. For the given values of X and the ! vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must ! evaluate the NEQ components of the system of differential ! equations DU/DX=F(X,U) and store the derivatives in the ! array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for ! equations I=1,...,NEQ. ! ! Subroutine F must not alter X or U(*). You must declare ! the name F in an external statement in your program that ! calls DERKF. You must dimension U and UPRIME in F. ! ! RPAR and IPAR are REAL and INTEGER parameter arrays which ! you can use for communication between your calling program ! and subroutine F. They are not used or altered by DERKF. ! If you do not need RPAR or IPAR, ignore these parameters ! by treating them as dummy arguments. If you do choose to ! use them, dimension them in your calling program and in F ! as arrays of appropriate length. ! ! NEQ -- Set it to the number of differential equations. ! (NEQ >= 1) ! ! T -- Set it to the initial point of the integration. ! You must use a program variable for T because the code ! changes its value. ! ! Y(*) -- Set this vector to the initial values of the NEQ solution ! components at the initial point. You must dimension Y at ! least NEQ in your calling program. ! ! TOUT -- Set it to the first point at which a solution ! is desired. You can take TOUT = T, in which case the code ! will evaluate the derivative of the solution at T and ! return. Integration either forward in T (TOUT > T) or ! backward in T (TOUT < T) is permitted. ! ! The code advances the solution from T to TOUT using ! step sizes which are automatically selected so as to ! achieve the desired accuracy. If you wish, the code will ! return with the solution and its derivative following ! each intermediate step (intermediate-output mode) so that ! you can monitor them, but you still must provide TOUT in ! accord with the basic aim of the code. ! ! The first step taken by the code is a critical one ! because it must reflect how fast the solution changes near ! the initial point. The code automatically selects an ! initial step size which is practically always suitable for ! the problem. By using the fact that the code will not ! step past TOUT in the first step, you could, if necessary, ! restrict the length of the initial step size. ! ! For some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP. Since DERKF will never step past a TOUT point, ! you need only make sure that no TOUT lies beyond TSTOP. ! ! INFO(*) -- Use the INFO array to give the code more details about ! how you want your problem solved. This array should be ! dimensioned of length 15 to accommodate other members of ! DEPAC or possible future extensions, though DERKF uses ! only the first three entries. You must respond to all of ! the following items which are arranged as questions. The ! simplest use of the code corresponds to answering all ! questions as YES ,i.e. setting all entries of INFO to 0. ! ! INFO(1) -- This parameter enables the code to initialize ! itself. You must set it to indicate the start of every ! new problem. ! ! **** Is this the first call for this problem ... ! YES -- Set INFO(1) = 0 ! NO -- Not applicable here. ! See below for continuation calls. **** ! ! INFO(2) -- How much accuracy you want of your solution ! is specified by the error tolerances RTOL and ATOL. ! The simplest use is to take them both to be scalars. ! To obtain more flexibility, they can both be vectors. ! The code must be told your choice. ! ! **** Are both error tolerances RTOL, ATOL scalars ... ! YES -- Set INFO(2) = 0 ! and input scalars for both RTOL and ATOL ! NO -- Set INFO(2) = 1 ! and input arrays for both RTOL and ATOL **** ! ! INFO(3) -- The code integrates from T in the direction ! of TOUT by steps. If you wish, it will return the ! computed solution and derivative at the next ! intermediate step (the intermediate-output mode). ! This is a good way to proceed if you want to see the ! behavior of the solution. If you must have solutions at ! a great many specific TOUT points, this code is ! INEFFICIENT. The code DEABM in DEPAC handles this task ! more efficiently. ! ! **** Do you want the solution only at ! TOUT (and not at the next intermediate step) ... ! YES -- Set INFO(3) = 0 ! NO -- Set INFO(3) = 1 **** ! ! RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) ! error tolerances to tell the code how accurately you want ! the solution to be computed. They must be defined as ! program variables because the code may change them. You ! have two choices -- ! Both RTOL and ATOL are scalars. (INFO(2)=0) ! Both RTOL and ATOL are vectors. (INFO(2)=1) ! In either case all components must be non-negative. ! ! The tolerances are used by the code in a local error test ! at each step which requires roughly that ! ABS(LOCAL ERROR) <= RTOL*ABS(Y)+ATOL ! for each vector component. ! (More specifically, a maximum norm is used to measure ! the size of vectors, and the error test uses the average ! of the magnitude of the solution at the beginning and end ! of the step.) ! ! The true (global) error is the difference between the true ! solution of the initial value problem and the computed ! approximation. Practically all present day codes, ! including this one, control the local error at each step ! and do not even attempt to control the global error ! directly. Roughly speaking, they produce a solution Y(T) ! which satisfies the differential equations with a ! residual R(T), DY(T)/DT = F(T,Y(T)) + R(T) , ! and, almost always, R(T) is bounded by the error ! tolerances. Usually, but not always, the true accuracy of ! the computed Y is comparable to the error tolerances. This ! code will usually, but not always, deliver a more accurate ! solution if you reduce the tolerances and integrate again. ! By comparing two such solutions you can get a fairly ! reliable idea of the true error in the solution at the ! bigger tolerances. ! ! Setting ATOL=0. results in a pure relative error test on ! that component. Setting RTOL=0. yields a pure absolute ! error test on that component. A mixed test with non-zero ! RTOL and ATOL corresponds roughly to a relative error ! test when the solution component is much bigger than ATOL ! and to an absolute error test when the solution component ! is smaller than the threshold ATOL. ! ! Proper selection of the absolute error control parameters ! ATOL requires you to have some idea of the scale of the ! solution components. To acquire this information may mean ! that you will have to solve the problem more than once. In ! the absence of scale information, you should ask for some ! relative accuracy in all the components (by setting RTOL ! values non-zero) and perhaps impose extremely small ! absolute error tolerances to protect against the danger of ! a solution component becoming zero. ! ! The code will not attempt to compute a solution at an ! accuracy unreasonable for the machine being used. It will ! advise you if you ask for too much accuracy and inform ! you as to the maximum accuracy it believes possible. ! If you want relative accuracies smaller than about ! 10**(-8), you should not ordinarily use DERKF. The code ! DEABM in DEPAC obtains stringent accuracies more ! efficiently. ! ! RWORK(*) -- Dimension this REAL work array of length LRW in your ! calling program. ! ! LRW -- Set it to the declared length of the RWORK array. ! You must have LRW >= 33+7*NEQ ! ! IWORK(*) -- Dimension this INTEGER work array of length LIW in ! your calling program. ! ! LIW -- Set it to the declared length of the IWORK array. ! You must have LIW >= 34 ! ! RPAR, IPAR -- These are parameter arrays, of REAL and INTEGER ! type, respectively. You can use them for communication ! between your program that calls DERKF and the F ! subroutine. They are not used or altered by DERKF. If ! you do not need RPAR or IPAR, ignore these parameters by ! treating them as dummy arguments. If you do choose to use ! them, dimension them in your calling program and in F as ! arrays of appropriate length. ! ! ********************************************************************** ! ** OUTPUT -- After any return from DERKF ** ! ********************************************************************** ! ! The principal aim of the code is to return a computed solution at ! TOUT, although it is also possible to obtain intermediate results ! along the way. To find out whether the code achieved its goal ! or if the integration process was interrupted before the task was ! completed, you must check the IDID parameter. ! ! ! T -- The solution was successfully advanced to the ! output value of T. ! ! Y(*) -- Contains the computed solution approximation at T. ! You may also be interested in the approximate derivative ! of the solution at T. It is contained in ! RWORK(21),...,RWORK(20+NEQ). ! ! IDID -- Reports what the code did ! ! *** Task Completed *** ! Reported by positive values of IDID ! ! IDID = 1 -- A step was successfully taken in the ! intermediate-output mode. The code has not ! yet reached TOUT. ! ! IDID = 2 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping exactly to TOUT. ! ! *** Task Interrupted *** ! Reported by negative values of IDID ! ! IDID = -1 -- A large amount of work has been expended. ! (500 steps attempted) ! ! IDID = -2 -- The error tolerances are too stringent. ! ! IDID = -3 -- The local error test cannot be satisfied ! because you specified a zero component in ATOL ! and the corresponding computed solution ! component is zero. Thus, a pure relative error ! test is impossible for this component. ! ! IDID = -4 -- The problem appears to be stiff. ! ! IDID = -5 -- DERKF is being used very inefficiently ! because the natural step size is being ! restricted by too frequent output. ! ! IDID = -6,-7,..,-32 -- Not applicable for this code but ! used by other members of DEPAC or possible ! future extensions. ! ! *** Task Terminated *** ! Reported by the value of IDID=-33 ! ! IDID = -33 -- The code has encountered trouble from which ! it cannot recover. A message is printed ! explaining the trouble and control is returned ! to the calling program. For example, this ! occurs when invalid input is detected. ! ! RTOL, ATOL -- These quantities remain unchanged except when ! IDID = -2. In this case, the error tolerances have been ! increased by the code to values which are estimated to be ! appropriate for continuing the integration. However, the ! reported solution at T was obtained using the input values ! of RTOL and ATOL. ! ! RWORK, IWORK -- Contain information which is usually of no ! interest to the user but necessary for subsequent calls. ! However, you may find use for ! ! RWORK(11)--which contains the step size H to be ! attempted on the next step. ! ! RWORK(12)--If the tolerances have been increased by the ! code (IDID = -2) , they were multiplied by the ! value in RWORK(12). ! ! RWORK(20+I)--which contains the approximate derivative ! of the solution component Y(I). In DERKF, it ! is always obtained by calling subroutine F to ! evaluate the differential equation using T and ! Y(*). ! ! ********************************************************************** ! ** INPUT -- What To Do To Continue The Integration ** ! ** (calls after the first) ** ! ********************************************************************** ! ! This code is organized so that subsequent calls to continue the ! integration involve little (if any) additional effort on your ! part. You must monitor the IDID parameter to determine ! what to do next. ! ! Recalling that the principal task of the code is to integrate ! from T to TOUT (the interval mode), usually all you will need ! to do is specify a new TOUT upon reaching the current TOUT. ! ! Do not alter any quantity not specifically permitted below, ! in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or ! the differential equation in subroutine F. Any such alteration ! constitutes a new problem and must be treated as such, i.e. ! you must start afresh. ! ! You cannot change from vector to scalar error control or vice ! versa (INFO(2)) but you can change the size of the entries of ! RTOL, ATOL. Increasing a tolerance makes the equation easier ! to integrate. Decreasing a tolerance will make the equation ! harder to integrate and should generally be avoided. ! ! You can switch from the intermediate-output mode to the ! interval mode (INFO(3)) or vice versa at any time. ! ! The parameter INFO(1) is used by the code to indicate the ! beginning of a new problem and to indicate whether integration ! is to be continued. You must input the value INFO(1) = 0 ! when starting a new problem. You must input the value ! INFO(1) = 1 if you wish to continue after an interrupted task. ! Do not set INFO(1) = 0 on a continuation call unless you ! want the code to restart at the current T. ! ! *** Following a Completed Task *** ! If ! IDID = 1, call the code again to continue the integration ! another step in the direction of TOUT. ! ! IDID = 2, define a new TOUT and call the code again. ! TOUT must be different from T. You cannot change ! the direction of integration without restarting. ! ! *** Following an Interrupted Task *** ! To show the code that you realize the task was ! interrupted and that you want to continue, you ! must take appropriate action and reset INFO(1) = 1 ! If ! IDID = -1, the code has attempted 500 steps. ! If you want to continue, set INFO(1) = 1 and ! call the code again. An additional 500 steps ! will be allowed. ! ! IDID = -2, the error tolerances RTOL, ATOL have been ! increased to values the code estimates appropriate ! for continuing. You may want to change them ! yourself. If you are sure you want to continue ! with relaxed error tolerances, set INFO(1)=1 and ! call the code again. ! ! IDID = -3, a solution component is zero and you set the ! corresponding component of ATOL to zero. If you ! are sure you want to continue, you must first ! alter the error criterion to use positive values ! for those components of ATOL corresponding to zero ! solution components, then set INFO(1)=1 and call ! the code again. ! ! IDID = -4, the problem appears to be stiff. It is very ! inefficient to solve such problems with DERKF. ! Code DEBDF in DEPAC handles this task efficiently. ! If you are absolutely sure you want to continue ! with DERKF, set INFO(1)=1 and call the code again. ! ! IDID = -5, you are using DERKF very inefficiently by ! choosing output points TOUT so close together that ! the step size is repeatedly forced to be rather ! smaller than necessary. If you are willing to ! accept solutions at the steps chosen by the code, ! a good way to proceed is to use the intermediate ! output mode (setting INFO(3)=1). If you must have ! solutions at so many specific TOUT points, the ! code DEABM in DEPAC handles this task ! efficiently. If you want to continue with DERKF, ! set INFO(1)=1 and call the code again. ! ! IDID = -6,-7,..,-32 --- cannot occur with this code but ! used by other members of DEPAC or possible future ! extensions. ! ! *** Following a Terminated Task *** ! If ! IDID = -33, you cannot continue the solution of this ! problem. An attempt to do so will result in your ! run being terminated. ! ! ********************************************************************** ! *Long Description: ! ! ********************************************************************** ! ** DEPAC Package Overview ** ! ********************************************************************** ! ! .... You have a choice of three differential equation solvers from ! .... DEPAC. The following brief descriptions are meant to aid you in ! .... choosing the most appropriate code for your problem. ! ! .... DERKF is a fifth order Runge-Kutta code. It is the simplest of ! .... the three choices, both algorithmically and in the use of the ! .... code. DERKF is primarily designed to solve non-stiff and ! .... mildly stiff differential equations when derivative evaluations ! .... are not expensive. It should generally not be used to get high ! .... accuracy results nor answers at a great many specific points. ! .... Because DERKF has very low overhead costs, it will usually ! .... result in the least expensive integration when solving ! .... problems requiring a modest amount of accuracy and having ! .... equations that are not costly to evaluate. DERKF attempts to ! .... discover when it is not suitable for the task posed. ! ! .... DEABM is a variable order (one through twelve) Adams code. ! .... Its complexity lies somewhere between that of DERKF and ! .... DEBDF. DEABM is primarily designed to solve non-stiff and ! .... mildly stiff differential equations when derivative evaluations ! .... are expensive, high accuracy results are needed or answers at ! .... many specific points are required. DEABM attempts to discover ! .... when it is not suitable for the task posed. ! ! .... DEBDF is a variable order (one through five) backward ! .... differentiation formula code. it is the most complicated of ! .... the three choices. DEBDF is primarily designed to solve stiff ! .... differential equations at crude to moderate tolerances. ! .... If the problem is very stiff at all, DERKF and DEABM will be ! .... quite inefficient compared to DEBDF. However, DEBDF will be ! .... inefficient compared to DERKF and DEABM on non-stiff problems ! .... because it uses much more storage, has a much larger overhead, ! .... and the low order formulas will not give high accuracies ! .... efficiently. ! ! .... The concept of stiffness cannot be described in a few words. ! .... If you do not know the problem to be stiff, try either DERKF ! .... or DEABM. Both of these codes will inform you of stiffness ! .... when the cost of solving such problems becomes important. ! ! ********************************************************************* ! !***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user ! oriented package of ODE solvers, Report SAND79-2374, ! Sandia Laboratories, 1979. ! L. F. Shampine and H. A. Watts, Practical solution of ! ordinary differential equations by Runge-Kutta ! methods, Report SAND76-0585, Sandia Laboratories, ! 1976. !***ROUTINES CALLED DERKFS, XERMSG !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891024 Changed references from VNORM to HVNRM. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls, change Prologue ! comments to agree with DDERKF. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DERKF ! LOGICAL STIFF,NONSTF CHARACTER*8 XERN1 CHARACTER*16 XERN3 ! DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), & RPAR(*),IPAR(*) ! EXTERNAL F ! ! CHECK FOR AN APPARENT INFINITE LOOP ! !***FIRST EXECUTABLE STATEMENT DERKF if (INFO(1) == 0) IWORK(LIW) = 0 if (IWORK(LIW) >= 5) THEN if (T == RWORK(21+NEQ)) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DERKF', & 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // & 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // & ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // & 'WAY YOU HAVE SET PARAMETERS FOR THE call TO THE ' // & 'CODE, PARTICULARLY INFO(1).', 13, 2) return ENDIF end if ! ! CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION ! IDID = 0 if (LRW < 30 + 7*NEQ) THEN WRITE (XERN1, '(I8)') LRW call XERMSG ('SLATEC', 'DERKF', 'LENGTH OF RWORK ARRAY ' // & 'MUST BE AT LEAST 30 + 7*NEQ. YOU HAVE CALLED THE ' // & 'CODE WITH LRW = ' // XERN1, 1, 1) IDID = -33 end if ! if (LIW < 34) THEN WRITE (XERN1, '(I8)') LIW call XERMSG ('SLATEC', 'DERKF', 'LENGTH OF IWORK ARRAY ' // & 'MUST BE AT LEAST 34. YOU HAVE CALLED THE CODE WITH ' // & 'LIW = ' // XERN1, 2, 1) IDID = -33 end if ! ! COMPUTE INDICES FOR THE SPLITTING OF THE RWORK ARRAY ! KH = 11 KTF = 12 KYP = 21 KTSTAR = KYP + NEQ KF1 = KTSTAR + 1 KF2 = KF1 + NEQ KF3 = KF2 + NEQ KF4 = KF3 + NEQ KF5 = KF4 + NEQ KYS = KF5 + NEQ KTO = KYS + NEQ KDI = KTO + 1 KU = KDI + 1 KRER = KU + 1 ! ! ********************************************************************** ! THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG ! CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE ! ARRAYS. if THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, ! S/HE MUST USE DERKFS DIRECTLY. ! ********************************************************************** ! RWORK(KTSTAR) = T if (INFO(1) /= 0) THEN STIFF = (IWORK(25) == 0) NONSTF = (IWORK(26) == 0) end if ! call DERKFS(F,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(KH), & RWORK(KTF),RWORK(KYP),RWORK(KF1),RWORK(KF2),RWORK(KF3), & RWORK(KF4),RWORK(KF5),RWORK(KYS),RWORK(KTO),RWORK(KDI), & RWORK(KU),RWORK(KRER),IWORK(21),IWORK(22),IWORK(23), & IWORK(24),STIFF,NONSTF,IWORK(27),IWORK(28),RPAR,IPAR) ! IWORK(25) = 1 if (STIFF) IWORK(25) = 0 IWORK(26) = 1 if (NONSTF) IWORK(26) = 0 ! if (IDID /= (-2)) IWORK(LIW) = IWORK(LIW) + 1 if (T /= RWORK(KTSTAR)) IWORK(LIW) = 0 ! return end subroutine DERKFS (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, H, & TOLFAC, YP, F1, F2, F3, F4, F5, YS, TOLD, DTSIGN, U26, RER, & INIT, KSTEPS, KOP, IQUIT, STIFF, NONSTF, NTSTEP, NSTIFS, RPAR, & IPAR) ! !! DERKFS is subsidiary to DERKF. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (DERKFS-S, DRKFS-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! Fehlberg Fourth-Fifth order Runge-Kutta Method ! ********************************************************************** ! ! DERKFS integrates a system of first order ordinary differential ! equations as described in the comments for DERKF . ! ! The arrays YP,F1,F2,F3,F4,F5,and YS (of length at least NEQ) ! appear in the call list for variable dimensioning purposes. ! ! The variables H,TOLFAC,TOLD,DTSIGN,U26,RER,INIT,KSTEPS,KOP,IQUIT, ! STIFF,NONSTF,NTSTEP, and NSTIFS are used internally by the code ! and appear in the call list to eliminate local retention of ! variables between calls. Accordingly, these variables and the ! array YP should not be altered. ! Items of possible interest are ! H - An appropriate step size to be used for the next step ! TOLFAC - Factor of change in the tolerances ! YP - Derivative of solution vector at T ! KSTEPS - Counter on the number of steps attempted ! ! ********************************************************************** ! !***SEE ALSO DERKF !***ROUTINES CALLED DEFEHL, HSTART, HVNRM, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891024 Changed references from VNORM to HVNRM. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls, replace GOTOs with ! IF-THEN-ELSEs. (RWC) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DERKFS ! LOGICAL HFAILD,OUTPUT,STIFF,NONSTF CHARACTER*8 XERN1 CHARACTER*16 XERN3, XERN4 ! DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), & YS(*),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) ! EXTERNAL F ! !....................................................................... ! ! A FIFTH ORDER METHOD WILL GENERALLY NOT BE CAPABLE OF DELIVERING ! ACCURACIES NEAR LIMITING PRECISION ON COMPUTERS WITH LONG ! WORDLENGTHS. TO PROTECT AGAINST LIMITING PRECISION DIFFICULTIES ! ARISING FROM UNREASONABLE ACCURACY REQUESTS, AN APPROPRIATE ! TOLERANCE THRESHOLD REMIN IS ASSIGNED FOR THIS METHOD. THIS VALUE ! SHOULD NOT BE CHANGED ACROSS DIFFERENT MACHINES. ! SAVE REMIN, MXSTEP, MXKOP DATA REMIN/1.E-12/ ! !....................................................................... ! ! THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE ! NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MXSTEP, THE COUNTER ! IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE ! WORK. ! DATA MXSTEP/500/ ! !....................................................................... ! ! INEFFICIENCY CAUSED BY TOO FREQUENT OUTPUT IS MONITORED BY COUNTING ! THE NUMBER OF STEP SIZES WHICH ARE SEVERELY SHORTENED DUE SOLELY TO ! THE CHOICE OF OUTPUT POINTS. WHEN THE NUMBER OF ABUSES EXCEED MXKOP, ! THE COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE ! MISUSE OF THE CODE. ! DATA MXKOP/100/ ! !....................................................................... ! !***FIRST EXECUTABLE STATEMENT DERKFS if (INFO(1) == 0) THEN ! ! ON THE FIRST call , PERFORM INITIALIZATION -- ! DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE ! FUNCTION ROUTINE R1MACH. THE USER MUST MAKE SURE THAT THE ! VALUES SET IN R1MACH ARE RELEVANT TO THE COMPUTER BEING USED. ! U = R1MACH(4) ! -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS U26 = 26.*U RER = 2.*U+REMIN ! -- SET TERMINATION FLAG IQUIT = 0 ! -- SET INITIALIZATION INDICATOR INIT = 0 ! -- SET COUNTER FOR IMPACT OF OUTPUT POINTS KOP = 0 ! -- SET COUNTER FOR ATTEMPTED STEPS KSTEPS = 0 ! -- SET INDICATORS FOR STIFFNESS DETECTION STIFF = .FALSE. NONSTF = .FALSE. ! -- SET STEP COUNTERS FOR STIFFNESS DETECTION NTSTEP = 0 NSTIFS = 0 ! -- RESET INFO(1) FOR SUBSEQUENT CALLS INFO(1) = 1 end if ! !....................................................................... ! ! CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY ! if (INFO(1) /= 0 .AND. INFO(1) /= 1) THEN WRITE (XERN1, '(I8)') INFO(1) call XERMSG ('SLATEC', 'DERKFS', & 'IN DERKF, INFO(1) MUST BE SET TO 0 ' // & 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // & 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // & 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE CODE ' // & 'WITH INFO(1) = ' // XERN1, 3, 1) IDID = -33 end if ! if (INFO(2) /= 0 .AND. INFO(2) /= 1) THEN WRITE (XERN1, '(I8)') INFO(2) call XERMSG ('SLATEC', 'DERKFS', & 'IN DERKF, INFO(2) MUST BE 0 OR 1 INDICATING SCALAR ' // & 'AND VECTOR ERROR TOLERANCES, RESPECTIVELY. YOU HAVE ' // & 'CALLED THE CODE WITH INFO(2) = ' // XERN1, 4, 1) IDID = -33 end if ! if (INFO(3) /= 0 .AND. INFO(3) /= 1) THEN WRITE (XERN1, '(I8)') INFO(3) call XERMSG ('SLATEC', 'DERKFS', & 'IN DERKF, INFO(3) MUST BE 0 OR 1 INDICATING THE ' // & 'OR INTERMEDIATE-OUTPUT MODE OF INTEGRATION, ' // & 'RESPECTIVELY. YOU HAVE CALLED THE CODE ' // & 'WITH INFO(3) = ' // XERN1, 5, 1) IDID = -33 end if ! if (NEQ < 1) THEN WRITE (XERN1, '(I8)') NEQ call XERMSG ('SLATEC', 'DERKFS', & 'IN DERKF, THE NUMBER OF EQUATIONS NEQ MUST BE A ' // & 'POSITIVE INTEGER. YOU HAVE CALLED THE ' // & 'CODE WITH NEQ = ' // XERN1, 6, 1) IDID = -33 end if ! NRTOLP = 0 NATOLP = 0 DO 10 K=1,NEQ if (NRTOLP == 0 .AND. RTOL(K) < 0.D0) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') RTOL(K) call XERMSG ('SLATEC', 'DERKFS', & 'IN DERKF, THE RELATIVE ERROR ' // & 'TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU HAVE ' // & 'CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // & XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // & 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) IDID = -33 NRTOLP = 1 ENDIF ! if (NATOLP == 0 .AND. ATOL(K) < 0.D0) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') ATOL(K) call XERMSG ('SLATEC', 'DERKFS', & 'IN DERKF, THE ABSOLUTE ERROR ' // & 'TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU HAVE ' // & 'CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // & XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // & 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) IDID = -33 NATOLP = 1 ENDIF ! if (INFO(2) == 0) go to 20 if (NATOLP > 0 .AND. NRTOLP > 0) go to 20 10 CONTINUE ! ! ! CHECK SOME CONTINUATION POSSIBILITIES ! 20 if (INIT /= 0) THEN if (T == TOUT) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DERKFS', & 'IN DERKF, YOU HAVE CALLED THE ' // & 'CODE WITH T = TOUT = ' // XERN3 // '$$THIS IS NOT ' // & 'ALLOWED ON CONTINUATION CALLS.', 9, 1) IDID=-33 ENDIF ! if (T /= TOLD) THEN WRITE (XERN3, '(1PE15.6)') TOLD WRITE (XERN4, '(1PE15.6)') T call XERMSG ('SLATEC', 'DERKFS', & 'IN DERKF, YOU HAVE CHANGED THE ' // & 'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 // & '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) IDID=-33 ENDIF ! if (INIT /= 1) THEN if (DTSIGN*(TOUT-T) < 0.D0) THEN WRITE (XERN3, '(1PE15.6)') TOUT call XERMSG ('SLATEC', 'DERKFS', & 'IN DERKF, BY CALLING THE CODE ' // & 'WITH TOUT = ' // XERN3 // ' YOU ARE ATTEMPTING ' // & 'TO CHANGE THE DIRECTION OF INTEGRATION.$$THIS IS ' // & 'NOT ALLOWED WITHOUT RESTARTING.', 11, 1) IDID=-33 ENDIF ENDIF end if ! ! INVALID INPUT DETECTED ! if (IDID == (-33)) THEN if (IQUIT /= (-33)) THEN IQUIT = -33 GOTO 909 ELSE call XERMSG ('SLATEC', 'DERKFS', & 'IN DERKF, INVALID INPUT WAS ' // & 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // & 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // & 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) return ENDIF end if ! !....................................................................... ! ! RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS ! ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, ! THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE ! RER WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE. ! DO 50 K=1,NEQ if (RTOL(K)+ATOL(K) > 0.) go to 45 RTOL(K)=RER IDID=-2 45 if (INFO(2) == 0) go to 55 50 CONTINUE ! 55 if (IDID /= (-2)) go to 60 ! ! RTOL=ATOL=0 ON INPUT, SO RTOL WAS CHANGED TO A ! SMALL POSITIVE VALUE TOLFAC=1. go to 909 ! ! BRANCH ON STATUS OF INITIALIZATION INDICATOR ! INIT=0 MEANS INITIAL DERIVATIVES AND STARTING STEP SIZE ! NOT YET COMPUTED ! INIT=1 MEANS STARTING STEP SIZE NOT YET COMPUTED ! INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED ! 60 if (INIT == 0) go to 65 if (INIT == 1) go to 70 go to 80 ! !....................................................................... ! ! MORE INITIALIZATION -- ! -- EVALUATE INITIAL DERIVATIVES ! 65 INIT=1 A=T call F(A,Y,YP,RPAR,IPAR) if (T == TOUT) go to 666 ! ! -- SET SIGN OF INTEGRATION DIRECTION AND ! -- ESTIMATE STARTING STEP SIZE ! 70 INIT=2 DTSIGN=SIGN(1.,TOUT-T) U=R1MACH(4) BIG=SQRT(R1MACH(2)) UTE=U**0.375 DY=UTE*HVNRM(Y,NEQ) if (DY == 0.) DY=UTE KTOL=1 DO 75 K=1,NEQ if (INFO(2) == 1) KTOL=K TOL=RTOL(KTOL)*ABS(Y(K))+ATOL(KTOL) if (TOL == 0.) TOL=DY*RTOL(KTOL) 75 F1(K)=TOL ! call HSTART (F,NEQ,T,TOUT,Y,YP,F1,4,U,BIG,F2,F3,F4,F5,RPAR,IPAR,H) ! !....................................................................... ! ! SET STEP SIZE FOR INTEGRATION IN THE DIRECTION FROM T TO TOUT ! AND SET OUTPUT POINT INDICATOR ! 80 DT=TOUT-T H=SIGN(H,DT) OUTPUT= .FALSE. ! ! TEST TO SEE if DERKF IS BEING SEVERELY IMPACTED BY TOO MANY ! OUTPUT POINTS ! if (ABS(H) >= 2.*ABS(DT)) KOP=KOP+1 if (KOP <= MXKOP) go to 85 ! ! UNNECESSARY FREQUENCY OF OUTPUT IS RESTRICTING ! THE STEP SIZE CHOICE IDID=-5 KOP=0 go to 909 ! 85 if (ABS(DT) > U26*ABS(T)) go to 100 ! ! if TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND RETURN ! DO 90 K=1,NEQ 90 Y(K)=Y(K)+DT*YP(K) A=TOUT call F(A,Y,YP,RPAR,IPAR) KSTEPS=KSTEPS+1 go to 666 ! ! ********************************************************************** ! ********************************************************************** ! STEP BY STEP INTEGRATION ! 100 HFAILD= .FALSE. ! ! TO PROTECT AGAINST IMPOSSIBLE ACCURACY REQUESTS, COMPUTE A ! TOLERANCE FACTOR BASED ON THE REQUESTED ERROR TOLERANCE AND A ! LEVEL OF ACCURACY ACHIEVABLE AT LIMITING PRECISION ! TOLFAC=0. KTOL=1 DO 125 K=1,NEQ if (INFO(2) == 1) KTOL=K ET=RTOL(KTOL)*ABS(Y(K))+ATOL(KTOL) if (ET > 0.) go to 120 TOLFAC=MAX(TOLFAC,RER/RTOL(KTOL)) go to 125 120 TOLFAC=MAX(TOLFAC,ABS(Y(K))*(RER/ET)) 125 CONTINUE if (TOLFAC <= 1.) go to 150 ! ! REQUESTED ERROR UNATTAINABLE DUE TO LIMITED ! PRECISION AVAILABLE TOLFAC=2.*TOLFAC IDID=-2 go to 909 ! ! SET SMALLEST ALLOWABLE STEP SIZE ! 150 HMIN=U26*ABS(T) ! ! ADJUST STEP SIZE if NECESSARY TO HIT THE OUTPUT POINT -- ! LOOK AHEAD TWO STEPS TO AVOID DRASTIC CHANGES IN THE STEP SIZE AND ! THUS LESSEN THE IMPACT OF OUTPUT POINTS ON THE CODE. ! STRETCH THE STEP SIZE BY, AT MOST, AN AMOUNT EQUAL TO THE ! SAFETY FACTOR OF 9/10. ! DT=TOUT-T if (ABS(DT) >= 2.*ABS(H)) go to 200 if (ABS(DT) > ABS(H)/0.9) go to 175 ! ! THE NEXT STEP, if SUCCESSFUL, WILL COMPLETE THE INTEGRATION TO ! THE OUTPUT POINT ! OUTPUT= .TRUE. H=DT go to 200 ! 175 H=0.5*DT ! ! ! ********************************************************************** ! CORE INTEGRATOR FOR TAKING A SINGLE STEP ! ********************************************************************** ! TO AVOID PROBLEMS WITH ZERO CROSSINGS, RELATIVE ERROR IS MEASURED ! USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION AT THE ! BEGINNING AND END OF A STEP. ! THE ERROR ESTIMATE FORMULA HAS BEEN GROUPED TO CONTROL LOSS OF ! SIGNIFICANCE. ! LOCAL ERROR ESTIMATES FOR A FIRST ORDER METHOD USING THE SAME ! STEP SIZE AS THE FEHLBERG METHOD ARE CALCULATED AS PART OF THE ! TEST FOR STIFFNESS. ! TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED ! TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T. ! PRACTICAL LIMITS ON THE CHANGE IN THE STEP SIZE ARE ENFORCED TO ! SMOOTH THE STEP SIZE SELECTION PROCESS AND TO AVOID EXCESSIVE ! CHATTERING ON PROBLEMS HAVING DISCONTINUITIES. ! TO PREVENT UNNECESSARY FAILURES, THE CODE USES 9/10 THE STEP SIZE ! IT ESTIMATES WILL SUCCEED. ! AFTER A STEP FAILURE, THE STEP SIZE IS NOT ALLOWED TO INCREASE FOR ! THE NEXT ATTEMPTED STEP. THIS MAKES THE CODE MORE EFFICIENT ON ! PROBLEMS HAVING DISCONTINUITIES AND MORE EFFECTIVE IN GENERAL ! SINCE LOCAL EXTRAPOLATION IS BEING USED AND EXTRA CAUTION SEEMS ! WARRANTED. !....................................................................... ! ! MONITOR NUMBER OF STEPS ATTEMPTED ! 200 if (KSTEPS <= MXSTEP) go to 222 ! ! A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED IDID=-1 KSTEPS=0 if (.NOT. STIFF) go to 909 ! ! PROBLEM APPEARS TO BE STIFF IDID=-4 STIFF= .FALSE. NONSTF= .FALSE. NTSTEP=0 NSTIFS=0 go to 909 ! ! ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H ! 222 call DEFEHL(F,NEQ,T,Y,H,YP,F1,F2,F3,F4,F5,YS,RPAR,IPAR) KSTEPS=KSTEPS+1 ! !....................................................................... ! ! COMPUTE AND TEST ALLOWABLE TOLERANCES VERSUS LOCAL ERROR ! ESTIMATES. NOTE THAT RELATIVE ERROR IS MEASURED WITH RESPECT TO ! THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION AT THE BEGINNING ! AND END OF THE STEP. ! LOCAL ERROR ESTIMATES FOR A SPECIAL FIRST ORDER METHOD ARE ! CALCULATED ONLY WHEN THE STIFFNESS DETECTION IS TURNED ON. ! EEOET=0. ESTIFF=0. KTOL=1 DO 350 K=1,NEQ YAVG=0.5*(ABS(Y(K))+ABS(YS(K))) if (INFO(2) == 1) KTOL=K ET=RTOL(KTOL)*YAVG+ATOL(KTOL) if (ET > 0.) go to 325 ! ! PURE RELATIVE ERROR INAPPROPRIATE WHEN SOLUTION ! VANISHES IDID=-3 go to 909 ! 325 EE=ABS((-2090.*YP(K)+(21970.*F3(K)-15048.*F4(K)))+ & (22528.*F2(K)-27360.*F5(K))) if (STIFF .OR. NONSTF) go to 350 ES=ABS(H*(0.055455*YP(K)-0.035493*F1(K)-0.036571*F2(K)+ & 0.023107*F3(K)-0.009515*F4(K)+0.003017*F5(K))) ESTIFF=MAX(ESTIFF,ES/ET) 350 EEOET=MAX(EEOET,EE/ET) ! ESTTOL=ABS(H)*EEOET/752400. ! if (ESTTOL <= 1.) go to 500 ! !....................................................................... ! ! UNSUCCESSFUL STEP ! if (ABS(H) > HMIN) go to 400 ! ! REQUESTED ERROR UNATTAINABLE AT SMALLEST ! ALLOWABLE STEP SIZE TOLFAC=1.69*ESTTOL IDID=-2 go to 909 ! ! REDUCE THE STEP SIZE , TRY AGAIN ! THE DECREASE IS LIMITED TO A FACTOR OF 1/10 ! 400 HFAILD= .TRUE. OUTPUT= .FALSE. S=0.1 if (ESTTOL < 59049.) S=0.9/ESTTOL**0.2 H=SIGN(MAX(S*ABS(H),HMIN),H) go to 200 ! !....................................................................... ! ! SUCCESSFUL STEP ! STORE SOLUTION AT T+H ! AND EVALUATE DERIVATIVES THERE ! 500 T=T+H DO 525 K=1,NEQ 525 Y(K)=YS(K) A=T call F(A,Y,YP,RPAR,IPAR) ! ! CHOOSE NEXT STEP SIZE ! THE INCREASE IS LIMITED TO A FACTOR OF 5 ! if STEP FAILURE HAS JUST OCCURRED, NEXT ! STEP SIZE IS NOT ALLOWED TO INCREASE ! S=5. if (ESTTOL > 1.889568E-4) S=0.9/ESTTOL**0.2 if (HFAILD) S=MIN(S,1.) H=SIGN(MAX(S*ABS(H),HMIN),H) ! !....................................................................... ! ! CHECK FOR STIFFNESS (IF NOT ALREADY DETECTED) ! ! IN A SEQUENCE OF 50 SUCCESSFUL STEPS BY THE FEHLBERG METHOD, 25 ! SUCCESSFUL STEPS BY THE FIRST ORDER METHOD INDICATES STIFFNESS ! AND TURNS THE TEST OFF. if 26 FAILURES BY THE FIRST ORDER METHOD ! OCCUR, THE TEST IS TURNED OFF UNTIL THIS SEQUENCE OF 50 STEPS ! BY THE FEHLBERG METHOD IS COMPLETED. ! if (STIFF) go to 600 NTSTEP=MOD(NTSTEP+1,50) if (NTSTEP == 1) NONSTF= .FALSE. if (NONSTF) go to 600 if (ESTIFF > 1.) go to 550 ! ! SUCCESSFUL STEP WITH FIRST ORDER METHOD NSTIFS=NSTIFS+1 ! TURN TEST OFF AFTER 25 INDICATIONS OF STIFFNESS if (NSTIFS == 25) STIFF= .TRUE. go to 600 ! ! UNSUCCESSFUL STEP WITH FIRST ORDER METHOD 550 if (NTSTEP-NSTIFS <= 25) go to 600 ! TURN STIFFNESS DETECTION OFF FOR THIS BLOCK OF ! FIFTY STEPS NONSTF= .TRUE. ! RESET STIFF STEP COUNTER NSTIFS=0 ! ! ********************************************************************** ! END OF CORE INTEGRATOR ! ********************************************************************** ! ! ! SHOULD WE TAKE ANOTHER STEP ! 600 if (OUTPUT) go to 666 if (INFO(3) == 0) go to 100 ! ! ********************************************************************** ! ********************************************************************** ! ! INTEGRATION SUCCESSFULLY COMPLETED ! ! ONE-STEP MODE IDID=1 TOLD=T return ! ! INTERVAL MODE 666 IDID=2 T=TOUT TOLD=T return ! ! INTEGRATION TASK INTERRUPTED ! 909 INFO(1)=-1 TOLD=T if (IDID /= (-2)) RETURN ! ! THE ERROR TOLERANCES ARE INCREASED TO VALUES ! WHICH ARE APPROPRIATE FOR CONTINUING RTOL(1)=TOLFAC*RTOL(1) ATOL(1)=TOLFAC*ATOL(1) if (INFO(2) == 0) RETURN DO 939 K=2,NEQ RTOL(K)=TOLFAC*RTOL(K) 939 ATOL(K)=TOLFAC*ATOL(K) return end subroutine DES (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, YPOUT, & YP, YY, WT, P, PHI, ALPHA, BETA, PSI, V, W, SIG, G, GI, H, EPS, & X, XOLD, HOLD, TOLD, DELSGN, TSTOP, TWOU, FOURU, START, PHASE1, & NORND, STIFF, INTOUT, NS, KORD, KOLD, INIT, KSTEPS, KLE4, & IQUIT, KPREV, IVC, IV, KGI, RPAR, IPAR) ! !! DES is subsidiary to DEABM. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (DES-S, DDES-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DEABM merely allocates storage for DES to relieve the user of the ! inconvenience of a long call list. Consequently DES is used as ! described in the comments for DEABM . ! !***SEE ALSO DEABM !***ROUTINES CALLED R1MACH, SINTRP, STEPS, XERMSG !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls, replace GOTOs with ! IF-THEN-ELSEs. (RWC) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DES ! LOGICAL STIFF,CRASH,START,PHASE1,NORND,INTOUT ! DIMENSION Y(*),YY(*),WT(*),PHI(NEQ,16),P(*),YP(*), & YPOUT(*),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13), & GI(11),IV(10),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) CHARACTER*8 XERN1 CHARACTER*16 XERN3, XERN4 ! EXTERNAL F ! !....................................................................... ! ! THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE ! NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER ! IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE ! WORK. ! SAVE MAXNUM DATA MAXNUM/500/ ! !....................................................................... ! !***FIRST EXECUTABLE STATEMENT DES if (INFO(1) == 0) THEN ! ! ON THE FIRST call , PERFORM INITIALIZATION -- ! DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE ! FUNCTION ROUTINE R1MACH. THE USER MUST MAKE SURE THAT THE ! VALUES SET IN R1MACH ARE RELEVANT TO THE COMPUTER BEING USED. ! U=R1MACH(4) ! -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS TWOU=2.*U FOURU=4.*U ! -- SET TERMINATION FLAG IQUIT=0 ! -- SET INITIALIZATION INDICATOR INIT=0 ! -- SET COUNTER FOR ATTEMPTED STEPS KSTEPS=0 ! -- SET INDICATOR FOR INTERMEDIATE-OUTPUT INTOUT= .FALSE. ! -- SET INDICATOR FOR STIFFNESS DETECTION STIFF= .FALSE. ! -- SET STEP COUNTER FOR STIFFNESS DETECTION KLE4=0 ! -- SET INDICATORS FOR STEPS CODE START= .TRUE. PHASE1= .TRUE. NORND= .TRUE. ! -- RESET INFO(1) FOR SUBSEQUENT CALLS INFO(1)=1 end if ! !....................................................................... ! ! CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY ! if (INFO(1) /= 0 .AND. INFO(1) /= 1) THEN WRITE (XERN1, '(I8)') INFO(1) call XERMSG ('SLATEC', 'DES', & 'IN DEABM, INFO(1) MUST BE ' // & 'SET TO 0 FOR THE START OF A NEW PROBLEM, AND MUST BE ' // & 'SET TO 1 FOLLOWING AN INTERRUPTED TASK. YOU ARE ' // & 'ATTEMPTING TO CONTINUE THE INTEGRATION ILLEGALLY BY ' // & 'CALLING THE CODE WITH INFO(1) = ' // XERN1, 3, 1) IDID=-33 end if ! if (INFO(2) /= 0 .AND. INFO(2) /= 1) THEN WRITE (XERN1, '(I8)') INFO(2) call XERMSG ('SLATEC', 'DES', & 'IN DEABM, INFO(2) MUST BE 0 OR 1 ' // & 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // & 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // & XERN1, 4, 1) IDID=-33 end if ! if (INFO(3) /= 0 .AND. INFO(3) /= 1) THEN WRITE (XERN1, '(I8)') INFO(3) call XERMSG ('SLATEC', 'DES', & 'IN DEABM, INFO(3) MUST BE 0 OR 1 ' // & 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // & 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // & 'WITH INFO(3) = ' // XERN1, 5, 1) IDID=-33 end if ! if (INFO(4) /= 0 .AND. INFO(4) /= 1) THEN WRITE (XERN1, '(I8)') INFO(4) call XERMSG ('SLATEC', 'DES', & 'IN DEABM, INFO(4) MUST BE 0 OR 1 ' // & 'INDICATING WHETHER OR NOT THE INTEGRATION INTERVAL IS ' // & 'TO BE RESTRICTED BY A POINT TSTOP. YOU HAVE CALLED ' // & 'THE CODE WITH INFO(4) = ' // XERN1, 14, 1) IDID=-33 end if ! if (NEQ < 1) THEN WRITE (XERN1, '(I8)') NEQ call XERMSG ('SLATEC', 'DES', & 'IN DEABM, THE NUMBER OF EQUATIONS ' // & 'NEQ MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // & 'CODE WITH NEQ = ' // XERN1, 6, 1) IDID=-33 end if ! NRTOLP = 0 NATOLP = 0 DO 90 K=1,NEQ if (NRTOLP == 0 .AND. RTOL(K) < 0.) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') RTOL(K) call XERMSG ('SLATEC', 'DES', & 'IN DEABM, THE RELATIVE ERROR ' // & 'TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU HAVE ' // & 'CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // & XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // & 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) IDID = -33 NRTOLP = 1 ENDIF ! if (NATOLP == 0 .AND. ATOL(K) < 0.) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') ATOL(K) call XERMSG ('SLATEC', 'DES', & 'IN DEABM, THE ABSOLUTE ERROR ' // & 'TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU HAVE ' // & 'CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // & XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // & 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) IDID = -33 NATOLP = 1 ENDIF ! if (INFO(2) == 0) go to 100 if (NATOLP > 0 .AND. NRTOLP > 0) go to 100 90 CONTINUE ! 100 if (INFO(4) == 1) THEN if (SIGN(1.,TOUT-T) /= SIGN(1.,TSTOP-T) & .OR. ABS(TOUT-T) > ABS(TSTOP-T)) THEN WRITE (XERN3, '(1PE15.6)') TOUT WRITE (XERN4, '(1PE15.6)') TSTOP call XERMSG ('SLATEC', 'DES', & 'IN DEABM, YOU HAVE CALLED THE ' // & 'CODE WITH TOUT = ' // XERN3 // ' BUT YOU HAVE ' // & 'ALSO TOLD THE CODE (INFO(4) = 1) NOT TO INTEGRATE ' // & 'PAST THE POINT TSTOP = ' // XERN4 // ' THESE ' // & 'INSTRUCTIONS CONFLICT.', 14, 1) IDID=-33 ENDIF end if ! ! CHECK SOME CONTINUATION POSSIBILITIES ! if (INIT /= 0) THEN if (T == TOUT) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DES', & 'IN DEABM, YOU HAVE CALLED THE ' // & 'CODE WITH T = TOUT = ' // XERN3 // '$$THIS IS NOT ' // & 'ALLOWED ON CONTINUATION CALLS.', 9, 1) IDID=-33 ENDIF ! if (T /= TOLD) THEN WRITE (XERN3, '(1PE15.6)') TOLD WRITE (XERN4, '(1PE15.6)') T call XERMSG ('SLATEC', 'DES', & 'IN DEABM, YOU HAVE CHANGED THE ' // & 'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 // & ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) IDID=-33 ENDIF ! if (INIT /= 1) THEN if (DELSGN*(TOUT-T) < 0.) THEN WRITE (XERN3, '(1PE15.6)') TOUT call XERMSG ('SLATEC', 'DES', & 'IN DEABM, BY CALLING THE ' // & 'CODE WITH TOUT = ' // XERN3 // ' YOU ARE ' // & 'ATTEMPTING TO CHANGE THE DIRECTION OF ' // & 'INTEGRATION.$$THIS IS NOT ALLOWED WITHOUT ' // & 'RESTARTING.', 11, 1) IDID=-33 ENDIF ENDIF end if ! ! INVALID INPUT DETECTED ! if (IDID == (-33)) THEN if (IQUIT /= (-33)) THEN IQUIT = -33 INFO(1) = -1 ELSE call XERMSG ('SLATEC', 'DES', & 'IN DEABM, INVALID INPUT WAS ' // & 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // & 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // & 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) ENDIF return end if ! !....................................................................... ! ! RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS ! ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, ! THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE ! FOURU WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE ! DO 180 K=1,NEQ if (RTOL(K)+ATOL(K) > 0.) go to 170 RTOL(K)=FOURU IDID=-2 170 if (INFO(2) == 0) go to 190 180 CONTINUE ! 190 if (IDID /= (-2)) go to 200 ! RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A ! SMALL POSITIVE VALUE INFO(1)=-1 return ! ! BRANCH ON STATUS OF INITIALIZATION INDICATOR ! INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE ! AND DIRECTION NOT YET SET ! INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET ! INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED ! 200 if (INIT == 0) go to 210 if (INIT == 1) go to 220 go to 240 ! !....................................................................... ! ! MORE INITIALIZATION -- ! -- EVALUATE INITIAL DERIVATIVES ! 210 INIT=1 A=T call F(A,Y,YP,RPAR,IPAR) if (T /= TOUT) go to 220 IDID=2 DO 215 L = 1,NEQ 215 YPOUT(L) = YP(L) TOLD=T return ! ! -- SET INDEPENDENT AND DEPENDENT VARIABLES ! X AND YY(*) FOR STEPS ! -- SET SIGN OF INTEGRATION DIRECTION ! -- INITIALIZE THE STEP SIZE ! 220 INIT = 2 X = T DO 230 L = 1,NEQ 230 YY(L) = Y(L) DELSGN = SIGN(1.0,TOUT-T) H = SIGN(MAX(FOURU*ABS(X),ABS(TOUT-X)),TOUT-X) ! !....................................................................... ! ! ON EACH call SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL ! OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT ! 240 DEL = TOUT - T ABSDEL = ABS(DEL) ! !....................................................................... ! ! if ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN ! 250 if ( ABS(X-T) < ABSDEL) go to 260 call SINTRP(X,YY,TOUT,Y,YPOUT,NEQ,KOLD,PHI,IVC,IV,KGI,GI, & ALPHA,G,W,XOLD,P) IDID = 3 if (X /= TOUT) go to 255 IDID = 2 INTOUT = .FALSE. 255 T = TOUT TOLD = T return ! ! if CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, ! EXTRAPOLATE AND RETURN ! 260 if (INFO(4) /= 1) go to 280 if (ABS(TSTOP-X) >= FOURU*ABS(X)) go to 280 DT = TOUT - X DO 270 L = 1,NEQ 270 Y(L) = YY(L) + DT*YP(L) call F(TOUT,Y,YPOUT,RPAR,IPAR) IDID = 3 T = TOUT TOLD = T return ! 280 if (INFO(3) == 0 .OR. .NOT.INTOUT) go to 300 ! ! INTERMEDIATE-OUTPUT MODE ! IDID = 1 DO 290 L = 1,NEQ Y(L)=YY(L) 290 YPOUT(L) = YP(L) T = X TOLD = T INTOUT = .FALSE. return ! !....................................................................... ! ! MONITOR NUMBER OF STEPS ATTEMPTED ! 300 if (KSTEPS <= MAXNUM) go to 330 ! ! A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED IDID=-1 KSTEPS=0 if (.NOT. STIFF) go to 310 ! ! PROBLEM APPEARS TO BE STIFF IDID=-4 STIFF= .FALSE. KLE4=0 ! 310 DO 320 L = 1,NEQ Y(L) = YY(L) 320 YPOUT(L) = YP(L) T = X TOLD = T INFO(1) = -1 INTOUT = .FALSE. return ! !....................................................................... ! ! LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP ! 330 HA = ABS(H) if (INFO(4) /= 1) go to 340 HA = MIN(HA,ABS(TSTOP-X)) 340 H = SIGN(HA,H) EPS = 1.0 LTOL = 1 DO 350 L = 1,NEQ if (INFO(2) == 1) LTOL = L WT(L) = RTOL(LTOL)*ABS(YY(L)) + ATOL(LTOL) if (WT(L) <= 0.0) go to 360 350 CONTINUE go to 380 ! ! RELATIVE ERROR CRITERION INAPPROPRIATE 360 IDID = -3 DO 370 L = 1,NEQ Y(L) = YY(L) 370 YPOUT(L) = YP(L) T = X TOLD = T INFO(1) = -1 INTOUT = .FALSE. return ! 380 call STEPS(F,NEQ,YY,X,H,EPS,WT,START,HOLD,KORD,KOLD,CRASH,PHI,P, & YP,PSI,ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND,KSTEPS, & TWOU,FOURU,XOLD,KPREV,IVC,IV,KGI,GI,RPAR,IPAR) ! !....................................................................... ! if ( .NOT.CRASH) go to 420 ! ! TOLERANCES TOO SMALL IDID = -2 RTOL(1) = EPS*RTOL(1) ATOL(1) = EPS*ATOL(1) if (INFO(2) == 0) go to 400 DO 390 L = 2,NEQ RTOL(L) = EPS*RTOL(L) 390 ATOL(L) = EPS*ATOL(L) 400 DO 410 L = 1,NEQ Y(L) = YY(L) 410 YPOUT(L) = YP(L) T = X TOLD = T INFO(1) = -1 INTOUT = .FALSE. return ! ! (STIFFNESS TEST) COUNT NUMBER OF CONSECUTIVE STEPS TAKEN WITH THE ! ORDER OF THE METHOD BEING LESS OR EQUAL TO FOUR ! 420 KLE4 = KLE4 + 1 if ( KOLD > 4) KLE4 = 0 if ( KLE4 >= 50) STIFF = .TRUE. INTOUT = .TRUE. go to 250 end subroutine DEXBVP (Y, NROWY, XPTS, A, NROWA, ALPHA, B, NROWB, & BETA, IFLAG, WORK, IWORK) ! !! DEXBVP is subsidiary to DBVSUP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (EXBVP-S, DEXBVP-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This subroutine is used to execute the basic technique for solving ! the two-point boundary value problem. ! !***SEE ALSO DBVSUP !***ROUTINES CALLED DBVPOR, XERMSG !***COMMON BLOCKS DML15T, DML17B, DML18J, DML5MC, DML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 890921 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DEXBVP ! INTEGER ICOCO, IEXP, IFLAG, IGOFX, INC, INDPVT, INFO, INHOMO, & INTEG, ISTKOP, IVP, IWORK(*), K1, K10, K11, K2, K3, & K4, K5, K6, K7, K8, K9, KKKINT, KKKZPW, KNSWOT, KOP, KOTC, & L1, L2, LLLINT, LOTJP, LPAR, MNSWOT, MXNON, NCOMP, NDISK, & NEEDIW, NEEDW, NEQ, NEQIVP, NFC, NFCC, NIC, NOPG, & NPS, NROWA, NROWB, NROWY, NSAFIW, NSAFW, NSWOT, NTAPE, NTP, & NUMORT, NXPTS DOUBLE PRECISION A(NROWA,*), AE, ALPHA(*), B(NROWB,*), BETA(*), & C, EPS, FOURU, PWCND, PX, RE, SQOVFL, SRU, TND, TOL, TWOU, & URO, WORK(*), X, XBEG, XEND, XL, XOP, XOT, XPTS(*), XSAV, & Y(NROWY,*), ZQUIT CHARACTER*8 XERN1, XERN2 ! ! ****************************************************************** ! COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, & ICOCO COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /DML17B/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, & K10,K11,L1,L2,KKKINT,LLLINT ! COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR ! !***FIRST EXECUTABLE STATEMENT DEXBVP KOTC = 1 IEXP = 0 if (IWORK(7) == -1) IEXP = IWORK(8) ! ! COMPUTE ORTHONORMALIZATION TOLERANCES. ! 10 TOL = 10.0D0**((-LPAR - IEXP)*2) ! IWORK(8) = IEXP MXNON = IWORK(2) ! ! ********************************************************************** ! ********************************************************************** ! call DBVPOR(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B, & NROWB,BETA,NFC,IFLAG,WORK(1),MXNON,WORK(K1),NTP, & IWORK(18),WORK(K2),IWORK(16),WORK(K3),WORK(K4), & WORK(K5),WORK(K6),WORK(K7),WORK(K8),WORK(K9), & WORK(K10),IWORK(L1),NFCC) ! ! ********************************************************************** ! ********************************************************************** ! if DMGSBV RETURNS WITH MESSAGE OF DEPENDENT VECTORS, WE REDUCE ! ORTHONORMALIZATION TOLERANCE AND TRY AGAIN. THIS IS DONE ! A MAXIMUM OF 2 TIMES. ! if (IFLAG /= 30) go to 20 if (KOTC == 3 .OR. NOPG == 1) go to 30 KOTC = KOTC + 1 IEXP = IEXP - 2 go to 10 ! ! ********************************************************************** ! if DBVPOR RETURNS MESSAGE THAT THE MAXIMUM NUMBER OF ! ORTHONORMALIZATIONS HAS BEEN ATTAINED AND WE CANNOT CONTINUE, THEN ! WE ESTIMATE THE NEW STORAGE REQUIREMENTS IN ORDER TO SOLVE PROBLEM ! 20 if (IFLAG /= 13) go to 30 XL = ABS(XEND-XBEG) ZQUIT = ABS(X-XBEG) INC = 1.5D0*XL/ZQUIT * (MXNON+1) if (NDISK /= 1) THEN NSAFW = INC*KKKZPW + NEEDW NSAFIW = INC*NFCC + NEEDIW ELSE NSAFW = NEEDW + INC NSAFIW = NEEDIW end if ! WRITE (XERN1, '(I8)') NSAFW WRITE (XERN2, '(I8)') NSAFIW call XERMSG ('SLATEC', 'DEXBVP', & 'IN DBVSUP, PREDICTED STORAGE ALLOCATION FOR WORK ARRAY IS ' // & XERN1 // ', PREDICTED STORAGE ALLOCATION FOR IWORK ARRAY IS ' & // XERN2, 1, 0) ! 30 IWORK(1) = MXNON return end subroutine DEXINT (X, N, KODE, M, TOL, EN, NZ, IERR) ! !! DEXINT computes an M member sequence of exponential integrals ... ! E(N+K,X), K=0,1,...,M-1 for N >= 1 and X >= 0. ! !***LIBRARY SLATEC !***CATEGORY C5 !***TYPE DOUBLE PRECISION (EXINT-S, DEXINT-D) !***KEYWORDS EXPONENTIAL INTEGRAL, SPECIAL FUNCTIONS !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! DEXINT computes M member sequences of exponential integrals ! E(N+K,X), K=0,1,...,M-1 for N >= 1 and X >= 0. The ! exponential integral is defined by ! ! E(N,X)=integral on (1,infinity) of EXP(-XT)/T**N ! ! where X=0.0 and N=1 cannot occur simultaneously. Formulas ! and notation are found in the NBS Handbook of Mathematical ! Functions (ref. 1). ! ! The power series is implemented for X <= XCUT and the ! confluent hypergeometric representation ! ! E(A,X) = EXP(-X)*(X**(A-1))*U(A,A,X) ! ! is computed for X > XCUT. Since sequences are computed in ! a stable fashion by recurring away from X, A is selected as ! the integer closest to X within the constraint N <= A <= ! N+M-1. For the U computation, A is further modified to be the ! nearest even integer. Indices are carried forward or ! backward by the two term recursion relation ! ! K*E(K+1,X) + X*E(K,X) = EXP(-X) ! ! once E(A,X) is computed. The U function is computed by means ! of the backward recursive Miller algorithm applied to the ! three term contiguous relation for U(A+K,A,X), K=0,1,... ! This produces accurate ratios and determines U(A+K,A,X), and ! hence E(A,X), to within a multiplicative constant C. ! Another contiguous relation applied to C*U(A,A,X) and ! C*U(A+1,A,X) gets C*U(A+1,A+1,X), a quantity proportional to ! E(A+1,X). The normalizing constant C is obtained from the ! two term recursion relation above with K=A. ! ! The maximum number of significant digits obtainable ! is the smaller of 14 and the number of digits carried in ! double precision arithmetic. ! ! Description of Arguments ! ! Input * X and TOL are double precision * ! X X > 0.0 for N=1 and X >= 0.0 for N >= 2 ! N order of the first member of the sequence, N >= 1 ! (X=0.0 and N=1 is an error) ! KODE a selection parameter for scaled values ! KODE=1 returns E(N+K,X), K=0,1,...,M-1. ! =2 returns EXP(X)*E(N+K,X), K=0,1,...,M-1. ! M number of exponential integrals in the sequence, ! M >= 1 ! TOL relative accuracy wanted, ETOL <= TOL <= 0.1 ! ETOL is the larger of double precision unit ! roundoff = D1MACH(4) and 1.0D-18 ! ! Output * EN is a double precision vector * ! EN a vector of dimension at least M containing values ! EN(K) = E(N+K-1,X) or EXP(X)*E(N+K-1,X), K=1,M ! depending on KODE ! NZ underflow indicator ! NZ=0 a normal return ! NZ=M X exceeds XLIM and an underflow occurs. ! EN(K)=0.0D0 , K=1,M returned on KODE=1 ! IERR error flag ! IERR=0, normal return, computation completed ! IERR=1, input error, no computation ! IERR=2, error, no computation ! algorithm termination condition not met ! !***REFERENCES M. Abramowitz and I. A. Stegun, Handbook of ! Mathematical Functions, NBS AMS Series 55, U.S. Dept. ! of Commerce, 1955. ! D. E. Amos, Computation of exponential integrals, ACM ! Transactions on Mathematical Software 6, (1980), ! pp. 365-377 and pp. 420-428. !***ROUTINES CALLED D1MACH, DPSIXN, I1MACH !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 910408 Updated the REFERENCES section. (WRB) ! 920207 Updated with code with a revision date of 880811 from ! D. Amos. Included correction of argument list. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DEXINT DOUBLE PRECISION A,AA,AAMS,AH,AK,AT,B,BK,BT,CC,CNORM,CT,EM,EMX,EN, & ETOL,FNM,FX,PT,P1,P2,S,TOL,TX,X,XCUT,XLIM,XTOL,Y, & YT,Y1,Y2 DOUBLE PRECISION D1MACH,DPSIXN INTEGER I,IC,ICASE,ICT,IERR,IK,IND,IX,I1M,JSET,K,KK,KN,KODE,KS,M, & ML,MU,N,ND,NM,NZ INTEGER I1MACH DIMENSION EN(*), A(99), B(99), Y(2) SAVE XCUT DATA XCUT / 2.0D0 / !***FIRST EXECUTABLE STATEMENT DEXINT IERR = 0 NZ = 0 ETOL = MAX(D1MACH(4),0.5D-18) if (X < 0.0D0) IERR = 1 if (N < 1) IERR = 1 if (KODE < 1 .OR. KODE > 2) IERR = 1 if (M < 1) IERR = 1 if (TOL < ETOL .OR. TOL > 0.1D0) IERR = 1 if (X == 0.0D0 .AND. N == 1) IERR = 1 if ( IERR /= 0) RETURN I1M = -I1MACH(15) PT = 2.3026D0*I1M*D1MACH(5) XLIM = PT - 6.907755D0 BT = PT + (N+M-1) if (BT > 1000.0D0) XLIM = PT - LOG(BT) ! if (X > XCUT) go to 100 if (X == 0.0D0 .AND. N > 1) go to 80 !----------------------------------------------------------------------- ! SERIES FOR E(N,X) FOR X <= XCUT !----------------------------------------------------------------------- TX = X + 0.5D0 IX = TX !----------------------------------------------------------------------- ! ICASE=1 MEANS INTEGER CLOSEST TO X IS 2 AND N=1 ! ICASE=2 MEANS INTEGER CLOSEST TO X IS 0,1, OR 2 AND N >= 2 !----------------------------------------------------------------------- ICASE = 2 if (IX > N) ICASE = 1 NM = N - ICASE + 1 ND = NM + 1 IND = 3 - ICASE MU = M - IND ML = 1 KS = ND FNM = NM S = 0.0D0 XTOL = 3.0D0*TOL if (ND == 1) go to 10 XTOL = 0.3333D0*TOL S = 1.0D0/FNM 10 CONTINUE AA = 1.0D0 AK = 1.0D0 IC = 35 if (X < ETOL) IC = 1 DO 50 I=1,IC AA = -AA*X/AK if (I == NM) go to 30 S = S - AA/(AK-FNM) if (ABS(AA) <= XTOL*ABS(S)) go to 20 AK = AK + 1.0D0 go to 50 20 CONTINUE if (I < 2) go to 40 if (ND-2 > I .OR. I > ND-1) go to 60 AK = AK + 1.0D0 go to 50 30 S = S + AA*(-LOG(X)+DPSIXN(ND)) XTOL = 3.0D0*TOL 40 AK = AK + 1.0D0 50 CONTINUE if (IC /= 1) go to 340 60 if (ND == 1) S = S + (-LOG(X)+DPSIXN(1)) if (KODE == 2) S = S*EXP(X) EN(1) = S EMX = 1.0D0 if (M == 1) go to 70 EN(IND) = S AA = KS if (KODE == 1) EMX = EXP(-X) go to (220, 240), ICASE 70 if (ICASE == 2) RETURN if (KODE == 1) EMX = EXP(-X) EN(1) = (EMX-S)/X return 80 CONTINUE DO 90 I=1,M EN(I) = 1.0D0/(N+I-2) 90 CONTINUE return !----------------------------------------------------------------------- ! BACKWARD RECURSIVE MILLER ALGORITHM FOR ! E(N,X)=EXP(-X)*(X**(N-1))*U(N,N,X) ! WITH RECURSION AWAY FROM N=INTEGER CLOSEST TO X. ! U(A,B,X) IS THE SECOND CONFLUENT HYPERGEOMETRIC FUNCTION !----------------------------------------------------------------------- 100 CONTINUE EMX = 1.0D0 if (KODE == 2) go to 130 if (X <= XLIM) go to 120 NZ = M DO 110 I=1,M EN(I) = 0.0D0 110 CONTINUE return 120 EMX = EXP(-X) 130 CONTINUE TX = X + 0.5D0 IX = TX KN = N + M - 1 if (KN <= IX) go to 140 if (N < IX .AND. IX < KN) go to 170 if (N >= IX) go to 160 go to 340 140 ICASE = 1 KS = KN ML = M - 1 MU = -1 IND = M if (KN > 1) go to 180 150 KS = 2 ICASE = 3 go to 180 160 ICASE = 2 IND = 1 KS = N MU = M - 1 if (N > 1) go to 180 if (KN == 1) go to 150 IX = 2 170 ICASE = 1 KS = IX ML = IX - N IND = ML + 1 MU = KN - IX 180 CONTINUE IK = KS/2 AH = IK JSET = 1 + KS - (IK+IK) !----------------------------------------------------------------------- ! START COMPUTATION FOR ! EN(IND) = C*U( A , A ,X) JSET=1 ! EN(IND) = C*U(A+1,A+1,X) JSET=2 ! FOR AN EVEN INTEGER A. !----------------------------------------------------------------------- IC = 0 AA = AH + AH AAMS = AA - 1.0D0 AAMS = AAMS*AAMS TX = X + X FX = TX + TX AK = AH XTOL = TOL if (TOL <= 1.0D-3) XTOL = 20.0D0*TOL CT = AAMS + FX*AH EM = (AH+1.0D0)/((X+AA)*XTOL*SQRT(CT)) BK = AA CC = AH*AH !----------------------------------------------------------------------- ! FORWARD RECURSION FOR P(IC),P(IC+1) AND INDEX IC FOR BACKWARD ! RECURSION !----------------------------------------------------------------------- P1 = 0.0D0 P2 = 1.0D0 190 CONTINUE if (IC == 99) go to 340 IC = IC + 1 AK = AK + 1.0D0 AT = BK/(BK+AK+CC+IC) BK = BK + AK + AK A(IC) = AT BT = (AK+AK+X)/(AK+1.0D0) B(IC) = BT PT = P2 P2 = BT*P2 - AT*P1 P1 = PT CT = CT + FX EM = EM*AT*(1.0D0-TX/CT) if (EM*(AK+1.0D0) > P1*P1) go to 190 ICT = IC KK = IC + 1 BT = TX/(CT+FX) Y2 = (BK/(BK+CC+KK))*(P1/P2)*(1.0D0-BT+0.375D0*BT*BT) Y1 = 1.0D0 !----------------------------------------------------------------------- ! BACKWARD RECURRENCE FOR ! Y1= C*U( A ,A,X) ! Y2= C*(A/(1+A/2))*U(A+1,A,X) !----------------------------------------------------------------------- DO 200 K=1,ICT KK = KK - 1 YT = Y1 Y1 = (B(KK)*Y1-Y2)/A(KK) Y2 = YT 200 CONTINUE !----------------------------------------------------------------------- ! THE CONTIGUOUS RELATION ! X*U(B,C+1,X)=(C-B)*U(B,C,X)+U(B-1,C,X) ! WITH B=A+1 , C=A IS USED FOR ! Y(2) = C * U(A+1,A+1,X) ! X IS INCORPORATED INTO THE NORMALIZING RELATION !----------------------------------------------------------------------- PT = Y2/Y1 CNORM = 1.0E0 - PT*(AH+1.0E0)/AA Y(1) = 1.0E0/(CNORM*AA+X) Y(2) = CNORM*Y(1) if (ICASE == 3) go to 210 EN(IND) = EMX*Y(JSET) if (M == 1) RETURN AA = KS go to (220, 240), ICASE !----------------------------------------------------------------------- ! RECURSION SECTION N*E(N+1,X) + X*E(N,X)=EMX !----------------------------------------------------------------------- 210 EN(1) = EMX*(1.0E0-Y(1))/X return 220 K = IND - 1 DO 230 I=1,ML AA = AA - 1.0D0 EN(K) = (EMX-AA*EN(K+1))/X K = K - 1 230 CONTINUE if (MU <= 0) RETURN AA = KS 240 K = IND DO 250 I=1,MU EN(K+1) = (EMX-X*EN(K))/AA AA = AA + 1.0D0 K = K + 1 250 CONTINUE return 340 CONTINUE IERR = 2 return end DOUBLE PRECISION FUNCTION DEXPRL (X) ! !! DEXPRL calculates the relative error exponential (EXP(X)-1)/X. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4B !***TYPE DOUBLE PRECISION (EXPREL-S, DEXPRL-D, CEXPRL-C) !***KEYWORDS ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate EXPREL(X) = (EXP(X) - 1.0) / X. For small ABS(X) the ! Taylor series is used. If X is negative the reflection formula ! EXPREL(X) = EXP(X) * EXPREL(ABS(X)) ! may be used. This reflection formula will be of use when the ! evaluation for small ABS(X) is done by Chebyshev series rather than ! Taylor series. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DEXPRL DOUBLE PRECISION X, ABSX, ALNEPS, XBND, XLN, XN, D1MACH LOGICAL FIRST SAVE NTERMS, XBND, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DEXPRL if (FIRST) THEN ALNEPS = LOG(D1MACH(3)) XN = 3.72D0 - 0.3D0*ALNEPS XLN = LOG((XN+1.0D0)/1.36D0) NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36D0) + 1.5D0 XBND = D1MACH(3) end if FIRST = .FALSE. ! ABSX = ABS(X) if (ABSX > 0.5D0) DEXPRL = (EXP(X)-1.0D0)/X if (ABSX > 0.5D0) RETURN ! DEXPRL = 1.0D0 if (ABSX < XBND) RETURN ! DEXPRL = 0.0D0 DO 20 I=1,NTERMS DEXPRL = 1.0D0 + DEXPRL*X/(NTERMS+2-I) 20 CONTINUE ! return end DOUBLE PRECISION FUNCTION DFAC (N) ! !! DFAC computes the factorial function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C1 !***TYPE DOUBLE PRECISION (FAC-S, DFAC-D) !***KEYWORDS FACTORIAL, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DFAC(N) calculates the double precision factorial for integer ! argument N. ! !***REFERENCES (NONE) !***ROUTINES CALLED D9LGMC, DGAMLM, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DFAC DOUBLE PRECISION FACN(31), SQ2PIL, X, XMAX, XMIN, D9LGMC SAVE FACN, SQ2PIL, NMAX DATA FACN ( 1) / +.100000000000000000000000000000000D+1 / DATA FACN ( 2) / +.100000000000000000000000000000000D+1 / DATA FACN ( 3) / +.200000000000000000000000000000000D+1 / DATA FACN ( 4) / +.600000000000000000000000000000000D+1 / DATA FACN ( 5) / +.240000000000000000000000000000000D+2 / DATA FACN ( 6) / +.120000000000000000000000000000000D+3 / DATA FACN ( 7) / +.720000000000000000000000000000000D+3 / DATA FACN ( 8) / +.504000000000000000000000000000000D+4 / DATA FACN ( 9) / +.403200000000000000000000000000000D+5 / DATA FACN ( 10) / +.362880000000000000000000000000000D+6 / DATA FACN ( 11) / +.362880000000000000000000000000000D+7 / DATA FACN ( 12) / +.399168000000000000000000000000000D+8 / DATA FACN ( 13) / +.479001600000000000000000000000000D+9 / DATA FACN ( 14) / +.622702080000000000000000000000000D+10 / DATA FACN ( 15) / +.871782912000000000000000000000000D+11 / DATA FACN ( 16) / +.130767436800000000000000000000000D+13 / DATA FACN ( 17) / +.209227898880000000000000000000000D+14 / DATA FACN ( 18) / +.355687428096000000000000000000000D+15 / DATA FACN ( 19) / +.640237370572800000000000000000000D+16 / DATA FACN ( 20) / +.121645100408832000000000000000000D+18 / DATA FACN ( 21) / +.243290200817664000000000000000000D+19 / DATA FACN ( 22) / +.510909421717094400000000000000000D+20 / DATA FACN ( 23) / +.112400072777760768000000000000000D+22 / DATA FACN ( 24) / +.258520167388849766400000000000000D+23 / DATA FACN ( 25) / +.620448401733239439360000000000000D+24 / DATA FACN ( 26) / +.155112100433309859840000000000000D+26 / DATA FACN ( 27) / +.403291461126605635584000000000000D+27 / DATA FACN ( 28) / +.108888694504183521607680000000000D+29 / DATA FACN ( 29) / +.304888344611713860501504000000000D+30 / DATA FACN ( 30) / +.884176199373970195454361600000000D+31 / DATA FACN ( 31) / +.265252859812191058636308480000000D+33 / DATA SQ2PIL / 0.91893853320467274178032973640562D0 / DATA NMAX / 0 / !***FIRST EXECUTABLE STATEMENT DFAC if (NMAX /= 0) go to 10 call DGAMLM (XMIN, XMAX) NMAX = XMAX - 1.D0 10 if (N < 0) call XERMSG ('SLATEC', 'DFAC', & 'FACTORIAL OF NEGATIVE INTEGER UNDEFINED', 1, 2) if ( N <= 30 ) then DFAC = FACN(N+1) RETURN end if if ( N > NMAX ) then call XERMSG ('SLATEC', 'DFAC', & 'N SO BIG FACTORIAL(N) OVERFLOWS', 2, 2) end if X = N + 1 DFAC = EXP ((X-0.5D0)*LOG(X) - X + SQ2PIL + D9LGMC(X) ) return end subroutine DFC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, & NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, W, IW) ! !! DFC fits a piecewise polynomial curve to discrete data. ! ! The piecewise polynomials are represented as B-splines. ! The fitting is done in a weighted least squares sense. ! Equality and inequality constraints can be imposed on the ! fitted curve. ! !***LIBRARY SLATEC !***CATEGORY K1A1A1, K1A2A, L8A3 !***TYPE DOUBLE PRECISION (FC-S, DFC-D) !***KEYWORDS B-SPLINE, CONSTRAINED LEAST SQUARES, CURVE FITTING, ! WEIGHTED LEAST SQUARES !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! This subprogram fits a piecewise polynomial curve ! to discrete data. The piecewise polynomials are ! represented as B-splines. ! The fitting is done in a weighted least squares sense. ! Equality and inequality constraints can be imposed on the ! fitted curve. ! ! For a description of the B-splines and usage instructions to ! evaluate them, see ! ! C. W. de Boor, Package for Calculating with B-Splines. ! SIAM J. Numer. Anal., p. 441, (June, 1977). ! ! For further documentation and discussion of constrained ! curve fitting using B-splines, see ! ! R. J. Hanson, Constrained Least Squares Curve Fitting ! to Discrete Data Using B-Splines, a User's ! Guide. Sandia Labs. Tech. Rept. SAND-78-1291, ! December, (1978). ! ! Input.. All TYPE REAL variables are DOUBLE PRECISION ! NDATA,XDATA(*), ! YDATA(*), ! SDDATA(*) ! The NDATA discrete (X,Y) pairs and the Y value ! standard deviation or uncertainty, SD, are in ! the respective arrays XDATA(*), YDATA(*), and ! SDDATA(*). No sorting of XDATA(*) is ! required. Any non-negative value of NDATA is ! allowed. A negative value of NDATA is an ! error. A zero value for any entry of ! SDDATA(*) will weight that data point as 1. ! Otherwise the weight of that data point is ! the reciprocal of this entry. ! ! NORD,NBKPT, ! BKPT(*) ! The NBKPT knots of the B-spline of order NORD ! are in the array BKPT(*). Normally the ! problem data interval will be included between ! the limits BKPT(NORD) and BKPT(NBKPT-NORD+1). ! The additional end knots BKPT(I),I=1,..., ! NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are ! required to compute the functions used to fit ! the data. No sorting of BKPT(*) is required. ! Internal to DFC( ) the extreme end knots may ! be reduced and increased respectively to ! accommodate any data values that are exterior ! to the given knot values. The contents of ! BKPT(*) is not changed. ! ! NORD must be in the range 1 <= NORD <= 20. ! The value of NBKPT must satisfy the condition ! NBKPT >= 2*NORD. ! Other values are considered errors. ! ! (The order of the spline is one more than the ! degree of the piecewise polynomial defined on ! each interval. This is consistent with the ! B-spline package convention. For example, ! NORD=4 when we are using piecewise cubics.) ! ! NCONST,XCONST(*), ! YCONST(*),NDERIV(*) ! The number of conditions that constrain the ! B-spline is NCONST. A constraint is specified ! by an (X,Y) pair in the arrays XCONST(*) and ! YCONST(*), and by the type of constraint and ! derivative value encoded in the array ! NDERIV(*). No sorting of XCONST(*) is ! required. The value of NDERIV(*) is ! determined as follows. Suppose the I-th ! constraint applies to the J-th derivative ! of the B-spline. (Any non-negative value of ! J < NORD is permitted. In particular the ! value J=0 refers to the B-spline itself.) ! For this I-th constraint, set ! XCONST(I)=X, ! YCONST(I)=Y, and ! NDERIV(I)=ITYPE+4*J, where ! ! ITYPE = 0, if (J-th deriv. at X) <= Y. ! = 1, if (J-th deriv. at X) >= Y. ! = 2, if (J-th deriv. at X) == Y. ! = 3, if (J-th deriv. at X) == ! (J-th deriv. at Y). ! (A value of NDERIV(I)=-1 will cause this ! constraint to be ignored. This subprogram ! feature is often useful when temporarily ! suppressing a constraint while still ! retaining the source code of the calling ! program.) ! ! MODE ! An input flag that directs the least squares ! solution method used by DFC( ). ! ! The variance function, referred to below, ! defines the square of the probable error of ! the fitted curve at any point, XVAL. ! This feature of DFC( ) allows one to use the ! square root of this variance function to ! determine a probable error band around the ! fitted curve. ! ! =1 a new problem. No variance function. ! ! =2 a new problem. Want variance function. ! ! =3 an old problem. No variance function. ! ! =4 an old problem. Want variance function. ! ! Any value of MODE other than 1-4 is an error. ! ! The user with a new problem can skip directly ! to the description of the input parameters ! IW(1), IW(2). ! ! If the user correctly specifies the new or old ! problem status, the subprogram DFC( ) will ! perform more efficiently. ! By an old problem it is meant that subprogram ! DFC( ) was last called with this same set of ! knots, data points and weights. ! ! Another often useful deployment of this old ! problem designation can occur when one has ! previously obtained a Q-R orthogonal ! decomposition of the matrix resulting from ! B-spline fitting of data (without constraints) ! at the breakpoints BKPT(I), I=1,...,NBKPT. ! For example, this matrix could be the result ! of sequential accumulation of the least ! squares equations for a very large data set. ! The user writes this code in a manner ! convenient for the application. For the ! discussion here let ! ! N=NBKPT-NORD, and K=N+3 ! ! Let us assume that an equivalent least squares ! system ! ! RC=D ! ! has been obtained. Here R is an N+1 by N ! matrix and D is a vector with N+1 components. ! The last row of R is zero. The matrix R is ! upper triangular and banded. At most NORD of ! the diagonals are nonzero. ! The contents of R and D can be copied to the ! working array W(*) as follows. ! ! The I-th diagonal of R, which has N-I+1 ! elements, is copied to W(*) starting at ! ! W((I-1)*K+1), ! ! for I=1,...,NORD. ! The vector D is copied to W(*) starting at ! ! W(NORD*K+1) ! ! The input value used for NDATA is arbitrary ! when an old problem is designated. Because ! of the feature of DFC( ) that checks the ! working storage array lengths, a value not ! exceeding NBKPT should be used. For example, ! use NDATA=0. ! ! (The constraints or variance function request ! can change in each call to DFC( ).) A new ! problem is anything other than an old problem. ! ! IW(1),IW(2) ! The amounts of working storage actually ! allocated for the working arrays W(*) and ! IW(*). These quantities are compared with the ! actual amounts of storage needed in DFC( ). ! Insufficient storage allocated for either ! W(*) or IW(*) is an error. This feature was ! included in DFC( ) because misreading the ! storage formulas for W(*) and IW(*) might very ! well lead to subtle and hard-to-find ! programming bugs. ! ! The length of W(*) must be at least ! ! NB=(NBKPT-NORD+3)*(NORD+1)+ ! 2*MAX(NDATA,NBKPT)+NBKPT+NORD**2 ! ! Whenever possible the code uses banded matrix ! processors DBNDAC( ) and DBNDSL( ). These ! are utilized if there are no constraints, ! no variance function is required, and there ! is sufficient data to uniquely determine the ! B-spline coefficients. If the band processors ! cannot be used to determine the solution, ! then the constrained least squares code DLSEI ! is used. In this case the subprogram requires ! an additional block of storage in W(*). For ! the discussion here define the integers NEQCON ! and NINCON respectively as the number of ! equality (ITYPE=2,3) and inequality ! (ITYPE=0,1) constraints imposed on the fitted ! curve. Define ! ! L=NBKPT-NORD+1 ! ! and note that ! ! NCONST=NEQCON+NINCON. ! ! When the subprogram DFC( ) uses DLSEI( ) the ! length of the working array W(*) must be at ! least ! ! LW=NB+(L+NCONST)*L+ ! 2*(NEQCON+L)+(NINCON+L)+(NINCON+2)*(L+6) ! ! The length of the array IW(*) must be at least ! ! IW1=NINCON+2*L ! ! in any case. ! ! Output.. All TYPE REAL variables are DOUBLE PRECISION ! MODE ! An output flag that indicates the status ! of the constrained curve fit. ! ! =-1 a usage error of DFC( ) occurred. The ! offending condition is noted with the ! SLATEC library error processor, XERMSG. ! In case the working arrays W(*) or IW(*) ! are not long enough, the minimal ! acceptable length is printed. ! ! = 0 successful constrained curve fit. ! ! = 1 the requested equality constraints ! are contradictory. ! ! = 2 the requested inequality constraints ! are contradictory. ! ! = 3 both equality and inequality constraints ! are contradictory. ! ! COEFF(*) ! If the output value of MODE=0 or 1, this array ! contains the unknowns obtained from the least ! squares fitting process. These N=NBKPT-NORD ! parameters are the B-spline coefficients. ! For MODE=1, the equality constraints are ! contradictory. To make the fitting process ! more robust, the equality constraints are ! satisfied in a least squares sense. In this ! case the array COEFF(*) contains B-spline ! coefficients for this extended concept of a ! solution. If MODE=-1,2 or 3 on output, the ! array COEFF(*) is undefined. ! ! Working Arrays.. All Type REAL variables are DOUBLE PRECISION ! W(*),IW(*) ! These arrays are respectively typed DOUBLE ! PRECISION and INTEGER. ! Their required lengths are specified as input ! parameters in IW(1), IW(2) noted above. The ! contents of W(*) must not be modified by the ! user if the variance function is desired. ! ! Evaluating the ! Variance Function.. ! To evaluate the variance function (assuming ! that the uncertainties of the Y values were ! provided to DFC( ) and an input value of ! MODE=2 or 4 was used), use the function ! subprogram DCV( ) ! ! VAR=DCV(XVAL,NDATA,NCONST,NORD,NBKPT, ! BKPT,W) ! ! Here XVAL is the point where the variance is ! desired. The other arguments have the same ! meaning as in the usage of DFC( ). ! ! For those users employing the old problem ! designation, let MDATA be the number of data ! points in the problem. (This may be different ! from NDATA if the old problem designation ! feature was used.) The value, VAR, should be ! multiplied by the quantity ! ! DBLE(MAX(NDATA-N,1))/DBLE(MAX(MDATA-N,1)) ! ! The output of this subprogram is not defined ! if an input value of MODE=1 or 3 was used in ! FC( ) or if an output value of MODE=-1, 2, or ! 3 was obtained. The variance function, except ! for the scaling factor noted above, is given ! by ! ! VAR=(transpose of B(XVAL))*C*B(XVAL) ! ! The vector B(XVAL) is the B-spline basis ! function values at X=XVAL. ! The covariance matrix, C, of the solution ! coefficients accounts only for the least ! squares equations and the explicitly stated ! equality constraints. This fact must be ! considered when interpreting the variance ! function from a data fitting problem that has ! inequality constraints on the fitted curve. ! ! Evaluating the ! Fitted Curve.. ! To evaluate derivative number IDER at XVAL, ! use the function subprogram DBVALU( ) ! ! F = DBVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER, ! XVAL,INBV,WORKB) ! ! The output of this subprogram will not be ! defined unless an output value of MODE=0 or 1 ! was obtained from DFC( ), XVAL is in the data ! interval, and IDER is nonnegative and < ! NORD. ! ! The first time DBVALU( ) is called, INBV=1 ! must be specified. This value of INBV is the ! overwritten by DBVALU( ). The array WORKB(*) ! must be of length at least 3*NORD, and must ! not be the same as the W(*) array used in ! the call to DFC( ). ! ! DBVALU( ) expects the breakpoint array BKPT(*) ! to be sorted. ! !***REFERENCES R. J. Hanson, Constrained least squares curve fitting ! to discrete data using B-splines, a users guide, ! Report SAND78-1291, Sandia Laboratories, December ! 1978. !***ROUTINES CALLED DFCMN !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert references to XERRWV to references to XERMSG. (RWC) ! 900607 Editorial changes to Prologue to make Prologues for EFC, ! DEFC, FC, and DFC look as much the same as possible. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DFC DOUBLE PRECISION BKPT(*), COEFF(*), SDDATA(*), W(*), XCONST(*), & XDATA(*), YCONST(*), YDATA(*) INTEGER IW(*), MODE, NBKPT, NCONST, NDATA, NDERIV(*), NORD ! EXTERNAL DFCMN ! INTEGER I1, I2, I3, I4, I5, I6, I7, MDG, MDW ! !***FIRST EXECUTABLE STATEMENT DFC MDG = NBKPT - NORD + 3 MDW = NBKPT - NORD + 1 + NCONST ! USAGE IN DFCMN( ) OF W(*).. ! I1,...,I2-1 G(*,*) ! ! I2,...,I3-1 XTEMP(*) ! ! I3,...,I4-1 PTEMP(*) ! ! I4,...,I5-1 BKPT(*) (LOCAL TO DFCMN( )) ! ! I5,...,I6-1 BF(*,*) ! ! I6,...,I7-1 W(*,*) ! ! I7,... WORK(*) FOR DLSEI( ) ! I1 = 1 I2 = I1 + MDG*(NORD+1) I3 = I2 + MAX(NDATA,NBKPT) I4 = I3 + MAX(NDATA,NBKPT) I5 = I4 + NBKPT I6 = I5 + NORD*NORD I7 = I6 + MDW*(NBKPT-NORD+1) call DFCMN(NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, NCONST, & XCONST, YCONST, NDERIV, MODE, COEFF, W(I5), W(I2), W(I3), & W(I4), W(I1), MDG, W(I6), MDW, W(I7), IW) return end subroutine DFCMN (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, & BKPTIN, NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, BF, XTEMP, & PTEMP, BKPT, G, MDG, W, MDW, WORK, IWORK) ! !! DFCMN is subsidiary to FC. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FCMN-S, DFCMN-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This is a companion subprogram to DFC( ). ! The documentation for DFC( ) has complete usage instructions. ! !***SEE ALSO DFC !***ROUTINES CALLED DAXPY, DBNDAC, DBNDSL, DCOPY, DFSPVD, DFSPVN, ! DLSEI, DSCAL, DSORT, XERMSG !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and extensively revised (WRB & RWC) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 900604 DP version created from SP version. (RWC) !***END PROLOGUE DFCMN INTEGER IWORK(*), MDG, MDW, MODE, NBKPT, NCONST, NDATA, NDERIV(*), & NORD DOUBLE PRECISION BF(NORD,*), BKPT(*), BKPTIN(*), COEFF(*), & G(MDG,*), PTEMP(*), SDDATA(*), W(MDW,*), WORK(*), & XCONST(*), XDATA(*), XTEMP(*), YCONST(*), YDATA(*) ! EXTERNAL DAXPY, DBNDAC, DBNDSL, DCOPY, DFSPVD, DFSPVN, DLSEI, & DSCAL, DSORT, XERMSG ! DOUBLE PRECISION DUMMY, PRGOPT(10), RNORM, RNORME, RNORML, XMAX, & XMIN, XVAL, YVAL INTEGER I, IDATA, IDERIV, ILEFT, INTRVL, INTW1, IP, IR, IROW, & ITYPE, IW1, IW2, L, LW, MT, N, NB, NEQCON, NINCON, NORDM1, & NORDP1, NP1 LOGICAL BAND, NEW, VAR CHARACTER*8 XERN1 ! !***FIRST EXECUTABLE STATEMENT DFCMN ! ! Analyze input. ! if (NORD < 1 .OR. NORD > 20) THEN call XERMSG ('SLATEC', 'DFCMN', & 'IN DFC, THE ORDER OF THE B-SPLINE MUST BE 1 THRU 20.', & 2, 1) MODE = -1 return ! ELSEIF (NBKPT < 2*NORD) THEN call XERMSG ('SLATEC', 'DFCMN', & 'IN DFC, THE NUMBER OF KNOTS MUST BE AT LEAST TWICE ' // & 'THE B-SPLINE ORDER.', 2, 1) MODE = -1 return end if ! if (NDATA < 0) THEN call XERMSG ('SLATEC', 'DFCMN', & 'IN DFC, THE NUMBER OF DATA POINTS MUST BE NONNEGATIVE.', & 2, 1) MODE = -1 return end if ! ! Amount of storage allocated for W(*), IW(*). ! IW1 = IWORK(1) IW2 = IWORK(2) NB = (NBKPT-NORD+3)*(NORD+1) + 2*MAX(NDATA,NBKPT) + NBKPT + & NORD**2 ! ! See if sufficient storage has been allocated. ! if (IW1 < NB) THEN WRITE (XERN1, '(I8)') NB call XERMSG ('SLATEC', 'DFCMN', & 'IN DFC, INSUFFICIENT STORAGE FOR W(*). CHECK NB = ' // & XERN1, 2, 1) MODE = -1 return end if ! if (MODE == 1) THEN BAND = .TRUE. VAR = .FALSE. NEW = .TRUE. ELSEIF (MODE == 2) THEN BAND = .FALSE. VAR = .TRUE. NEW = .TRUE. ELSEIF (MODE == 3) THEN BAND = .TRUE. VAR = .FALSE. NEW = .FALSE. ELSEIF (MODE == 4) THEN BAND = .FALSE. VAR = .TRUE. NEW = .FALSE. ELSE call XERMSG ('SLATEC', 'DFCMN', & 'IN DFC, INPUT VALUE OF MODE MUST BE 1-4.', 2, 1) MODE = -1 return end if MODE = 0 ! ! Sort the breakpoints. ! call DCOPY (NBKPT, BKPTIN, 1, BKPT, 1) call DSORT (BKPT, DUMMY, NBKPT, 1) ! ! Initialize variables. ! NEQCON = 0 NINCON = 0 DO 100 I = 1,NCONST L = NDERIV(I) ITYPE = MOD(L,4) if (ITYPE < 2) THEN NINCON = NINCON + 1 ELSE NEQCON = NEQCON + 1 ENDIF 100 CONTINUE ! ! Compute the number of variables. ! N = NBKPT - NORD NP1 = N + 1 LW = NB + (NP1+NCONST)*NP1 + 2*(NEQCON+NP1) + (NINCON+NP1) + & (NINCON+2)*(NP1+6) INTW1 = NINCON + 2*NP1 ! ! Save interval containing knots. ! XMIN = BKPT(NORD) XMAX = BKPT(NP1) ! ! Find the smallest referenced independent variable value in any ! constraint. ! DO 110 I = 1,NCONST XMIN = MIN(XMIN,XCONST(I)) XMAX = MAX(XMAX,XCONST(I)) 110 CONTINUE NORDM1 = NORD - 1 NORDP1 = NORD + 1 ! ! Define the option vector PRGOPT(1-10) for use in DLSEI( ). ! PRGOPT(1) = 4 ! ! Set the covariance matrix computation flag. ! PRGOPT(2) = 1 if (VAR) THEN PRGOPT(3) = 1 ELSE PRGOPT(3) = 0 end if ! ! Increase the rank determination tolerances for both equality ! constraint equations and least squares equations. ! PRGOPT(4) = 7 PRGOPT(5) = 4 PRGOPT(6) = 1.D-4 ! PRGOPT(7) = 10 PRGOPT(8) = 5 PRGOPT(9) = 1.D-4 ! PRGOPT(10) = 1 ! ! Turn off work array length checking in DLSEI( ). ! IWORK(1) = 0 IWORK(2) = 0 ! ! Initialize variables and analyze input. ! if (NEW) THEN ! ! To process least squares equations sort data and an array of ! pointers. ! call DCOPY (NDATA, XDATA, 1, XTEMP, 1) DO 120 I = 1,NDATA PTEMP(I) = I 120 CONTINUE ! if (NDATA > 0) THEN call DSORT (XTEMP, PTEMP, NDATA, 2) XMIN = MIN(XMIN,XTEMP(1)) XMAX = MAX(XMAX,XTEMP(NDATA)) ENDIF ! ! Fix breakpoint array if needed. ! DO 130 I = 1,NORD BKPT(I) = MIN(BKPT(I),XMIN) 130 CONTINUE ! DO 140 I = NP1,NBKPT BKPT(I) = MAX(BKPT(I),XMAX) 140 CONTINUE ! ! Initialize parameters of banded matrix processor, DBNDAC( ). ! MT = 0 IP = 1 IR = 1 ILEFT = NORD DO 160 IDATA = 1,NDATA ! ! Sorted indices are in PTEMP(*). ! L = PTEMP(IDATA) XVAL = XDATA(L) ! ! When interval changes, process equations in the last block. ! if (XVAL >= BKPT(ILEFT+1)) THEN call DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) MT = 0 ! ! Move pointer up to have BKPT(ILEFT) <= XVAL, ! ILEFT < NP1. ! 150 if (XVAL >= BKPT(ILEFT+1) .AND. ILEFT < N) THEN ILEFT = ILEFT + 1 go to 150 ENDIF ENDIF ! ! Obtain B-spline function value. ! call DFSPVN (BKPT, NORD, 1, XVAL, ILEFT, BF) ! ! Move row into place. ! IROW = IR + MT MT = MT + 1 call DCOPY (NORD, BF, 1, G(IROW,1), MDG) G(IROW,NORDP1) = YDATA(L) ! ! Scale data if uncertainty is nonzero. ! if (SDDATA(L) /= 0.D0) call DSCAL (NORDP1, 1.D0/SDDATA(L), & G(IROW,1), MDG) ! ! When staging work area is exhausted, process rows. ! if (IROW == MDG-1) THEN call DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) MT = 0 ENDIF 160 CONTINUE ! ! Process last block of equations. ! call DBNDAC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) ! ! Last call to adjust block positioning. ! call dinit ( NORDP1, 0.D0, G(IR,1), MDG) call DBNDAC (G, MDG, NORD, IP, IR, 1, NP1) end if ! BAND = BAND .AND. NCONST == 0 DO 170 I = 1,N BAND = BAND .AND. G(I,1) /= 0.D0 170 CONTINUE ! ! Process banded least squares equations. ! if (BAND) THEN call DBNDSL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM) return end if ! ! Check further for sufficient storage in working arrays. ! if (IW1 < LW) THEN WRITE (XERN1, '(I8)') LW call XERMSG ('SLATEC', 'DFCMN', & 'IN DFC, INSUFFICIENT STORAGE FOR W(*). CHECK LW = ' // & XERN1, 2, 1) MODE = -1 return end if ! if (IW2 < INTW1) THEN WRITE (XERN1, '(I8)') INTW1 call XERMSG ('SLATEC', 'DFCMN', & 'IN DFC, INSUFFICIENT STORAGE FOR IW(*). CHECK IW1 = ' // & XERN1, 2, 1) MODE = -1 return end if ! ! Write equality constraints. ! Analyze constraint indicators for an equality constraint. ! NEQCON = 0 DO 220 IDATA = 1,NCONST L = NDERIV(IDATA) ITYPE = MOD(L,4) if (ITYPE > 1) THEN IDERIV = L/4 NEQCON = NEQCON + 1 ILEFT = NORD XVAL = XCONST(IDATA) ! 180 if (XVAL < BKPT(ILEFT+1) .OR. ILEFT >= N) go to 190 ILEFT = ILEFT + 1 go to 180 ! 190 call DFSPVD (BKPT, NORD, XVAL, ILEFT, BF, IDERIV+1) call dinit (NP1, 0.D0, W(NEQCON,1), MDW) call DCOPY (NORD, BF(1,IDERIV+1), 1, W(NEQCON,ILEFT-NORDM1), & MDW) ! if (ITYPE == 2) THEN W(NEQCON,NP1) = YCONST(IDATA) ELSE ILEFT = NORD YVAL = YCONST(IDATA) ! 200 if (YVAL < BKPT(ILEFT+1) .OR. ILEFT >= N) go to 210 ILEFT = ILEFT + 1 go to 200 ! 210 call DFSPVD (BKPT, NORD, YVAL, ILEFT, BF, IDERIV+1) call DAXPY (NORD, -1.D0, BF(1, IDERIV+1), 1, & W(NEQCON, ILEFT-NORDM1), MDW) ENDIF ENDIF 220 CONTINUE ! ! Transfer least squares data. ! DO 230 I = 1,NP1 IROW = I + NEQCON call dinit ( N, 0.D0, W(IROW,1), MDW) call DCOPY (MIN(NP1-I, NORD), G(I,1), MDG, W(IROW,I), MDW) W(IROW,NP1) = G(I,NORDP1) 230 CONTINUE ! ! Write inequality constraints. ! Analyze constraint indicators for inequality constraints. ! NINCON = 0 DO 260 IDATA = 1,NCONST L = NDERIV(IDATA) ITYPE = MOD(L,4) if (ITYPE < 2) THEN IDERIV = L/4 NINCON = NINCON + 1 ILEFT = NORD XVAL = XCONST(IDATA) ! 240 if (XVAL < BKPT(ILEFT+1) .OR. ILEFT >= N) go to 250 ILEFT = ILEFT + 1 go to 240 ! 250 call DFSPVD (BKPT, NORD, XVAL, ILEFT, BF, IDERIV+1) IROW = NEQCON + NP1 + NINCON call dinit ( N, 0.D0, W(IROW,1), MDW) INTRVL = ILEFT - NORDM1 call DCOPY (NORD, BF(1, IDERIV+1), 1, W(IROW, INTRVL), MDW) ! if (ITYPE == 1) THEN W(IROW,NP1) = YCONST(IDATA) ELSE W(IROW,NP1) = -YCONST(IDATA) call DSCAL (NORD, -1.D0, W(IROW, INTRVL), MDW) ENDIF ENDIF 260 CONTINUE ! ! Solve constrained least squares equations. ! call DLSEI(W, MDW, NEQCON, NP1, NINCON, N, PRGOPT, COEFF, RNORME, & RNORML, MODE, WORK, IWORK) return end subroutine DFDJC1 (FCN, N, X, FVEC, FJAC, LDFJAC, IFLAG, ML, MU, & EPSFCN, WA1, WA2) ! !! DFDJC1 computes a forward difference approximation to an N by N Jacobian. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DNSQ and DNSQE !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FDJAC1-S, DFDJC1-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine computes a forward-difference approximation ! to the N by N Jacobian matrix associated with a specified ! problem of N functions in N variables. If the Jacobian has ! a banded form, then function evaluations are saved by only ! approximating the nonzero terms. ! ! The subroutine statement is ! ! SUBROUTINE DFDJC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, ! WA1,WA2) ! ! where ! ! FCN is the name of the user-supplied subroutine which ! calculates the functions. FCN must be declared ! in an EXTERNAL statement in the user calling ! program, and should be written as follows. ! ! SUBROUTINE FCN(N,X,FVEC,IFLAG) ! INTEGER N,IFLAG ! DOUBLE PRECISION X(N),FVEC(N) ! ---------- ! Calculate the functions at X and ! return this vector in FVEC. ! ---------- ! return ! ! The value of IFLAG should not be changed by FCN unless ! the user wants to terminate execution of DFDJC1. ! In this case set IFLAG to a negative integer. ! ! N is a positive integer input variable set to the number ! of functions and variables. ! ! X is an input array of length N. ! ! FVEC is an input array of length N which must contain the ! functions evaluated at X. ! ! FJAC is an output N by N array which contains the ! approximation to the Jacobian matrix evaluated at X. ! ! LDFJAC is a positive integer input variable not less than N ! which specifies the leading dimension of the array FJAC. ! ! IFLAG is an integer variable which can be used to terminate ! the execution of DFDJC1. See description of FCN. ! ! ML is a nonnegative integer input variable which specifies ! the number of subdiagonals within the band of the ! Jacobian matrix. If the Jacobian is not banded, set ! ML to at least N - 1. ! ! EPSFCN is an input variable used in determining a suitable ! step length for the forward-difference approximation. This ! approximation assumes that the relative errors in the ! functions are of the order of EPSFCN. If EPSFCN is less ! than the machine precision, it is assumed that the relative ! errors in the functions are of the order of the machine ! precision. ! ! MU is a nonnegative integer input variable which specifies ! the number of superdiagonals within the band of the ! Jacobian matrix. If the Jacobian is not banded, set ! MU to at least N - 1. ! ! WA1 and WA2 are work arrays of length N. If ML + MU + 1 is at ! least N, then the Jacobian is considered dense, and WA2 is ! not referenced. ! !***SEE ALSO DNSQ, DNSQE !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DFDJC1 DOUBLE PRECISION D1MACH INTEGER I, IFLAG, J, K, LDFJAC, ML, MSUM, MU, N DOUBLE PRECISION EPS, EPSFCN, EPSMCH, FJAC(LDFJAC,*), & FVEC(*), H, TEMP, WA1(*), WA2(*), X(*), ZERO SAVE ZERO DATA ZERO /0.0D0/ ! ! EPSMCH IS THE MACHINE PRECISION. ! !***FIRST EXECUTABLE STATEMENT DFDJC1 EPSMCH = D1MACH(4) ! EPS = SQRT(MAX(EPSFCN,EPSMCH)) MSUM = ML + MU + 1 if (MSUM < N) go to 40 ! ! COMPUTATION OF DENSE APPROXIMATE JACOBIAN. ! DO 20 J = 1, N TEMP = X(J) H = EPS*ABS(TEMP) if (H == ZERO) H = EPS X(J) = TEMP + H call FCN(N,X,WA1,IFLAG) if (IFLAG < 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 ! ! COMPUTATION OF BANDED APPROXIMATE JACOBIAN. ! DO 90 K = 1, MSUM DO 60 J = K, N, MSUM WA2(J) = X(J) H = EPS*ABS(WA2(J)) if (H == ZERO) H = EPS X(J) = WA2(J) + H 60 CONTINUE call FCN(N,X,WA1,IFLAG) if (IFLAG < 0) go to 100 DO 80 J = K, N, MSUM X(J) = WA2(J) H = EPS*ABS(WA2(J)) if (H == ZERO) H = EPS DO 70 I = 1, N FJAC(I,J) = ZERO if (I >= J - MU .AND. I <= J + ML) & FJAC(I,J) = (WA1(I) - FVEC(I))/H 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE 110 CONTINUE return ! ! LAST CARD OF SUBROUTINE DFDJC1. ! end subroutine DFDJC3 (FCN, M, N, X, FVEC, FJAC, LDFJAC, IFLAG, & EPSFCN, WA) ! !! DFDJC3 computes an M by N forward difference approximation to a Jacobian. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DNLS1 and DNLS1E !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FDJAC3-S, DFDJC3-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! **** Double Precision version of FDJAC3 **** ! ! This subroutine computes a forward-difference approximation ! to the M by N Jacobian matrix associated with a specified ! problem of M functions in N variables. ! ! The subroutine statement is ! ! SUBROUTINE DFDJC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) ! ! where ! ! FCN is the name of the user-supplied subroutine which ! calculates the functions. FCN must be declared ! in an external statement in the user calling ! program, and should be written as follows. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! INTEGER LDFJAC,M,N,IFLAG ! DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) ! ---------- ! When IFLAG == 1 calculate the functions at X and ! return this vector in FVEC. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by FCN unless ! the user wants to terminate execution of DFDJC3. ! In this case set IFLAG to a negative integer. ! ! M is a positive integer input variable set to the number ! of functions. ! ! N is a positive integer input variable set to the number ! of variables. N must not exceed M. ! ! X is an input array of length N. ! ! FVEC is an input array of length M which must contain the ! functions evaluated at X. ! ! FJAC is an output M by N array which contains the ! approximation to the Jacobian matrix evaluated at X. ! ! LDFJAC is a positive integer input variable not less than M ! which specifies the leading dimension of the array FJAC. ! ! IFLAG is an integer variable which can be used to terminate ! THE EXECUTION OF DFDJC3. See description of FCN. ! ! EPSFCN is an input variable used in determining a suitable ! step length for the forward-difference approximation. This ! approximation assumes that the relative errors in the ! functions are of the order of EPSFCN. If EPSFCN is less ! than the machine precision, it is assumed that the relative ! errors in the functions are of the order of the machine ! precision. ! ! WA is a work array of length M. ! !***SEE ALSO DNLS1, DNLS1E !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DFDJC3 INTEGER M,N,LDFJAC,IFLAG DOUBLE PRECISION EPSFCN DOUBLE PRECISION X(*),FVEC(*),FJAC(LDFJAC,*),WA(*) INTEGER I,J DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO DOUBLE PRECISION D1MACH SAVE ZERO DATA ZERO /0.0D0/ !***FIRST EXECUTABLE STATEMENT DFDJC3 EPSMCH = D1MACH(4) ! EPS = SQRT(MAX(EPSFCN,EPSMCH)) ! SET IFLAG=1 TO INDICATE THAT FUNCTION VALUES ! ARE TO BE RETURNED BY FCN. IFLAG = 1 DO 20 J = 1, N TEMP = X(J) H = EPS*ABS(TEMP) if (H == ZERO) H = EPS X(J) = TEMP + H call FCN(IFLAG,M,N,X,WA,FJAC,LDFJAC) if (IFLAG < 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 ! ! LAST CARD OF SUBROUTINE DFDJC3. ! end subroutine DFEHL (DF, NEQ, T, Y, H, YP, F1, F2, F3, F4, F5, YS, & RPAR, IPAR) ! !! DFEHL implements a (4,5) order Runge-Kutta-Fehlberg ODE method. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DDERKF !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (DEFEHL-S, DFEHL-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! Fehlberg Fourth-Fifth Order Runge-Kutta Method ! ********************************************************************** ! ! DFEHL integrates a system of NEQ first order ! ordinary differential equations of the form ! DU/DX = DF(X,U) ! over one step when the vector Y(*) of initial values for U(*) and ! the vector YP(*) of initial derivatives, satisfying YP = DF(T,Y), ! are given at the starting point X=T. ! ! DFEHL advances the solution over the fixed step H and returns ! the fifth order (sixth order accurate locally) solution ! approximation at T+H in the array YS(*). ! F1,---,F5 are arrays of dimension NEQ which are needed ! for internal storage. ! The formulas have been grouped to control loss of significance. ! DFEHL should be called with an H not smaller than 13 units of ! roundoff in T so that the various independent arguments can be ! distinguished. ! ! This subroutine has been written with all variables and statement ! numbers entirely compatible with DRKFS. For greater efficiency, ! the call to DFEHL can be replaced by the module beginning with ! line 222 and extending to the last line just before the return ! statement. ! ! ********************************************************************** ! !***SEE ALSO DDERKF !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DFEHL ! INTEGER IPAR, K, NEQ DOUBLE PRECISION CH, F1, F2, F3, F4, F5, H, RPAR, T, Y, YP, YS DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), & YS(*),RPAR(*),IPAR(*) ! !***FIRST EXECUTABLE STATEMENT DFEHL CH = H/4.0D0 DO 10 K = 1, NEQ YS(K) = Y(K) + CH*YP(K) 10 CONTINUE call DF(T+CH,YS,F1,RPAR,IPAR) ! CH = 3.0D0*H/32.0D0 DO 20 K = 1, NEQ YS(K) = Y(K) + CH*(YP(K) + 3.0D0*F1(K)) 20 CONTINUE call DF(T+3.0D0*H/8.0D0,YS,F2,RPAR,IPAR) ! CH = H/2197.0D0 DO 30 K = 1, NEQ YS(K) = Y(K) & + CH & *(1932.0D0*YP(K) + (7296.0D0*F2(K) - 7200.0D0*F1(K))) 30 CONTINUE call DF(T+12.0D0*H/13.0D0,YS,F3,RPAR,IPAR) ! CH = H/4104.0D0 DO 40 K = 1, NEQ YS(K) = Y(K) & + CH & *((8341.0D0*YP(K) - 845.0D0*F3(K)) & + (29440.0D0*F2(K) - 32832.0D0*F1(K))) 40 CONTINUE call DF(T+H,YS,F4,RPAR,IPAR) ! CH = H/20520.0D0 DO 50 K = 1, NEQ YS(K) = Y(K) & + CH & *((-6080.0D0*YP(K) & + (9295.0D0*F3(K) - 5643.0D0*F4(K))) & + (41040.0D0*F1(K) - 28352.0D0*F2(K))) 50 CONTINUE call DF(T+H/2.0D0,YS,F5,RPAR,IPAR) ! ! COMPUTE APPROXIMATE SOLUTION AT T+H ! CH = H/7618050.0D0 DO 60 K = 1, NEQ YS(K) = Y(K) & + CH & *((902880.0D0*YP(K) & + (3855735.0D0*F3(K) - 1371249.0D0*F4(K))) & + (3953664.0D0*F2(K) + 277020.0D0*F5(K))) 60 CONTINUE ! return end subroutine DFSPVD (T, K, X, ILEFT, VNIKX, NDERIV) ! !! DFSPVD evaluates all nonzero B splines and derivatives at X. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DFC !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BSPLVD-S, DFSPVD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! **** Double Precision Version of BSPLVD **** ! Calculates value and deriv.s of all B-splines which do not vanish at X ! ! Fill VNIKX(J,IDERIV), J=IDERIV, ... ,K with nonzero values of ! B-splines of order K+1-IDERIV , IDERIV=NDERIV, ... ,1, by repeated ! calls to DFSPVN ! !***SEE ALSO DFC !***ROUTINES CALLED DFSPVN !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DFSPVD IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION T(*),VNIKX(K,*) DIMENSION A(20,20) !***FIRST EXECUTABLE STATEMENT DFSPVD call DFSPVN(T,K+1-NDERIV,1,X,ILEFT,VNIKX(NDERIV,NDERIV)) if (NDERIV <= 1) go to 99 IDERIV = NDERIV DO 15 I=2,NDERIV IDERVM = IDERIV-1 DO 11 J=IDERIV,K 11 VNIKX(J-1,IDERVM) = VNIKX(J,IDERIV) IDERIV = IDERVM call DFSPVN(T,0,2,X,ILEFT,VNIKX(IDERIV,IDERIV)) 15 CONTINUE ! DO 20 I=1,K DO 19 J=1,K 19 A(I,J) = 0.D0 20 A(I,I) = 1.D0 KMD = K DO 40 M=2,NDERIV KMD = KMD-1 FKMD = KMD I = ILEFT J = K 21 JM1 = J-1 IPKMD = I + KMD DIFF = T(IPKMD) - T(I) if (JM1 == 0) go to 26 if (DIFF == 0.D0) go to 25 DO 24 L=1,J 24 A(L,J) = (A(L,J) - A(L,J-1))/DIFF*FKMD 25 J = JM1 I = I - 1 go to 21 26 if (DIFF == 0.) go to 30 A(1,1) = A(1,1)/DIFF*FKMD ! 30 DO 40 I=1,K V = 0.D0 JLOW = MAX(I,M) DO 35 J=JLOW,K 35 V = A(I,J)*VNIKX(J,M) + V 40 VNIKX(I,M) = V 99 return end subroutine DFSPVN (T, JHIGH, INDEX, X, ILEFT, VNIKX) ! !! DFSPVN evaluates all nonzero B-splines of given order at X. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DFC !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BSPLVN-S, DFSPVN-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! **** Double Precision version of BSPLVN **** ! ! Calculates the value of all possibly nonzero B-splines at *X* of ! order MAX(JHIGH,(J+1)(INDEX-1)) on *T*. ! !***SEE ALSO DFC !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DFSPVN IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION T(*),VNIKX(*) DIMENSION DELTAM(20),DELTAP(20) SAVE J, DELTAM, DELTAP DATA J/1/,(DELTAM(I),I=1,20),(DELTAP(I),I=1,20)/40*0.0D0/ !***FIRST EXECUTABLE STATEMENT DFSPVN go to (10,20),INDEX 10 J = 1 VNIKX(1) = 1.D0 if (J >= JHIGH) go to 99 ! 20 IPJ = ILEFT+J DELTAP(J) = T(IPJ) - X IMJP1 = ILEFT-J+1 DELTAM(J) = X - T(IMJP1) VMPREV = 0.D0 JP1 = J+1 DO 26 L=1,J JP1ML = JP1-L VM = VNIKX(L)/(DELTAP(L) + DELTAM(JP1ML)) VNIKX(L) = VM*DELTAP(L) + VMPREV 26 VMPREV = VM*DELTAM(JP1ML) VNIKX(JP1) = VMPREV J = JP1 if (J < JHIGH) go to 20 ! 99 return end subroutine DFULMT (I, J, AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) ! !! DFULMT decodes a standard 2D Fortran array passed as a vector. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DSPLP !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FULMAT-S, DFULMT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DECODES A STANDARD TWO-DIMENSIONAL FORTRAN ARRAY PASSED ! IN THE ARRAY DATTRV(IA,*). THE ROW DIMENSION IA AND THE ! MATRIX DIMENSIONS MRELAS AND NVARS MUST SIMULTANEOUSLY BE ! PASSED USING THE OPTION ARRAY, PRGOPT(*). IT IS AN ERROR ! if THIS DATA IS NOT PASSED TO DFULMT( ). ! EXAMPLE-- (FOR USE TOGETHER WITH DSPLP().) ! EXTERNAL DUSRMT ! DIMENSION DATTRV(IA,*) ! PRGOPT(01)=7 ! PRGOPT(02)=68 ! PRGOPT(03)=1 ! PRGOPT(04)=IA ! PRGOPT(05)=MRELAS ! PRGOPT(06)=NVARS ! PRGOPT(07)=1 ! call DSPLP( ... DFULMT INSTEAD OF DUSRMT...) ! !***SEE ALSO DSPLP !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DFULMT DOUBLE PRECISION AIJ,ZERO,DATTRV(*),PRGOPT(*) INTEGER IFLAG(10) SAVE ZERO !***FIRST EXECUTABLE STATEMENT DFULMT if (.NOT.(IFLAG(1) == 1)) go to 50 ! INITIALIZE POINTERS TO PROCESS FULL TWO-DIMENSIONAL FORTRAN ! ARRAYS. ZERO = 0.D0 LP = 1 10 NEXT = PRGOPT(LP) if (.NOT.(NEXT <= 1)) go to 20 NERR = 29 LEVEL = 1 call XERMSG ('SLATEC', 'DFULMT', & 'IN DSPLP, ROW DIM., MRELAS, NVARS ARE MISSING FROM PRGOPT.', & NERR, LEVEL) IFLAG(1) = 3 go to 110 20 KEY = PRGOPT(LP+1) if (.NOT.(KEY /= 68)) go to 30 LP = NEXT go to 10 30 if (.NOT.(PRGOPT(LP+2) == ZERO)) go to 40 LP = NEXT go to 10 40 IFLAG(2) = 1 IFLAG(3) = 1 IFLAG(4) = PRGOPT(LP+3) IFLAG(5) = PRGOPT(LP+4) IFLAG(6) = PRGOPT(LP+5) go to 110 50 if (.NOT.(IFLAG(1) == 2)) go to 100 60 I = IFLAG(2) J = IFLAG(3) if (.NOT.(J > IFLAG(6))) go to 70 IFLAG(1) = 3 go to 110 70 if (.NOT.(I > IFLAG(5))) go to 80 IFLAG(2) = 1 IFLAG(3) = J + 1 go to 60 80 AIJ = DATTRV(IFLAG(4)*(J-1)+I) IFLAG(2) = I + 1 if (.NOT.(AIJ == ZERO)) go to 90 go to 60 90 INDCAT = 0 go to 110 100 CONTINUE 110 RETURN end subroutine DFZERO (F, B, C, R, RE, AE, IFLAG) ! !! DFZERO finds a zero of a function in a given interval. ! !***PURPOSE Search for a zero of a function F(X) in a given interval ! (B,C). It is designed primarily for problems where F(B) ! and F(C) have opposite signs. !***LIBRARY SLATEC !***CATEGORY F1B !***TYPE DOUBLE PRECISION (FZERO-S, DFZERO-D) !***KEYWORDS BISECTION, NONLINEAR, ROOTS, ZEROS !***AUTHOR Shampine, L. F., (SNLA) ! Watts, H. A., (SNLA) !***DESCRIPTION ! ! DFZERO searches for a zero of a DOUBLE PRECISION function F(X) ! between the given DOUBLE PRECISION values B and C until the width ! of the interval (B,C) has collapsed to within a tolerance ! specified by the stopping criterion, ! ABS(B-C) <= 2.*(RW*ABS(B)+AE). ! The method used is an efficient combination of bisection and the ! secant rule and is due to T. J. Dekker. ! ! Description Of Arguments ! ! F :EXT - Name of the DOUBLE PRECISION external function. This ! name must be in an EXTERNAL statement in the calling ! program. F must be a function of one DOUBLE ! PRECISION argument. ! ! B :INOUT - One end of the DOUBLE PRECISION interval (B,C). The ! value returned for B usually is the better ! approximation to a zero of F. ! ! C :INOUT - The other end of the DOUBLE PRECISION interval (B,C) ! ! R :IN - A (better) DOUBLE PRECISION guess of a zero of F ! which could help in speeding up convergence. If F(B) ! and F(R) have opposite signs, a root will be found in ! the interval (B,R); if not, but F(R) and F(C) have ! opposite signs, a root will be found in the interval ! (R,C); otherwise, the interval (B,C) will be ! searched for a possible root. When no better guess ! is known, it is recommended that R be set to B or C, ! since if R is not interior to the interval (B,C), it ! will be ignored. ! ! RE :IN - Relative error used for RW in the stopping criterion. ! If the requested RE is less than machine precision, ! then RW is set to approximately machine precision. ! ! AE :IN - Absolute error used in the stopping criterion. If ! the given interval (B,C) contains the origin, then a ! nonzero value should be chosen for AE. ! ! IFLAG :OUT - A status code. User must check IFLAG after each ! call. Control returns to the user from DFZERO in all ! cases. ! ! 1 B is within the requested tolerance of a zero. ! The interval (B,C) collapsed to the requested ! tolerance, the function changes sign in (B,C), and ! F(X) decreased in magnitude as (B,C) collapsed. ! ! 2 F(B) = 0. However, the interval (B,C) may not have ! collapsed to the requested tolerance. ! ! 3 B may be near a singular point of F(X). ! The interval (B,C) collapsed to the requested tol- ! erance and the function changes sign in (B,C), but ! F(X) increased in magnitude as (B,C) collapsed, i.e. ! ABS(F(B out)) > MAX(ABS(F(B in)),ABS(F(C in))) ! ! 4 No change in sign of F(X) was found although the ! interval (B,C) collapsed to the requested tolerance. ! The user must examine this case and decide whether ! B is near a local minimum of F(X), or B is near a ! zero of even multiplicity, or neither of these. ! ! 5 Too many ( > 500) function evaluations used. ! !***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving ! code, Report SC-TM-70-631, Sandia Laboratories, ! September 1970. ! T. J. Dekker, Finding a zero by means of successive ! linear interpolation, Constructive Aspects of the ! Fundamental Theorem of Algebra, edited by B. Dejon ! and P. Henrici, Wiley-Interscience, 1969. !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 700901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DFZERO DOUBLE PRECISION A,ACBS,ACMB,AE,AW,B,C,CMB,D1MACH,ER, & F,FA,FB,FC,FX,FZ,P,Q,R,RE,RW,T,TOL,Z INTEGER IC,IFLAG,KOUNT ! !***FIRST EXECUTABLE STATEMENT DFZERO ! ! ER is two times the computer unit roundoff value which is defined ! here by the function D1MACH. ! ER = 2.0D0 * D1MACH(4) ! ! Initialize. ! Z = R if (R <= MIN(B,C) .OR. R >= MAX(B,C)) Z = C RW = MAX(RE,ER) AW = MAX(AE,0.D0) IC = 0 T = Z FZ = F(T) FC = FZ T = B FB = F(T) KOUNT = 2 if (SIGN(1.0D0,FZ) == SIGN(1.0D0,FB)) go to 1 C = Z go to 2 1 if (Z == C) go to 2 T = C FC = F(T) KOUNT = 3 if (SIGN(1.0D0,FZ) == SIGN(1.0D0,FC)) go to 2 B = Z FB = FZ 2 A = C FA = FC ACBS = ABS(B-C) FX = MAX(ABS(FB),ABS(FC)) ! 3 if (ABS(FC) >= ABS(FB)) go to 4 ! ! Perform interchange. ! A = B FA = FB B = C FB = FC C = A FC = FA ! 4 CMB = 0.5D0*(C-B) ACMB = ABS(CMB) TOL = RW*ABS(B) + AW ! ! Test stopping criterion and function count. ! if (ACMB <= TOL) go to 10 if (FB == 0.D0) go to 11 if (KOUNT >= 500) go to 14 ! ! Calculate new iterate implicitly as B+P/Q, where we arrange ! P >= 0. The implicit form is used to prevent overflow. ! P = (B-A)*FB Q = FA - FB if (P >= 0.D0) go to 5 P = -P Q = -Q ! ! Update A and check for satisfactory reduction in the size of the ! bracketing interval. If not, perform bisection. ! 5 A = B FA = FB IC = IC + 1 if (IC < 4) go to 6 if (8.0D0*ACMB >= ACBS) go to 8 IC = 0 ACBS = ACMB ! ! Test for too small a change. ! 6 if (P > ABS(Q)*TOL) go to 7 ! ! Increment by TOLerance. ! B = B + SIGN(TOL,CMB) go to 9 ! ! Root ought to be between B and (C+B)/2. ! 7 if (P >= CMB*Q) go to 8 ! ! Use secant rule. ! B = B + P/Q go to 9 ! ! Use bisection (C+B)/2. ! 8 B = B + CMB ! ! Have completed computation for new iterate B. ! 9 T = B FB = F(T) KOUNT = KOUNT + 1 ! ! Decide whether next step is interpolation or extrapolation. ! if (SIGN(1.0D0,FB) /= SIGN(1.0D0,FC)) go to 3 C = A FC = FA go to 3 ! ! Finished. Process results for proper setting of IFLAG. ! 10 if (SIGN(1.0D0,FB) == SIGN(1.0D0,FC)) go to 13 if (ABS(FB) > FX) go to 12 IFLAG = 1 return 11 IFLAG = 2 return 12 IFLAG = 3 return 13 IFLAG = 4 return 14 IFLAG = 5 return end DOUBLE PRECISION FUNCTION DGAMIC (A, X) ! !! DGAMIC calculates the complementary incomplete Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE DOUBLE PRECISION (GAMIC-S, DGAMIC-D) !***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate the complementary incomplete Gamma function ! ! DGAMIC = integral from X to infinity of EXP(-T) * T**(A-1.) . ! ! DGAMIC is evaluated for arbitrary real values of A and for non- ! negative values of X (even though DGAMIC is defined for X < ! 0.0), except that for X = 0 and A <= 0.0, DGAMIC is undefined. ! ! DGAMIC, A, and X are DOUBLE PRECISION. ! ! A slight deterioration of 2 or 3 digits accuracy will occur when ! DGAMIC is very large or very small in absolute value, because log- ! arithmic variables are used. Also, if the parameter A is very close ! to a negative INTEGER (but not a negative integer), there is a loss ! of accuracy, which is reported if the result is less than half ! machine precision. ! !***REFERENCES W. Gautschi, A computational procedure for incomplete ! gamma functions, ACM Transactions on Mathematical ! Software 5, 4 (December 1979), pp. 466-481. ! W. Gautschi, Incomplete gamma functions, Algorithm 542, ! ACM Transactions on Mathematical Software 5, 4 ! (December 1979), pp. 482-489. !***ROUTINES CALLED D1MACH, D9GMIC, D9GMIT, D9LGIC, D9LGIT, DLGAMS, ! DLNGAM, XERCLR, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920528 DESCRIPTION and REFERENCES sections revised. (WRB) !***END PROLOGUE DGAMIC DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNGS, ALX, & BOT, E, EPS, GSTAR, H, SGA, SGNG, SGNGAM, SGNGS, SQEPS, T, & D1MACH, DLNGAM, D9GMIC, D9GMIT, D9LGIC, D9LGIT LOGICAL FIRST SAVE EPS, SQEPS, ALNEPS, BOT, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DGAMIC if (FIRST) THEN EPS = 0.5D0*D1MACH(3) SQEPS = SQRT(D1MACH(4)) ALNEPS = -LOG (D1MACH(3)) BOT = LOG (D1MACH(1)) end if FIRST = .FALSE. ! if (X < 0.D0) call XERMSG ('SLATEC', 'DGAMIC', 'X IS NEGATIVE' & , 2, 2) ! if (X > 0.D0) go to 20 if (A <= 0.D0) call XERMSG ('SLATEC', 'DGAMIC', & 'X = 0 AND A LE 0 SO DGAMIC IS UNDEFINED', 3, 2) ! DGAMIC = EXP (DLNGAM(A+1.D0) - LOG(A)) return ! 20 ALX = LOG (X) SGA = 1.0D0 if (A /= 0.D0) SGA = SIGN (1.0D0, A) AINTA = AINT (A + 0.5D0*SGA) AEPS = A - AINTA ! IZERO = 0 if (X >= 1.0D0) go to 40 ! if (A > 0.5D0 .OR. ABS(AEPS) > 0.001D0) go to 30 E = 2.0D0 if (-AINTA > 1.D0) E = 2.D0*(-AINTA+2.D0)/(AINTA*AINTA-1.0D0) E = E - ALX * X**(-0.001D0) if (E*ABS(AEPS) > EPS) go to 30 ! DGAMIC = D9GMIC (A, X, ALX) return ! 30 call DLGAMS (A+1.0D0, ALGAP1, SGNGAM) GSTAR = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) if (GSTAR == 0.D0) IZERO = 1 if (GSTAR /= 0.D0) ALNGS = LOG (ABS(GSTAR)) if (GSTAR /= 0.D0) SGNGS = SIGN (1.0D0, GSTAR) go to 50 ! 40 if (A < X) DGAMIC = EXP (D9LGIC(A, X, ALX)) if (A < X) RETURN ! SGNGAM = 1.0D0 ALGAP1 = DLNGAM (A+1.0D0) SGNGS = 1.0D0 ALNGS = D9LGIT (A, X, ALGAP1) ! ! EVALUATION OF DGAMIC(A,X) IN TERMS OF TRICOMI-S INCOMPLETE GAMMA FN. ! 50 H = 1.D0 if (IZERO == 1) go to 60 ! T = A*ALX + ALNGS if (T > ALNEPS) go to 70 if (T > (-ALNEPS)) H = 1.0D0 - SGNGS*EXP(T) ! if (ABS(H) < SQEPS) call XERCLR if (ABS(H) < SQEPS) call XERMSG ('SLATEC', 'DGAMIC', & 'RESULT LT HALF PRECISION', 1, 1) ! 60 SGNG = SIGN (1.0D0, H) * SGA * SGNGAM T = LOG(ABS(H)) + ALGAP1 - LOG(ABS(A)) if (T < BOT) call XERCLR DGAMIC = SGNG * EXP(T) return ! 70 SGNG = -SGNGS * SGA * SGNGAM T = T + ALGAP1 - LOG(ABS(A)) if (T < BOT) call XERCLR DGAMIC = SGNG * EXP(T) return ! end DOUBLE PRECISION FUNCTION DGAMI (A, X) ! !! DGAMI evaluates the incomplete Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE DOUBLE PRECISION (GAMI-S, DGAMI-D) !***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate the incomplete gamma function defined by ! ! DGAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . ! ! DGAMI is evaluated for positive values of A and non-negative values ! of X. A slight deterioration of 2 or 3 digits accuracy will occur ! when DGAMI is very large or very small, because logarithmic variables ! are used. The function and both arguments are double precision. ! !***REFERENCES (NONE) !***ROUTINES CALLED DGAMIT, DLNGAM, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DGAMI DOUBLE PRECISION A, X, FACTOR, DLNGAM, DGAMIT !***FIRST EXECUTABLE STATEMENT DGAMI if (A <= 0.D0) call XERMSG ('SLATEC', 'DGAMI', & 'A MUST BE GT ZERO', 1, 2) if (X < 0.D0) call XERMSG ('SLATEC', 'DGAMI', & 'X MUST BE GE ZERO', 2, 2) ! DGAMI = 0.D0 if (X == 0.0D0) RETURN ! ! THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. FACTOR = EXP (DLNGAM(A) + A*LOG(X)) ! DGAMI = FACTOR * DGAMIT (A, X) ! return end DOUBLE PRECISION FUNCTION DGAMIT (A, X) ! !! DGAMIT calculates Tricomi's form of the incomplete Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE DOUBLE PRECISION (GAMIT-S, DGAMIT-D) !***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, ! SPECIAL FUNCTIONS, TRICOMI !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate Tricomi's incomplete Gamma function defined by ! ! DGAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) * ! T**(A-1.) ! ! for A > 0.0 and by analytic continuation for A <= 0.0. ! GAMMA(X) is the complete gamma function of X. ! ! DGAMIT is evaluated for arbitrary real values of A and for non- ! negative values of X (even though DGAMIT is defined for X < ! 0.0), except that for X = 0 and A <= 0.0, DGAMIT is infinite, ! which is a fatal error. ! ! The function and both arguments are DOUBLE PRECISION. ! ! A slight deterioration of 2 or 3 digits accuracy will occur when ! DGAMIT is very large or very small in absolute value, because log- ! arithmic variables are used. Also, if the parameter A is very ! close to a negative integer (but not a negative integer), there is ! a loss of accuracy, which is reported if the result is less than ! half machine precision. ! !***REFERENCES W. Gautschi, A computational procedure for incomplete ! gamma functions, ACM Transactions on Mathematical ! Software 5, 4 (December 1979), pp. 466-481. ! W. Gautschi, Incomplete gamma functions, Algorithm 542, ! ACM Transactions on Mathematical Software 5, 4 ! (December 1979), pp. 482-489. !***ROUTINES CALLED D1MACH, D9GMIT, D9LGIC, D9LGIT, DGAMR, DLGAMS, ! DLNGAM, XERCLR, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920528 DESCRIPTION and REFERENCES sections revised. (WRB) !***END PROLOGUE DGAMIT DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX, & BOT, H, SGA, SGNGAM, SQEPS, T, D1MACH, DGAMR, D9GMIT, D9LGIT, & DLNGAM, D9LGIC LOGICAL FIRST SAVE ALNEPS, SQEPS, BOT, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DGAMIT if (FIRST) THEN ALNEPS = -LOG (D1MACH(3)) SQEPS = SQRT(D1MACH(4)) BOT = LOG (D1MACH(1)) end if FIRST = .FALSE. ! if (X < 0.D0) call XERMSG ('SLATEC', 'DGAMIT', 'X IS NEGATIVE' & , 2, 2) ! if (X /= 0.D0) ALX = LOG (X) SGA = 1.0D0 if (A /= 0.D0) SGA = SIGN (1.0D0, A) AINTA = AINT (A + 0.5D0*SGA) AEPS = A - AINTA ! if (X > 0.D0) go to 20 DGAMIT = 0.0D0 if (AINTA > 0.D0 .OR. AEPS /= 0.D0) DGAMIT = DGAMR(A+1.0D0) return ! 20 if (X > 1.D0) go to 30 if (A >= (-0.5D0) .OR. AEPS /= 0.D0) call DLGAMS (A+1.0D0, ALGAP1, & SGNGAM) DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) return ! 30 if (A < X) go to 40 T = D9LGIT (A, X, DLNGAM(A+1.0D0)) if (T < BOT) call XERCLR DGAMIT = EXP (T) return ! 40 ALNG = D9LGIC (A, X, ALX) ! ! EVALUATE DGAMIT IN TERMS OF LOG (DGAMIC (A, X)) ! H = 1.0D0 if (AEPS == 0.D0 .AND. AINTA <= 0.D0) go to 50 ! call DLGAMS (A+1.0D0, ALGAP1, SGNGAM) T = LOG (ABS(A)) + ALNG - ALGAP1 if (T > ALNEPS) go to 60 ! if (T > (-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * EXP(T) if (ABS(H) > SQEPS) go to 50 ! call XERCLR call XERMSG ('SLATEC', 'DGAMIT', 'RESULT LT HALF PRECISION', 1, & 1) ! 50 T = -A*ALX + LOG(ABS(H)) if (T < BOT) call XERCLR DGAMIT = SIGN (EXP(T), H) return ! 60 T = T - A*ALX if (T < BOT) call XERCLR DGAMIT = -SGA * SGNGAM * EXP(T) return ! end subroutine DGAMLM (XMIN, XMAX) ! !! DGAMLM computes bounds for the argument in the Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A, R2 !***TYPE DOUBLE PRECISION (GAMLIM-S, DGAMLM-D) !***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Calculate the minimum and maximum legal bounds for X in gamma(X). ! XMIN and XMAX are not the only bounds, but they are the only non- ! trivial ones to calculate. ! ! Output Arguments -- ! XMIN double precision minimum legal value of X in gamma(X). Any ! smaller value of X might result in underflow. ! XMAX double precision maximum legal value of X in gamma(X). Any ! larger value of X might cause overflow. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DGAMLM DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH !***FIRST EXECUTABLE STATEMENT DGAMLM ALNSML = LOG(D1MACH(1)) XMIN = -ALNSML DO 10 I=1,10 XOLD = XMIN XLN = LOG(XMIN) XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) & / (XMIN*XLN+0.5D0) if (ABS(XMIN-XOLD) < 0.005D0) go to 20 10 CONTINUE call XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2) ! 20 XMIN = -XMIN + 0.01D0 ! ALNBIG = LOG (D1MACH(2)) XMAX = ALNBIG DO 30 I=1,10 XOLD = XMAX XLN = LOG(XMAX) XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) & / (XMAX*XLN-0.5D0) if (ABS(XMAX-XOLD) < 0.005D0) go to 40 30 CONTINUE call XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2) ! 40 XMAX = XMAX - 0.01D0 XMIN = MAX (XMIN, -XMAX+1.D0) ! return end DOUBLE PRECISION FUNCTION DGAMLN (Z, IERR) ! !! DGAMLN computes the logarithm of the Gamma function. ! !***LIBRARY SLATEC !***CATEGORY C7A !***TYPE DOUBLE PRECISION (GAMLN-S, DGAMLN-D) !***KEYWORDS LOGARITHM OF GAMMA FUNCTION !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! **** A DOUBLE PRECISION ROUTINE **** ! DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR ! Z > 0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES ! GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION ! G(Z+1)=Z*G(Z) FOR Z <= ZMIN. THE FUNCTION WAS MADE AS ! PORTABLE AS POSSIBLE BY COMPUTING ZMIN FROM THE NUMBER OF BASE ! 10 DIGITS IN A WORD, RLN=MAX(-ALOG10(R1MACH(4)),0.5E-18) ! LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. ! ! SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 ! VALUES IS USED FOR SPEED OF EXECUTION. ! ! DESCRIPTION OF ARGUMENTS ! ! INPUT Z IS DOUBLE PRECISION ! Z - ARGUMENT, Z > 0.0D0 ! ! OUTPUT DGAMLN IS DOUBLE PRECISION ! DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z /= 0.0D0 ! IERR - ERROR FLAG ! IERR=0, NORMAL RETURN, COMPUTATION COMPLETED ! IERR=1, Z <= 0.0D0, NO COMPUTATION ! ! !***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT ! BY D. E. AMOS, SAND83-0083, MAY, 1983. !***ROUTINES CALLED D1MACH, I1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 830501 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 921215 DGAMLN defined for Z negative. (WRB) !***END PROLOGUE DGAMLN DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, & T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH DIMENSION CF(22), GLN(100) ! LNGAMMA(N), N=1,100 DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), & GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), & GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), & GLN(21), GLN(22)/ & 0.00000000000000000D+00, 0.00000000000000000D+00, & 6.93147180559945309D-01, 1.79175946922805500D+00, & 3.17805383034794562D+00, 4.78749174278204599D+00, & 6.57925121201010100D+00, 8.52516136106541430D+00, & 1.06046029027452502D+01, 1.28018274800814696D+01, & 1.51044125730755153D+01, 1.75023078458738858D+01, & 1.99872144956618861D+01, 2.25521638531234229D+01, & 2.51912211827386815D+01, 2.78992713838408916D+01, & 3.06718601060806728D+01, 3.35050734501368889D+01, & 3.63954452080330536D+01, 3.93398841871994940D+01, & 4.23356164607534850D+01, 4.53801388984769080D+01/ DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), & GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), & GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), & GLN(41), GLN(42), GLN(43), GLN(44)/ & 4.84711813518352239D+01, 5.16066755677643736D+01, & 5.47847293981123192D+01, 5.80036052229805199D+01, & 6.12617017610020020D+01, 6.45575386270063311D+01, & 6.78897431371815350D+01, 7.12570389671680090D+01, & 7.46582363488301644D+01, 7.80922235533153106D+01, & 8.15579594561150372D+01, 8.50544670175815174D+01, & 8.85808275421976788D+01, 9.21361756036870925D+01, & 9.57196945421432025D+01, 9.93306124547874269D+01, & 1.02968198614513813D+02, 1.06631760260643459D+02, & 1.10320639714757395D+02, 1.14034211781461703D+02, & 1.17771881399745072D+02, 1.21533081515438634D+02/ DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), & GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), & GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), & GLN(63), GLN(64), GLN(65), GLN(66)/ & 1.25317271149356895D+02, 1.29123933639127215D+02, & 1.32952575035616310D+02, 1.36802722637326368D+02, & 1.40673923648234259D+02, 1.44565743946344886D+02, & 1.48477766951773032D+02, 1.52409592584497358D+02, & 1.56360836303078785D+02, 1.60331128216630907D+02, & 1.64320112263195181D+02, 1.68327445448427652D+02, & 1.72352797139162802D+02, 1.76395848406997352D+02, & 1.80456291417543771D+02, 1.84533828861449491D+02, & 1.88628173423671591D+02, 1.92739047287844902D+02, & 1.96866181672889994D+02, 2.01009316399281527D+02, & 2.05168199482641199D+02, 2.09342586752536836D+02/ DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), & GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), & GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), & GLN(85), GLN(86), GLN(87), GLN(88)/ & 2.13532241494563261D+02, 2.17736934113954227D+02, & 2.21956441819130334D+02, 2.26190548323727593D+02, & 2.30439043565776952D+02, 2.34701723442818268D+02, & 2.38978389561834323D+02, 2.43268849002982714D+02, & 2.47572914096186884D+02, 2.51890402209723194D+02, & 2.56221135550009525D+02, 2.60564940971863209D+02, & 2.64921649798552801D+02, 2.69291097651019823D+02, & 2.73673124285693704D+02, 2.78067573440366143D+02, & 2.82474292687630396D+02, 2.86893133295426994D+02, & 2.91323950094270308D+02, 2.95766601350760624D+02, & 3.00220948647014132D+02, 3.04686856765668715D+02/ DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), & GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ & 3.09164193580146922D+02, 3.13652829949879062D+02, & 3.18152639620209327D+02, 3.22663499126726177D+02, & 3.27185287703775217D+02, 3.31717887196928473D+02, & 3.36261181979198477D+02, 3.40815058870799018D+02, & 3.45379407062266854D+02, 3.49954118040770237D+02, & 3.54539085519440809D+02, 3.59134205369575399D+02/ ! COEFFICIENTS OF ASYMPTOTIC EXPANSION DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), & CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), & CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ & 8.33333333333333333D-02, -2.77777777777777778D-03, & 7.93650793650793651D-04, -5.95238095238095238D-04, & 8.41750841750841751D-04, -1.91752691752691753D-03, & 6.41025641025641026D-03, -2.95506535947712418D-02, & 1.79644372368830573D-01, -1.39243221690590112D+00, & 1.34028640441683920D+01, -1.56848284626002017D+02, & 2.19310333333333333D+03, -3.61087712537249894D+04, & 6.91472268851313067D+05, -1.52382215394074162D+07, & 3.82900751391414141D+08, -1.08822660357843911D+10, & 3.47320283765002252D+11, -1.23696021422692745D+13, & 4.88788064793079335D+14, -2.13203339609193739D+16/ ! ! LN(2*PI) DATA CON / 1.83787706640934548D+00/ ! !***FIRST EXECUTABLE STATEMENT DGAMLN IERR=0 if (Z <= 0.0D0) go to 70 if (Z > 101.0D0) go to 10 NZ = Z FZ = Z - NZ if (FZ > 0.0D0) go to 10 if (NZ > 100) go to 10 DGAMLN = GLN(NZ) return 10 CONTINUE WDTOL = D1MACH(4) WDTOL = MAX(WDTOL,0.5D-18) I1M = I1MACH(14) RLN = D1MACH(5)*I1M FLN = MIN(RLN,20.0D0) FLN = MAX(FLN,3.0D0) FLN = FLN - 3.0D0 ZM = 1.8000D0 + 0.3875D0*FLN MZ = ZM + 1 ZMIN = MZ ZDMY = Z ZINC = 0.0D0 if (Z >= ZMIN) go to 20 ZINC = ZMIN - NZ ZDMY = Z + ZINC 20 CONTINUE ZP = 1.0D0/ZDMY T1 = CF(1)*ZP S = T1 if (ZP < WDTOL) go to 40 ZSQ = ZP*ZP TST = T1*WDTOL DO 30 K=2,22 ZP = ZP*ZSQ TRM = CF(K)*ZP if (ABS(TRM) < TST) go to 40 S = S + TRM 30 CONTINUE 40 CONTINUE if (ZINC /= 0.0D0) go to 50 TLG = LOG(Z) DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S return 50 CONTINUE ZP = 1.0D0 NZ = ZINC DO 60 I=1,NZ ZP = ZP*(Z+(I-1)) 60 CONTINUE TLG = LOG(ZDMY) DGAMLN = ZDMY*(TLG-1.0D0) - LOG(ZP) + 0.5D0*(CON-TLG) + S return ! ! 70 CONTINUE DGAMLN = D1MACH(2) IERR=1 return end DOUBLE PRECISION FUNCTION DGAMMA (X) ! !! DGAMMA computes the complete Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) !***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DGAMMA(X) calculates the double precision complete Gamma function ! for double precision argument X. ! ! Series for GAM on the interval 0. to 1.00000E+00 ! with weighted error 5.79E-32 ! log weighted error 31.24 ! significant figures required 30.00 ! decimal places required 32.05 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920618 Removed space from variable name. (RWC, WRB) !***END PROLOGUE DGAMMA DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX, & XMIN, Y, D9LGMC, DCSEVL, D1MACH LOGICAL FIRST ! SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST DATA GAMCS( 1) / +.8571195590989331421920062399942D-2 / DATA GAMCS( 2) / +.4415381324841006757191315771652D-2 / DATA GAMCS( 3) / +.5685043681599363378632664588789D-1 / DATA GAMCS( 4) / -.4219835396418560501012500186624D-2 / DATA GAMCS( 5) / +.1326808181212460220584006796352D-2 / DATA GAMCS( 6) / -.1893024529798880432523947023886D-3 / DATA GAMCS( 7) / +.3606925327441245256578082217225D-4 / DATA GAMCS( 8) / -.6056761904460864218485548290365D-5 / DATA GAMCS( 9) / +.1055829546302283344731823509093D-5 / DATA GAMCS( 10) / -.1811967365542384048291855891166D-6 / DATA GAMCS( 11) / +.3117724964715322277790254593169D-7 / DATA GAMCS( 12) / -.5354219639019687140874081024347D-8 / DATA GAMCS( 13) / +.9193275519859588946887786825940D-9 / DATA GAMCS( 14) / -.1577941280288339761767423273953D-9 / DATA GAMCS( 15) / +.2707980622934954543266540433089D-10 / DATA GAMCS( 16) / -.4646818653825730144081661058933D-11 / DATA GAMCS( 17) / +.7973350192007419656460767175359D-12 / DATA GAMCS( 18) / -.1368078209830916025799499172309D-12 / DATA GAMCS( 19) / +.2347319486563800657233471771688D-13 / DATA GAMCS( 20) / -.4027432614949066932766570534699D-14 / DATA GAMCS( 21) / +.6910051747372100912138336975257D-15 / DATA GAMCS( 22) / -.1185584500221992907052387126192D-15 / DATA GAMCS( 23) / +.2034148542496373955201026051932D-16 / DATA GAMCS( 24) / -.3490054341717405849274012949108D-17 / DATA GAMCS( 25) / +.5987993856485305567135051066026D-18 / DATA GAMCS( 26) / -.1027378057872228074490069778431D-18 / DATA GAMCS( 27) / +.1762702816060529824942759660748D-19 / DATA GAMCS( 28) / -.3024320653735306260958772112042D-20 / DATA GAMCS( 29) / +.5188914660218397839717833550506D-21 / DATA GAMCS( 30) / -.8902770842456576692449251601066D-22 / DATA GAMCS( 31) / +.1527474068493342602274596891306D-22 / DATA GAMCS( 32) / -.2620731256187362900257328332799D-23 / DATA GAMCS( 33) / +.4496464047830538670331046570666D-24 / DATA GAMCS( 34) / -.7714712731336877911703901525333D-25 / DATA GAMCS( 35) / +.1323635453126044036486572714666D-25 / DATA GAMCS( 36) / -.2270999412942928816702313813333D-26 / DATA GAMCS( 37) / +.3896418998003991449320816639999D-27 / DATA GAMCS( 38) / -.6685198115125953327792127999999D-28 / DATA GAMCS( 39) / +.1146998663140024384347613866666D-28 / DATA GAMCS( 40) / -.1967938586345134677295103999999D-29 / DATA GAMCS( 41) / +.3376448816585338090334890666666D-30 / DATA GAMCS( 42) / -.5793070335782135784625493333333D-31 / DATA PI / 3.14159265358979323846264338327950D0 / DATA SQ2PIL / 0.91893853320467274178032973640562D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DGAMMA if (FIRST) THEN NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) ) ! call DGAMLM (XMIN, XMAX) DXREL = SQRT(D1MACH(4)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 10.D0) go to 50 ! ! COMPUTE GAMMA(X) FOR -XBND <= X <= XBND. REDUCE INTERVAL AND FIND ! GAMMA(1+Y) FOR 0.0 <= Y < 1.0 FIRST OF ALL. ! N = X if (X < 0.D0) N = N - 1 Y = X - N N = N - 1 DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM) if (N == 0) RETURN ! if (N > 0) go to 30 ! ! COMPUTE GAMMA(X) FOR X < 1.0 ! N = -N if (X == 0.D0) call XERMSG ('SLATEC', 'DGAMMA', 'X IS 0', 4, 2) if (X < 0.0 .AND. X+N-2 == 0.D0) call XERMSG ('SLATEC', & 'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2) if (X < (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) < DXREL) & call XERMSG ('SLATEC', 'DGAMMA', & 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', & 1, 1) ! DO 20 I=1,N DGAMMA = DGAMMA/(X+I-1 ) 20 CONTINUE return ! ! GAMMA(X) FOR X >= 2.0 AND X <= 10.0 ! 30 DO 40 I=1,N DGAMMA = (Y+I) * DGAMMA 40 CONTINUE return ! ! GAMMA(X) FOR ABS(X) > 10.0. RECALL Y = ABS(X). ! 50 if (X > XMAX) call XERMSG ('SLATEC', 'DGAMMA', & 'X SO BIG GAMMA OVERFLOWS', 3, 2) ! DGAMMA = 0.D0 if (X < XMIN) call XERMSG ('SLATEC', 'DGAMMA', & 'X SO SMALL GAMMA UNDERFLOWS', 2, 1) if (X < XMIN) RETURN ! DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) ) if (X > 0.D0) RETURN ! if (ABS((X-AINT(X-0.5D0))/X) < DXREL) call XERMSG ('SLATEC', & 'DGAMMA', & 'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1) ! SINPIY = SIN (PI*Y) if (SINPIY == 0.D0) call XERMSG ('SLATEC', 'DGAMMA', & 'X IS A NEGATIVE INTEGER', 4, 2) ! DGAMMA = -PI/(Y*SINPIY*DGAMMA) ! return end DOUBLE PRECISION FUNCTION DGAMR (X) ! !! DGAMR computes the reciprocal of the Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE DOUBLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) !***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DGAMR(X) calculates the double precision reciprocal of the ! complete Gamma function for double precision argument X. ! !***REFERENCES (NONE) !***ROUTINES CALLED DGAMMA, DLGAMS, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE DGAMR DOUBLE PRECISION X, ALNGX, SGNGX, DGAMMA EXTERNAL DGAMMA !***FIRST EXECUTABLE STATEMENT DGAMR DGAMR = 0.0D0 if (X <= 0.0D0 .AND. AINT(X) == X) RETURN ! call XGETF (IROLD) call XSETF (1) if (ABS(X) > 10.0D0) go to 10 DGAMR = 1.0D0/DGAMMA(X) call XERCLR call XSETF (IROLD) return ! 10 call DLGAMS (X, ALNGX, SGNGX) call XERCLR call XSETF (IROLD) DGAMR = SGNGX * EXP(-ALNGX) return ! end DOUBLE PRECISION FUNCTION DGAMRN (X) ! !! DGAMRN computes a Gamma function ratio. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DBSKIN !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (GAMRN-S, DGAMRN-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract * A Double Precision Routine * ! DGAMRN computes the GAMMA function ratio GAMMA(X)/GAMMA(X+0.5) ! for real X.gt.0. If X.ge.XMIN, an asymptotic expansion is ! evaluated. If X.lt.XMIN, an integer is added to X to form a ! new value of X.ge.XMIN and the asymptotic expansion is eval- ! uated for this new value of X. Successive application of the ! recurrence relation ! ! W(X)=W(X+1)*(1+0.5/X) ! ! reduces the argument to its original value. XMIN and comp- ! utational tolerances are computed as a function of the number ! of digits carried in a word by calls to I1MACH and D1MACH. ! However, the computational accuracy is limited to the max- ! imum of unit roundoff (=D1MACH(4)) and 1.0D-18 since critical ! constants are given to only 18 digits. ! ! Input X is Double Precision ! X - Argument, X.gt.0.0D0 ! ! Output DGAMRN is DOUBLE PRECISION ! DGAMRN - Ratio GAMMA(X)/GAMMA(X+0.5) ! !***SEE ALSO DBSKIN !***REFERENCES Y. L. Luke, The Special Functions and Their ! Approximations, Vol. 1, Math In Sci. And ! Eng. Series 53, Academic Press, New York, 1969, ! pp. 34-35. !***ROUTINES CALLED D1MACH, I1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920520 Added REFERENCES section. (WRB) !***END PROLOGUE DGAMRN INTEGER I, I1M11, K, MX, NX INTEGER I1MACH DOUBLE PRECISION FLN, GR, RLN, S, TOL, TRM, X, XDMY, XINC, XM, & XMIN, XP, XSQ DOUBLE PRECISION D1MACH DIMENSION GR(12) SAVE GR ! DATA GR(1), GR(2), GR(3), GR(4), GR(5), GR(6), GR(7), GR(8), & GR(9), GR(10), GR(11), GR(12) /1.00000000000000000D+00, & -1.56250000000000000D-02,2.56347656250000000D-03, & -1.27983093261718750D-03,1.34351104497909546D-03, & -2.43289663922041655D-03,6.75423753364157164D-03, & -2.66369606131178216D-02,1.41527455519564332D-01, & -9.74384543032201613D-01,8.43686251229783675D+00, & -8.97258321640552515D+01/ ! !***FIRST EXECUTABLE STATEMENT DGAMRN NX = INT(X) TOL = MAX(D1MACH(4),1.0D-18) I1M11 = I1MACH(14) RLN = D1MACH(5)*I1M11 FLN = MIN(RLN,20.0D0) FLN = MAX(FLN,3.0D0) FLN = FLN - 3.0D0 XM = 2.0D0 + FLN*(0.2366D0+0.01723D0*FLN) MX = INT(XM) + 1 XMIN = MX XDMY = X - 0.25D0 XINC = 0.0D0 if (X >= XMIN) go to 10 XINC = XMIN - NX XDMY = XDMY + XINC 10 CONTINUE S = 1.0D0 if (XDMY*TOL > 1.0D0) go to 30 XSQ = 1.0D0/(XDMY*XDMY) XP = XSQ DO 20 K=2,12 TRM = GR(K)*XP if (ABS(TRM) < TOL) go to 30 S = S + TRM XP = XP*XSQ 20 CONTINUE 30 CONTINUE S = S/SQRT(XDMY) if (XINC /= 0.0D0) go to 40 DGAMRN = S return 40 CONTINUE NX = INT(XINC) XP = 0.0D0 DO 50 I=1,NX S = S*(1.0D0+0.5D0/(X+XP)) XP = XP + 1.0D0 50 CONTINUE DGAMRN = S return end subroutine DGAUS8 (FUN, A, B, ERR, ANS, IERR) ! !! DGAUS8 integrates a real function of one variable over a finite interval ... ! using an adaptive 8-point Legendre-Gauss ! algorithm. Intended primarily for high accuracy ! integration or integration of smooth functions. ! !***LIBRARY SLATEC !***CATEGORY H2A1A1 !***TYPE DOUBLE PRECISION (GAUS8-S, DGAUS8-D) !***KEYWORDS ADAPTIVE QUADRATURE, AUTOMATIC INTEGRATOR, ! GAUSS QUADRATURE, NUMERICAL INTEGRATION !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract *** a DOUBLE PRECISION routine *** ! DGAUS8 integrates real functions of one variable over finite ! intervals using an adaptive 8-point Legendre-Gauss algorithm. ! DGAUS8 is intended primarily for high accuracy integration ! or integration of smooth functions. ! ! The maximum number of significant digits obtainable in ANS ! is the smaller of 18 and the number of digits carried in ! double precision arithmetic. ! ! Description of Arguments ! ! Input--* FUN, A, B, ERR are DOUBLE PRECISION * ! FUN - name of external function to be integrated. This name ! must be in an EXTERNAL statement in the calling program. ! FUN must be a DOUBLE PRECISION function of one DOUBLE ! PRECISION argument. The value of the argument to FUN ! is the variable of integration which ranges from A to B. ! A - lower limit of integration ! B - upper limit of integration (may be less than A) ! ERR - is a requested pseudorelative error tolerance. Normally ! pick a value of ABS(ERR) so that DTOL < ABS(ERR) <= ! 1.0D-3 where DTOL is the larger of 1.0D-18 and the ! double precision unit roundoff D1MACH(4). ANS will ! normally have no more error than ABS(ERR) times the ! integral of the absolute value of FUN(X). Usually, ! smaller values of ERR yield more accuracy and require ! more function evaluations. ! ! A negative value for ERR causes an estimate of the ! absolute error in ANS to be returned in ERR. Note that ! ERR must be a variable (not a constant) in this case. ! Note also that the user must reset the value of ERR ! before making any more calls that use the variable ERR. ! ! Output--* ERR,ANS are double precision * ! ERR - will be an estimate of the absolute error in ANS if the ! input value of ERR was negative. (ERR is unchanged if ! the input value of ERR was non-negative.) The estimated ! error is solely for information to the user and should ! not be used as a correction to the computed integral. ! ANS - computed value of integral ! IERR- a status code ! --Normal codes ! 1 ANS most likely meets requested error tolerance, ! or A=B. ! -1 A and B are too nearly equal to allow normal ! integration. ANS is set to zero. ! --Abnormal code ! 2 ANS probably does not meet requested error tolerance. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, I1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 810223 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE DGAUS8 INTEGER IERR, K, KML, KMX, L, LMN, LMX, LR, MXL, NBITS, & NIB, NLMN, NLMX INTEGER I1MACH DOUBLE PRECISION A,AA,AE,ANIB,ANS,AREA,B,C,CE,EE,EF, & EPS, ERR, EST, GL, GLR, GR, HH, SQ2, TOL, VL, VR, W1, W2, W3, & W4, X1, X2, X3, X4, X, H DOUBLE PRECISION D1MACH, G8, FUN DIMENSION AA(60), HH(60), LR(60), VL(60), GR(60) SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, & NLMN, KMX, KML DATA X1, X2, X3, X4/ & 1.83434642495649805D-01, 5.25532409916328986D-01, & 7.96666477413626740D-01, 9.60289856497536232D-01/ DATA W1, W2, W3, W4/ & 3.62683783378361983D-01, 3.13706645877887287D-01, & 2.22381034453374471D-01, 1.01228536290376259D-01/ DATA SQ2/1.41421356D0/ DATA NLMN/1/,KMX/5000/,KML/6/ G8(X,H)=H*((W1*(FUN(X-X1*H) + FUN(X+X1*H)) & +W2*(FUN(X-X2*H) + FUN(X+X2*H))) & +(W3*(FUN(X-X3*H) + FUN(X+X3*H)) & +W4*(FUN(X-X4*H) + FUN(X+X4*H)))) !***FIRST EXECUTABLE STATEMENT DGAUS8 ! ! Initialize ! K = I1MACH(14) ANIB = D1MACH(5)*K/0.30102000D0 NBITS = ANIB NLMX = MIN(60,(NBITS*5)/8) ANS = 0.0D0 IERR = 1 CE = 0.0D0 if (A == B) go to 140 LMX = NLMX LMN = NLMN if (B == 0.0D0) go to 10 if (SIGN(1.0D0,B)*A <= 0.0D0) go to 10 C = ABS(1.0D0-A/B) if (C > 0.1D0) go to 10 if (C <= 0.0D0) go to 140 ANIB = 0.5D0 - LOG(C)/0.69314718D0 NIB = ANIB LMX = MIN(NLMX,NBITS-NIB-7) if (LMX < 1) go to 130 LMN = MIN(LMN,LMX) 10 TOL = MAX(ABS(ERR),2.0D0**(5-NBITS))/2.0D0 if (ERR == 0.0D0) TOL = SQRT(D1MACH(4)) EPS = TOL HH(1) = (B-A)/4.0D0 AA(1) = A LR(1) = 1 L = 1 EST = G8(AA(L)+2.0D0*HH(L),2.0D0*HH(L)) K = 8 AREA = ABS(EST) EF = 0.5D0 MXL = 0 ! ! Compute refined estimates, estimate the error, etc. ! 20 GL = G8(AA(L)+HH(L),HH(L)) GR(L) = G8(AA(L)+3.0D0*HH(L),HH(L)) K = K + 16 AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) ! if (L .LT .LMN) go to 11 GLR = GL + GR(L) EE = ABS(EST-GLR)*EF AE = MAX(EPS*AREA,TOL*ABS(GLR)) if (EE-AE) 40, 40, 50 30 MXL = 1 40 CE = CE + (EST-GLR) if (LR(L)) 60, 60, 80 ! ! Consider the left half of this level ! 50 if (K > KMX) LMX = KML if (L >= LMX) go to 30 L = L + 1 EPS = EPS*0.5D0 EF = EF/SQ2 HH(L) = HH(L-1)*0.5D0 LR(L) = -1 AA(L) = AA(L-1) EST = GL go to 20 ! ! Proceed to right half at this level ! 60 VL(L) = GLR 70 EST = GR(L-1) LR(L) = 1 AA(L) = AA(L) + 4.0D0*HH(L) go to 20 ! ! Return one level ! 80 VR = GLR 90 if (L <= 1) go to 120 L = L - 1 EPS = EPS*2.0D0 EF = EF*SQ2 if (LR(L)) 100, 100, 110 100 VL(L) = VL(L+1) + VR go to 70 110 VR = VL(L+1) + VR go to 90 ! ! Exit ! 120 ANS = VR if ((MXL == 0) .OR. (ABS(CE) <= 2.0D0*TOL*AREA)) go to 140 IERR = 2 call XERMSG ('SLATEC', 'DGAUS8', & 'ANS is probably insufficiently accurate.', 3, 1) go to 140 130 IERR = -1 call XERMSG ('SLATEC', 'DGAUS8', & 'A and B are too nearly equal to allow normal integration. $$' & // 'ANS is set to zero and IERR to -1.', 1, -1) 140 if (ERR < 0.0D0) ERR = CE return end subroutine DGBCO (ABD, LDA, N, ML, MU, IPVT, RCOND, Z) ! !! DGBCO factors a band matrix by Gaussian elimination and estimates ... ! the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A2 !***TYPE DOUBLE PRECISION (SGBCO-S, DGBCO-D, CGBCO-C) !***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DGBCO factors a double precision band matrix by Gaussian ! elimination and estimates the condition of the matrix. ! ! If RCOND is not needed, DGBFA is slightly faster. ! To solve A*X = B , follow DGBCO by DGBSL. ! To compute INVERSE(A)*C , follow DGBCO by DGBSL. ! To compute DETERMINANT(A) , follow DGBCO by DGBDI. ! ! On Entry ! ! ABD DOUBLE PRECISION(LDA, N) ! contains the matrix in band storage. The columns ! of the matrix are stored in the columns of ABD and ! the diagonals of the matrix are stored in rows ! ML+1 through 2*ML+MU+1 of ABD . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= 2*ML + MU + 1 . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! ! On Return ! ! ABD an upper triangular matrix in band storage and ! the multipliers which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND DOUBLE PRECISION ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z DOUBLE PRECISION(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! M = ML + MU + 1 ! DO 20 J = 1, N ! I1 = MAX(1, J-MU) ! I2 = MIN(N, J+ML) ! DO 10 I = I1, I2 ! K = I - J + M ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses rows ML+1 through 2*ML+MU+1 of ABD . ! In addition, the first ML rows in ABD are used for ! elements generated during the triangularization. ! The total number of rows needed in ABD is 2*ML+MU+1 . ! The ML+MU by ML+MU upper left triangle and the ! ML by ML lower right triangle are not referenced. ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABD should contain ! ! * * * + + + , * = not used ! * * 13243546 , + = used for pivoting ! * 1223344556 ! 112233445566 ! 2132435465 * ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DASUM, DAXPY, DDOT, DGBFA, DSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGBCO INTEGER LDA,N,ML,MU,IPVT(*) DOUBLE PRECISION ABD(LDA,*),Z(*) DOUBLE PRECISION RCOND ! DOUBLE PRECISION DDOT,EK,T,WK,WKM DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM INTEGER IS,INFO,J,JU,K,KB,KP1,L,LA,LM,LZ,M,MM ! ! COMPUTE 1-NORM OF A ! !***FIRST EXECUTABLE STATEMENT DGBCO ANORM = 0.0D0 L = ML + 1 IS = L + MU DO 10 J = 1, N ANORM = MAX(ANORM,DASUM(L,ABD(IS,J),1)) if (IS > ML + 1) IS = IS - 1 if (J <= MU) L = L + 1 if (J >= N - ML) L = L - 1 10 CONTINUE ! ! FACTOR ! call DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . ! TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE ! CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE ! TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID ! OVERFLOW. ! ! SOLVE TRANS(U)*W = E ! EK = 1.0D0 DO 20 J = 1, N Z(J) = 0.0D0 20 CONTINUE M = ML + MU + 1 JU = 0 DO 100 K = 1, N if (Z(K) /= 0.0D0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= ABS(ABD(M,K))) go to 30 S = ABS(ABD(M,K))/ABS(EK-Z(K)) call DSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) if (ABD(M,K) == 0.0D0) go to 40 WK = WK/ABD(M,K) WKM = WKM/ABD(M,K) go to 50 40 CONTINUE WK = 1.0D0 WKM = 1.0D0 50 CONTINUE KP1 = K + 1 JU = MIN(MAX(JU,MU+IPVT(K)),N) MM = M if (KP1 > JU) go to 90 DO 60 J = KP1, JU MM = MM - 1 SM = SM + ABS(Z(J)+WKM*ABD(MM,J)) Z(J) = Z(J) + WK*ABD(MM,J) S = S + ABS(Z(J)) 60 CONTINUE if (S >= SM) go to 80 T = WKM - WK WK = WKM MM = M DO 70 J = KP1, JU MM = MM - 1 Z(J) = Z(J) + T*ABD(MM,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) ! ! SOLVE TRANS(L)*Y = W ! DO 120 KB = 1, N K = N + 1 - KB LM = MIN(ML,N-K) if (K < N) Z(K) = Z(K) + DDOT(LM,ABD(M+1,K),1,Z(K+1),1) if (ABS(Z(K)) <= 1.0D0) go to 110 S = 1.0D0/ABS(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) ! YNORM = 1.0D0 ! ! SOLVE L*V = Y ! DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T LM = MIN(ML,N-K) if (K < N) call DAXPY(LM,T,ABD(M+1,K),1,Z(K+1),1) if (ABS(Z(K)) <= 1.0D0) go to 130 S = 1.0D0/ABS(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 ! ! SOLVE U*Z = W ! DO 160 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= ABS(ABD(M,K))) go to 150 S = ABS(ABD(M,K))/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE if (ABD(M,K) /= 0.0D0) Z(K) = Z(K)/ABD(M,K) if (ABD(M,K) == 0.0D0) Z(K) = 1.0D0 LM = MIN(K,M) - 1 LA = M - LM LZ = K - LM T = -Z(K) call DAXPY(LM,T,ABD(LA,K),1,Z(LZ),1) 160 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0D0) RCOND = YNORM/ANORM if (ANORM == 0.0D0) RCOND = 0.0D0 return end subroutine DGBDI (ABD, LDA, N, ML, MU, IPVT, DET) ! !! DGBDI computes the determinant of a band matrix using the factors ... ! computed by DGBCO or DGBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D3A2 !***TYPE DOUBLE PRECISION (SGBDI-S, DGBDI-D, CGBDI-C) !***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, ! MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DGBDI computes the determinant of a band matrix ! using the factors computed by DGBCO or DGBFA. ! If the inverse is needed, use DGBSL N times. ! ! On Entry ! ! ABD DOUBLE PRECISION(LDA, N) ! the output from DGBCO or DGBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from DGBCO or DGBFA. ! ! On Return ! ! DET DOUBLE PRECISION(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGBDI INTEGER LDA,N,ML,MU,IPVT(*) DOUBLE PRECISION ABD(LDA,*),DET(2) ! DOUBLE PRECISION TEN INTEGER I,M !***FIRST EXECUTABLE STATEMENT DGBDI M = ML + MU + 1 DET(1) = 1.0D0 DET(2) = 0.0D0 TEN = 10.0D0 DO 50 I = 1, N if (IPVT(I) /= I) DET(1) = -DET(1) DET(1) = ABD(M,I)*DET(1) if (DET(1) == 0.0D0) go to 60 10 if (ABS(DET(1)) >= 1.0D0) go to 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 go to 10 20 CONTINUE 30 if (ABS(DET(1)) < TEN) go to 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0D0 go to 30 40 CONTINUE 50 CONTINUE 60 CONTINUE return end subroutine DGBFA (ABD, LDA, N, ML, MU, IPVT, INFO) ! !! DGBFA factors a band matrix using Gaussian elimination. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A2 !***TYPE DOUBLE PRECISION (SGBFA-S, DGBFA-D, CGBFA-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DGBFA factors a double precision band matrix by elimination. ! ! DGBFA is usually called by DGBCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! ! On Entry ! ! ABD DOUBLE PRECISION(LDA, N) ! contains the matrix in band storage. The columns ! of the matrix are stored in the columns of ABD and ! the diagonals of the matrix are stored in rows ! ML+1 through 2*ML+MU+1 of ABD . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= 2*ML + MU + 1 . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! On Return ! ! ABD an upper triangular matrix in band storage and ! the multipliers which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if U(K,K) == 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that DGBSL will divide by zero if ! called. Use RCOND in DGBCO for a reliable ! indication of singularity. ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! M = ML + MU + 1 ! DO 20 J = 1, N ! I1 = MAX(1, J-MU) ! I2 = MIN(N, J+ML) ! DO 10 I = I1, I2 ! K = I - J + M ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses rows ML+1 through 2*ML+MU+1 of ABD . ! In addition, the first ML rows in ABD are used for ! elements generated during the triangularization. ! The total number of rows needed in ABD is 2*ML+MU+1 . ! The ML+MU by ML+MU upper left triangle and the ! ML by ML lower right triangle are not referenced. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DSCAL, IDAMAX !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGBFA INTEGER LDA,N,ML,MU,IPVT(*),INFO DOUBLE PRECISION ABD(LDA,*) ! DOUBLE PRECISION T INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 ! !***FIRST EXECUTABLE STATEMENT DGBFA M = ML + MU + 1 INFO = 0 ! ! ZERO INITIAL FILL-IN COLUMNS ! J0 = MU + 2 J1 = MIN(N,M) - 1 if (J1 < J0) go to 30 DO 20 JZ = J0, J1 I0 = M + 1 - JZ DO 10 I = I0, ML ABD(I,JZ) = 0.0D0 10 CONTINUE 20 CONTINUE 30 CONTINUE JZ = J1 JU = 0 ! ! GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING ! NM1 = N - 1 if (NM1 < 1) go to 130 DO 120 K = 1, NM1 KP1 = K + 1 ! ! ZERO NEXT FILL-IN COLUMN ! JZ = JZ + 1 if (JZ > N) go to 50 if (ML < 1) go to 50 DO 40 I = 1, ML ABD(I,JZ) = 0.0D0 40 CONTINUE 50 CONTINUE ! ! FIND L = PIVOT INDEX ! LM = MIN(ML,N-K) L = IDAMAX(LM+1,ABD(M,K),1) + M - 1 IPVT(K) = L + K - M ! ! ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED ! if (ABD(L,K) == 0.0D0) go to 100 ! ! INTERCHANGE if NECESSARY ! if (L == M) go to 60 T = ABD(L,K) ABD(L,K) = ABD(M,K) ABD(M,K) = T 60 CONTINUE ! ! COMPUTE MULTIPLIERS ! T = -1.0D0/ABD(M,K) call DSCAL(LM,T,ABD(M+1,K),1) ! ! ROW ELIMINATION WITH COLUMN INDEXING ! JU = MIN(MAX(JU,MU+IPVT(K)),N) MM = M if (JU < KP1) go to 90 DO 80 J = KP1, JU L = L - 1 MM = MM - 1 T = ABD(L,J) if (L == MM) go to 70 ABD(L,J) = ABD(MM,J) ABD(MM,J) = T 70 CONTINUE call DAXPY(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) == 0.0D0) INFO = N return end subroutine DGBMV (TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, & BETA, Y, INCY) ! !! DGBMV performs y = alpha*A*x+beta*y or y = alpha*A'*x+beta*y. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (SGBMV-S, DGBMV-D, CGBMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DGBMV performs one of the matrix-vector operations ! ! y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, ! ! where alpha and beta are scalars, x and y are vectors and A is an ! m by n band matrix, with kl sub-diagonals and ku super-diagonals. ! ! Parameters ! ========== ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' y := alpha*A*x + beta*y. ! ! TRANS = 'T' or 't' y := alpha*A'*x + beta*y. ! ! TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix A. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! KL - INTEGER. ! On entry, KL specifies the number of sub-diagonals of the ! matrix A. KL must satisfy 0 .le. KL. ! Unchanged on exit. ! ! KU - INTEGER. ! On entry, KU specifies the number of super-diagonals of the ! matrix A. KU must satisfy 0 .le. KU. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). ! Before entry, the leading ( kl + ku + 1 ) by n part of the ! array A must contain the matrix of coefficients, supplied ! column by column, with the leading diagonal of the matrix in ! row ( ku + 1 ) of the array, the first super-diagonal ! starting at position 2 in row ku, the first sub-diagonal ! starting at position 1 in row ( ku + 2 ), and so on. ! Elements in the array A that do not correspond to elements ! in the band matrix (such as the top left ku by ku triangle) ! are not referenced. ! The following program segment will transfer a band matrix ! from conventional full matrix storage to band storage: ! ! DO 20, J = 1, N ! K = KU + 1 - J ! DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) ! A( K + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( kl + ku + 1 ). ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. ! Before entry, the incremented array X must contain the ! vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - DOUBLE PRECISION. ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - DOUBLE PRECISION array of DIMENSION at least ! ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. ! Before entry, the incremented array Y must contain the ! vector y. On exit, Y is overwritten by the updated vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DGBMV ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, KL, KU, LDA, M, N CHARACTER*1 TRANS ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, & LENX, LENY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX, MIN !***FIRST EXECUTABLE STATEMENT DGBMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE if ( M < 0 )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( KL < 0 )THEN INFO = 4 ELSE if ( KU < 0 )THEN INFO = 5 ELSE if ( LDA < ( KL + KU + 1 ) )THEN INFO = 8 ELSE if ( INCX == 0 )THEN INFO = 10 ELSE if ( INCY == 0 )THEN INFO = 13 end if if ( INFO /= 0 )THEN call XERBLA( 'DGBMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if ( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N end if if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the band part of A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return KUP1 = KU + 1 if ( LSAME( TRANS, 'N' ) )THEN ! ! Form y := alpha*A*x + y. ! JX = KX if ( INCY == 1 )THEN DO 60, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) K = KUP1 - J DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) Y( I ) = Y( I ) + TEMP*A( K + I, J ) 50 CONTINUE end if JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY K = KUP1 - J DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) IY = IY + INCY 70 CONTINUE end if JX = JX + INCX if ( J > KU ) & KY = KY + INCY 80 CONTINUE end if ELSE ! ! Form y := alpha*A'*x + y. ! JY = KY if ( INCX == 1 )THEN DO 100, J = 1, N TEMP = ZERO K = KUP1 - J DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + A( K + I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX K = KUP1 - J DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + A( K + I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY if ( J > KU ) & KX = KX + INCX 120 CONTINUE end if end if ! return ! ! End of DGBMV . ! end subroutine DGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB) ! !! DGBSL solves the real band system A*X=B or TRANS(A)*X=B using ... ! the factors computed by DGBCO or DGBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A2 !***TYPE DOUBLE PRECISION (SGBSL-S, DGBSL-D, CGBSL-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DGBSL solves the double precision band system ! A * X = B or TRANS(A) * X = B ! using the factors computed by DGBCO or DGBFA. ! ! On Entry ! ! ABD DOUBLE PRECISION(LDA, N) ! the output from DGBCO or DGBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from DGBCO or DGBFA. ! ! B DOUBLE PRECISION(N) ! the right hand side vector. ! ! JOB INTEGER ! = 0 to solve A*X = B , ! = nonzero to solve TRANS(A)*X = B , where ! TRANS(A) is the transpose. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically this indicates singularity ! but it is often caused by improper arguments or improper ! setting of LDA . It will not occur if the subroutines are ! called correctly and if DGBCO has set RCOND > 0.0 ! or DGBFA has set INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) ! if (RCOND is too small) go to ... ! DO 10 J = 1, P ! call DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGBSL INTEGER LDA,N,ML,MU,IPVT(*),JOB DOUBLE PRECISION ABD(LDA,*),B(*) ! DOUBLE PRECISION DDOT,T INTEGER K,KB,L,LA,LB,LM,M,NM1 !***FIRST EXECUTABLE STATEMENT DGBSL M = MU + ML + 1 NM1 = N - 1 if (JOB /= 0) go to 50 ! ! JOB = 0 , SOLVE A * X = B ! FIRST SOLVE L*Y = B ! if (ML == 0) go to 30 if (NM1 < 1) go to 30 DO 20 K = 1, NM1 LM = MIN(ML,N-K) L = IPVT(K) T = B(L) if (L == K) go to 10 B(L) = B(K) B(K) = T 10 CONTINUE call DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE ! ! NOW SOLVE U*X = Y ! DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/ABD(M,K) LM = MIN(K,M) - 1 LA = M - LM LB = K - LM T = -B(K) call DAXPY(LM,T,ABD(LA,K),1,B(LB),1) 40 CONTINUE go to 100 50 CONTINUE ! ! JOB = NONZERO, SOLVE TRANS(A) * X = B ! FIRST SOLVE TRANS(U)*Y = B ! DO 60 K = 1, N LM = MIN(K,M) - 1 LA = M - LM LB = K - LM T = DDOT(LM,ABD(LA,K),1,B(LB),1) B(K) = (B(K) - T)/ABD(M,K) 60 CONTINUE ! ! NOW SOLVE TRANS(L)*X = Y ! if (ML == 0) go to 90 if (NM1 < 1) go to 90 DO 80 KB = 1, NM1 K = N - KB LM = MIN(ML,N-K) B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1) L = IPVT(K) if (L == 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 DGECO (A, LDA, N, IPVT, RCOND, Z) ! !! DGECO factors a matrix using Gaussian elimination and estimate ... ! the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A1 !***TYPE DOUBLE PRECISION (SGECO-S, DGECO-D, CGECO-C) !***KEYWORDS CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DGECO factors a double precision matrix by Gaussian elimination ! and estimates the condition of the matrix. ! ! If RCOND is not needed, DGEFA is slightly faster. ! To solve A*X = B , follow DGECO by DGESL. ! To compute INVERSE(A)*C , follow DGECO by DGESL. ! To compute DETERMINANT(A) , follow DGECO by DGEDI. ! To compute INVERSE(A) , follow DGECO by DGEDI. ! ! On Entry ! ! A DOUBLE PRECISION(LDA, N) ! the matrix to be factored. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix and the multipliers ! which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an INTEGER vector of pivot indices. ! ! RCOND DOUBLE PRECISION ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z DOUBLE PRECISION(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DASUM, DAXPY, DDOT, DGEFA, DSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGECO INTEGER LDA,N,IPVT(*) DOUBLE PRECISION A(LDA,*),Z(*) DOUBLE PRECISION RCOND ! DOUBLE PRECISION DDOT,EK,T,WK,WKM DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM INTEGER INFO,J,K,KB,KP1,L ! ! COMPUTE 1-NORM OF A ! !***FIRST EXECUTABLE STATEMENT DGECO ANORM = 0.0D0 DO 10 J = 1, N ANORM = MAX(ANORM,DASUM(N,A(1,J),1)) 10 CONTINUE ! ! FACTOR ! call DGEFA(A,LDA,N,IPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . ! TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE ! CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE ! TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID ! OVERFLOW. ! ! SOLVE TRANS(U)*W = E ! EK = 1.0D0 DO 20 J = 1, N Z(J) = 0.0D0 20 CONTINUE DO 100 K = 1, N if (Z(K) /= 0.0D0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= ABS(A(K,K))) go to 30 S = ABS(A(K,K))/ABS(EK-Z(K)) call DSCAL(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) == 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 > 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 >= 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) ! ! SOLVE TRANS(L)*Y = W ! DO 120 KB = 1, N K = N + 1 - KB if (K < N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) if (ABS(Z(K)) <= 1.0D0) go to 110 S = 1.0D0/ABS(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) ! YNORM = 1.0D0 ! ! SOLVE L*V = Y ! DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T if (K < N) call DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) if (ABS(Z(K)) <= 1.0D0) go to 130 S = 1.0D0/ABS(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 ! ! SOLVE U*Z = V ! DO 160 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= ABS(A(K,K))) go to 150 S = ABS(A(K,K))/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE if (A(K,K) /= 0.0D0) Z(K) = Z(K)/A(K,K) if (A(K,K) == 0.0D0) Z(K) = 1.0D0 T = -Z(K) call DAXPY(K-1,T,A(1,K),1,Z(1),1) 160 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0D0) RCOND = YNORM/ANORM if (ANORM == 0.0D0) RCOND = 0.0D0 return end subroutine DGEDI (A, LDA, N, IPVT, DET, WORK, JOB) ! !! DGEDI computes the determinant and inverse of a matrix using the ... ! factors computed by DGECO or DGEFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D3A1, D2A1 !***TYPE DOUBLE PRECISION (SGEDI-S, DGEDI-D, CGEDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DGEDI computes the determinant and inverse of a matrix ! using the factors computed by DGECO or DGEFA. ! ! On Entry ! ! A DOUBLE PRECISION(LDA, N) ! the output from DGECO or DGEFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! IPVT INTEGER(N) ! the pivot vector from DGECO or DGEFA. ! ! WORK DOUBLE PRECISION(N) ! work vector. Contents destroyed. ! ! JOB INTEGER ! = 11 both determinant and inverse. ! = 01 inverse only. ! = 10 determinant only. ! ! On Return ! ! A inverse of original matrix if requested. ! Otherwise unchanged. ! ! DET DOUBLE PRECISION(2) ! determinant of original matrix if requested. ! Otherwise not referenced. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) == 0.0 . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal and the inverse is requested. ! It will not occur if the subroutines are called correctly ! and if DGECO has set RCOND > 0.0 or DGEFA has set ! INFO == 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DSCAL, DSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGEDI INTEGER LDA,N,IPVT(*),JOB DOUBLE PRECISION A(LDA,*),DET(2),WORK(*) ! DOUBLE PRECISION T DOUBLE PRECISION TEN INTEGER I,J,K,KB,KP1,L,NM1 !***FIRST EXECUTABLE STATEMENT DGEDI ! ! COMPUTE DETERMINANT ! if (JOB/10 == 0) go to 70 DET(1) = 1.0D0 DET(2) = 0.0D0 TEN = 10.0D0 DO 50 I = 1, N if (IPVT(I) /= I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) if (DET(1) == 0.0D0) go to 60 10 if (ABS(DET(1)) >= 1.0D0) go to 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 go to 10 20 CONTINUE 30 if (ABS(DET(1)) < 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 ! ! COMPUTE INVERSE(U) ! if (MOD(JOB,10) == 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 < 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 ! ! FORM INVERSE(U)*INVERSE(L) ! NM1 = N - 1 if (NM1 < 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 /= K) call DSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE return end subroutine DGEFA (A, LDA, N, IPVT, INFO) ! !! DGEFA factors a matrix using Gaussian elimination. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A1 !***TYPE DOUBLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C) !***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DGEFA factors a double precision matrix by Gaussian elimination. ! ! DGEFA is usually called by DGECO, but it can be called ! directly with a saving in time if RCOND is not needed. ! (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . ! ! On Entry ! ! A DOUBLE PRECISION(LDA, N) ! the matrix to be factored. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix and the multipliers ! which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if U(K,K) == 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that DGESL or DGEDI will divide by zero ! if called. Use RCOND in DGECO for a reliable ! indication of singularity. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DSCAL, IDAMAX !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGEFA INTEGER LDA,N,IPVT(*),INFO DOUBLE PRECISION A(LDA,*) ! DOUBLE PRECISION T INTEGER IDAMAX,J,K,KP1,L,NM1 ! ! GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING ! !***FIRST EXECUTABLE STATEMENT DGEFA INFO = 0 NM1 = N - 1 if (NM1 < 1) go to 70 DO 60 K = 1, NM1 KP1 = K + 1 ! ! FIND L = PIVOT INDEX ! L = IDAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L ! ! ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED ! if (A(L,K) == 0.0D0) go to 40 ! ! INTERCHANGE if NECESSARY ! if (L == K) go to 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE ! ! COMPUTE MULTIPLIERS ! T = -1.0D0/A(K,K) call DSCAL(N-K,T,A(K+1,K),1) ! ! ROW ELIMINATION WITH COLUMN INDEXING ! DO 30 J = KP1, N T = A(L,J) if (L == 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) == 0.0D0) INFO = N return end subroutine DGEFS (A, LDA, N, V, ITASK, IND, WORK, IWORK) ! !! DGEFS solves a general system of linear equations. ! !***LIBRARY SLATEC !***CATEGORY D2A1 !***TYPE DOUBLE PRECISION (SGEFS-S, DGEFS-D, CGEFS-C) !***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, ! GENERAL SYSTEM OF LINEAR EQUATIONS !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine DGEFS solves a general NxN system of double ! precision linear equations using LINPACK subroutines DGECO ! and DGESL. That is, if A is an NxN double precision matrix ! and if X and B are double precision N-vectors, then DGEFS ! solves the equation ! ! A*X=B. ! ! The matrix A is first factored into upper and lower tri- ! angular matrices U and L using partial pivoting. These ! factors and the pivoting information are used to find the ! solution vector X. An approximate condition number is ! calculated to provide a rough estimate of the number of ! digits of accuracy in the computed solution. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N and IWORK must not have been altered by the user follow- ! ing factorization (ITASK=1). IND will not be changed by DGEFS ! in this case. ! ! Argument Description *** ! ! A DOUBLE PRECISION(LDA,N) ! on entry, the doubly subscripted array with dimension ! (LDA,N) which contains the coefficient matrix. ! on return, an upper triangular matrix U and the ! multipliers necessary to construct a matrix L ! so that A=L*U. ! LDA INTEGER ! the leading dimension of the array A. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. The first N elements of ! the array A are the elements of the first column of ! the matrix A. N must be greater than or equal to 1. ! (terminal error message IND=-2) ! V DOUBLE PRECISION(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! If ITASK=1, the matrix A is factored and then the ! linear equation is solved. ! If ITASK > 1, the equation is solved using the existing ! factored matrix A and IWORK. ! If ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. ! LT. 0 see error message corresponding to IND below. ! WORK DOUBLE PRECISION(N) ! a singly subscripted array of dimension at least N. ! IWORK INTEGER(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than 1. ! IND=-3 terminal ITASK is less than 1. ! IND=-4 terminal The matrix A is computationally singular. ! A solution has not been computed. ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! Note- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED D1MACH, DGECO, DGESL, XERMSG !***REVISION HISTORY (YYMMDD) ! 800326 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGEFS ! INTEGER LDA,N,ITASK,IND,IWORK(*) DOUBLE PRECISION A(LDA,*),V(*),WORK(*),D1MACH DOUBLE PRECISION RCOND CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT DGEFS if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'DGEFS', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'DGEFS', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'DGEFS', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ITASK == 1) THEN ! ! FACTOR MATRIX A INTO LU ! call DGECO(A,LDA,N,IWORK,RCOND,WORK) ! ! CHECK FOR COMPUTATIONALLY SINGULAR MATRIX ! if (RCOND == 0.0D0) THEN IND = -4 call XERMSG ('SLATEC', 'DGEFS', & 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) return ENDIF ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(D1MACH(4)/RCOND) if (IND <= 0) THEN IND=-10 call XERMSG ('SLATEC', 'DGEFS', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) ENDIF end if ! ! SOLVE AFTER FACTORING ! call DGESL(A,LDA,N,IWORK,V,0) return end subroutine DGEMM (TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, & BETA, C, LDC) ! !! DGEMM performs the operation C = alpha op(A) op(B) + beta * C. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE DOUBLE PRECISION (SGEMM-S, DGEMM-D, CGEMM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! DGEMM performs one of the matrix-matrix operations ! ! C := alpha*op( A )*op( B ) + beta*C, ! ! where op( X ) is one of ! ! op( X ) = X or op( X ) = X', ! ! alpha and beta are scalars, and A, B and C are matrices, with op( A ) ! an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. ! ! Parameters ! ========== ! ! TRANSA - CHARACTER*1. ! On entry, TRANSA specifies the form of op( A ) to be used in ! the matrix multiplication as follows: ! ! TRANSA = 'N' or 'n', op( A ) = A. ! ! TRANSA = 'T' or 't', op( A ) = A'. ! ! TRANSA = 'C' or 'c', op( A ) = A'. ! ! Unchanged on exit. ! ! TRANSB - CHARACTER*1. ! On entry, TRANSB specifies the form of op( B ) to be used in ! the matrix multiplication as follows: ! ! TRANSB = 'N' or 'n', op( B ) = B. ! ! TRANSB = 'T' or 't', op( B ) = B'. ! ! TRANSB = 'C' or 'c', op( B ) = B'. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix ! op( A ) and of the matrix C. M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix ! op( B ) and the number of columns of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry, K specifies the number of columns of the matrix ! op( A ) and the number of rows of the matrix op( B ). K must ! be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is ! k when TRANSA = 'N' or 'n', and is m otherwise. ! Before entry with TRANSA = 'N' or 'n', the leading m by k ! part of the array A must contain the matrix A, otherwise ! the leading k by m part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANSA = 'N' or 'n' then ! LDA must be at least max( 1, m ), otherwise LDA must be at ! least max( 1, k ). ! Unchanged on exit. ! ! B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is ! n when TRANSB = 'N' or 'n', and is k otherwise. ! Before entry with TRANSB = 'N' or 'n', the leading k by n ! part of the array B must contain the matrix B, otherwise ! the leading n by k part of the array B must contain the ! matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. When TRANSB = 'N' or 'n' then ! LDB must be at least max( 1, k ), otherwise LDB must be at ! least max( 1, n ). ! Unchanged on exit. ! ! BETA - DOUBLE PRECISION. ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then C need not be set on input. ! Unchanged on exit. ! ! C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). ! Before entry, the leading m by n part of the array C must ! contain the matrix C, except when beta is zero, in which ! case C need not be set on entry. ! On exit, the array C is overwritten by the m by n matrix ! ( alpha*op( A )*op( B ) + beta*C ). ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DGEMM ! .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB DOUBLE PRECISION TEMP ! .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) !***FIRST EXECUTABLE STATEMENT DGEMM ! ! Set NOTA and NOTB as true if A and B respectively are not ! transposed and set NROWA, NCOLA and NROWB as the number of rows ! and columns of A and the number of rows of B respectively. ! NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) if ( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M end if if ( NOTB )THEN NROWB = K ELSE NROWB = N end if ! ! Test the input parameters. ! INFO = 0 if ( ( .NOT.NOTA ).AND. & ( .NOT.LSAME( TRANSA, 'C' ) ).AND. & ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.NOTB ).AND. & ( .NOT.LSAME( TRANSB, 'C' ) ).AND. & ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE if ( M < 0 )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( K < 0 )THEN INFO = 5 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 8 ELSE if ( LDB < MAX( 1, NROWB ) )THEN INFO = 10 ELSE if ( LDC < MAX( 1, M ) )THEN INFO = 13 end if if ( INFO /= 0 )THEN call XERBLA( 'DGEMM ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And if alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if return end if ! ! Start the operations. ! if ( NOTB )THEN if ( NOTA )THEN ! ! Form C := alpha*A*B + beta*C. ! DO 90, J = 1, N if ( BETA == ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE if ( BETA /= ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE end if DO 80, L = 1, K if ( B( L, J ) /= ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE end if 80 CONTINUE 90 CONTINUE ELSE ! ! Form C := alpha*A'*B + beta*C ! DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 100 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 110 CONTINUE 120 CONTINUE end if ELSE if ( NOTA )THEN ! ! Form C := alpha*A*B' + beta*C ! DO 170, J = 1, N if ( BETA == ZERO )THEN DO 130, I = 1, M C( I, J ) = ZERO 130 CONTINUE ELSE if ( BETA /= ONE )THEN DO 140, I = 1, M C( I, J ) = BETA*C( I, J ) 140 CONTINUE end if DO 160, L = 1, K if ( B( J, L ) /= ZERO )THEN TEMP = ALPHA*B( J, L ) DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 150 CONTINUE end if 160 CONTINUE 170 CONTINUE ELSE ! ! Form C := alpha*A'*B' + beta*C ! DO 200, J = 1, N DO 190, I = 1, M TEMP = ZERO DO 180, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 180 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 190 CONTINUE 200 CONTINUE end if end if ! return ! ! End of DGEMM . ! end subroutine DGEMV (TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, & INCY) ! !! DGEMV performs y = alpha*A*x+beta*y or y = alpha*A'*x+beta*y. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (SGEMV-S, DGEMV-D, CGEMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DGEMV performs one of the matrix-vector operations ! ! y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, ! ! where alpha and beta are scalars, x and y are vectors and A is an ! m by n matrix. ! ! Parameters ! ========== ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' y := alpha*A*x + beta*y. ! ! TRANS = 'T' or 't' y := alpha*A'*x + beta*y. ! ! TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix A. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). ! Before entry, the leading m by n part of the array A must ! contain the matrix of coefficients. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, m ). ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. ! Before entry, the incremented array X must contain the ! vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - DOUBLE PRECISION. ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - DOUBLE PRECISION array of DIMENSION at least ! ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. ! Before entry with BETA non-zero, the incremented array Y ! must contain the vector y. On exit, Y is overwritten by the ! updated vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DGEMV ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT DGEMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE if ( M < 0 )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( LDA < MAX( 1, M ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 ELSE if ( INCY == 0 )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'DGEMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if ( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N end if if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return if ( LSAME( TRANS, 'N' ) )THEN ! ! Form y := alpha*A*x + y. ! JX = KX if ( INCY == 1 )THEN DO 60, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE end if JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if ELSE ! ! Form y := alpha*A'*x + y. ! JY = KY if ( INCX == 1 )THEN DO 100, J = 1, N TEMP = ZERO DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX DO 110, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 120 CONTINUE end if end if ! return ! ! End of DGEMV . ! end subroutine DGER (M, N, ALPHA, X, INCX, Y, INCY, A, LDA) ! !! DGER performs A = A + alpha*x*y'. ! !***PURPOSE Perform the rank 1 operation. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (DGER-D) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DGER performs the rank 1 operation ! ! A := alpha*x*y' + A, ! ! where alpha is a scalar, x is an m element vector, y is an n element ! vector and A is an m by n matrix. ! ! Parameters ! ========== ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix A. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( m - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the m ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! Y - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. ! Unchanged on exit. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). ! Before entry, the leading m by n part of the array A must ! contain the matrix of coefficients. On exit, A is ! overwritten by the updated matrix. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DGER ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, INCY, LDA, M, N ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JY, KX ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT DGER ! ! Test the input parameters. ! INFO = 0 if ( M < 0 )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( INCY == 0 )THEN INFO = 7 ELSE if ( LDA < MAX( 1, M ) )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'DGER ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( INCY > 0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY end if if ( INCX == 1 )THEN DO 20, J = 1, N if ( Y( JY ) /= ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE end if JY = JY + INCY 20 CONTINUE ELSE if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX end if DO 40, J = 1, N if ( Y( JY ) /= ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE end if JY = JY + INCY 40 CONTINUE end if ! return ! ! End of DGER . ! end subroutine DGESL (A, LDA, N, IPVT, B, JOB) ! !! DGESL solves the real system A*X=B or TRANS(A)*X=B using the ... ! factors computed by DGECO or DGEFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A1 !***TYPE DOUBLE PRECISION (SGESL-S, DGESL-D, CGESL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DGESL solves the double precision system ! A * X = B or TRANS(A) * X = B ! using the factors computed by DGECO or DGEFA. ! ! On Entry ! ! A DOUBLE PRECISION(LDA, N) ! the output from DGECO or DGEFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! IPVT INTEGER(N) ! the pivot vector from DGECO or DGEFA. ! ! B DOUBLE PRECISION(N) ! the right hand side vector. ! ! JOB INTEGER ! = 0 to solve A*X = B , ! = nonzero to solve TRANS(A)*X = B where ! TRANS(A) is the transpose. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically this indicates singularity ! but it is often caused by improper arguments or improper ! setting of LDA . It will not occur if the subroutines are ! called correctly and if DGECO has set RCOND > 0.0 ! or DGEFA has set INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call DGECO(A,LDA,N,IPVT,RCOND,Z) ! if (RCOND is too small) go to ... ! DO 10 J = 1, P ! call DGESL(A,LDA,N,IPVT,C(1,J),0) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGESL INTEGER LDA,N,IPVT(*),JOB DOUBLE PRECISION A(LDA,*),B(*) ! DOUBLE PRECISION DDOT,T INTEGER K,KB,L,NM1 !***FIRST EXECUTABLE STATEMENT DGESL NM1 = N - 1 if (JOB /= 0) go to 50 ! ! JOB = 0 , SOLVE A * X = B ! FIRST SOLVE L*Y = B ! if (NM1 < 1) go to 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) if (L == 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 ! ! NOW SOLVE U*X = Y ! 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 ! ! JOB = NONZERO, SOLVE TRANS(A) * X = B ! FIRST SOLVE TRANS(U)*Y = B ! 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 ! ! NOW SOLVE TRANS(L)*X = Y ! if (NM1 < 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 == 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 DGLSS (A, MDA, M, N, B, MDB, NB, RNORM, WORK, LW, & IWORK, LIW, INFO) ! !! DGLSS solves a linear least squares problems by performing a QR ... ! factorization of the input matrix using Householder ! transformations. Emphasis is put on detecting possible ! rank deficiency. ! !***LIBRARY SLATEC !***CATEGORY D9, D5 !***TYPE DOUBLE PRECISION (SGLSS-S, DGLSS-D) !***KEYWORDS LINEAR LEAST SQUARES, LQ FACTORIZATION, QR FACTORIZATION, ! UNDERDETERMINED LINEAR SYSTEMS !***AUTHOR Manteuffel, T. A., (LANL) !***DESCRIPTION ! ! DGLSS solves both underdetermined and overdetermined ! LINEAR systems AX = B, where A is an M by N matrix ! and B is an M by NB matrix of right hand sides. If ! M >= N, the least squares solution is computed by ! decomposing the matrix A into the product of an ! orthogonal matrix Q and an upper triangular matrix ! R (QR factorization). If M < N, the minimal ! length solution is computed by factoring the ! matrix A into the product of a lower triangular ! matrix L and an orthogonal matrix Q (LQ factor- ! ization). If the matrix A is determined to be rank ! deficient, that is the rank of A is less than ! MIN(M,N), then the minimal length least squares ! solution is computed. ! ! DGLSS assumes full machine precision in the data. ! If more control over the uncertainty in the data ! is desired, the codes DLLSIA and DULSIA are ! recommended. ! ! DGLSS requires MDA*N + (MDB + 1)*NB + 5*MIN(M,N) dimensioned ! real space and M+N dimensioned integer space. ! ! ! ****************************************************************** ! * * ! * WARNING - All input arrays are changed on exit. * ! * * ! ****************************************************************** ! SUBROUTINE DGLSS(A,MDA,M,N,B,MDB,NB,RNORM,WORK,LW,IWORK,LIW,INFO) ! ! Input..All TYPE REAL variables are DOUBLE PRECISION ! ! A(,) Linear coefficient matrix of AX=B, with MDA the ! MDA,M,N actual first dimension of A in the calling program. ! M is the row dimension (no. of EQUATIONS of the ! problem) and N the col dimension (no. of UNKNOWNS). ! ! B(,) Right hand side(s), with MDB the actual first ! MDB,NB dimension of B in the calling program. NB is the ! number of M by 1 right hand sides. Must have ! MDB >= MAX(M,N). If NB = 0, B is never accessed. ! ! ! RNORM() Vector of length at least NB. On input the contents ! of RNORM are unused. ! ! WORK() A real work array dimensioned 5*MIN(M,N). ! ! LW Actual dimension of WORK. ! ! IWORK() Integer work array dimensioned at least N+M. ! ! LIW Actual dimension of IWORK. ! ! ! INFO A flag which provides for the efficient ! solution of subsequent problems involving the ! same A but different B. ! If INFO = 0 original call ! INFO = 1 subsequent calls ! On subsequent calls, the user must supply A, INFO, ! LW, IWORK, LIW, and the first 2*MIN(M,N) locations ! of WORK as output by the original call to DGLSS. ! ! ! Output..All TYPE REAL variables are DOUBLE PRECISION ! ! A(,) Contains the triangular part of the reduced matrix ! and the transformation information. It together with ! the first 2*MIN(M,N) elements of WORK (see below) ! completely specify the factorization of A. ! ! B(,) Contains the N by NB solution matrix X. ! ! ! RNORM() Contains the Euclidean length of the NB residual ! vectors B(I)-AX(I), I=1,NB. ! ! WORK() The first 2*MIN(M,N) locations of WORK contain value ! necessary to reproduce the factorization of A. ! ! IWORK() The first M+N locations contain the order in ! which the rows and columns of A were used. ! If M >= N columns then rows. If M < N rows ! then columns. ! ! INFO Flag to indicate status of computation on completion ! -1 Parameter error(s) ! 0 - Full rank ! N > 0 - Reduced rank rank=MIN(M,N)-INFO ! !***REFERENCES T. Manteuffel, An interval analysis approach to rank ! determination in linear least squares problems, ! Report SAND80-0655, Sandia Laboratories, June 1980. !***ROUTINES CALLED DLLSIA, DULSIA !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGLSS IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(MDA,*),B(MDB,*),RNORM(*),WORK(*) INTEGER IWORK(*) ! !***FIRST EXECUTABLE STATEMENT DGLSS RE=0.D0 AE=0.D0 KEY=0 MODE=2 NP=0 ! ! if M >= N call DLLSIA ! if M < N call DULSIA ! if ( M < N) go to 10 call DLLSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, & KRANK,KSURE,RNORM,WORK,LW,IWORK,LIW,INFO) if ( INFO == -1) RETURN INFO=N-KRANK return 10 call DULSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, & KRANK,KSURE,RNORM,WORK,LW,IWORK,LIW,INFO) if ( INFO == -1) RETURN INFO=M-KRANK return end subroutine DGMRES (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, SB, SX, RGWK, LRGW, & IGWK, LIGW, RWORK, IWORK) ! !! DGMRES is the Preconditioned GMRES iterative sparse Ax=b solver. ! ! This routine uses the generalized minimum residual ! (GMRES) method with preconditioning to solve ! non-symmetric linear systems of the form: Ax = b. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SGMRES-S, DGMRES-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LRGW, IGWK(LIGW), LIGW ! INTEGER IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, SB(N), SX(N) ! DOUBLE PRECISION RGWK(LRGW), RWORK(USER DEFINED) ! EXTERNAL MATVEC, MSOLVE ! ! call DGMRES(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ! $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, SB, SX, ! $ RGWK, LRGW, IGWK, LIGW, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for the solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, ! for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC(N, X, Y, NELT, IA, JA, A, ISYM) ! where N is the number of unknowns, Y is the product A*X ! upon return, X is an input vector, and NELT is the number of ! non-zeros in the SLAP IA, JA, A storage for the matrix A. ! ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of the routine which solves a linear system Mz = r for ! z given r with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays. The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IWORK is an integer work array ! for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate the type of convergence criterion used. ! ITOL=0 Means the iteration stops when the test described ! below on the residual RL is satisfied. This is ! the "Natural Stopping Criteria" for this routine. ! Other values of ITOL cause extra, otherwise ! unnecessary, computation per iteration and are ! therefore much less efficient. See ISDGMR (the ! stop test routine) for more information. ! ITOL=1 Means the iteration stops when the first test ! described below on the residual RL is satisfied, ! and there is either right or no preconditioning ! being used. ! ITOL=2 Implies that the user is using left ! preconditioning, and the second stopping criterion ! below is used. ! ITOL=3 Means the iteration stops when the third test ! described below on Minv*Residual is satisfied, and ! there is either left or no preconditioning being ! used. ! ITOL=11 is often useful for checking and comparing ! different routines. For this case, the user must ! supply the "exact" solution or a very accurate ! approximation (one with an error much less than ! TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the ! difference between the iterative approximation and ! the user-supplied solution divided by the 2-norm ! of the user-supplied solution is less than TOL. ! Note that this requires the user to set up the ! "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling ! routine. The routine with this declaration should ! be loaded before the stop test so that the correct ! length is used by the loader. This procedure is ! not standard Fortran and may not work correctly on ! your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 ! then this common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described below. If TOL is set ! to zero on input, then a default value of 500*(the smallest ! positive magnitude, machine epsilon) is used. ! ITMAX :DUMMY Integer. ! Maximum number of iterations in most SLAP routines. In ! this routine this does not make sense. The maximum number ! of iterations here is given by ITMAX = MAXL*(NRMAX+1). ! See IGWK for definitions of MAXL and NRMAX. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. Letting norm() denote the Euclidean ! norm, ERR is defined as follows.. ! ! If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! for right or no preconditioning, and ! ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! for left preconditioning. ! If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! since right or no preconditioning ! being used. ! If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! since left preconditioning is being ! used. ! If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| ! i=1,n ! If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient storage allocated for ! RGWK or IGWK. ! IERR = 2 => Routine DGMRES failed to reduce the norm ! of the current residual on its last call, ! and so the iteration has stalled. In ! this case, X equals the last computed ! approximation. The user must either ! increase MAXL, or choose a different ! initial guess. ! IERR =-1 => Insufficient length for RGWK array. ! IGWK(6) contains the required minimum ! length of the RGWK array. ! IERR =-2 => Illegal value of ITOL, or ITOL and JPRE ! values are inconsistent. ! For IERR <= 2, RGWK(1) = RHOL, which is the norm on the ! left-hand-side of the relevant stopping test defined ! below associated with the residual for the current ! approximation X(L). ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! SB :IN Double Precision SB(N). ! Array of length N containing scale factors for the right ! hand side vector B. If JSCAL.eq.0 (see below), SB need ! not be supplied. ! SX :IN Double Precision SX(N). ! Array of length N containing scale factors for the solution ! vector X. If JSCAL.eq.0 (see below), SX need not be ! supplied. SB and SX can be the same array in the calling ! program if desired. ! RGWK :INOUT Double Precision RGWK(LRGW). ! Double Precision array used for workspace by DGMRES. ! On return, RGWK(1) = RHOL. See IERR for definition of RHOL. ! LRGW :IN Integer. ! Length of the double precision workspace, RGWK. ! LRGW >= 1 + N*(MAXL+6) + MAXL*(MAXL+3). ! See below for definition of MAXL. ! For the default values, RGWK has size at least 131 + 16*N. ! IGWK :INOUT Integer IGWK(LIGW). ! The following IGWK parameters should be set by the user ! before calling this routine. ! IGWK(1) = MAXL. Maximum dimension of Krylov subspace in ! which X - X0 is to be found (where, X0 is the initial ! guess). The default value of MAXL is 10. ! IGWK(2) = KMP. Maximum number of previous Krylov basis ! vectors to which each new basis vector is made orthogonal. ! The default value of KMP is MAXL. ! IGWK(3) = JSCAL. Flag indicating whether the scaling ! arrays SB and SX are to be used. ! JSCAL = 0 => SB and SX are not used and the algorithm ! will perform as if all SB(I) = 1 and SX(I) = 1. ! JSCAL = 1 => Only SX is used, and the algorithm ! performs as if all SB(I) = 1. ! JSCAL = 2 => Only SB is used, and the algorithm ! performs as if all SX(I) = 1. ! JSCAL = 3 => Both SB and SX are used. ! IGWK(4) = JPRE. Flag indicating whether preconditioning ! is being used. ! JPRE = 0 => There is no preconditioning. ! JPRE > 0 => There is preconditioning on the right ! only, and the solver will call routine MSOLVE. ! JPRE < 0 => There is preconditioning on the left ! only, and the solver will call routine MSOLVE. ! IGWK(5) = NRMAX. Maximum number of restarts of the ! Krylov iteration. The default value of NRMAX = 10. ! if IWORK(5) = -1, then no restarts are performed (in ! this case, NRMAX is set to zero internally). ! The following IWORK parameters are diagnostic information ! made available to the user after this routine completes. ! IGWK(6) = MLWK. Required minimum length of RGWK array. ! IGWK(7) = NMS. The total number of calls to MSOLVE. ! LIGW :IN Integer. ! Length of the integer workspace, IGWK. LIGW >= 20. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used for workspace in ! MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE. ! ! *Description: ! DGMRES solves a linear system A*X = B rewritten in the form: ! ! (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, ! ! with right preconditioning, or ! ! (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, ! ! with left preconditioning, where A is an N-by-N double precision ! matrix, X and B are N-vectors, SB and SX are diagonal scaling ! matrices, and M is a preconditioning matrix. It uses ! preconditioned Krylov subpace methods based on the ! generalized minimum residual method (GMRES). This routine ! optionally performs either the full orthogonalization ! version of the GMRES algorithm or an incomplete variant of ! it. Both versions use restarting of the linear iteration by ! default, although the user can disable this feature. ! ! The GMRES algorithm generates a sequence of approximations ! X(L) to the true solution of the above linear system. The ! convergence criteria for stopping the iteration is based on ! the size of the scaled norm of the residual R(L) = B - ! A*X(L). The actual stopping test is either: ! ! norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), ! ! for right preconditioning, or ! ! norm(SB*(M-inverse)*(B-A*X(L))) .le. ! TOL*norm(SB*(M-inverse)*B), ! ! for left preconditioning, where norm() denotes the Euclidean ! norm, and TOL is a positive scalar less than one input by ! the user. If TOL equals zero when DGMRES is called, then a ! default value of 500*(the smallest positive magnitude, ! machine epsilon) is used. If the scaling arrays SB and SX ! are used, then ideally they should be chosen so that the ! vectors SX*X(or SX*M*X) and SB*B have all their components ! approximately equal to one in magnitude. If one wants to ! use the same scaling in X and B, then SB and SX can be the ! same array in the calling program. ! ! The following is a list of the other routines and their ! functions used by DGMRES: ! DPIGMR Contains the main iteration loop for GMRES. ! DORTH Orthogonalizes a new vector against older basis vectors. ! DHEQR Computes a QR decomposition of a Hessenberg matrix. ! DHELS Solves a Hessenberg least-squares system, using QR ! factors. ! DRLCAL Computes the scaled residual RL. ! DXLCAL Computes the solution XL. ! ISDGMR User-replaceable stopping routine. ! ! This routine does not care what matrix data structure is ! used for A and M. It simply calls the MATVEC and MSOLVE ! routines, with the arguments as described above. The user ! could write any type of structure and the appropriate MATVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK in some fashion. The SLAP ! routines DSDCG and DSICCG are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage ! Matrix Methods in Stiff ODE Systems, Lawrence Liver- ! more National Laboratory Report UCRL-95088, Rev. 1, ! Livermore, California, June 1987. ! 2. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED D1MACH, DCOPY, DNRM2, DPIGMR !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Corrected errors in C***ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) ! 921026 Added check for valid value of ITOL. (FNF) !***END PROLOGUE DGMRES ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LIGW, LRGW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RGWK(LRGW), RWORK(*), SB(N), & SX(N), X(N) INTEGER IA(NELT), IGWK(LIGW), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. DOUBLE PRECISION BNRM, RHOL, SUM INTEGER I, IFLAG, JPRE, JSCAL, KMP, LDL, LGMR, LHES, LQ, LR, LV, & LW, LXL, LZ, LZM1, MAXL, MAXLP1, NMS, NMSL, NRMAX, NRSTS ! .. External Functions .. DOUBLE PRECISION D1MACH, DNRM2 EXTERNAL D1MACH, DNRM2 ! .. External Subroutines .. EXTERNAL DCOPY, DPIGMR ! .. Intrinsic Functions .. INTRINSIC SQRT !***FIRST EXECUTABLE STATEMENT DGMRES IERR = 0 ! ------------------------------------------------------------------ ! Load method parameters with user values or defaults. ! ------------------------------------------------------------------ MAXL = IGWK(1) if (MAXL == 0) MAXL = 10 if (MAXL > N) MAXL = N KMP = IGWK(2) if (KMP == 0) KMP = MAXL if (KMP > MAXL) KMP = MAXL JSCAL = IGWK(3) JPRE = IGWK(4) ! Check for valid value of ITOL. if ( (ITOL < 0) .OR. ((ITOL > 3).AND.(ITOL /= 11)) ) GOTO 650 ! Check for consistent values of ITOL and JPRE. if ( ITOL == 1 .AND. JPRE < 0 ) GOTO 650 if ( ITOL == 2 .AND. JPRE >= 0 ) GOTO 650 NRMAX = IGWK(5) if ( NRMAX == 0 ) NRMAX = 10 ! If NRMAX .eq. -1, then set NRMAX = 0 to turn off restarting. if ( NRMAX == -1 ) NRMAX = 0 ! If input value of TOL is zero, set it to its default value. if ( TOL == 0.0D0 ) TOL = 500*D1MACH(3) ! ! Initialize counters. ITER = 0 NMS = 0 NRSTS = 0 ! ------------------------------------------------------------------ ! Form work array segment pointers. ! ------------------------------------------------------------------ MAXLP1 = MAXL + 1 LV = 1 LR = LV + N*MAXLP1 LHES = LR + N + 1 LQ = LHES + MAXL*MAXLP1 LDL = LQ + 2*MAXL LW = LDL + N LXL = LW + N LZ = LXL + N ! ! Load IGWK(6) with required minimum length of the RGWK array. IGWK(6) = LZ + N - 1 if ( LZ+N-1 > LRGW ) GOTO 640 ! ------------------------------------------------------------------ ! Calculate scaled-preconditioned norm of RHS vector b. ! ------------------------------------------------------------------ if (JPRE < 0) THEN call MSOLVE(N, B, RGWK(LR), NELT, IA, JA, A, ISYM, & RWORK, IWORK) NMS = NMS + 1 ELSE call DCOPY(N, B, 1, RGWK(LR), 1) end if if ( JSCAL == 2 .OR. JSCAL == 3 ) THEN SUM = 0 DO 10 I = 1,N SUM = SUM + (RGWK(LR-1+I)*SB(I))**2 10 CONTINUE BNRM = SQRT(SUM) ELSE BNRM = DNRM2(N,RGWK(LR),1) end if ! ------------------------------------------------------------------ ! Calculate initial residual. ! ------------------------------------------------------------------ call MATVEC(N, X, RGWK(LR), NELT, IA, JA, A, ISYM) DO 50 I = 1,N RGWK(LR-1+I) = B(I) - RGWK(LR-1+I) 50 CONTINUE ! ------------------------------------------------------------------ ! If performing restarting, then load the residual into the ! correct location in the RGWK array. ! ------------------------------------------------------------------ 100 CONTINUE if ( NRSTS > NRMAX ) GOTO 610 if ( NRSTS > 0 ) THEN ! Copy the current residual to a different location in the RGWK ! array. call DCOPY(N, RGWK(LDL), 1, RGWK(LR), 1) end if ! ------------------------------------------------------------------ ! Use the DPIGMR algorithm to solve the linear system A*Z = R. ! ------------------------------------------------------------------ call DPIGMR(N, RGWK(LR), SB, SX, JSCAL, MAXL, MAXLP1, KMP, & NRSTS, JPRE, MATVEC, MSOLVE, NMSL, RGWK(LZ), RGWK(LV), & RGWK(LHES), RGWK(LQ), LGMR, RWORK, IWORK, RGWK(LW), & RGWK(LDL), RHOL, NRMAX, B, BNRM, X, RGWK(LXL), ITOL, & TOL, NELT, IA, JA, A, ISYM, IUNIT, IFLAG, ERR) ITER = ITER + LGMR NMS = NMS + NMSL ! ! Increment X by the current approximate solution Z of A*Z = R. ! LZM1 = LZ - 1 DO 110 I = 1,N X(I) = X(I) + RGWK(LZM1+I) 110 CONTINUE if ( IFLAG == 0 ) GOTO 600 if ( IFLAG == 1 ) THEN NRSTS = NRSTS + 1 GOTO 100 end if if ( IFLAG == 2 ) GOTO 620 ! ------------------------------------------------------------------ ! All returns are made through this section. ! ------------------------------------------------------------------ ! The iteration has converged. ! 600 CONTINUE IGWK(7) = NMS RGWK(1) = RHOL IERR = 0 return ! ! Max number((NRMAX+1)*MAXL) of linear iterations performed. 610 CONTINUE IGWK(7) = NMS RGWK(1) = RHOL IERR = 1 return ! ! GMRES failed to reduce last residual in MAXL iterations. ! The iteration has stalled. 620 CONTINUE IGWK(7) = NMS RGWK(1) = RHOL IERR = 2 return ! Error return. Insufficient length for RGWK array. 640 CONTINUE ERR = TOL IERR = -1 return ! Error return. Inconsistent ITOL and JPRE values. 650 CONTINUE ERR = TOL IERR = -2 return !------------- LAST LINE OF DGMRES FOLLOWS ---------------------------- end subroutine DGTSL (N, C, D, E, B, INFO) ! !! DGTSL solves a tridiagonal linear system. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A2A !***TYPE DOUBLE PRECISION (SGTSL-S, DGTSL-D, CGTSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, TRIDIAGONAL !***AUTHOR Dongarra, J., (ANL) !***DESCRIPTION ! ! DGTSL given a general tridiagonal matrix and a right hand ! side will find the solution. ! ! On Entry ! ! N INTEGER ! is the order of the tridiagonal matrix. ! ! C DOUBLE PRECISION(N) ! is the subdiagonal of the tridiagonal matrix. ! C(2) through C(N) should contain the subdiagonal. ! On output C is destroyed. ! ! D DOUBLE PRECISION(N) ! is the diagonal of the tridiagonal matrix. ! On output D is destroyed. ! ! E DOUBLE PRECISION(N) ! is the superdiagonal of the tridiagonal matrix. ! E(1) through E(N-1) should contain the superdiagonal. ! On output E is destroyed. ! ! B DOUBLE PRECISION(N) ! is the right hand side vector. ! ! On Return ! ! B is the solution vector. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th element of the diagonal becomes ! exactly zero. The subroutine returns when ! this is detected. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DGTSL INTEGER N,INFO DOUBLE PRECISION C(*),D(*),E(*),B(*) ! INTEGER K,KB,KP1,NM1,NM2 DOUBLE PRECISION T !***FIRST EXECUTABLE STATEMENT DGTSL INFO = 0 C(1) = D(1) NM1 = N - 1 if (NM1 < 1) go to 40 D(1) = E(1) E(1) = 0.0D0 E(N) = 0.0D0 ! DO 30 K = 1, NM1 KP1 = K + 1 ! ! FIND THE LARGEST OF THE TWO ROWS ! if (ABS(C(KP1)) < ABS(C(K))) go to 10 ! ! INTERCHANGE ROW ! T = C(KP1) C(KP1) = C(K) C(K) = T T = D(KP1) D(KP1) = D(K) D(K) = T T = E(KP1) E(KP1) = E(K) E(K) = T T = B(KP1) B(KP1) = B(K) B(K) = T 10 CONTINUE ! ! ZERO ELEMENTS ! if (C(K) /= 0.0D0) go to 20 INFO = K go to 100 20 CONTINUE T = -C(KP1)/C(K) C(KP1) = D(KP1) + T*D(K) D(KP1) = E(KP1) + T*E(K) E(KP1) = 0.0D0 B(KP1) = B(KP1) + T*B(K) 30 CONTINUE 40 CONTINUE if (C(N) /= 0.0D0) go to 50 INFO = N go to 90 50 CONTINUE ! ! BACK SOLVE ! NM2 = N - 2 B(N) = B(N)/C(N) if (N == 1) go to 80 B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1) if (NM2 < 1) go to 70 DO 60 KB = 1, NM2 K = NM2 - KB + 1 B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K) 60 CONTINUE 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE ! return end subroutine DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, NCV) ! !! DH12 constructs or applies a Householder transformation. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DHFTI, DLSEI and DWNNLS !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (H12-S, DH12-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! *** DOUBLE PRECISION VERSION OF H12 ****** ! ! C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 ! to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 ! ! Construction and/or application of a single ! Householder transformation.. Q = I + U*(U**T)/B ! ! MODE = 1 or 2 to select algorithm H1 or H2 . ! LPIVOT is the index of the pivot element. ! L1,M If L1 <= M the transformation will be constructed to ! zero elements indexed from L1 through M. If L1 GT. M ! THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. ! U(),IUE,UP On entry to H1 U() contains the pivot vector. ! IUE is the storage increment between elements. ! On exit from H1 U() and UP ! contain quantities defining the vector U of the ! Householder transformation. On entry to H2 U() ! and UP should contain quantities previously computed ! by H1. These will not be modified by H2. ! C() On entry to H1 or H2 C() contains a matrix which will be ! regarded as a set of vectors to which the Householder ! transformation is to be applied. On exit C() contains the ! set of transformed vectors. ! ICE Storage increment between elements of vectors in C(). ! ICV Storage increment between vectors in C(). ! NCV Number of vectors in C() to be transformed. If NCV <= 0 ! no operations will be done on C(). ! !***SEE ALSO DHFTI, DLSEI, DWNNLS !***ROUTINES CALLED DAXPY, DDOT, DSWAP !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900911 Added DDOT to DOUBLE PRECISION statement. (WRB) !***END PROLOGUE DH12 INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP, & L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT DIMENSION U(IUE,*), C(*) ! BEGIN BLOCK PERMITTING ...EXITS TO 140 !***FIRST EXECUTABLE STATEMENT DH12 ONE = 1.0D0 ! ! ...EXIT if (0 >= LPIVOT .OR. LPIVOT >= L1 .OR. L1 > M) go to 140 CL = ABS(U(1,LPIVOT)) if (MODE == 2) go to 40 ! ****** CONSTRUCT THE TRANSFORMATION. ****** DO 10 J = L1, M CL = MAX(ABS(U(1,J)),CL) 10 CONTINUE if (CL > 0.0D0) go to 20 ! .........EXIT go to 140 20 CONTINUE CLINV = ONE/CL SM = (U(1,LPIVOT)*CLINV)**2 DO 30 J = L1, M SM = SM + (U(1,J)*CLINV)**2 30 CONTINUE CL = CL*SQRT(SM) if (U(1,LPIVOT) > 0.0D0) CL = -CL UP = U(1,LPIVOT) - CL U(1,LPIVOT) = CL go to 50 40 CONTINUE ! ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** ! if (CL > 0.0D0) go to 50 ! ......EXIT go to 140 50 CONTINUE ! ...EXIT if (NCV <= 0) go to 140 B = UP*U(1,LPIVOT) ! B MUST BE NONPOSITIVE HERE. if B = 0., RETURN. ! if (B < 0.0D0) go to 60 ! ......EXIT go to 140 60 CONTINUE B = ONE/B MML1P2 = M - L1 + 2 if (MML1P2 <= 20) go to 80 L1M1 = L1 - 1 KL1 = 1 + (L1M1 - 1)*ICE KL2 = KL1 KLP = 1 + (LPIVOT - 1)*ICE UL1M1 = U(1,L1M1) U(1,L1M1) = UP if (LPIVOT /= L1M1) call DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) DO 70 J = 1, NCV SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) SM = SM*B call DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) KL1 = KL1 + ICV 70 CONTINUE U(1,L1M1) = UL1M1 ! ......EXIT if (LPIVOT == L1M1) go to 140 KL1 = KL2 call DSWAP(NCV,C(KL1),ICV,C(KLP),ICV) go to 130 80 CONTINUE 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) I3 = I3 + ICE 90 CONTINUE if (SM == 0.0D0) go to 110 SM = SM*B C(I2) = C(I2) + SM*UP DO 100 I = L1, M C(I4) = C(I4) + SM*U(1,I) I4 = I4 + ICE 100 CONTINUE 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE return end subroutine DHELS (A, LDA, N, Q, B) ! !! DHELS is an internal routine for DGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SHELS-S, DHELS-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine is extracted from the LINPACK routine SGESL with ! changes due to the fact that A is an upper Hessenberg matrix. ! ! DHELS solves the least squares problem: ! ! MIN(B-A*X,B-A*X) ! ! using the factors computed by DHEQR. ! ! *Usage: ! INTEGER LDA, N ! DOUBLE PRECISION A(LDA,N), Q(2*N), B(N+1) ! ! call DHELS(A, LDA, N, Q, B) ! ! *Arguments: ! A :IN Double Precision A(LDA,N) ! The output from DHEQR which contains the upper ! triangular factor R in the QR decomposition of A. ! LDA :IN Integer ! The leading dimension of the array A. ! N :IN Integer ! A is originally an (N+1) by N matrix. ! Q :IN Double Precision Q(2*N) ! The coefficients of the N Givens rotations ! used in the QR factorization of A. ! B :INOUT Double Precision B(N+1) ! On input, B is the right hand side vector. ! On output, B is the solution vector X. ! !***SEE ALSO DGMRES !***ROUTINES CALLED DAXPY !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Added C***FIRST EXECUTABLE STATEMENT line. (FNF) ! 910506 Made subsidiary to DGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE DHELS ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. INTEGER LDA, N ! .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(*), Q(*) ! .. Local Scalars .. DOUBLE PRECISION C, S, T, T1, T2 INTEGER IQ, K, KB, KP1 ! .. External Subroutines .. EXTERNAL DAXPY !***FIRST EXECUTABLE STATEMENT DHELS ! ! Minimize(B-A*X,B-A*X). First form Q*B. ! DO 20 K = 1, N KP1 = K + 1 IQ = 2*(K-1) + 1 C = Q(IQ) S = Q(IQ+1) T1 = B(K) T2 = B(KP1) B(K) = C*T1 - S*T2 B(KP1) = S*T1 + C*T2 20 CONTINUE ! ! Now solve R*X = Q*B. ! 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 return !------------- LAST LINE OF DHELS FOLLOWS ---------------------------- end subroutine DHEQR (A, LDA, N, Q, INFO, IJOB) ! !! DHEQR is an internal routine for DGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SHEQR-S, DHEQR-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine performs a QR decomposition of an upper ! Hessenberg matrix A using Givens rotations. There are two ! options available: 1) Performing a fresh decomposition 2) ! updating the QR factors by adding a row and a column to the ! matrix A. ! ! *Usage: ! INTEGER LDA, N, INFO, IJOB ! DOUBLE PRECISION A(LDA,N), Q(2*N) ! ! call DHEQR(A, LDA, N, Q, INFO, IJOB) ! ! *Arguments: ! A :INOUT Double Precision A(LDA,N) ! On input, the matrix to be decomposed. ! On output, the upper triangular matrix R. ! The factorization can be written Q*A = R, where ! Q is a product of Givens rotations and R is upper ! triangular. ! LDA :IN Integer ! The leading dimension of the array A. ! N :IN Integer ! A is an (N+1) by N Hessenberg matrix. ! Q :OUT Double Precision Q(2*N) ! The factors c and s of each Givens rotation used ! in decomposing A. ! INFO :OUT Integer ! = 0 normal value. ! = K if A(K,K) .eq. 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that DHELS will divide by zero ! if called. ! IJOB :IN Integer ! = 1 means that a fresh decomposition of the ! matrix A is desired. ! .ge. 2 means that the current decomposition of A ! will be updated by the addition of a row ! and a column. ! !***SEE ALSO DGMRES !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Made subsidiary to DGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE DHEQR ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. INTEGER IJOB, INFO, LDA, N ! .. Array Arguments .. DOUBLE PRECISION A(LDA,*), Q(*) ! .. Local Scalars .. DOUBLE PRECISION C, S, T, T1, T2 INTEGER I, IQ, J, K, KM1, KP1, NM1 ! .. Intrinsic Functions .. INTRINSIC ABS, SQRT !***FIRST EXECUTABLE STATEMENT DHEQR if (IJOB > 1) go to 70 ! ------------------------------------------------------------------- ! A new factorization is desired. ! ------------------------------------------------------------------- ! QR decomposition without pivoting. ! INFO = 0 DO 60 K = 1, N KM1 = K - 1 KP1 = K + 1 ! ! Compute K-th column of R. ! First, multiply the K-th column of A by the previous ! K-1 Givens rotations. ! if (KM1 < 1) go to 20 DO 10 J = 1, KM1 I = 2*(J-1) + 1 T1 = A(J,K) T2 = A(J+1,K) C = Q(I) S = Q(I+1) A(J,K) = C*T1 - S*T2 A(J+1,K) = S*T1 + C*T2 10 CONTINUE ! ! Compute Givens components C and S. ! 20 CONTINUE IQ = 2*KM1 + 1 T1 = A(K,K) T2 = A(KP1,K) if ( T2 == 0.0D0 ) THEN C = 1 S = 0 ELSEIF( ABS(T2) >= ABS(T1) ) THEN T = T1/T2 S = -1.0D0/SQRT(1.0D0+T*T) C = -S*T ELSE T = T2/T1 C = 1.0D0/SQRT(1.0D0+T*T) S = -C*T ENDIF Q(IQ) = C Q(IQ+1) = S A(K,K) = C*T1 - S*T2 if ( A(K,K) == 0.0D0 ) INFO = K 60 CONTINUE return ! ------------------------------------------------------------------- ! The old factorization of a will be updated. A row and a ! column has been added to the matrix A. N by N-1 is now ! the old size of the matrix. ! ------------------------------------------------------------------- 70 CONTINUE NM1 = N - 1 ! ------------------------------------------------------------------- ! Multiply the new column by the N previous Givens rotations. ! ------------------------------------------------------------------- DO 100 K = 1,NM1 I = 2*(K-1) + 1 T1 = A(K,N) T2 = A(K+1,N) C = Q(I) S = Q(I+1) A(K,N) = C*T1 - S*T2 A(K+1,N) = S*T1 + C*T2 100 CONTINUE ! ------------------------------------------------------------------- ! Complete update of decomposition by forming last Givens ! rotation, and multiplying it times the column ! vector(A(N,N),A(NP1,N)). ! ------------------------------------------------------------------- INFO = 0 T1 = A(N,N) T2 = A(N+1,N) if ( T2 == 0.0D0 ) THEN C = 1 S = 0 ELSEIF( ABS(T2) >= ABS(T1) ) THEN T = T1/T2 S = -1.0D0/SQRT(1.0D0+T*T) C = -S*T ELSE T = T2/T1 C = 1.0D0/SQRT(1.0D0+T*T) S = -C*T end if IQ = 2*N - 1 Q(IQ) = C Q(IQ+1) = S A(N,N) = C*T1 - S*T2 if (A(N,N) == 0.0D0) INFO = N return !------------- LAST LINE OF DHEQR FOLLOWS ---------------------------- end subroutine DHFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, & G, IP) ! !! DHFTI solves a least squares problem for banded matrices using ... ! sequential accumulation of rows of the data matrix. ! Exactly one right-hand side vector is permitted. ! !***LIBRARY SLATEC !***CATEGORY D9 !***TYPE DOUBLE PRECISION (HFTI-S, DHFTI-D) !***KEYWORDS CURVE FITTING, LEAST SQUARES !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) ! ! This subroutine solves a linear least squares problem or a set of ! linear least squares problems having the same matrix but different ! right-side vectors. The problem data consists of an M by N matrix ! A, an M by NB matrix B, and an absolute tolerance parameter TAU ! whose usage is described below. The NB column vectors of B ! represent right-side vectors for NB distinct linear least squares ! problems. ! ! This set of problems can also be written as the matrix least ! squares problem ! ! AX = B, ! ! where X is the N by NB solution matrix. ! ! Note that if B is the M by M identity matrix, then X will be the ! pseudo-inverse of A. ! ! This subroutine first transforms the augmented matrix (A B) to a ! matrix (R C) using premultiplying Householder transformations with ! column interchanges. All subdiagonal elements in the matrix R are ! zero and its diagonal elements satisfy ! ! ABS(R(I,I)) >= ABS(R(I+1,I+1)), ! ! I = 1,...,L-1, where ! ! L = MIN(M,N). ! ! The subroutine will compute an integer, KRANK, equal to the number ! of diagonal terms of R that exceed TAU in magnitude. Then a ! solution of minimum Euclidean length is computed using the first ! KRANK rows of (R C). ! ! To be specific we suggest that the user consider an easily ! computable matrix norm, such as, the maximum of all column sums of ! magnitudes. ! ! Now if the relative uncertainty of B is EPS, (norm of uncertainty/ ! norm of B), it is suggested that TAU be set approximately equal to ! EPS*(norm of A). ! ! The user must dimension all arrays appearing in the call list.. ! A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This ! permits the solution of a range of problems in the same array ! space. ! ! The entire set of parameters for DHFTI are ! ! INPUT.. All TYPE REAL variables are DOUBLE PRECISION ! ! A(*,*),MDA,M,N The array A(*,*) initially contains the M by N ! matrix A of the least squares problem AX = B. ! The first dimensioning parameter of the array ! A(*,*) is MDA, which must satisfy MDA >= M ! Either M >= N or M < N is permitted. There ! is no restriction on the rank of A. The ! condition MDA < M is considered an error. ! ! B(*),MDB,NB If NB = 0 the subroutine will perform the ! orthogonal decomposition but will make no ! references to the array B(*). If NB > 0 ! the array B(*) must initially contain the M by ! NB matrix B of the least squares problem AX = ! B. If NB >= 2 the array B(*) must be doubly ! subscripted with first dimensioning parameter ! MDB >= MAX(M,N). If NB = 1 the array B(*) may ! be either doubly or singly subscripted. In ! the latter case the value of MDB is arbitrary ! but it should be set to some valid integer ! value such as MDB = M. ! ! The condition of NB > 1.AND.MDB < MAX(M,N) ! is considered an error. ! ! TAU Absolute tolerance parameter provided by user ! for pseudorank determination. ! ! H(*),G(*),IP(*) Arrays of working space used by DHFTI. ! ! OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION ! ! A(*,*) The contents of the array A(*,*) will be ! modified by the subroutine. These contents ! are not generally required by the user. ! ! B(*) On return the array B(*) will contain the N by ! NB solution matrix X. ! ! KRANK Set by the subroutine to indicate the ! pseudorank of A. ! ! RNORM(*) On return, RNORM(J) will contain the Euclidean ! norm of the residual vector for the problem ! defined by the J-th column vector of the array ! B(*,*) for J = 1,...,NB. ! ! H(*),G(*) On return these arrays respectively contain ! elements of the pre- and post-multiplying ! Householder transformations used to compute ! the minimum Euclidean length solution. ! ! IP(*) Array in which the subroutine records indices ! describing the permutation of column vectors. ! The contents of arrays H(*),G(*) and IP(*) ! are not generally required by the user. ! !***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares ! Problems, Prentice-Hall, Inc., 1974, Chapter 14. !***ROUTINES CALLED D1MACH, DH12, XERMSG !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 901005 Replace usage of DDIFF with usage of D1MACH. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DHFTI INTEGER I, II, IOPT, IP(*), IP1, J, JB, JJ, K, KP1, KRANK, L, & LDIAG, LMAX, M, MDA, MDB, N, NB, NERR DOUBLE PRECISION A, B, D1MACH, DZERO, FACTOR, & G, H, HMAX, RELEPS, RNORM, SM, SM1, SZERO, TAU, TMP DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) SAVE RELEPS DATA RELEPS /0.D0/ ! BEGIN BLOCK PERMITTING ...EXITS TO 360 !***FIRST EXECUTABLE STATEMENT DHFTI if (RELEPS == 0.D0) RELEPS = D1MACH(4) SZERO = 0.0D0 DZERO = 0.0D0 FACTOR = 0.001D0 ! K = 0 LDIAG = MIN(M,N) if (LDIAG <= 0) go to 350 ! BEGIN BLOCK PERMITTING ...EXITS TO 130 ! BEGIN BLOCK PERMITTING ...EXITS TO 120 if (MDA >= M) go to 10 NERR = 1 IOPT = 2 call XERMSG ('SLATEC', 'DHFTI', & 'MDA < M, PROBABLE ERROR.', & NERR, IOPT) ! ...............EXIT go to 360 10 CONTINUE ! if (NB <= 1 .OR. MAX(M,N) <= MDB) go to 20 NERR = 2 IOPT = 2 call XERMSG ('SLATEC', 'DHFTI', & 'MDB < MAX(M,N).AND.NB > 1. PROBABLE ERROR.', & NERR, IOPT) ! ...............EXIT go to 360 20 CONTINUE ! DO 100 J = 1, LDIAG ! BEGIN BLOCK PERMITTING ...EXITS TO 70 if (J == 1) go to 40 ! ! UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX ! .. LMAX = J DO 30 L = J, N H(L) = H(L) - A(J-1,L)**2 if (H(L) > H(LMAX)) LMAX = L 30 CONTINUE ! ......EXIT if (FACTOR*H(LMAX) > HMAX*RELEPS) go to 70 40 CONTINUE ! ! COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX ! .. LMAX = J DO 60 L = J, N H(L) = 0.0D0 DO 50 I = J, M H(L) = H(L) + A(I,L)**2 50 CONTINUE if (H(L) > H(LMAX)) LMAX = L 60 CONTINUE HMAX = H(LMAX) 70 CONTINUE ! .. ! LMAX HAS BEEN DETERMINED ! ! DO COLUMN INTERCHANGES if NEEDED. ! .. IP(J) = LMAX if (IP(J) == J) go to 90 DO 80 I = 1, M TMP = A(I,J) A(I,J) = A(I,LMAX) A(I,LMAX) = TMP 80 CONTINUE H(LMAX) = H(J) 90 CONTINUE ! ! COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A ! AND B. ! .. call DH12(1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA, & N-J) call DH12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) 100 CONTINUE ! ! DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, ! TAU. ! .. DO 110 J = 1, LDIAG ! ......EXIT if (ABS(A(J,J)) <= TAU) go to 120 110 CONTINUE K = LDIAG ! ......EXIT go to 130 120 CONTINUE K = J - 1 130 CONTINUE KP1 = K + 1 ! ! COMPUTE THE NORMS OF THE RESIDUAL VECTORS. ! if (NB < 1) go to 170 DO 160 JB = 1, NB TMP = SZERO if (M < KP1) go to 150 DO 140 I = KP1, M TMP = TMP + B(I,JB)**2 140 CONTINUE 150 CONTINUE RNORM(JB) = SQRT(TMP) 160 CONTINUE 170 CONTINUE ! SPECIAL FOR PSEUDORANK = 0 if (K > 0) go to 210 if (NB < 1) go to 200 DO 190 JB = 1, NB DO 180 I = 1, N B(I,JB) = SZERO 180 CONTINUE 190 CONTINUE 200 CONTINUE go to 340 210 CONTINUE ! ! if THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER ! DECOMPOSITION OF FIRST K ROWS. ! .. if (K == N) go to 230 DO 220 II = 1, K I = KP1 - II call DH12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) 220 CONTINUE 230 CONTINUE ! ! if (NB < 1) go to 330 DO 320 JB = 1, NB ! ! SOLVE THE K BY K TRIANGULAR SYSTEM. ! .. DO 260 L = 1, K SM = DZERO I = KP1 - L IP1 = I + 1 if (K < IP1) go to 250 DO 240 J = IP1, K SM = SM + A(I,J)*B(J,JB) 240 CONTINUE 250 CONTINUE SM1 = SM B(I,JB) = (B(I,JB) - SM1)/A(I,I) 260 CONTINUE ! ! COMPLETE COMPUTATION OF SOLUTION VECTOR. ! .. if (K == N) go to 290 DO 270 J = KP1, N B(J,JB) = SZERO 270 CONTINUE DO 280 I = 1, K call DH12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1, & MDB,1) 280 CONTINUE 290 CONTINUE ! ! RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE ! COLUMN INTERCHANGES. ! .. DO 310 JJ = 1, LDIAG J = LDIAG + 1 - JJ if (IP(J) == J) go to 300 L = IP(J) TMP = B(L,JB) B(L,JB) = B(J,JB) B(J,JB) = TMP 300 CONTINUE 310 CONTINUE 320 CONTINUE 330 CONTINUE 340 CONTINUE 350 CONTINUE ! .. ! THE SOLUTION VECTORS, X, ARE NOW ! IN THE FIRST N ROWS OF THE ARRAY B(,). ! KRANK = K 360 CONTINUE return end subroutine DHKSEQ (X, M, H, IERR) ! !! DHKSEQ is subsidiary to DBSKIN. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (HKSEQ-S, DHKSEQ-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! DHKSEQ is an adaptation of subroutine DPSIFN described in the ! reference below. DHKSEQ generates the sequence ! H(K,X) = (-X)**(K+1)*(PSI(K,X) PSI(K,X+0.5))/GAMMA(K+1), for ! K=0,...,M. ! !***SEE ALSO DBSKIN !***REFERENCES D. E. Amos, A portable Fortran subroutine for ! derivatives of the Psi function, Algorithm 610, ACM ! Transactions on Mathematical Software 9, 4 (1983), ! pp. 494-502. !***ROUTINES CALLED D1MACH, I1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920528 DESCRIPTION and REFERENCES sections revised. (WRB) !***END PROLOGUE DHKSEQ INTEGER I, IERR, J, K, M, MX, NX INTEGER I1MACH DOUBLE PRECISION B, FK, FLN, FN, FNP, H, HRX, RLN, RXSQ, R1M5, S, & SLOPE, T, TK, TRM, TRMH, TRMR, TST, U, V, WDTOL, X, XDMY, XH, & XINC, XM, XMIN, YINT DOUBLE PRECISION D1MACH DIMENSION B(22), TRM(22), TRMR(25), TRMH(25), U(25), V(25), H(*) SAVE B !----------------------------------------------------------------------- ! SCALED BERNOULLI NUMBERS 2.0*B(2K)*(1-2**(-2K)) !----------------------------------------------------------------------- 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.00000000000000000D+00, & -5.00000000000000000D-01,2.50000000000000000D-01, & -6.25000000000000000D-02,4.68750000000000000D-02, & -6.64062500000000000D-02,1.51367187500000000D-01, & -5.06103515625000000D-01,2.33319091796875000D+00, & -1.41840972900390625D+01,1.09941936492919922D+02, & -1.05824747562408447D+03,1.23842434241771698D+04, & -1.73160495905935764D+05,2.85103429084961116D+06, & -5.45964619322445132D+07,1.20316174668075304D+09, & -3.02326315271452307D+10,8.59229286072319606D+11, & -2.74233104097776039D+13,9.76664637943633248D+14, & -3.85931586838450360D+16/ ! !***FIRST EXECUTABLE STATEMENT DHKSEQ IERR=0 WDTOL = MAX(D1MACH(4),1.0D-18) FN = M - 1 FNP = FN + 1.0D0 !----------------------------------------------------------------------- ! COMPUTE XMIN !----------------------------------------------------------------------- R1M5 = D1MACH(5) RLN = R1M5*I1MACH(14) RLN = MIN(RLN,18.06D0) FLN = MAX(RLN,3.0D0) - 3.0D0 YINT = 3.50D0 + 0.40D0*FLN SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0) XM = YINT + SLOPE*FN MX = INT(XM) + 1 XMIN = MX !----------------------------------------------------------------------- ! GENERATE H(M-1,XDMY)*XDMY**(M) BY THE ASYMPTOTIC EXPANSION !----------------------------------------------------------------------- XDMY = X XINC = 0.0D0 if (X >= XMIN) go to 10 NX = INT(X) XINC = XMIN - NX XDMY = X + XINC 10 CONTINUE RXSQ = 1.0D0/(XDMY*XDMY) HRX = 0.5D0/XDMY TST = 0.5D0*WDTOL T = FNP*HRX !----------------------------------------------------------------------- ! INITIALIZE COEFFICIENT ARRAY !----------------------------------------------------------------------- S = T*B(3) if (ABS(S) < TST) go to 30 TK = 2.0D0 DO 20 K=4,22 T = T*((TK+FN+1.0D0)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ TRM(K) = T*B(K) if (ABS(TRM(K)) < TST) go to 30 S = S + TRM(K) TK = TK + 2.0D0 20 CONTINUE go to 110 30 CONTINUE H(M) = S + 0.5D0 if (M == 1) go to 70 !----------------------------------------------------------------------- ! GENERATE LOWER DERIVATIVES, I < M-1 !----------------------------------------------------------------------- DO 60 I=2,M FNP = FN FN = FN - 1.0D0 S = FNP*HRX*B(3) if (ABS(S) < TST) go to 50 FK = FNP + 3.0D0 DO 40 K=4,22 TRM(K) = TRM(K)*FNP/FK if (ABS(TRM(K)) < TST) go to 50 S = S + TRM(K) FK = FK + 2.0D0 40 CONTINUE go to 110 50 CONTINUE MX = M - I + 1 H(MX) = S + 0.5D0 60 CONTINUE 70 CONTINUE if (XINC == 0.0D0) RETURN !----------------------------------------------------------------------- ! RECUR BACKWARD FROM XDMY TO X !----------------------------------------------------------------------- XH = X + 0.5D0 S = 0.0D0 NX = INT(XINC) DO 80 I=1,NX TRMR(I) = X/(X+NX-I) U(I) = TRMR(I) TRMH(I) = X/(XH+NX-I) V(I) = TRMH(I) S = S + U(I) - V(I) 80 CONTINUE MX = NX + 1 TRMR(MX) = X/XDMY U(MX) = TRMR(MX) H(1) = H(1)*TRMR(MX) + S if (M == 1) RETURN DO 100 J=2,M S = 0.0D0 DO 90 I=1,NX TRMR(I) = TRMR(I)*U(I) TRMH(I) = TRMH(I)*V(I) S = S + TRMR(I) - TRMH(I) 90 CONTINUE TRMR(MX) = TRMR(MX)*U(MX) H(J) = H(J)*TRMR(MX) + S 100 CONTINUE return 110 CONTINUE IERR=2 return end subroutine DHSTRT (DF, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, & BIG, SPY, PV, YP, SF, RPAR, IPAR, H) ! !! DHSTRT computes a starting step for DDEABM, DDEBDF or DDERKF. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (HSTART-S, DHSTRT-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DHSTRT computes a starting step size to be used in solving initial ! value problems in ordinary differential equations. ! ! ********************************************************************** ! ABSTRACT ! ! Subroutine DHSTRT computes a starting step size to be used by an ! initial value method in solving ordinary differential equations. ! It is based on an estimate of the local Lipschitz constant for the ! differential equation (lower bound on a norm of the Jacobian) , ! a bound on the differential equation (first derivative) , and ! a bound on the partial derivative of the equation with respect to ! the independent variable. ! (all approximated near the initial point A) ! ! Subroutine DHSTRT uses a function subprogram DHVNRM for computing ! a vector norm. The maximum norm is presently utilized though it ! can easily be replaced by any other vector norm. It is presumed ! that any replacement norm routine would be carefully coded to ! prevent unnecessary underflows or overflows from occurring, and ! also, would not alter the vector or number of components. ! ! ********************************************************************** ! On input you must provide the following ! ! DF -- This is a subroutine of the form ! DF(X,U,UPRIME,RPAR,IPAR) ! which defines the system of first order differential ! equations to be solved. For the given values of X and the ! vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must ! evaluate the NEQ components of the system of differential ! equations DU/DX=DF(X,U) and store the derivatives in the ! array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for ! equations I=1,...,NEQ. ! ! Subroutine DF must not alter X or U(*). You must declare ! the name DF in an external statement in your program that ! calls DHSTRT. You must dimension U and UPRIME in DF. ! ! RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter ! arrays which you can use for communication between your ! program and subroutine DF. They are not used or altered by ! DHSTRT. If you do not need RPAR or IPAR, ignore these ! parameters by treating them as dummy arguments. If you do ! choose to use them, dimension them in your program and in ! DF as arrays of appropriate length. ! ! NEQ -- This is the number of (first order) differential equations ! to be integrated. ! ! A -- This is the initial point of integration. ! ! B -- This is a value of the independent variable used to define ! the direction of integration. A reasonable choice is to ! set B to the first point at which a solution is desired. ! You can also use B, if necessary, to restrict the length ! of the first integration step because the algorithm will ! not compute a starting step length which is bigger than ! ABS(B-A), unless B has been chosen too close to A. ! (it is presumed that DHSTRT has been called with B ! different from A on the machine being used. Also see the ! discussion about the parameter SMALL.) ! ! Y(*) -- This is the vector of initial values of the NEQ solution ! components at the initial point A. ! ! YPRIME(*) -- This is the vector of derivatives of the NEQ ! solution components at the initial point A. ! (defined by the differential equations in subroutine DF) ! ! ETOL -- This is the vector of error tolerances corresponding to ! the NEQ solution components. It is assumed that all ! elements are positive. Following the first integration ! step, the tolerances are expected to be used by the ! integrator in an error test which roughly requires that ! ABS(LOCAL ERROR) <= ETOL ! for each vector component. ! ! MORDER -- This is the order of the formula which will be used by ! the initial value method for taking the first integration ! step. ! ! SMALL -- This is a small positive machine dependent constant ! which is used for protecting against computations with ! numbers which are too small relative to the precision of ! floating point arithmetic. SMALL should be set to ! (approximately) the smallest positive DOUBLE PRECISION ! number such that (1.+SMALL) > 1. on the machine being ! used. The quantity SMALL**(3/8) is used in computing ! increments of variables for approximating derivatives by ! differences. Also the algorithm will not compute a ! starting step length which is smaller than ! 100*SMALL*ABS(A). ! ! BIG -- This is a large positive machine dependent constant which ! is used for preventing machine overflows. A reasonable ! choice is to set big to (approximately) the square root of ! the largest DOUBLE PRECISION number which can be held in ! the machine. ! ! SPY(*),PV(*),YP(*),SF(*) -- These are DOUBLE PRECISION work ! arrays of length NEQ which provide the routine with needed ! storage space. ! ! RPAR,IPAR -- These are parameter arrays, of DOUBLE PRECISION and ! INTEGER type, respectively, which can be used for ! communication between your program and the DF subroutine. ! They are not used or altered by DHSTRT. ! ! ********************************************************************** ! On Output (after the return from DHSTRT), ! ! H -- is an appropriate starting step size to be attempted by the ! differential equation method. ! ! All parameters in the call list remain unchanged except for ! the working arrays SPY(*),PV(*),YP(*), and SF(*). ! ! ********************************************************************** ! !***SEE ALSO DDEABM, DDEBDF, DDERKF !***ROUTINES CALLED DHVNRM !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891024 Changed references from DVNORM to DHVNRM. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DHSTRT ! INTEGER IPAR, J, K, LK, MORDER, NEQ DOUBLE PRECISION A, ABSDX, B, BIG, DA, DELF, DELY, & DFDUB, DFDXB, DHVNRM, & DX, DY, ETOL, FBND, H, PV, RELPER, RPAR, SF, SMALL, SPY, & SRYDPB, TOLEXP, TOLMIN, TOLP, TOLSUM, Y, YDPB, YP, YPRIME DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*), & SF(*),RPAR(*),IPAR(*) EXTERNAL DF ! ! .................................................................. ! ! BEGIN BLOCK PERMITTING ...EXITS TO 160 !***FIRST EXECUTABLE STATEMENT DHSTRT DX = B - A ABSDX = ABS(DX) RELPER = SMALL**0.375D0 ! ! ............................................................... ! ! COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL ! DERIVATIVE OF THE EQUATION WITH RESPECT TO THE ! INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. ! ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE ! LOCALLY. ! DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX), & 100.0D0*SMALL*ABS(A)),DX) if (DA == 0.0D0) DA = RELPER*DX call DF(A+DA,Y,SF,RPAR,IPAR) DO 10 J = 1, NEQ YP(J) = SF(J) - YPRIME(J) 10 CONTINUE DELF = DHVNRM(YP,NEQ) DFDXB = BIG if (DELF < BIG*ABS(DA)) DFDXB = DELF/ABS(DA) FBND = DHVNRM(SF,NEQ) ! ! ............................................................... ! ! COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ ! CONSTANT FOR THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS ! ALSO REPRESENTS AN ESTIMATE OF THE NORM OF THE JACOBIAN ! LOCALLY. THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO ! ESTIMATE THE LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. ! THE FIRST PERTURBATION VECTOR IS BASED ON THE INITIAL ! DERIVATIVES AND DIRECTION OF INTEGRATION. THE SECOND ! PERTURBATION VECTOR IS FORMED USING ANOTHER EVALUATION OF ! THE DIFFERENTIAL EQUATION. THE THIRD PERTURBATION VECTOR ! IS FORMED USING PERTURBATIONS BASED ONLY ON THE INITIAL ! VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS CHANGED TO ! NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN ! INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT ! COMPONENTS OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE ! CONSISTENT WITH THE SLOPES OF LOCAL SOLUTION CURVES. ! ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST ! DERIVATIVE. ! ! PERTURBATION VECTOR SIZE IS HELD ! CONSTANT FOR ALL ITERATIONS. COMPUTE ! THIS CHANGE FROM THE ! SIZE OF THE VECTOR OF INITIAL ! VALUES. DELY = RELPER*DHVNRM(Y,NEQ) if (DELY == 0.0D0) DELY = RELPER DELY = SIGN(DELY,DX) DELF = DHVNRM(YPRIME,NEQ) FBND = MAX(FBND,DELF) if (DELF == 0.0D0) go to 30 ! USE INITIAL DERIVATIVES FOR FIRST PERTURBATION DO 20 J = 1, NEQ SPY(J) = YPRIME(J) YP(J) = YPRIME(J) 20 CONTINUE go to 50 30 CONTINUE ! CANNOT HAVE A NULL PERTURBATION VECTOR DO 40 J = 1, NEQ SPY(J) = 0.0D0 YP(J) = 1.0D0 40 CONTINUE DELF = DHVNRM(YP,NEQ) 50 CONTINUE ! DFDUB = 0.0D0 LK = MIN(NEQ+1,3) DO 140 K = 1, LK ! DEFINE PERTURBED VECTOR OF INITIAL VALUES DO 60 J = 1, NEQ PV(J) = Y(J) + DELY*(YP(J)/DELF) 60 CONTINUE if (K == 2) go to 80 ! EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED ! VECTOR AND COMPUTE CORRESPONDING DIFFERENCES call DF(A,PV,YP,RPAR,IPAR) DO 70 J = 1, NEQ PV(J) = YP(J) - YPRIME(J) 70 CONTINUE go to 100 80 CONTINUE ! USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE ! IN COMPUTING ONE ESTIMATE call DF(A+DA,PV,YP,RPAR,IPAR) DO 90 J = 1, NEQ PV(J) = YP(J) - SF(J) 90 CONTINUE 100 CONTINUE ! CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE ! AND A LOCAL LIPSCHITZ CONSTANT FBND = MAX(FBND,DHVNRM(YP,NEQ)) DELF = DHVNRM(PV,NEQ) ! ...EXIT if (DELF >= BIG*ABS(DELY)) go to 150 DFDUB = MAX(DFDUB,DELF/ABS(DELY)) ! ......EXIT if (K == LK) go to 160 ! CHOOSE NEXT PERTURBATION VECTOR if (DELF == 0.0D0) DELF = 1.0D0 DO 130 J = 1, NEQ if (K == 2) go to 110 DY = ABS(PV(J)) if (DY == 0.0D0) DY = DELF go to 120 110 CONTINUE DY = Y(J) if (DY == 0.0D0) DY = DELY/RELPER 120 CONTINUE if (SPY(J) == 0.0D0) SPY(J) = YP(J) if (SPY(J) /= 0.0D0) DY = SIGN(DY,SPY(J)) YP(J) = DY 130 CONTINUE DELF = DHVNRM(YP,NEQ) 140 CONTINUE 150 CONTINUE ! ! PROTECT AGAINST AN OVERFLOW DFDUB = BIG 160 CONTINUE ! ! .................................................................. ! ! COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE ! YDPB = DFDXB + DFDUB*FBND ! ! .................................................................. ! ! DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP ! SIZE IS TO BE BASED. A VALUE IN THE MIDDLE OF THE ERROR ! TOLERANCE RANGE IS SELECTED. ! TOLMIN = BIG TOLSUM = 0.0D0 DO 170 K = 1, NEQ TOLEXP = LOG10(ETOL(K)) TOLMIN = MIN(TOLMIN,TOLEXP) TOLSUM = TOLSUM + TOLEXP 170 CONTINUE TOLP = 10.0D0**(0.5D0*(TOLSUM/NEQ + TOLMIN)/(MORDER+1)) ! ! .................................................................. ! ! COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND ! SECOND DERIVATIVE INFORMATION ! ! RESTRICT THE STEP LENGTH TO BE NOT BIGGER ! THAN ABS(B-A). (UNLESS B IS TOO CLOSE ! TO A) H = ABSDX ! if (YDPB /= 0.0D0 .OR. FBND /= 0.0D0) go to 180 ! ! BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND ! DERIVATIVE TERM (YDPB) ARE ZERO if (TOLP < 1.0D0) H = ABSDX*TOLP go to 200 180 CONTINUE ! if (YDPB /= 0.0D0) go to 190 ! ! ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO if (TOLP < FBND*ABSDX) H = TOLP/FBND go to 200 190 CONTINUE ! ! SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO SRYDPB = SQRT(0.5D0*YDPB) if (TOLP < SRYDPB*ABSDX) H = TOLP/SRYDPB 200 CONTINUE ! ! FURTHER RESTRICT THE STEP LENGTH TO BE NOT ! BIGGER THAN 1/DFDUB if (H*DFDUB > 1.0D0) H = 1.0D0/DFDUB ! ! FINALLY, RESTRICT THE STEP LENGTH TO BE NOT ! SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF ! A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, ! THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE ! STEP LENGTH. H = MAX(H,100.0D0*SMALL*ABS(A)) if (H == 0.0D0) H = SMALL*ABS(B) ! ! NOW SET DIRECTION OF INTEGRATION H = SIGN(H,DX) ! return end DOUBLE PRECISION FUNCTION DHVNRM (V, NCOMP) ! !! DHVNRM computes the maximum norm of a vector. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (HVNRM-S, DHVNRM-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! Compute the maximum norm of the vector V(*) of length NCOMP and ! return the result as DHVNRM ! !***SEE ALSO DDEABM, DDEBDF, DDERKF !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891024 Changed references from DVNORM to DHVNRM. (WRB) ! 891024 Changed routine name from DVNORM to DHVNRM. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DHVNRM ! INTEGER K, NCOMP DOUBLE PRECISION V DIMENSION V(*) !***FIRST EXECUTABLE STATEMENT DHVNRM DHVNRM = 0.0D0 DO K = 1, NCOMP DHVNRM = MAX(DHVNRM,ABS(V(K))) end do return end subroutine dinit ( n, sa, x, incx ) ! !******************************************************************************* ! !! DINIT initializes a double precision vector to a constant. ! ! ! Modified: ! ! 28 October 2002 ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, double precision SA, the constant value to be used to initialize X. ! ! Output, double precision X(*), the vector to be initialized. ! ! Input, integer INCX, the increment between successive entries of X. ! implicit none ! integer i integer incx integer ix integer n double precision sa double precision x(*) ! if ( n <= 0 ) then else if ( incx == 1 ) then x(1:n) = sa else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if do i = 1, n x(ix) = sa ix = ix + incx end do end if return end subroutine DINTP (X, Y, XOUT, YOUT, YPOUT, NEQN, KOLD, PHI, IVC, & IV, KGI, GI, ALPHA, OG, OW, OX, OY) ! !! DINTP approximates the solution at XOUT by evaluating the polynomial ... ! computed in DSTEPS at XOUT. Must be used in ! conjunction with DSTEPS. ! !***LIBRARY SLATEC (DEPAC) !***CATEGORY I1A1B !***TYPE DOUBLE PRECISION (SINTRP-S, DINTP-D) !***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR, ! SMOOTH INTERPOLANT !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! The methods in subroutine DSTEPS approximate the solution near X ! by a polynomial. Subroutine DINTP approximates the solution at ! XOUT by evaluating the polynomial there. Information defining this ! polynomial is passed from DSTEPS so DINTP cannot be used alone. ! ! Subroutine DSTEPS is completely explained and documented in the text ! "Computer Solution of Ordinary Differential Equations, the Initial ! Value Problem" by L. F. Shampine and M. K. Gordon. ! ! Input to DINTP -- ! ! The user provides storage in the calling program for the arrays in ! the call list ! DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),OY(NEQN) ! AND ALPHA(12),OG(13),OW(12),GI(11),IV(10) ! and defines ! XOUT -- point at which solution is desired. ! The remaining parameters are defined in DSTEPS and passed to ! DINTP from that subroutine ! ! Output from DINTP -- ! ! YOUT(*) -- solution at XOUT ! YPOUT(*) -- derivative of solution at XOUT ! The remaining parameters are returned unaltered from their input ! values. Integration with DSTEPS may be continued. ! !***REFERENCES H. A. Watts, A smoother interpolant for DE/STEP, INTRP ! II, Report SAND84-0293, Sandia Laboratories, 1984. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 840201 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DINTP ! INTEGER I, IQ, IV, IVC, IW, J, JQ, KGI, KOLD, KP1, KP2, & L, M, NEQN DOUBLE PRECISION ALP, ALPHA, C, G, GDI, GDIF, GI, GAMMA, H, HI, & HMU, OG, OW, OX, OY, PHI, RMU, SIGMA, TEMP1, TEMP2, TEMP3, & W, X, XI, XIM1, XIQ, XOUT, Y, YOUT, YPOUT ! DIMENSION Y(*),YOUT(*),YPOUT(*),PHI(NEQN,16),OY(*) DIMENSION G(13),C(13),W(13),OG(13),OW(12),ALPHA(12),GI(11),IV(10) ! !***FIRST EXECUTABLE STATEMENT DINTP KP1 = KOLD + 1 KP2 = KOLD + 2 ! HI = XOUT - OX H = X - OX XI = HI/H XIM1 = XI - 1.D0 ! ! INITIALIZE W(*) FOR COMPUTING G(*) ! XIQ = XI DO 10 IQ = 1,KP1 XIQ = XI*XIQ TEMP1 = IQ*(IQ+1) 10 W(IQ) = XIQ/TEMP1 ! ! COMPUTE THE DOUBLE INTEGRAL TERM GDI ! if (KOLD <= KGI) go to 50 if (IVC > 0) go to 20 GDI = 1.0D0/TEMP1 M = 2 go to 30 20 IW = IV(IVC) GDI = OW(IW) M = KOLD - IW + 3 30 if (M > KOLD) go to 60 DO 40 I = M,KOLD 40 GDI = OW(KP2-I) - ALPHA(I)*GDI go to 60 50 GDI = GI(KOLD) ! ! COMPUTE G(*) AND C(*) ! 60 G(1) = XI G(2) = 0.5D0*XI*XI C(1) = 1.0D0 C(2) = XI if (KOLD < 2) go to 90 DO 80 I = 2,KOLD ALP = ALPHA(I) GAMMA = 1.0D0 + XIM1*ALP L = KP2 - I DO 70 JQ = 1,L 70 W(JQ) = GAMMA*W(JQ) - ALP*W(JQ+1) G(I+1) = W(1) 80 C(I+1) = GAMMA*C(I) ! ! DEFINE INTERPOLATION PARAMETERS ! 90 SIGMA = (W(2) - XIM1*W(1))/GDI RMU = XIM1*C(KP1)/GDI HMU = RMU/H ! ! INTERPOLATE FOR THE SOLUTION -- YOUT ! AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT ! DO 100 L = 1,NEQN YOUT(L) = 0.0D0 100 YPOUT(L) = 0.0D0 DO 120 J = 1,KOLD I = KP2 - J GDIF = OG(I) - OG(I-1) TEMP2 = (G(I) - G(I-1)) - SIGMA*GDIF TEMP3 = (C(I) - C(I-1)) + RMU*GDIF DO 110 L = 1,NEQN YOUT(L) = YOUT(L) + TEMP2*PHI(L,I) 110 YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I) 120 CONTINUE DO 130 L = 1,NEQN YOUT(L) = ((1.0D0 - SIGMA)*OY(L) + SIGMA*Y(L)) + & H*(YOUT(L) + (G(1) - SIGMA*OG(1))*PHI(L,1)) 130 YPOUT(L) = HMU*(OY(L) - Y(L)) + & (YPOUT(L) + (C(1) + RMU*OG(1))*PHI(L,1)) ! return end subroutine DINTRV (XT, LXT, X, ILO, ILEFT, MFLAG) ! !! DINTRV computes the largest integer ILEFT in 1 <= ILEFT <= LXT ... ! such that XT(ILEFT) <= X where XT(*) is a subdivision of ! the X interval. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE DOUBLE PRECISION (INTRV-S, DINTRV-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract **** a double precision routine **** ! DINTRV is the INTERV routine of the reference. ! ! DINTRV computes the largest integer ILEFT in 1 <= ILEFT <= ! LXT such that XT(ILEFT) <= X where XT(*) is a subdivision of ! the X interval. Precisely, ! ! X < XT(1) 1 -1 ! if XT(I) <= X < XT(I+1) then ILEFT=I , MFLAG=0 ! XT(LXT) <= X LXT 1, ! ! That is, when multiplicities are present in the break point ! to the left of X, the largest index is taken for ILEFT. ! ! Description of Arguments ! ! Input XT,X are double precision ! XT - XT is a knot or break point vector of length LXT ! LXT - length of the XT vector ! X - argument ! ILO - an initialization parameter which must be set ! to 1 the first time the spline array XT is ! processed by DINTRV. ! ! Output ! ILO - ILO contains information for efficient process- ! ing after the initial call and ILO must not be ! changed by the user. Distinct splines require ! distinct ILO parameters. ! ILEFT - largest integer satisfying XT(ILEFT) <= X ! MFLAG - signals when X lies out of bounds ! ! Error Conditions ! None ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DINTRV ! INTEGER IHI, ILEFT, ILO, ISTEP, LXT, MFLAG, MIDDLE DOUBLE PRECISION X, XT DIMENSION XT(*) !***FIRST EXECUTABLE STATEMENT DINTRV IHI = ILO + 1 if (IHI < LXT) go to 10 if (X >= XT(LXT)) go to 110 if (LXT <= 1) go to 90 ILO = LXT - 1 IHI = LXT ! 10 if (X >= XT(IHI)) go to 40 if (X >= XT(ILO)) go to 100 ! ! *** NOW X < XT(IHI) . FIND LOWER BOUND ISTEP = 1 20 IHI = ILO ILO = IHI - ISTEP if (ILO <= 1) go to 30 if (X >= XT(ILO)) go to 70 ISTEP = ISTEP*2 go to 20 30 ILO = 1 if (X < XT(1)) go to 90 go to 70 ! *** NOW X >= XT(ILO) . FIND UPPER BOUND 40 ISTEP = 1 50 ILO = IHI IHI = ILO + ISTEP if (IHI >= LXT) go to 60 if (X < XT(IHI)) go to 70 ISTEP = ISTEP*2 go to 50 60 if (X >= XT(LXT)) go to 110 IHI = LXT ! ! *** NOW XT(ILO) <= X < XT(IHI) . NARROW THE INTERVAL 70 MIDDLE = (ILO+IHI)/2 if (MIDDLE == ILO) go to 100 ! NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1 if (X < XT(MIDDLE)) go to 80 ILO = MIDDLE go to 70 80 IHI = MIDDLE go to 70 ! *** SET OUTPUT AND RETURN 90 MFLAG = -1 ILEFT = 1 return 100 MFLAG = 0 ILEFT = ILO return 110 MFLAG = 1 ILEFT = LXT return end subroutine DINTYD (T, K, YH, NYH, DKY, IFLAG) ! !! DINTYD approximates the ODE solution at T by polynomial interpolation. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DDEBDF !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (INTYD-S, DINTYD-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DINTYD approximates the solution and derivatives at T by polynomial ! interpolation. Must be used in conjunction with the integrator ! package DDEBDF. ! ---------------------------------------------------------------------- ! DINTYD computes interpolated values of the K-th derivative of the ! dependent variable vector Y, and stores it in DKY. ! This routine is called by DDEBDF with K = 0,1 and T = TOUT, but may ! also be called by the user for any K up to the current order. ! (see detailed instructions in LSODE usage documentation.) ! ---------------------------------------------------------------------- ! The computed values in DKY are gotten by interpolation using the ! Nordsieck history array YH. This array corresponds uniquely to a ! vector-valued polynomial of degree NQCUR or less, and DKY is set ! to the K-th derivative of this polynomial at T. ! The formula for DKY is.. ! Q ! DKY(I) = Sum C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) ! J=K ! where C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. ! The quantities NQ = NQCUR, L = NQ+1, N = NEQ, TN, and H are ! communicated by common. The above sum is done in reverse order. ! IFLAG is returned negative if either K or T is out of bounds. ! ---------------------------------------------------------------------- ! !***SEE ALSO DDEBDF !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DDEBD1 !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DINTYD ! INTEGER I, IC, IER, IFLAG, IOWND, IOWNS, J, JB, JB2, JJ, JJ1, & JP1, JSTART, K, KFLAG, L, MAXORD, METH, MITER, N, NFE, & NJE, NQ, NQU, NST, NYH DOUBLE PRECISION C, DKY, EL0, H, HMIN, HMXI, HU, R, ROWND, & ROWNS, S, T, TN, TP, UROUND, YH DIMENSION YH(NYH,*),DKY(*) COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, & IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, & MAXORD,N,NQ,NST,NFE,NJE,NQU ! ! BEGIN BLOCK PERMITTING ...EXITS TO 130 !***FIRST EXECUTABLE STATEMENT DINTYD IFLAG = 0 if (K < 0 .OR. K > NQ) go to 110 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) if ((T - TP)*(T - TN) <= 0.0D0) go to 10 IFLAG = -2 ! .........EXIT go to 130 10 CONTINUE ! S = (T - TN)/H IC = 1 if (K == 0) go to 30 JJ1 = L - K DO 20 JJ = JJ1, NQ IC = IC*JJ 20 CONTINUE 30 CONTINUE C = IC DO 40 I = 1, N DKY(I) = C*YH(I,L) 40 CONTINUE if (K == NQ) go to 90 JB2 = NQ - K DO 80 JB = 1, JB2 J = NQ - JB JP1 = J + 1 IC = 1 if (K == 0) go to 60 JJ1 = JP1 - K DO 50 JJ = JJ1, J IC = IC*JJ 50 CONTINUE 60 CONTINUE C = IC DO 70 I = 1, N DKY(I) = C*YH(I,JP1) + S*DKY(I) 70 CONTINUE 80 CONTINUE ! .........EXIT if (K == 0) go to 130 90 CONTINUE R = H**(-K) DO 100 I = 1, N DKY(I) = R*DKY(I) 100 CONTINUE go to 120 110 CONTINUE ! IFLAG = -1 120 CONTINUE 130 CONTINUE return ! ----------------------- END OF SUBROUTINE DINTYD ! ----------------------- end subroutine DIR (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, & IWORK) ! !! DIR is the Preconditioned Iterative Refinement Sparse Ax = b Solver. ! ! Routine to solve a general linear system Ax = b using ! iterative refinement with a matrix splitting. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SIR-S, DIR-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), DZ(N) ! DOUBLE PRECISION RWORK(USER DEFINED) ! EXTERNAL MATVEC, MSOLVE ! ! call DIR(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ITOL, ! $ TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, ! for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X ! upon return, X is an input vector, NELT is the number of ! non-zeros in the SLAP IA, JA, A storage for the matrix A. ! ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IWORK is an integer work array ! for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Double Precision R(N). ! Z :WORK Double Precision Z(N). ! DZ :WORK Double Precision DZ(N). ! Double Precision arrays used for workspace. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! ! *Description: ! The basic algorithm for iterative refinement (also known as ! iterative improvement) is: ! ! n+1 n -1 n ! X = X + M (B - AX ). ! ! -1 -1 ! If M = A then this is the standard iterative refinement ! algorithm and the "subtraction" in the residual calculation ! should be done in double precision (which it is not in this ! routine). ! If M = DIAG(A), the diagonal of A, then iterative refinement ! is known as Jacobi's method. The SLAP routine DSJAC ! implements this iterative strategy. ! If M = L, the lower triangle of A, then iterative refinement ! is known as Gauss-Seidel. The SLAP routine DSGS implements ! this iterative strategy. ! ! This routine does not care what matrix data structure is ! used for A and M. It simply calls the MATVEC and MSOLVE ! routines, with the arguments as described above. The user ! could write any type of structure and the appropriate MATVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK) in some fashion. The SLAP ! routines DSJAC and DSGS are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the double pre- ! cision array A. In other words, for each column in the ! matrix first put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- ! th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) ! are the last elements of the ICOL-th column. Note that we ! always have JA(N+1)=NELT+1, where N is the number of columns ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Examples: ! See the SLAP routines DSJAC, DSGS ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DSJAC, DSGS !***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, ! Johns Hopkins University Press, Baltimore, Maryland, ! 1983. ! 2. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED D1MACH, ISDIR !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) !***END PROLOGUE DIR ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), DZ(N), R(N), RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. DOUBLE PRECISION BNRM, SOLNRM, TOLMIN INTEGER I, K ! .. External Functions .. DOUBLE PRECISION D1MACH INTEGER ISDIR EXTERNAL D1MACH, ISDIR !***FIRST EXECUTABLE STATEMENT DIR ! ! Check some of the input data. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if TOLMIN = 500*D1MACH(3) if ( TOL < TOLMIN ) THEN TOL = TOLMIN IERR = 4 end if ! ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N R(I) = B(I) - R(I) 10 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! if ( ISDIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, & IWORK, BNRM, SOLNRM) /= 0 ) go to 200 if ( IERR /= 0 ) RETURN ! ! ***** iteration loop ***** ! DO 100 K=1,ITMAX ITER = K ! ! Calculate new iterate x, new residual r, and new ! pseudo-residual z. DO 20 I = 1, N X(I) = X(I) + Z(I) 20 CONTINUE call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 30 I = 1, N R(I) = B(I) - R(I) 30 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! ! check stopping criterion. if ( ISDIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, & IWORK, BNRM, SOLNRM) /= 0 ) go to 200 ! 100 CONTINUE ! ! ***** end of loop ***** ! Stopping criterion not satisfied. ITER = ITMAX + 1 IERR = 2 ! 200 return !------------- LAST LINE OF DIR FOLLOWS ------------------------------- end subroutine DJAIRY (X, RX, C, AI, DAI) ! !! DJAIRY is subsidiary to DBESJ and DBESY. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (JAIRY-S, DJAIRY-D) !***AUTHOR Amos, D. E., (SNLA) ! Daniel, S. L., (SNLA) ! Weston, M. K., (SNLA) !***DESCRIPTION ! ! DJAIRY computes the Airy function AI(X) ! and its derivative DAI(X) for DASYJY ! ! INPUT ! ! X - Argument, computed by DASYJY, X unrestricted ! RX - RX=SQRT(ABS(X)), computed by DASYJY ! C - C=2.*(ABS(X)**1.5)/3., computed by DASYJY ! ! OUTPUT ! ! AI - Value of function AI(X) ! DAI - Value of the derivative DAI(X) ! !***SEE ALSO DBESJ, DBESY !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE DJAIRY ! INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4, M4D, N1, N1D, N2, & N2D, N3, N3D, N4, N4D DOUBLE PRECISION A,AI,AJN,AJP,AK1,AK2,AK3,B,C,CCV,CON2, & CON3, CON4, CON5, CV, DA, DAI, DAJN, DAJP, DAK1, DAK2, DAK3, & DB, EC, E1, E2, FPI12, F1, F2, RTRX, RX, SCV, T, TEMP1, TEMP2, & TT, X DIMENSION AJP(19), AJN(19), A(15), B(15) DIMENSION AK1(14), AK2(23), AK3(14) DIMENSION DAJP(19), DAJN(19), DA(15), DB(15) DIMENSION DAK1(14), DAK2(24), DAK3(14) SAVE N1, N2, N3, N4, M1, M2, M3, M4, FPI12, CON2, CON3, & CON4, CON5, AK1, AK2, AK3, AJP, AJN, A, B, & N1D, N2D, N3D, N4D, M1D, M2D, M3D, M4D, DAK1, DAK2, DAK3, & DAJP, DAJN, DA, DB DATA N1,N2,N3,N4/14,23,19,15/ DATA M1,M2,M3,M4/12,21,17,13/ DATA FPI12,CON2,CON3,CON4,CON5/ & 1.30899693899575D+00, 5.03154716196777D+00, 3.80004589867293D-01, & 8.33333333333333D-01, 8.66025403784439D-01/ DATA AK1(1), AK1(2), AK1(3), AK1(4), AK1(5), AK1(6), AK1(7), & AK1(8), AK1(9), AK1(10),AK1(11),AK1(12),AK1(13), & AK1(14) / 2.20423090987793D-01,-1.25290242787700D-01, & 1.03881163359194D-02, 8.22844152006343D-04,-2.34614345891226D-04, & 1.63824280172116D-05, 3.06902589573189D-07,-1.29621999359332D-07, & 8.22908158823668D-09, 1.53963968623298D-11,-3.39165465615682D-11, & 2.03253257423626D-12,-1.10679546097884D-14,-5.16169497785080D-15/ DATA AK2(1), AK2(2), AK2(3), AK2(4), AK2(5), AK2(6), AK2(7), & AK2(8), AK2(9), AK2(10),AK2(11),AK2(12),AK2(13),AK2(14), & AK2(15),AK2(16),AK2(17),AK2(18),AK2(19),AK2(20),AK2(21), & AK2(22),AK2(23) / 2.74366150869598D-01, 5.39790969736903D-03, & -1.57339220621190D-03, 4.27427528248750D-04,-1.12124917399925D-04, & 2.88763171318904D-05,-7.36804225370554D-06, 1.87290209741024D-06, & -4.75892793962291D-07, 1.21130416955909D-07,-3.09245374270614D-08, & 7.92454705282654D-09,-2.03902447167914D-09, 5.26863056595742D-10, & -1.36704767639569D-10, 3.56141039013708D-11,-9.31388296548430D-12, & 2.44464450473635D-12,-6.43840261990955D-13, 1.70106030559349D-13, & -4.50760104503281D-14, 1.19774799164811D-14,-3.19077040865066D-15/ DATA AK3(1), AK3(2), AK3(3), AK3(4), AK3(5), AK3(6), AK3(7), & AK3(8), AK3(9), AK3(10),AK3(11),AK3(12),AK3(13), & AK3(14) / 2.80271447340791D-01,-1.78127042844379D-03, & 4.03422579628999D-05,-1.63249965269003D-06, 9.21181482476768D-08, & -6.52294330229155D-09, 5.47138404576546D-10,-5.24408251800260D-11, & 5.60477904117209D-12,-6.56375244639313D-13, 8.31285761966247D-14, & -1.12705134691063D-14, 1.62267976598129D-15,-2.46480324312426D-16/ DATA AJP(1), AJP(2), AJP(3), AJP(4), AJP(5), AJP(6), AJP(7), & AJP(8), AJP(9), AJP(10),AJP(11),AJP(12),AJP(13),AJP(14), & AJP(15),AJP(16),AJP(17),AJP(18), & AJP(19) / 7.78952966437581D-02,-1.84356363456801D-01, & 3.01412605216174D-02, 3.05342724277608D-02,-4.95424702513079D-03, & -1.72749552563952D-03, 2.43137637839190D-04, 5.04564777517082D-05, & -6.16316582695208D-06,-9.03986745510768D-07, 9.70243778355884D-08, & 1.09639453305205D-08,-1.04716330588766D-09,-9.60359441344646D-11, & 8.25358789454134D-12, 6.36123439018768D-13,-4.96629614116015D-14, & -3.29810288929615D-15, 2.35798252031104D-16/ DATA AJN(1), AJN(2), AJN(3), AJN(4), AJN(5), AJN(6), AJN(7), & AJN(8), AJN(9), AJN(10),AJN(11),AJN(12),AJN(13),AJN(14), & AJN(15),AJN(16),AJN(17),AJN(18), & AJN(19) / 3.80497887617242D-02,-2.45319541845546D-01, & 1.65820623702696D-01, 7.49330045818789D-02,-2.63476288106641D-02, & -5.92535597304981D-03, 1.44744409589804D-03, 2.18311831322215D-04, & -4.10662077680304D-05,-4.66874994171766D-06, 7.15218807277160D-07, & 6.52964770854633D-08,-8.44284027565946D-09,-6.44186158976978D-10, & 7.20802286505285D-11, 4.72465431717846D-12,-4.66022632547045D-13, & -2.67762710389189D-14, 2.36161316570019D-15/ DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), & A(8), A(9), A(10), A(11), A(12), A(13), A(14), & A(15) / 4.90275424742791D-01, 1.57647277946204D-03, & -9.66195963140306D-05, 1.35916080268815D-07, 2.98157342654859D-07, & -1.86824767559979D-08,-1.03685737667141D-09, 3.28660818434328D-10, & -2.57091410632780D-11,-2.32357655300677D-12, 9.57523279048255D-13, & -1.20340828049719D-13,-2.90907716770715D-15, 4.55656454580149D-15, & -9.99003874810259D-16/ 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) / 2.78593552803079D-01,-3.52915691882584D-03, & -2.31149677384994D-05, 4.71317842263560D-06,-1.12415907931333D-07, & -2.00100301184339D-08, 2.60948075302193D-09,-3.55098136101216D-11, & -3.50849978423875D-11, 5.83007187954202D-12,-2.04644828753326D-13, & -1.10529179476742D-13, 2.87724778038775D-14,-2.88205111009939D-15, & -3.32656311696166D-16/ DATA N1D,N2D,N3D,N4D/14,24,19,15/ DATA M1D,M2D,M3D,M4D/12,22,17,13/ DATA DAK1(1), DAK1(2), DAK1(3), DAK1(4), DAK1(5), DAK1(6), & DAK1(7), DAK1(8), DAK1(9), DAK1(10),DAK1(11),DAK1(12), & DAK1(13),DAK1(14)/ 2.04567842307887D-01,-6.61322739905664D-02, & -8.49845800989287D-03, 3.12183491556289D-03,-2.70016489829432D-04, & -6.35636298679387D-06, 3.02397712409509D-06,-2.18311195330088D-07, & -5.36194289332826D-10, 1.13098035622310D-09,-7.43023834629073D-11, & 4.28804170826891D-13, 2.23810925754539D-13,-1.39140135641182D-14/ DATA DAK2(1), DAK2(2), DAK2(3), DAK2(4), DAK2(5), DAK2(6), & DAK2(7), DAK2(8), DAK2(9), DAK2(10),DAK2(11),DAK2(12), & DAK2(13),DAK2(14),DAK2(15),DAK2(16),DAK2(17),DAK2(18), & DAK2(19),DAK2(20),DAK2(21),DAK2(22),DAK2(23), & DAK2(24) / 2.93332343883230D-01,-8.06196784743112D-03, & 2.42540172333140D-03,-6.82297548850235D-04, 1.85786427751181D-04, & -4.97457447684059D-05, 1.32090681239497D-05,-3.49528240444943D-06, & 9.24362451078835D-07,-2.44732671521867D-07, 6.49307837648910D-08, & -1.72717621501538D-08, 4.60725763604656D-09,-1.23249055291550D-09, & 3.30620409488102D-10,-8.89252099772401D-11, 2.39773319878298D-11, & -6.48013921153450D-12, 1.75510132023731D-12,-4.76303829833637D-13, & 1.29498241100810D-13,-3.52679622210430D-14, 9.62005151585923D-15, & -2.62786914342292D-15/ DATA DAK3(1), DAK3(2), DAK3(3), DAK3(4), DAK3(5), DAK3(6), & DAK3(7), DAK3(8), DAK3(9), DAK3(10),DAK3(11),DAK3(12), & DAK3(13),DAK3(14)/ 2.84675828811349D-01, 2.53073072619080D-03, & -4.83481130337976D-05, 1.84907283946343D-06,-1.01418491178576D-07, & 7.05925634457153D-09,-5.85325291400382D-10, 5.56357688831339D-11, & -5.90889094779500D-12, 6.88574353784436D-13,-8.68588256452194D-14, & 1.17374762617213D-14,-1.68523146510923D-15, 2.55374773097056D-16/ DATA DAJP(1), DAJP(2), DAJP(3), DAJP(4), DAJP(5), DAJP(6), & DAJP(7), DAJP(8), DAJP(9), DAJP(10),DAJP(11),DAJP(12), & DAJP(13),DAJP(14),DAJP(15),DAJP(16),DAJP(17),DAJP(18), & DAJP(19) / 6.53219131311457D-02,-1.20262933688823D-01, & 9.78010236263823D-03, 1.67948429230505D-02,-1.97146140182132D-03, & -8.45560295098867D-04, 9.42889620701976D-05, 2.25827860945475D-05, & -2.29067870915987D-06,-3.76343991136919D-07, 3.45663933559565D-08, & 4.29611332003007D-09,-3.58673691214989D-10,-3.57245881361895D-11, & 2.72696091066336D-12, 2.26120653095771D-13,-1.58763205238303D-14, & -1.12604374485125D-15, 7.31327529515367D-17/ DATA DAJN(1), DAJN(2), DAJN(3), DAJN(4), DAJN(5), DAJN(6), & DAJN(7), DAJN(8), DAJN(9), DAJN(10),DAJN(11),DAJN(12), & DAJN(13),DAJN(14),DAJN(15),DAJN(16),DAJN(17),DAJN(18), & DAJN(19) / 1.08594539632967D-02, 8.53313194857091D-02, & -3.15277068113058D-01,-8.78420725294257D-02, 5.53251906976048D-02, & 9.41674060503241D-03,-3.32187026018996D-03,-4.11157343156826D-04, & 1.01297326891346D-04, 9.87633682208396D-06,-1.87312969812393D-06, & -1.50798500131468D-07, 2.32687669525394D-08, 1.59599917419225D-09, & -2.07665922668385D-10,-1.24103350500302D-11, 1.39631765331043D-12, & 7.39400971155740D-14,-7.32887475627500D-15/ DATA DA(1), DA(2), DA(3), DA(4), DA(5), DA(6), DA(7), & DA(8), DA(9), DA(10), DA(11), DA(12), DA(13), DA(14), & DA(15) / 4.91627321104601D-01, 3.11164930427489D-03, & 8.23140762854081D-05,-4.61769776172142D-06,-6.13158880534626D-08, & 2.87295804656520D-08,-1.81959715372117D-09,-1.44752826642035D-10, & 4.53724043420422D-11,-3.99655065847223D-12,-3.24089119830323D-13, & 1.62098952568741D-13,-2.40765247974057D-14, 1.69384811284491D-16, & 8.17900786477396D-16/ DATA DB(1), DB(2), DB(3), DB(4), DB(5), DB(6), DB(7), & DB(8), DB(9), DB(10), DB(11), DB(12), DB(13), DB(14), & DB(15) /-2.77571356944231D-01, 4.44212833419920D-03, & -8.42328522190089D-05,-2.58040318418710D-06, 3.42389720217621D-07, & -6.24286894709776D-09,-2.36377836844577D-09, 3.16991042656673D-10, & -4.40995691658191D-12,-5.18674221093575D-12, 9.64874015137022D-13, & -4.90190576608710D-14,-1.77253430678112D-14, 5.55950610442662D-15, & -7.11793337579530D-16/ !***FIRST EXECUTABLE STATEMENT DJAIRY if (X < 0.0D0) go to 90 if (C > 5.0D0) go to 60 if (X > 1.20D0) go to 30 T = (X+X-1.2D0)*CON4 TT = T + T J = N1 F1 = AK1(J) F2 = 0.0D0 DO 10 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + AK1(J) F2 = TEMP1 10 CONTINUE AI = T*F1 - F2 + AK1(1) ! J = N1D F1 = DAK1(J) F2 = 0.0D0 DO 20 I=1,M1D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DAK1(J) F2 = TEMP1 20 CONTINUE DAI = -(T*F1-F2+DAK1(1)) return ! 30 CONTINUE T = (X+X-CON2)*CON3 TT = T + T J = N2 F1 = AK2(J) F2 = 0.0D0 DO 40 I=1,M2 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + AK2(J) F2 = TEMP1 40 CONTINUE RTRX = SQRT(RX) EC = EXP(-C) AI = EC*(T*F1-F2+AK2(1))/RTRX J = N2D F1 = DAK2(J) F2 = 0.0D0 DO 50 I=1,M2D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DAK2(J) F2 = TEMP1 50 CONTINUE DAI = -EC*(T*F1-F2+DAK2(1))*RTRX return ! 60 CONTINUE T = 10.0D0/C - 1.0D0 TT = T + T J = N1 F1 = AK3(J) F2 = 0.0D0 DO 70 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + AK3(J) F2 = TEMP1 70 CONTINUE RTRX = SQRT(RX) EC = EXP(-C) AI = EC*(T*F1-F2+AK3(1))/RTRX J = N1D F1 = DAK3(J) F2 = 0.0D0 DO 80 I=1,M1D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DAK3(J) F2 = TEMP1 80 CONTINUE DAI = -RTRX*EC*(T*F1-F2+DAK3(1)) return ! 90 CONTINUE if (C > 5.0D0) go to 120 T = 0.4D0*C - 1.0D0 TT = T + T J = N3 F1 = AJP(J) E1 = AJN(J) F2 = 0.0D0 E2 = 0.0D0 DO 100 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 100 CONTINUE AI = (T*E1-E2+AJN(1)) - X*(T*F1-F2+AJP(1)) J = N3D F1 = DAJP(J) E1 = DAJN(J) F2 = 0.0D0 E2 = 0.0D0 DO 110 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 110 CONTINUE DAI = X*X*(T*F1-F2+DAJP(1)) + (T*E1-E2+DAJN(1)) return ! 120 CONTINUE T = 10.0D0/C - 1.0D0 TT = T + T J = N4 F1 = A(J) E1 = B(J) F2 = 0.0D0 E2 = 0.0D0 DO 130 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 130 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.0D0 E2 = 0.0D0 DO 140 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 140 CONTINUE TEMP1 = T*F1 - F2 + DA(1) TEMP2 = T*E1 - E2 + DB(1) E1 = CCV*CON5 + 0.5D0*SCV E2 = SCV*CON5 - 0.5D0*CCV DAI = (TEMP1*E1-TEMP2*E2)*RTRX return end DOUBLE PRECISION FUNCTION DLBETA (A, B) ! !! DLBETA computes the natural logarithm of the complete Beta function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7B !***TYPE DOUBLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C) !***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DLBETA(A,B) calculates the double precision natural logarithm of ! the complete beta function for double precision arguments ! A and B. ! !***REFERENCES (NONE) !***ROUTINES CALLED D9LGMC, DGAMMA, DLNGAM, DLNREL, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE DLBETA DOUBLE PRECISION A, B, P, Q, CORR, SQ2PIL, D9LGMC, DGAMMA, DLNGAM, & DLNREL EXTERNAL DGAMMA SAVE SQ2PIL DATA SQ2PIL / 0.91893853320467274178032973640562D0 / !***FIRST EXECUTABLE STATEMENT DLBETA P = MIN (A, B) Q = MAX (A, B) ! if (P <= 0.D0) call XERMSG ('SLATEC', 'DLBETA', & 'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2) ! if (P >= 10.D0) go to 30 if (Q >= 10.D0) go to 20 ! ! P AND Q ARE SMALL. ! DLBETA = LOG (DGAMMA(P) * (DGAMMA(Q)/DGAMMA(P+Q)) ) return ! ! P IS SMALL, BUT Q IS BIG. ! 20 CORR = D9LGMC(Q) - D9LGMC(P+Q) DLBETA = DLNGAM(P) + CORR + P - P*LOG(P+Q) & + (Q-0.5D0)*DLNREL(-P/(P+Q)) return ! ! P AND Q ARE BIG. ! 30 CORR = D9LGMC(P) + D9LGMC(Q) - D9LGMC(P+Q) DLBETA = -0.5D0*LOG(Q) + SQ2PIL + CORR + (P-0.5D0)*LOG(P/(P+Q)) & + Q*DLNREL(-P/(P+Q)) return ! end subroutine DLGAMS (X, DLGAM, SGNGAM) ! !! DLGAMS computes the logarithm of the absolute value of the Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE DOUBLE PRECISION (ALGAMS-S, DLGAMS-D) !***KEYWORDS ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION, ! FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DLGAMS(X,DLGAM,SGNGAM) calculates the double precision natural ! logarithm of the absolute value of the Gamma function for ! double precision argument X and stores the result in double ! precision argument DLGAM. ! !***REFERENCES (NONE) !***ROUTINES CALLED DLNGAM !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DLGAMS DOUBLE PRECISION X, DLGAM, SGNGAM, DLNGAM !***FIRST EXECUTABLE STATEMENT DLGAMS DLGAM = DLNGAM(X) SGNGAM = 1.0D0 if (X > 0.D0) RETURN ! INT = MOD (-AINT(X), 2.0D0) + 0.1D0 if (INT == 0) SGNGAM = -1.0D0 ! return end DOUBLE PRECISION FUNCTION DLI (X) ! !! DLI computes the logarithmic integral. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C5 !***TYPE DOUBLE PRECISION (ALI-S, DLI-D) !***KEYWORDS FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DLI(X) calculates the double precision logarithmic integral ! for double precision argument X. ! !***REFERENCES (NONE) !***ROUTINES CALLED DEI, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DLI DOUBLE PRECISION X, DEI !***FIRST EXECUTABLE STATEMENT DLI if (X <= 0.D0) call XERMSG ('SLATEC', 'DLI', & 'LOG INTEGRAL UNDEFINED FOR X LE 0', 1, 2) if (X == 1.D0) call XERMSG ('SLATEC', 'DLI', & 'LOG INTEGRAL UNDEFINED FOR X = 0', 2, 2) ! DLI = DEI (LOG(X)) ! return end subroutine DLLSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, & NP, KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO) ! !! DLLSIA solves linear least squares problems by performing a QR ... ! factorization of the input matrix using Householder ! transformations. Emphasis is put on detecting possible ! rank deficiency. ! !***LIBRARY SLATEC !***CATEGORY D9, D5 !***TYPE DOUBLE PRECISION (LLSIA-S, DLLSIA-D) !***KEYWORDS LINEAR LEAST SQUARES, QR FACTORIZATION !***AUTHOR Manteuffel, T. A., (LANL) !***DESCRIPTION ! ! DLLSIA computes the least squares solution(s) to the problem AX=B ! where A is an M by N matrix with M >= N and B is the M by NB ! matrix of right hand sides. User input bounds on the uncertainty ! in the elements of A are used to detect numerical rank deficiency. ! The algorithm employs a row and column pivot strategy to ! minimize the growth of uncertainty and round-off errors. ! ! DLLSIA requires (MDA+6)*N + (MDB+1)*NB + M dimensioned space ! ! ****************************************************************** ! * * ! * WARNING - All input arrays are changed on exit. * ! * * ! ****************************************************************** ! SUBROUTINE DLLSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, ! 1 KRANK,KSURE,RNORM,W,LW,IWORK,LIW,INFO) ! ! Input..All TYPE REAL variables are DOUBLE PRECISION ! ! A(,) Linear coefficient matrix of AX=B, with MDA the ! MDA,M,N actual first dimension of A in the calling program. ! M is the row dimension (no. of EQUATIONS of the ! problem) and N the col dimension (no. of UNKNOWNS). ! Must have MDA >= M and M >= N. ! ! B(,) Right hand side(s), with MDB the actual first ! MDB,NB dimension of B in the calling program. NB is the ! number of M by 1 right hand sides. Must have ! MDB >= M. If NB = 0, B is never accessed. ! ! ****************************************************************** ! * * ! * Note - Use of RE and AE are what make this * ! * code significantly different from * ! * other linear least squares solvers. * ! * However, the inexperienced user is * ! * advised to set RE=0.,AE=0.,KEY=0. * ! * * ! ****************************************************************** ! RE(),AE(),KEY ! RE() RE() is a vector of length N such that RE(I) is ! the maximum relative uncertainty in column I of ! the matrix A. The values of RE() must be between ! 0 and 1. A minimum of 10*machine precision will ! be enforced. ! ! AE() AE() is a vector of length N such that AE(I) is ! the maximum absolute uncertainty in column I of ! the matrix A. The values of AE() must be greater ! than or equal to 0. ! ! KEY For ease of use, RE and AE may be input as either ! vectors or scalars. If a scalar is input, the algo- ! rithm will use that value for each column of A. ! The parameter key indicates whether scalars or ! vectors are being input. ! KEY=0 RE scalar AE scalar ! KEY=1 RE vector AE scalar ! KEY=2 RE scalar AE vector ! KEY=3 RE vector AE vector ! ! MODE The integer mode indicates how the routine ! is to react if rank deficiency is detected. ! If MODE = 0 return immediately, no solution ! 1 compute truncated solution ! 2 compute minimal length solution ! The inexperienced user is advised to set MODE=0 ! ! NP The first NP columns of A will not be interchanged ! with other columns even though the pivot strategy ! would suggest otherwise. ! The inexperienced user is advised to set NP=0. ! ! WORK() A real work array dimensioned 5*N. However, if ! RE or AE have been specified as vectors, dimension ! WORK 4*N. If both RE and AE have been specified ! as vectors, dimension WORK 3*N. ! ! LW Actual dimension of WORK ! ! IWORK() Integer work array dimensioned at least N+M. ! ! LIW Actual dimension of IWORK. ! ! INFO Is a flag which provides for the efficient ! solution of subsequent problems involving the ! same A but different B. ! If INFO = 0 original call ! INFO = 1 subsequent calls ! On subsequent calls, the user must supply A, KRANK, ! LW, IWORK, LIW, and the first 2*N locations of WORK ! as output by the original call to DLLSIA. MODE must ! be equal to the value of MODE in the original call. ! If MODE < 2, only the first N locations of WORK ! are accessed. AE, RE, KEY, and NP are not accessed. ! ! Output..All TYPE REAL variable are DOUBLE PRECISION ! ! A(,) Contains the upper triangular part of the reduced ! matrix and the transformation information. It togeth ! with the first N elements of WORK (see below) ! completely specify the QR factorization of A. ! ! B(,) Contains the N by NB solution matrix for X. ! ! KRANK,KSURE The numerical rank of A, based upon the relative ! and absolute bounds on uncertainty, is bounded ! above by KRANK and below by KSURE. The algorithm ! returns a solution based on KRANK. KSURE provides ! an indication of the precision of the rank. ! ! RNORM() Contains the Euclidean length of the NB residual ! vectors B(I)-AX(I), I=1,NB. ! ! WORK() The first N locations of WORK contain values ! necessary to reproduce the Householder ! transformation. ! ! IWORK() The first N locations contain the order in ! which the columns of A were used. The next ! M locations contain the order in which the ! rows of A were used. ! ! INFO Flag to indicate status of computation on completion ! -1 Parameter error(s) ! 0 - Rank deficient, no solution ! 1 - Rank deficient, truncated solution ! 2 - Rank deficient, minimal length solution ! 3 - Numerical rank 0, zero solution ! 4 - Rank < NP ! 5 - Full rank ! !***REFERENCES T. Manteuffel, An interval analysis approach to rank ! determination in linear least squares problems, ! Report SAND80-0655, Sandia Laboratories, June 1980. !***ROUTINES CALLED D1MACH, DU11LS, DU12LS, XERMSG !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Fixed an error message. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DLLSIA IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION D1MACH DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*) INTEGER IWORK(*) ! !***FIRST EXECUTABLE STATEMENT DLLSIA if ( INFO < 0 .OR. INFO > 1) go to 514 IT=INFO INFO=-1 if ( NB == 0 .AND. IT == 1) go to 501 if ( M < 1) go to 502 if ( N < 1) go to 503 if ( N > M) go to 504 if ( MDA < M) go to 505 if ( LIW < M+N) go to 506 if ( MODE < 0 .OR. MODE > 3) go to 515 if ( NB == 0) go to 4 if ( NB < 0) go to 507 if ( MDB < M) go to 508 if ( IT == 0) go to 4 go to 400 4 if ( KEY < 0.OR.KEY > 3) go to 509 if ( KEY == 0 .AND. LW < 5*N) go to 510 if ( KEY == 1 .AND. LW < 4*N) go to 510 if ( KEY == 2 .AND. LW < 4*N) go to 510 if ( KEY == 3 .AND. LW < 3*N) go to 510 if ( NP < 0 .OR. NP > N) go to 516 ! EPS=10.*D1MACH(3) N1=1 N2=N1+N N3=N2+N N4=N3+N N5=N4+N ! if ( KEY == 1) go to 100 if ( KEY == 2) go to 200 if ( KEY == 3) go to 300 ! if ( RE(1) < 0.0D0) go to 511 if ( RE(1) > 1.0D0) go to 512 if ( RE(1) < EPS) RE(1)=EPS if ( AE(1) < 0.0D0) go to 513 DO 20 I=1,N W(N4-1+I)=RE(1) W(N5-1+I)=AE(1) 20 CONTINUE call DU11LS(A,MDA,M,N,W(N4),W(N5),MODE,NP,KRANK,KSURE, & W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) go to 400 ! 100 CONTINUE if ( AE(1) < 0.0D0) go to 513 DO 120 I=1,N if ( RE(I) < 0.0D0) go to 511 if ( RE(I) > 1.0D0) go to 512 if ( RE(I) < EPS) RE(I)=EPS W(N4-1+I)=AE(1) 120 CONTINUE call DU11LS(A,MDA,M,N,RE,W(N4),MODE,NP,KRANK,KSURE, & W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) go to 400 ! 200 CONTINUE if ( RE(1) < 0.0D0) go to 511 if ( RE(1) > 1.0D0) go to 512 if ( RE(1) < EPS) RE(1)=EPS DO 220 I=1,N W(N4-1+I)=RE(1) if ( AE(I) < 0.0D0) go to 513 220 CONTINUE call DU11LS(A,MDA,M,N,W(N4),AE,MODE,NP,KRANK,KSURE, & W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) go to 400 ! 300 CONTINUE DO 320 I=1,N if ( RE(I) < 0.0D0) go to 511 if ( RE(I) > 1.0D0) go to 512 if ( RE(I) < EPS) RE(I)=EPS if ( AE(I) < 0.0D0) go to 513 320 CONTINUE call DU11LS(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE, & W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) ! ! DETERMINE INFO ! 400 if ( KRANK /= N) go to 402 INFO=5 go to 410 402 if ( KRANK /= 0) go to 404 INFO=3 go to 410 404 if ( KRANK >= NP) go to 406 INFO=4 return 406 INFO=MODE if ( MODE == 0) RETURN 410 if ( NB == 0) RETURN ! ! SOLUTION PHASE ! N1=1 N2=N1+N N3=N2+N if ( INFO == 2) go to 420 if ( LW < N2-1) go to 510 call DU12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK, & RNORM,W(N1),W(N1),IWORK(N1),IWORK(N2)) return ! 420 if ( LW < N3-1) go to 510 call DU12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK, & RNORM,W(N1),W(N2),IWORK(N1),IWORK(N2)) return ! ! ERROR MESSAGES ! 501 call XERMSG ('SLATEC', 'DLLSIA', & 'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0) return 502 call XERMSG ('SLATEC', 'DLLSIA', 'M < 1', 2, 1) return 503 call XERMSG ('SLATEC', 'DLLSIA', 'N < 1', 2, 1) return 504 call XERMSG ('SLATEC', 'DLLSIA', 'N > M', 2, 1) return 505 call XERMSG ('SLATEC', 'DLLSIA', 'MDA < M', 2, 1) return 506 call XERMSG ('SLATEC', 'DLLSIA', 'LIW < M+N', 2, 1) return 507 call XERMSG ('SLATEC', 'DLLSIA', 'NB < 0', 2, 1) return 508 call XERMSG ('SLATEC', 'DLLSIA', 'MDB < M', 2, 1) return 509 call XERMSG ('SLATEC', 'DLLSIA', 'KEY OUT OF RANGE', 2, 1) return 510 call XERMSG ('SLATEC', 'DLLSIA', 'INSUFFICIENT WORK SPACE', 8, 1) INFO=-1 return 511 call XERMSG ('SLATEC', 'DLLSIA', 'RE(I) < 0', 2, 1) return 512 call XERMSG ('SLATEC', 'DLLSIA', 'RE(I) > 1', 2, 1) return 513 call XERMSG ('SLATEC', 'DLLSIA', 'AE(I) < 0', 2, 1) return 514 call XERMSG ('SLATEC', 'DLLSIA', 'INFO OUT OF RANGE', 2, 1) return 515 call XERMSG ('SLATEC', 'DLLSIA', 'MODE OUT OF RANGE', 2, 1) return 516 call XERMSG ('SLATEC', 'DLLSIA', 'NP OUT OF RANGE', 2, 1) return end subroutine DLLTI2 (N, B, X, NEL, IEL, JEL, EL, DINV) ! !! DLLTI2 is the SLAP Backsolve routine for LDL' Factorization. ! ! Routine to solve a system of the form L*D*L' X = B, ! where L is a unit lower triangular matrix and D is a ! diagonal matrix and ' means transpose. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SLLTI2-S, DLLTI2-D) !***KEYWORDS INCOMPLETE FACTORIZATION, ITERATIVE PRECONDITION, SLAP, ! SPARSE, SYMMETRIC LINEAR SYSTEM SOLVE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NEL, IEL(NEL), JEL(NEL) ! DOUBLE PRECISION B(N), X(N), EL(NEL), DINV(N) ! ! call DLLTI2( N, B, X, NEL, IEL, JEL, EL, DINV ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right hand side vector. ! X :OUT Double Precision X(N). ! Solution to L*D*L' x = b. ! NEL :IN Integer. ! Number of non-zeros in the EL array. ! IEL :IN Integer IEL(NEL). ! JEL :IN Integer JEL(NEL). ! EL :IN Double Precision EL(NEL). ! IEL, JEL, EL contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in ! SLAP Row format. The diagonal of ones *IS* stored. This ! structure can be set up by the DS2LT routine. See the ! "Description", below for more details about the SLAP Row ! format. ! DINV :IN Double Precision DINV(N). ! Inverse of the diagonal matrix D. ! ! *Description: ! This routine is supplied with the SLAP package as a routine ! to perform the MSOLVE operation in the SCG iteration routine ! for the driver routine DSICCG. It must be called via the ! SLAP MSOLVE calling sequence convention interface routine ! DSLLI. ! **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** ! **** SLAP MSOLVE CALLING CONVENTION **** ! ! IEL, JEL, EL should contain the unit lower triangular factor ! of the incomplete decomposition of the A matrix stored in ! SLAP Row format. This IC factorization can be computed by ! the DSICS routine. The diagonal (which is all one's) is ! stored. ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the ! double precision array A. In other words, for each row in ! the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going across the row (except the ! diagonal) in order. The JA array holds the column index for ! each non-zero. The IA array holds the offsets into the JA, ! A arrays for the beginning of each row. That is, ! JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- ! th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! are the last elements of the IROW-th row. Note that we ! always have IA(N+1) = NELT+1, where N is the number of rows ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP Row format the "inner loop" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! !***SEE ALSO DSICCG, DSICS !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DLLTI2 ! .. Scalar Arguments .. INTEGER N, NEL ! .. Array Arguments .. DOUBLE PRECISION B(N), DINV(N), EL(NEL), X(N) INTEGER IEL(NEL), JEL(NEL) ! .. Local Scalars .. INTEGER I, IBGN, IEND, IROW !***FIRST EXECUTABLE STATEMENT DLLTI2 ! ! Solve L*y = b, storing result in x. ! DO 10 I=1,N X(I) = B(I) 10 CONTINUE DO 30 IROW = 1, N IBGN = IEL(IROW) + 1 IEND = IEL(IROW+1) - 1 if ( IBGN <= IEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NOCONCUR !VD$ NODEPCHK DO 20 I = IBGN, IEND X(IROW) = X(IROW) - EL(I)*X(JEL(I)) 20 CONTINUE ENDIF 30 CONTINUE ! ! Solve D*Z = Y, storing result in X. ! DO 40 I=1,N X(I) = X(I)*DINV(I) 40 CONTINUE ! ! Solve L-trans*X = Z. ! DO 60 IROW = N, 2, -1 IBGN = IEL(IROW) + 1 IEND = IEL(IROW+1) - 1 if ( IBGN <= IEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NOCONCUR !VD$ NODEPCHK DO 50 I = IBGN, IEND X(JEL(I)) = X(JEL(I)) - EL(I)*X(IROW) 50 CONTINUE ENDIF 60 CONTINUE ! return !------------- LAST LINE OF DLLTI2 FOLLOWS ---------------------------- end DOUBLE PRECISION FUNCTION DLNGAM (X) ! !! DLNGAM computes the logarithm of the absolute value of the Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE DOUBLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C) !***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DLNGAM(X) calculates the double precision logarithm of the ! absolute value of the Gamma function for double precision ! argument X. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, D9LGMC, DGAMMA, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE DLNGAM DOUBLE PRECISION X, DXREL, PI, SINPIY, SQPI2L, SQ2PIL, XMAX, & Y, DGAMMA, D9LGMC, D1MACH, TEMP LOGICAL FIRST EXTERNAL DGAMMA SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST DATA SQ2PIL / 0.91893853320467274178032973640562D0 / DATA SQPI2L / +.225791352644727432363097614947441D+0 / DATA PI / 3.14159265358979323846264338327950D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DLNGAM if (FIRST) THEN TEMP = 1.D0/LOG(D1MACH(2)) XMAX = TEMP*D1MACH(2) DXREL = SQRT(D1MACH(4)) end if FIRST = .FALSE. ! Y = ABS (X) if (Y > 10.D0) go to 20 ! ! LOG (ABS (DGAMMA(X)) ) FOR ABS(X) <= 10.0 ! DLNGAM = LOG (ABS (DGAMMA(X)) ) return ! ! LOG ( ABS (DGAMMA(X)) ) FOR ABS(X) > 10.0 ! 20 if (Y > XMAX) call XERMSG ('SLATEC', 'DLNGAM', & 'ABS(X) SO BIG DLNGAM OVERFLOWS', 2, 2) ! if (X > 0.D0) DLNGAM = SQ2PIL + (X-0.5D0)*LOG(X) - X + D9LGMC(Y) if (X > 0.D0) RETURN ! SINPIY = ABS (SIN(PI*Y)) if (SINPIY == 0.D0) call XERMSG ('SLATEC', 'DLNGAM', & 'X IS A NEGATIVE INTEGER', 3, 2) ! if (ABS((X-AINT(X-0.5D0))/X) < DXREL) call XERMSG ('SLATEC', & 'DLNGAM', & 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', & 1, 1) ! DLNGAM = SQPI2L + (X-0.5D0)*LOG(Y) - X - LOG(SINPIY) - D9LGMC(Y) return ! end DOUBLE PRECISION FUNCTION DLNREL (X) ! !! DLNREL evaluates ln(1+X) accurate in the sense of relative error. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4B !***TYPE DOUBLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C) !***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DLNREL(X) calculates the double precision natural logarithm of ! (1.0+X) for double precision argument X. This routine should ! be used when X is small and accurate to calculate the logarithm ! accurately (in the relative error sense) in the neighborhood ! of 1.0. ! ! Series for ALNR on the interval -3.75000E-01 to 3.75000E-01 ! with weighted error 6.35E-32 ! log weighted error 31.20 ! significant figures required 30.93 ! decimal places required 32.01 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DLNREL DOUBLE PRECISION ALNRCS(43), X, XMIN, DCSEVL, D1MACH LOGICAL FIRST SAVE ALNRCS, NLNREL, XMIN, FIRST DATA ALNRCS( 1) / +.10378693562743769800686267719098D+1 / DATA ALNRCS( 2) / -.13364301504908918098766041553133D+0 / DATA ALNRCS( 3) / +.19408249135520563357926199374750D-1 / DATA ALNRCS( 4) / -.30107551127535777690376537776592D-2 / DATA ALNRCS( 5) / +.48694614797154850090456366509137D-3 / DATA ALNRCS( 6) / -.81054881893175356066809943008622D-4 / DATA ALNRCS( 7) / +.13778847799559524782938251496059D-4 / DATA ALNRCS( 8) / -.23802210894358970251369992914935D-5 / DATA ALNRCS( 9) / +.41640416213865183476391859901989D-6 / DATA ALNRCS( 10) / -.73595828378075994984266837031998D-7 / DATA ALNRCS( 11) / +.13117611876241674949152294345011D-7 / DATA ALNRCS( 12) / -.23546709317742425136696092330175D-8 / DATA ALNRCS( 13) / +.42522773276034997775638052962567D-9 / DATA ALNRCS( 14) / -.77190894134840796826108107493300D-10 / DATA ALNRCS( 15) / +.14075746481359069909215356472191D-10 / DATA ALNRCS( 16) / -.25769072058024680627537078627584D-11 / DATA ALNRCS( 17) / +.47342406666294421849154395005938D-12 / DATA ALNRCS( 18) / -.87249012674742641745301263292675D-13 / DATA ALNRCS( 19) / +.16124614902740551465739833119115D-13 / DATA ALNRCS( 20) / -.29875652015665773006710792416815D-14 / DATA ALNRCS( 21) / +.55480701209082887983041321697279D-15 / DATA ALNRCS( 22) / -.10324619158271569595141333961932D-15 / DATA ALNRCS( 23) / +.19250239203049851177878503244868D-16 / DATA ALNRCS( 24) / -.35955073465265150011189707844266D-17 / DATA ALNRCS( 25) / +.67264542537876857892194574226773D-18 / DATA ALNRCS( 26) / -.12602624168735219252082425637546D-18 / DATA ALNRCS( 27) / +.23644884408606210044916158955519D-19 / DATA ALNRCS( 28) / -.44419377050807936898878389179733D-20 / DATA ALNRCS( 29) / +.83546594464034259016241293994666D-21 / DATA ALNRCS( 30) / -.15731559416479562574899253521066D-21 / DATA ALNRCS( 31) / +.29653128740247422686154369706666D-22 / DATA ALNRCS( 32) / -.55949583481815947292156013226666D-23 / DATA ALNRCS( 33) / +.10566354268835681048187284138666D-23 / DATA ALNRCS( 34) / -.19972483680670204548314999466666D-24 / DATA ALNRCS( 35) / +.37782977818839361421049855999999D-25 / DATA ALNRCS( 36) / -.71531586889081740345038165333333D-26 / DATA ALNRCS( 37) / +.13552488463674213646502024533333D-26 / DATA ALNRCS( 38) / -.25694673048487567430079829333333D-27 / DATA ALNRCS( 39) / +.48747756066216949076459519999999D-28 / DATA ALNRCS( 40) / -.92542112530849715321132373333333D-29 / DATA ALNRCS( 41) / +.17578597841760239233269760000000D-29 / DATA ALNRCS( 42) / -.33410026677731010351377066666666D-30 / DATA ALNRCS( 43) / +.63533936180236187354180266666666D-31 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DLNREL if (FIRST) THEN NLNREL = INITDS (ALNRCS, 43, 0.1*REAL(D1MACH(3))) XMIN = -1.0D0 + SQRT(D1MACH(4)) end if FIRST = .FALSE. ! if (X <= (-1.D0)) call XERMSG ('SLATEC', 'DLNREL', 'X IS LE -1' & , 2, 2) if (X < XMIN) call XERMSG ('SLATEC', 'DLNREL', & 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1) ! if (ABS(X) <= 0.375D0) DLNREL = X*(1.D0 - & X*DCSEVL (X/.375D0, ALNRCS, NLNREL)) ! if (ABS(X) > 0.375D0) DLNREL = LOG (1.0D0+X) ! return end subroutine DLPDOC ! !! DLPDOC is the Sparse Linear Algebra Package Version 2.0.2 Documentation. ! ! Routines to solve large sparse symmetric and nonsymmetric ! positive definite linear systems, Ax = b, using precondi- ! tioned iterative methods. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4, Z !***TYPE DOUBLE PRECISION (SLPDOC-S, DLPDOC-D) !***KEYWORDS BICONJUGATE GRADIENT SQUARED, DOCUMENTATION, ! GENERALIZED MINIMUM RESIDUAL, ITERATIVE IMPROVEMENT, ! NORMAL EQUATIONS, ORTHOMIN, ! PRECONDITIONED CONJUGATE GRADIENT, SLAP, ! SPARSE ITERATIVE METHODS !***AUTHOR Seager, Mark. K., (LLNL) ! User Systems Division ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 ! (FTS) 543-3141, (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! The ! Sparse Linear Algebra Package ! Double Precision Routines ! ! @@@@@@@ @ @@@ @@@@@@@@ ! @ @ @ @ @ @ @ ! @ @ @ @ @ @ ! @@@@@@@ @ @ @ @@@@@@@@ ! @ @ @@@@@@@@@ @ ! @ @ @ @ @ @ ! @@@@@@@ @@@@@@@@@ @ @ @ ! ! @ @ @@@@@@@ @@@@@ ! @ @ @ @ @ @@ ! @ @ @@@@@@@ @ @@ @ @ @ @ ! @ @ @ @ @@ @ @@@@@@ @ @ @ ! @ @ @@@@@@@@@ @ @ @ @ @ ! @ @ @ @ @ @@@ @@ @ ! @@@ @@@@@@@ @ @@@@@@@@@ @@@ @@@@@ ! ! ! ================================================================= ! ========================== Introduction ========================= ! ================================================================= ! This package was originally derived from a set of iterative ! routines written by Anne Greenbaum, as announced in "Routines ! for Solving Large Sparse Linear Systems", Tentacle, Lawrence ! Livermore National Laboratory, Livermore Computing Center ! (January 1986), pp 15-21. ! ! This document contains the specifications for the SLAP Version ! 2.0 package, a Fortran 77 package for the solution of large ! sparse linear systems, Ax = b, via preconditioned iterative ! methods. Included in this package are "core" routines to do ! Iterative Refinement (Jacobi's method), Conjugate Gradient, ! Conjugate Gradient on the normal equations, AA'y = b, (where x = ! A'y and A' denotes the transpose of A), BiConjugate Gradient, ! BiConjugate Gradient Squared, Orthomin and Generalized Minimum ! Residual Iteration. These "core" routines do not require a ! "fixed" data structure for storing the matrix A and the ! preconditioning matrix M. The user is free to choose any ! structure that facilitates efficient solution of the problem at ! hand. The drawback to this approach is that the user must also ! supply at least two routines (MATVEC and MSOLVE, say). MATVEC ! must calculate, y = Ax, given x and the user's data structure for ! A. MSOLVE must solve, r = Mz, for z (*NOT* r) given r and the ! user's data structure for M (or its inverse). The user should ! choose M so that inv(M)*A is approximately the identity and the ! solution step r = Mz is "easy" to solve. For some of the "core" ! routines (Orthomin, BiConjugate Gradient and Conjugate Gradient ! on the normal equations) the user must also supply a matrix ! transpose times vector routine (MTTVEC, say) and (possibly, ! depending on the "core" method) a routine that solves the ! transpose of the preconditioning step (MTSOLV, say). ! Specifically, MTTVEC is a routine which calculates y = A'x, given ! x and the user's data structure for A (A' is the transpose of A). ! MTSOLV is a routine which solves the system r = M'z for z given r ! and the user's data structure for M. ! ! This process of writing the matrix vector operations can be time ! consuming and error prone. To alleviate these problems we have ! written drivers for the "core" methods that assume the user ! supplies one of two specific data structures (SLAP Triad and SLAP ! Column format), see below. Utilizing these data structures we ! have augmented each "core" method with two preconditioners: ! Diagonal Scaling and Incomplete Factorization. Diagonal scaling ! is easy to implement, vectorizes very well and for problems that ! are not too ill-conditioned reduces the number of iterations ! enough to warrant its use. On the other hand, an Incomplete ! factorization (Incomplete Cholesky for symmetric systems and ! Incomplete LU for nonsymmetric systems) may take much longer to ! calculate, but it reduces the iteration count (for most problems) ! significantly. Our implementations of IC and ILU vectorize for ! machines with hardware gather scatter, but the vector lengths can ! be quite short if the number of non-zeros in a column is not ! large. ! ! ================================================================= ! ==================== Supplied Data Structures =================== ! ================================================================= ! The following describes the data structures supplied with the ! package: SLAP Triad and Column formats. ! ! ====================== S L A P Triad format ===================== ! ! In the SLAP Triad format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of length ! NELT, where NELT is the number of non-zeros in the matrix: ! (IA(NELT), JA(NELT), A(NELT)). If the matrix is symmetric then ! one need only store the lower triangle (including the diagonal) ! and NELT would be the corresponding number of non-zeros stored. ! For each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding location ! of the A array. This is an extremely easy data structure to ! generate. On the other hand, it is not very efficient on vector ! computers for the iterative solution of linear systems. Hence, ! SLAP changes this input data structure to the SLAP Column format ! for the iteration (but does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! nonsymmetric 5x5 Matrix. NELT=11. Recall that the entries may ! appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! ====================== S L A P Column format ==================== ! ! In the SLAP Column format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear first ! in each "column") and are stored in the double precision array A. ! In other words, for each column in the matrix first put the ! diagonal entry in A. Then put in the other non-zero elements ! going down the column (except the diagonal) in order. The IA ! array holds the row index for each non-zero. The JA array holds ! the offsets into the IA, A arrays for the beginning of each ! column. That is, IA(JA(ICOL)), A(JA(ICOL)) are the first elements ! of the ICOL-th column in IA and A, and IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) are the last elements of the ICOL-th column. Note ! that we always have JA(N+1) = NELT+1, where N is the number of ! columns in the matrix and NELT is the number of non-zeros in the ! matrix. If the matrix is symmetric one need only store the lower ! triangle (including the diagonal) and NELT would be the corre- ! sponding number of non-zeros stored. ! ! Here is an example of the SLAP Column storage format for a ! nonsymmetric 5x5 Matrix (in the A and IA arrays '|' denotes the ! end of a column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ================================================================= ! ====================== Which Method To Use ====================== ! ================================================================= ! ! BACKGROUND ! In solving a large sparse linear system Ax = b using an iterative ! method, it is not necessary to actually store the matrix A. ! Rather, what is needed is a procedure for multiplying the matrix ! A times a given vector y to obtain the matrix-vector product, Ay. ! SLAP has been written to take advantage of this fact. The higher ! level routines in the package require storage only of the non-zero ! elements of A (and their positions), and even this can be ! avoided, if the user writes his own subroutine for multiplying ! the matrix times a vector and calls the lower-level iterative ! routines in the package. ! ! If the matrix A is ill-conditioned, then most iterative methods ! will be slow to converge (if they converge at all!). To improve ! the convergence rate, one may use a "matrix splitting," or, ! "preconditioning matrix," say, M. It is then necessary to solve, ! at each iteration, a linear system with coefficient matrix M. A ! good preconditioner M should have two properties: (1) M should ! "approximate" A, in the sense that the matrix inv(M)*A (or some ! variant thereof) is better conditioned than the original matrix ! A; and (2) linear systems with coefficient matrix M should be ! much easier to solve than the original system with coefficient ! matrix A. Preconditioning routines in the SLAP package are ! separate from the iterative routines, so that any of the ! preconditioners provided in the package, or one that the user ! codes himself, can be used with any of the iterative routines. ! ! CHOICE OF PRECONDITIONER ! If you willing to live with either the SLAP Triad or Column ! matrix data structure you can then choose one of two types of ! preconditioners to use: diagonal scaling or incomplete ! factorization. To choose between these two methods requires ! knowing something about the computer you're going to run these ! codes on and how well incomplete factorization approximates the ! inverse of your matrix. ! ! Let us suppose you have a scalar machine. Then, unless the ! incomplete factorization is very, very poor this is *GENERALLY* ! the method to choose. It will reduce the number of iterations ! significantly and is not all that expensive to compute. So if ! you have just one linear system to solve and "just want to get ! the job done" then try incomplete factorization first. If you ! are thinking of integrating some SLAP iterative method into your ! favorite "production code" then try incomplete factorization ! first, but also check to see that diagonal scaling is indeed ! slower for a large sample of test problems. ! ! Let us now suppose you have a vector computer with hardware ! gather/scatter support (Cray X-MP, Y-MP, SCS-40 or Cyber 205, ETA ! 10, ETA Piper, Convex C-1, etc.). Then it is much harder to ! choose between the two methods. The versions of incomplete ! factorization in SLAP do in fact vectorize, but have short vector ! lengths and the factorization step is relatively more expensive. ! Hence, for most problems (i.e., unless your problem is ill ! conditioned, sic!) diagonal scaling is faster, with its very ! fast set up time and vectorized (with long vectors) ! preconditioning step (even though it may take more iterations). ! If you have several systems (or right hand sides) to solve that ! can utilize the same preconditioner then the cost of the ! incomplete factorization can be amortized over these several ! solutions. This situation gives more advantage to the incomplete ! factorization methods. If you have a vector machine without ! hardware gather/scatter (Cray 1, Cray 2 & Cray 3) then the ! advantages for incomplete factorization are even less. ! ! If you're trying to shoehorn SLAP into your favorite "production ! code" and can not easily generate either the SLAP Triad or Column ! format then you are left to your own devices in terms of ! preconditioning. Also, you may find that the preconditioners ! supplied with SLAP are not sufficient for your problem. In this ! situation we would recommend that you talk with a numerical ! analyst versed in iterative methods about writing other ! preconditioning subroutines (e.g., polynomial preconditioning, ! shifted incomplete factorization, SOR or SSOR iteration). You ! can always "roll your own" by using the "core" iterative methods ! and supplying your own MSOLVE and MATVEC (and possibly MTSOLV and ! MTTVEC) routines. ! ! SYMMETRIC SYSTEMS ! If your matrix is symmetric then you would want to use one of the ! symmetric system solvers. If your system is also positive ! definite, (Ax,x) (Ax dot product with x) is positive for all ! non-zero vectors x, then use Conjugate Gradient (DCG, DSDCG, ! DSICSG). If you're not sure it's SPD (symmetric and Positive ! Definite) then try DCG anyway and if it works, fine. If you're ! sure your matrix is not positive definite then you may want to ! try the iterative refinement methods (DIR) or the GMRES code ! (DGMRES) if DIR converges too slowly. ! ! NONSYMMETRIC SYSTEMS ! This is currently an area of active research in numerical ! analysis and there are new strategies being developed. ! Consequently take the following advice with a grain of salt. If ! you matrix is positive definite, (Ax,x) (Ax dot product with x ! is positive for all non-zero vectors x), then you can use any of ! the methods for nonsymmetric systems (Orthomin, GMRES, ! BiConjugate Gradient, BiConjugate Gradient Squared and Conjugate ! Gradient applied to the normal equations). If your system is not ! too ill conditioned then try BiConjugate Gradient Squared (BCGS) ! or GMRES (DGMRES). Both of these methods converge very quickly ! and do not require A' or M' (' denotes transpose) information. ! DGMRES does require some additional storage, though. If the ! system is very ill conditioned or nearly positive indefinite ! ((Ax,x) is positive, but may be very small), then GMRES should ! be the first choice, but try the other methods if you have to ! fine tune the solution process for a "production code". If you ! have a great preconditioner for the normal equations (i.e., M is ! an approximation to the inverse of AA' rather than just A) then ! this is not a bad route to travel. Old wisdom would say that the ! normal equations are a disaster (since it squares the condition ! number of the system and DCG convergence is linked to this number ! of infamy), but some preconditioners (like incomplete ! factorization) can reduce the condition number back below that of ! the original system. ! ! ================================================================= ! ======================= Naming Conventions ====================== ! ================================================================= ! SLAP iterative methods, matrix vector and preconditioner ! calculation routines follow a naming convention which, when ! understood, allows one to determine the iterative method and data ! structure(s) used. The subroutine naming convention takes the ! following form: ! P[S][M]DESC ! where ! P stands for the precision (or data type) of the routine and ! is required in all names, ! S denotes whether or not the routine requires the SLAP Triad ! or Column format (it does if the second letter of the name ! is S and does not otherwise), ! M stands for the type of preconditioner used (only appears ! in drivers for "core" routines), and ! DESC is some number of letters describing the method or purpose ! of the routine. The following is a list of the "DESC" ! fields for iterative methods and their meaning: ! BCG,BC: BiConjugate Gradient ! CG: Conjugate Gradient ! CGN,CN: Conjugate Gradient on the Normal equations ! CGS,CS: biConjugate Gradient Squared ! GMRES,GMR,GM: Generalized Minimum RESidual ! IR,R: Iterative Refinement ! JAC: JACobi's method ! GS: Gauss-Seidel ! OMN,OM: OrthoMiN ! ! In the double precision version of SLAP, all routine names start ! with a D. The brackets around the S and M designate that these ! fields are optional. ! ! Here are some examples of the routines: ! 1) DBCG: Double precision BiConjugate Gradient "core" routine. ! One can deduce that this is a "core" routine, because the S and ! M fields are missing and BiConjugate Gradient is an iterative ! method. ! 2) DSDBCG: Double precision, SLAP data structure BCG with Diagonal ! scaling. ! 3) DSLUBC: Double precision, SLAP data structure BCG with incom- ! plete LU factorization as the preconditioning. ! 4) DCG: Double precision Conjugate Gradient "core" routine. ! 5) DSDCG: Double precision, SLAP data structure Conjugate Gradient ! with Diagonal scaling. ! 6) DSICCG: Double precision, SLAP data structure Conjugate Gra- ! dient with Incomplete Cholesky factorization preconditioning. ! ! ! ================================================================= ! ===================== USER CALLABLE ROUTINES ==================== ! ================================================================= ! The following is a list of the "user callable" SLAP routines and ! their one line descriptions. The headers denote the file names ! where the routines can be found, as distributed for UNIX systems. ! ! Note: Each core routine, DXXX, has a corresponding stop routine, ! ISDXXX. If the stop routine does not have the specific stop ! test the user requires (e.g., weighted infinity norm), then ! the user should modify the source for ISDXXX accordingly. ! ! ============================= dir.f ============================= ! DIR: Preconditioned Iterative Refinement Sparse Ax = b Solver. ! DSJAC: Jacobi's Method Iterative Sparse Ax = b Solver. ! DSGS: Gauss-Seidel Method Iterative Sparse Ax = b Solver. ! DSILUR: Incomplete LU Iterative Refinement Sparse Ax = b Solver. ! ! ============================= dcg.f ============================= ! DCG: Preconditioned Conjugate Gradient Sparse Ax=b Solver. ! DSDCG: Diagonally Scaled Conjugate Gradient Sparse Ax=b Solver. ! DSICCG: Incomplete Cholesky Conjugate Gradient Sparse Ax=b Solver. ! ! ============================= dcgn.f ============================ ! DCGN: Preconditioned CG Sparse Ax=b Solver for Normal Equations. ! DSDCGN: Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's. ! DSLUCN: Incomplete LU CG Sparse Ax=b Solver for Normal Equations. ! ! ============================= dbcg.f ============================ ! DBCG: Preconditioned BiConjugate Gradient Sparse Ax = b Solver. ! DSDBCG: Diagonally Scaled BiConjugate Gradient Sparse Ax=b Solver. ! DSLUBC: Incomplete LU BiConjugate Gradient Sparse Ax=b Solver. ! ! ============================= dcgs.f ============================ ! DCGS: Preconditioned BiConjugate Gradient Squared Ax=b Solver. ! DSDCGS: Diagonally Scaled CGS Sparse Ax=b Solver. ! DSLUCS: Incomplete LU BiConjugate Gradient Squared Ax=b Solver. ! ! ============================= domn.f ============================ ! DOMN: Preconditioned Orthomin Sparse Iterative Ax=b Solver. ! DSDOMN: Diagonally Scaled Orthomin Sparse Iterative Ax=b Solver. ! DSLUOM: Incomplete LU Orthomin Sparse Iterative Ax=b Solver. ! ! ============================ dgmres.f =========================== ! DGMRES: Preconditioned GMRES Iterative Sparse Ax=b Solver. ! DSDGMR: Diagonally Scaled GMRES Iterative Sparse Ax=b Solver. ! DSLUGM: Incomplete LU GMRES Iterative Sparse Ax=b Solver. ! ! ============================ dmset.f ============================ ! The following routines are used to set up preconditioners. ! ! DSDS: Diagonal Scaling Preconditioner SLAP Set Up. ! DSDSCL: Diagonally Scales/Unscales a SLAP Column Matrix. ! DSD2S: Diagonal Scaling Preconditioner SLAP Normal Eqns Set Up. ! DS2LT: Lower Triangle Preconditioner SLAP Set Up. ! DSICS: Incomplete Cholesky Decomp. Preconditioner SLAP Set Up. ! DSILUS: Incomplete LU Decomposition Preconditioner SLAP Set Up. ! ! ============================ dmvops.f =========================== ! Most of the incomplete factorization (LL' and LDU) solvers ! in this file require an intermediate routine to translate ! from the SLAP MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, ! IWORK) calling convention to the calling sequence required ! by the solve routine. This generally is accomplished by ! fishing out pointers to the preconditioner (stored in RWORK) ! from the IWORK array and then making a call to the routine ! that actually does the backsolve. ! ! DSMV: SLAP Column Format Sparse Matrix Vector Product. ! DSMTV: SLAP Column Format Sparse Matrix (transpose) Vector Prod. ! DSDI: Diagonal Matrix Vector Multiply. ! DSLI: SLAP MSOLVE for Lower Triangle Matrix (set up for DSLI2). ! DSLI2: Lower Triangle Matrix Backsolve. ! DSLLTI: SLAP MSOLVE for LDL' (IC) Fact. (set up for DLLTI2). ! DLLTI2: Backsolve routine for LDL' Factorization. ! DSLUI: SLAP MSOLVE for LDU Factorization (set up for DSLUI2). ! DSLUI2: SLAP Backsolve for LDU Factorization. ! DSLUTI: SLAP MTSOLV for LDU Factorization (set up for DSLUI4). ! DSLUI4: SLAP Backsolve for LDU Factorization. ! DSMMTI: SLAP MSOLVE for LDU Fact of Normal Eq (set up for DSMMI2). ! DSMMI2: SLAP Backsolve for LDU Factorization of Normal Equations. ! ! =========================== dlaputil.f ========================== ! The following utility routines are useful additions to SLAP. ! ! DBHIN: Read Sparse Linear System in the Boeing/Harwell Format. ! DCHKW: SLAP WORK/IWORK Array Bounds Checker. ! DCPPLT: Printer Plot of SLAP Column Format Matrix. ! DS2Y: SLAP Triad to SLAP Column Format Converter. ! QS2I1D: Quick Sort Integer array, moving integer and DP arrays. ! (Used by DS2Y.) ! DTIN: Read in SLAP Triad Format Linear System. ! DTOUT: Write out SLAP Triad Format Linear System. ! ! !***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! -----( This produced Version 2.0.1. )----- ! 891003 Rearranged list of user callable routines to agree with ! order in source deck. (FNF) ! 891004 Updated reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! -----( This produced Version 2.0.2. )----- ! 910506 Minor improvements to prologue. (FNF) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 921019 Improved one-line descriptions, reordering some. (FNF) !***END PROLOGUE DLPDOC !***FIRST EXECUTABLE STATEMENT DLPDOC ! ! This is a *DUMMY* subroutine and should never be called. ! return !------------- LAST LINE OF DLPDOC FOLLOWS ----------------------------- end subroutine DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, & IS) ! !! DLPDP is subsidiary to DLSEI. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (LPDP-S, DLPDP-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! **** Double Precision version of LPDP **** ! DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), ! where N=N1+N2. This is a slight overestimate for WS(*). ! ! Determine an N1-vector W, and ! an N2-vector Z ! which minimizes the Euclidean length of W ! subject to G*W+H*Z >= Y. ! This is the least projected distance problem, LPDP. ! The matrices G and H are of respective ! dimensions M by N1 and M by N2. ! ! Called by subprogram DLSI( ). ! ! The matrix ! (G H Y) ! ! occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). ! ! The solution (W) is returned in X(*). ! (Z) ! ! The value of MODE indicates the status of ! the computation after returning to the user. ! ! MODE=1 The solution was successfully obtained. ! ! MODE=2 The inequalities are inconsistent. ! !***SEE ALSO DLSEI !***ROUTINES CALLED DCOPY, DDOT, DNRM2, DSCAL, DWNNLS !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE DLPDP ! INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2, & NP1 DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE, & PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO SAVE ZERO, ONE, FAC DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/ !***FIRST EXECUTABLE STATEMENT DLPDP N = N1 + N2 MODE = 1 if (M > 0) go to 20 if (N <= 0) go to 10 X(1) = ZERO call DCOPY(N,X,0,X,1) 10 CONTINUE WNORM = ZERO go to 200 20 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 190 NP1 = N + 1 ! ! SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. DO 40 I = 1, M SC = DNRM2(N,A(I,1),MDA) if (SC == ZERO) go to 30 SC = ONE/SC call DSCAL(NP1,SC,A(I,1),MDA) 30 CONTINUE 40 CONTINUE ! ! SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). YNORM = DNRM2(M,A(1,NP1),1) if (YNORM == ZERO) go to 50 SC = ONE/YNORM call DSCAL(M,SC,A(1,NP1),1) 50 CONTINUE ! ! SCALE COLS OF MATRIX H. J = N1 + 1 60 if (J > N) go to 70 SC = DNRM2(M,A(1,J),1) if (SC /= ZERO) SC = ONE/SC call DSCAL(M,SC,A(1,J),1) X(J) = SC J = J + 1 go to 60 70 CONTINUE if (N1 <= 0) go to 130 ! ! COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). IW = 0 DO 80 I = 1, M ! ! MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. call DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1) IW = IW + N2 ! ! MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. call DCOPY(N1,A(I,1),MDA,WS(IW+1),1) IW = IW + N1 ! ! MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. WS(IW+1) = A(I,NP1) IW = IW + 1 80 CONTINUE WS(IW+1) = ZERO call DCOPY(N,WS(IW+1),0,WS(IW+1),1) IW = IW + N WS(IW+1) = ONE IW = IW + 1 ! ! SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U >= 0. THE ! MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR ! F = TRANSPOSE OF (0,...,0,1). IX = IW + 1 IW = IW + M ! ! DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF ! DWNNLS( ). IS(1) = 0 IS(2) = 0 call DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM, & MODEW,IS,WS(IW+1)) ! ! COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) if (ONE + FAC*ABS(SC) == ONE .OR. RNORM <= ZERO) & go to 110 SC = ONE/SC DO 90 J = 1, N1 X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) 90 CONTINUE ! ! COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS ! VECTOR. DO 100 I = 1, M A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) 100 CONTINUE go to 120 110 CONTINUE MODE = 2 ! .........EXIT go to 190 120 CONTINUE 130 CONTINUE if (N2 <= 0) go to 180 ! ! COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). IW = 0 DO 140 I = 1, M call DCOPY(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 DCOPY(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 ! ! SOLVE RV=S SUBJECT TO V >= 0. THE MATRIX R =(TRANSPOSE ! OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE ! OF (0,...,0,1)). ! ! DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF ! DWNNLS( ). IS(1) = 0 IS(2) = 0 call DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW, & IS,WS(IW+1)) ! ! COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) if (ONE + FAC*ABS(SC) == ONE .OR. RNORM <= ZERO) & go to 160 SC = ONE/SC DO 150 J = 1, N2 L = N1 + J X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) 150 CONTINUE go to 170 160 CONTINUE MODE = 2 ! .........EXIT go to 190 170 CONTINUE 180 CONTINUE ! ! ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. call DSCAL(N,YNORM,X,1) WNORM = DNRM2(N1,X,1) 190 CONTINUE 200 CONTINUE return end subroutine DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, & RNORML, MODE, WS, IP) ! !! DLSEI solves a linearly constrained least squares problem with ... ! equality and inequality constraints, and optionally compute ! a covariance matrix. ! !***LIBRARY SLATEC !***CATEGORY K1A2A, D9 !***TYPE DOUBLE PRECISION (LSEI-S, DLSEI-D) !***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, ! EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, ! QUADRATIC PROGRAMMING !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! Abstract ! ! This subprogram solves a linearly constrained least squares ! problem with both equality and inequality constraints, and, if the ! user requests, obtains a covariance matrix of the solution ! parameters. ! ! Suppose there are given matrices E, A and G of respective ! dimensions ME by N, MA by N and MG by N, and vectors F, B and H of ! respective lengths ME, MA and MG. This subroutine solves the ! linearly constrained least squares problem ! ! EX = F, (E ME by N) (equations to be exactly ! satisfied) ! AX = B, (A MA by N) (equations to be ! approximately satisfied, ! least squares sense) ! GX >= H,(G MG by N) (inequality constraints) ! ! The inequalities GX >= H mean that every component of the ! product GX must be >= the corresponding component of H. ! ! In case the equality constraints cannot be satisfied, a ! generalized inverse solution residual vector length is obtained ! for F-EX. This is the minimal length possible for F-EX. ! ! Any values ME >= 0, MA >= 0, or MG >= 0 are permitted. The ! rank of the matrix E is estimated during the computation. We call ! this value KRANKE. It is an output parameter in IP(1) defined ! below. Using a generalized inverse solution of EX=F, a reduced ! least squares problem with inequality constraints is obtained. ! The tolerances used in these tests for determining the rank ! of E and the rank of the reduced least squares problem are ! given in Sandia Tech. Rept. SAND-78-1290. They can be ! modified by the user if new values are provided in ! the option list of the array PRGOPT(*). ! ! The user must dimension all arrays appearing in the call list.. ! W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) ! where K=MAX(MA+MG,N). This allows for a solution of a range of ! problems in the given working space. The dimension of WS(*) ! given is a necessary overestimate. Once a particular problem ! has been run, the output parameter IP(3) gives the actual ! dimension required for that problem. ! ! The parameters for DLSEI( ) are ! ! Input.. All TYPE REAL variables are DOUBLE PRECISION ! ! W(*,*),MDW, The array W(*,*) is doubly subscripted with ! ME,MA,MG,N first dimensioning parameter equal to MDW. ! For this discussion let us call M = ME+MA+MG. Then ! MDW must satisfy MDW >= M. The condition ! MDW < M is an error. ! ! The array W(*,*) contains the matrices and vectors ! ! (E F) ! (A B) ! (G H) ! ! in rows and columns 1,...,M and 1,...,N+1 ! respectively. ! ! The integers ME, MA, and MG are the ! respective matrix row dimensions ! of E, A and G. Each matrix has N columns. ! ! PRGOPT(*) This real-valued array is the option vector. ! If the user is satisfied with the nominal ! subprogram features set ! ! PRGOPT(1)=1 (or PRGOPT(1)=1.0) ! ! Otherwise PRGOPT(*) is a linked list consisting of ! groups of data of the following form ! ! LINK ! KEY ! DATA SET ! ! The parameters LINK and KEY are each one word. ! The DATA SET can be comprised of several words. ! The number of items depends on the value of KEY. ! The value of LINK points to the first ! entry of the next group of data within ! PRGOPT(*). The exception is when there are ! no more options to change. In that ! case, LINK=1 and the values KEY and DATA SET ! are not referenced. The general layout of ! PRGOPT(*) is as follows. ! ! ...PRGOPT(1) = LINK1 (link to first entry of next group) ! . PRGOPT(2) = KEY1 (key to the option change) ! . PRGOPT(3) = data value (data value for this change) ! . . ! . . ! . . ! ...PRGOPT(LINK1) = LINK2 (link to the first entry of ! . next group) ! . PRGOPT(LINK1+1) = KEY2 (key to the option change) ! . PRGOPT(LINK1+2) = data value ! ... . ! . . ! . . ! ...PRGOPT(LINK) = 1 (no more options to change) ! ! Values of LINK that are nonpositive are errors. ! A value of LINK > NLINK=100000 is also an error. ! This helps prevent using invalid but positive ! values of LINK that will probably extend ! beyond the program limits of PRGOPT(*). ! Unrecognized values of KEY are ignored. The ! order of the options is arbitrary and any number ! of options can be changed with the following ! restriction. To prevent cycling in the ! processing of the option array, a count of the ! number of options changed is maintained. ! Whenever this count exceeds NOPT=1000, an error ! message is printed and the subprogram returns. ! ! Options.. ! ! KEY=1 ! Compute in W(*,*) the N by N ! covariance matrix of the solution variables ! as an output parameter. Nominally the ! covariance matrix will not be computed. ! (This requires no user input.) ! The data set for this option is a single value. ! It must be nonzero when the covariance matrix ! is desired. If it is zero, the covariance ! matrix is not computed. When the covariance matrix ! is computed, the first dimensioning parameter ! of the array W(*,*) must satisfy MDW >= MAX(M,N). ! ! KEY=10 ! Suppress scaling of the inverse of the ! normal matrix by the scale factor RNORM**2/ ! MAX(1, no. of degrees of freedom). This option ! only applies when the option for computing the ! covariance matrix (KEY=1) is used. With KEY=1 and ! KEY=10 used as options the unscaled inverse of the ! normal matrix is returned in W(*,*). ! The data set for this option is a single value. ! When it is nonzero no scaling is done. When it is ! zero scaling is done. The nominal case is to do ! scaling so if option (KEY=1) is used alone, the ! matrix will be scaled on output. ! ! KEY=2 ! Scale the nonzero columns of the ! entire data matrix. ! (E) ! (A) ! (G) ! ! to have length one. The data set for this ! option is a single value. It must be ! nonzero if unit length column scaling ! is desired. ! ! KEY=3 ! Scale columns of the entire data matrix ! (E) ! (A) ! (G) ! ! with a user-provided diagonal matrix. ! The data set for this option consists ! of the N diagonal scaling factors, one for ! each matrix column. ! ! KEY=4 ! Change the rank determination tolerance for ! the equality constraint equations from ! the nominal value of SQRT(DRELPR). This quantity can ! be no smaller than DRELPR, the arithmetic- ! storage precision. The quantity DRELPR is the ! largest positive number such that T=1.+DRELPR ! satisfies T == 1. The quantity used ! here is internally restricted to be at ! least DRELPR. The data set for this option ! is the new tolerance. ! ! KEY=5 ! Change the rank determination tolerance for ! the reduced least squares equations from ! the nominal value of SQRT(DRELPR). This quantity can ! be no smaller than DRELPR, the arithmetic- ! storage precision. The quantity used ! here is internally restricted to be at ! least DRELPR. The data set for this option ! is the new tolerance. ! ! For example, suppose we want to change ! the tolerance for the reduced least squares ! problem, compute the covariance matrix of ! the solution parameters, and provide ! column scaling for the data matrix. For ! these options the dimension of PRGOPT(*) ! must be at least N+9. The Fortran statements ! defining these options would be as follows: ! ! PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) ! PRGOPT(2)=1 (covariance matrix key) ! PRGOPT(3)=1 (covariance matrix wanted) ! ! PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) ! PRGOPT(5)=5 (least squares equas. tolerance key) ! PRGOPT(6)=... (new value of the tolerance) ! ! PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) ! PRGOPT(8)=3 (user-provided column scaling key) ! ! call DCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N ! scaling factors from the user array D(*) ! to PRGOPT(9)-PRGOPT(N+8)) ! ! PRGOPT(N+9)=1 (no more options to change) ! ! The contents of PRGOPT(*) are not modified ! by the subprogram. ! The options for WNNLS( ) can also be included ! in this array. The values of KEY recognized ! by WNNLS( ) are 6, 7 and 8. Their functions ! are documented in the usage instructions for ! subroutine WNNLS( ). Normally these options ! do not need to be modified when using DLSEI( ). ! ! IP(1), The amounts of working storage actually ! IP(2) allocated for the working arrays WS(*) and ! IP(*), respectively. These quantities are ! compared with the actual amounts of storage ! needed by DLSEI( ). Insufficient storage ! allocated for either WS(*) or IP(*) is an ! error. This feature was included in DLSEI( ) ! because miscalculating the storage formulas ! for WS(*) and IP(*) might very well lead to ! subtle and hard-to-find execution errors. ! ! The length of WS(*) must be at least ! ! LW = 2*(ME+N)+K+(MG+2)*(N+7) ! ! where K = max(MA+MG,N) ! This test will not be made if IP(1) <= 0. ! ! The length of IP(*) must be at least ! ! LIP = MG+2*N+2 ! This test will not be made if IP(2) <= 0. ! ! Output.. All TYPE REAL variables are DOUBLE PRECISION ! ! X(*),RNORME, The array X(*) contains the solution parameters ! RNORML if the integer output flag MODE = 0 or 1. ! The definition of MODE is given directly below. ! When MODE = 0 or 1, RNORME and RNORML ! respectively contain the residual vector ! Euclidean lengths of F - EX and B - AX. When ! MODE=1 the equality constraint equations EX=F ! are contradictory, so RNORME /= 0. The residual ! vector F-EX has minimal Euclidean length. For ! MODE >= 2, none of these parameters is defined. ! ! MODE Integer flag that indicates the subprogram ! status after completion. If MODE >= 2, no ! solution has been computed. ! ! MODE = ! ! 0 Both equality and inequality constraints ! are compatible and have been satisfied. ! ! 1 Equality constraints are contradictory. ! A generalized inverse solution of EX=F was used ! to minimize the residual vector length F-EX. ! In this sense, the solution is still meaningful. ! ! 2 Inequality constraints are contradictory. ! ! 3 Both equality and inequality constraints ! are contradictory. ! ! The following interpretation of ! MODE=1,2 or 3 must be made. The ! sets consisting of all solutions ! of the equality constraints EX=F ! and all vectors satisfying GX >= H ! have no points in common. (In ! particular this does not say that ! each individual set has no points ! at all, although this could be the ! case.) ! ! 4 Usage error occurred. The value ! of MDW is < ME+MA+MG, MDW is ! < N and a covariance matrix is ! requested, or the option vector ! PRGOPT(*) is not properly defined, ! or the lengths of the working arrays ! WS(*) and IP(*), when specified in ! IP(1) and IP(2) respectively, are not ! long enough. ! ! W(*,*) The array W(*,*) contains the N by N symmetric ! covariance matrix of the solution parameters, ! provided this was requested on input with ! the option vector PRGOPT(*) and the output ! flag is returned with MODE = 0 or 1. ! ! IP(*) The integer working array has three entries ! that provide rank and working array length ! information after completion. ! ! IP(1) = rank of equality constraint ! matrix. Define this quantity ! as KRANKE. ! ! IP(2) = rank of reduced least squares ! problem. ! ! IP(3) = the amount of storage in the ! working array WS(*) that was ! actually used by the subprogram. ! The formula given above for the length ! of WS(*) is a necessary overestimate. ! If exactly the same problem matrices ! are used in subsequent executions, ! the declared dimension of WS(*) can ! be reduced to this output value. ! User Designated ! Working Arrays.. ! ! WS(*),IP(*) These are respectively type real ! and type integer working arrays. ! Their required minimal lengths are ! given above. ! !***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for ! linear least squares problems with equality and ! nonnegativity constraints, Report SAND77-0552, Sandia ! Laboratories, June 1978. ! K. H. Haskell and R. J. Hanson, Selected algorithms for ! the linearly constrained least squares problem - a ! users guide, Report SAND78-1290, Sandia Laboratories, ! August 1979. ! K. H. Haskell and R. J. Hanson, An algorithm for ! linear least squares problems with equality and ! nonnegativity constraints, Mathematical Programming ! 21 (1981), pp. 98-118. ! R. J. Hanson and K. H. Haskell, Two algorithms for the ! linearly constrained least squares problem, ACM ! Transactions on Mathematical Software, September 1982. !***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, ! DNRM2, DSCAL, DSWAP, XERMSG !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and extensively revised (WRB & RWC) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 900604 DP version created from SP version. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DLSEI INTEGER IP(3), MA, MDW, ME, MG, MODE, N DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) ! EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2, & DSCAL, DSWAP, XERMSG DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2 ! DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, & SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, & MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, & NTIMES LOGICAL COV, FIRST CHARACTER*8 XERN1, XERN2, XERN3, XERN4 SAVE FIRST, DRELPR ! DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DLSEI ! ! Set the nominal tolerance used in the code for the equality ! constraint equations. ! if (FIRST) DRELPR = D1MACH(4) FIRST = .FALSE. TAU = SQRT(DRELPR) ! ! Check that enough storage was allocated in WS(*) and IP(*). ! MODE = 4 if (MIN(N,ME,MA,MG) < 0) THEN WRITE (XERN1, '(I8)') N WRITE (XERN2, '(I8)') ME WRITE (XERN3, '(I8)') MA WRITE (XERN4, '(I8)') MG call XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // & ' MA, MG MUST BE >= 0$$ENTERED ROUTINE WITH' // & '$$N = ' // XERN1 // & '$$ME = ' // XERN2 // & '$$MA = ' // XERN3 // & '$$MG = ' // XERN4, 2, 1) return end if ! if (IP(1) > 0) THEN LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) if (IP(1) < LCHK) THEN WRITE (XERN1, '(I8)') LCHK call XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // & 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) return ENDIF end if ! if (IP(2) > 0) THEN LCHK = MG + 2*N + 2 if (IP(2) < LCHK) THEN WRITE (XERN1, '(I8)') LCHK call XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' // & 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) return ENDIF end if ! ! Compute number of possible right multiplying Householder ! transformations. ! M = ME + MA + MG if (N <= 0 .OR. M <= 0) THEN MODE = 0 RNORME = 0 RNORML = 0 return end if ! if (MDW < M) THEN call XERMSG ('SLATEC', 'DLSEI', 'MDW < ME+MA+MG IS AN ERROR', & 2, 1) return end if ! NP1 = N + 1 KRANKE = MIN(ME,N) N1 = 2*KRANKE + 1 N2 = N1 + N ! ! Set nominal values. ! ! The nominal column scaling used in the code is ! the identity scaling. ! call dinit ( N, 1.D0, WS(N1), 1) ! ! No covariance matrix is nominally computed. ! COV = .FALSE. ! ! Process option vector. ! Define bound for number of options to change. ! NOPT = 1000 NTIMES = 0 ! ! Define bound for positive values of LINK. ! NLINK = 100000 LAST = 1 LINK = PRGOPT(1) if (LINK == 0 .OR. LINK > NLINK) THEN call XERMSG ('SLATEC', 'DLSEI', & 'THE OPTION VECTOR IS UNDEFINED', 2, 1) return end if ! 100 if (LINK > 1) THEN NTIMES = NTIMES + 1 if (NTIMES > NOPT) THEN call XERMSG ('SLATEC', 'DLSEI', & 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) return ENDIF ! KEY = PRGOPT(LAST+1) if (KEY == 1) THEN COV = PRGOPT(LAST+2) /= 0.D0 ELSEIF (KEY == 2 .AND. PRGOPT(LAST+2) /= 0.D0) THEN DO 110 J = 1,N T = DNRM2(M,W(1,J),1) if (T /= 0.D0) T = 1.D0/T WS(J+N1-1) = T 110 CONTINUE ELSEIF (KEY == 3) THEN call DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) ELSEIF (KEY == 4) THEN TAU = MAX(DRELPR,PRGOPT(LAST+2)) ENDIF ! NEXT = PRGOPT(LINK) if (NEXT <= 0 .OR. NEXT > NLINK) THEN call XERMSG ('SLATEC', 'DLSEI', & 'THE OPTION VECTOR IS UNDEFINED', 2, 1) return ENDIF ! LAST = LINK LINK = NEXT go to 100 end if ! DO 120 J = 1,N call DSCAL (M, WS(N1+J-1), W(1,J), 1) 120 CONTINUE ! if (COV .AND. MDW < N) THEN call XERMSG ('SLATEC', 'DLSEI', & 'MDW < N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) return end if ! ! Problem definition and option vector OK. ! MODE = 0 ! ! Compute norm of equality constraint matrix and right side. ! ENORM = 0.D0 DO 130 J = 1,N ENORM = MAX(ENORM,DASUM(ME,W(1,J),1)) 130 CONTINUE ! FNORM = DASUM(ME,W(1,NP1),1) SNMAX = 0.D0 RNMAX = 0.D0 DO 150 I = 1,KRANKE ! ! Compute maximum ratio of vector lengths. Partition is at ! column I. ! DO 140 K = I,ME SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW) if (RN == 0.D0 .AND. SN > SNMAX) THEN SNMAX = SN IMAX = K ELSEIF (K == I .OR. SN*RNMAX > RN*SNMAX) THEN SNMAX = SN RNMAX = RN IMAX = K ENDIF 140 CONTINUE ! ! Interchange rows if necessary. ! if (I /= IMAX) call DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) if (SNMAX > RNMAX*TAU**2) THEN ! ! Eliminate elements I+1,...,N in row I. ! call DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, & 1, M-I) ELSE KRANKE = I - 1 go to 160 ENDIF 150 CONTINUE ! ! Save diagonal terms of lower trapezoidal matrix. ! 160 call DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) ! ! Use Householder transformation from left to achieve ! KRANKE by KRANKE upper triangular form. ! if (KRANKE < ME) THEN DO 170 K = KRANKE,1,-1 ! ! Apply transformation to matrix cols. 1,...,K-1. ! call DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, & K-1) ! ! Apply to rt side vector. ! call DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, & 1, 1) 170 CONTINUE end if ! ! Solve for variables 1,...,KRANKE in new coordinates. ! call DCOPY (KRANKE, W(1, NP1), 1, X, 1) DO 180 I = 1,KRANKE X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I) 180 CONTINUE ! ! Compute residuals for reduced problem. ! MEP1 = ME + 1 RNORML = 0.D0 DO 190 I = MEP1,M W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1) SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) if (RN <= SN*TAU**2 .AND. KRANKE < N) & call dinit ( N-KRANKE, 0.D0, W(I,KRANKE+1), MDW) 190 CONTINUE ! ! Compute equality constraint equations residual length. ! RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) ! ! Move reduced problem data upward if KRANKE < ME. ! if (KRANKE < ME) THEN DO 200 J = 1,NP1 call DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) 200 CONTINUE end if ! ! Compute solution of reduced problem. ! call DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, & X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) ! ! Test for consistency of equality constraints. ! if (ME > 0) THEN MDEQC = 0 XNRME = DASUM(KRANKE,W(1,NP1),1) if (RNORME > TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 MODE = MODE + MDEQC ! ! Check if solution to equality constraints satisfies inequality ! constraints when there are no degrees of freedom left. ! if (KRANKE == N .AND. MG > 0) THEN XNORM = DASUM(N,X,1) MAPKE1 = MA + KRANKE + 1 MEND = MA + KRANKE + MG DO 210 I = MAPKE1,MEND SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) if (W(I,NP1) > TAU*SIZE) THEN MODE = MODE + 2 go to 290 ENDIF 210 CONTINUE ENDIF end if ! ! Replace diagonal terms of lower trapezoidal matrix. ! if (KRANKE > 0) THEN call DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) ! ! Reapply transformation to put solution in original coordinates. ! DO 220 I = KRANKE,1,-1 call DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) 220 CONTINUE ! ! Compute covariance matrix of equality constrained problem. ! if (COV) THEN DO 270 J = MIN(KRANKE,N-1),1,-1 RB = WS(J)*W(J,J) if (RB /= 0.D0) RB = 1.D0/RB JP1 = J + 1 DO 230 I = JP1,N W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) 230 CONTINUE ! GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) call DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) DO 250 I = JP1,N DO 240 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) 240 CONTINUE 250 CONTINUE UJ = WS(J) VJ = GAM*UJ W(J,J) = UJ*VJ + UJ*VJ DO 260 I = JP1,N W(J,I) = UJ*W(I,J) + VJ*W(J,I) 260 CONTINUE call DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) 270 CONTINUE ENDIF end if ! ! Apply the scaling to the covariance matrix. ! if (COV) THEN DO 280 I = 1,N call DSCAL (N, WS(I+N1-1), W(I,1), MDW) call DSCAL (N, WS(I+N1-1), W(1,I), 1) 280 CONTINUE end if ! ! Rescale solution vector. ! 290 if (MODE <= 1) THEN DO 300 J = 1,N X(J) = X(J)*WS(N1+J-1) 300 CONTINUE end if ! IP(1) = KRANKE IP(3) = IP(3) + 2*KRANKE + N return end subroutine DLSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, & IP) ! !! DLSI is subsidiary to DLSEI. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (LSI-S, DLSI-D) !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! This is a companion subprogram to DLSEI. The documentation for ! DLSEI has complete usage instructions. ! ! Solve.. ! AX = B, A MA by N (least squares equations) ! subject to.. ! ! GX >= H, G MG by N (inequality constraints) ! ! Input.. ! ! W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. ! (G H) ! ! MDW,MA,MG,N ! contain (resp) var. dimension of W(*,*), ! and matrix dimensions. ! ! PRGOPT(*), ! Program option vector. ! ! OUTPUT.. ! ! X(*),RNORM ! ! Solution vector(unless MODE=2), length of AX-B. ! ! MODE ! =0 Inequality constraints are compatible. ! =2 Inequality constraints contradictory. ! ! WS(*), ! Working storage of dimension K+N+(MG+2)*(N+7), ! where K=MAX(MA+MG,N). ! IP(MG+2*N+1) ! Integer working storage ! !***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, ! DLPDP, DSCAL, DSWAP !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and extensively revised (WRB & RWC) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900604 DP version created from SP version. (RWC) ! 920422 Changed call to DHFTI to include variable MA. (WRB) !***END PROLOGUE DLSI INTEGER IP(*), MA, MDW, MG, MODE, N DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) ! EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DHFTI, DLPDP, & DSCAL, DSWAP DOUBLE PRECISION D1MACH, DASUM, DDOT ! DOUBLE PRECISION ANORM, DRELPR, FAC, GAM, RB, TAU, TOL, XNORM INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, & MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 LOGICAL COV, FIRST, SCLCOV ! SAVE DRELPR, FIRST DATA FIRST /.TRUE./ ! !***FIRST EXECUTABLE STATEMENT DLSI ! ! Set the nominal tolerance used in the code. ! if (FIRST) DRELPR = D1MACH(4) FIRST = .FALSE. TOL = SQRT(DRELPR) ! MODE = 0 RNORM = 0.D0 M = MA + MG NP1 = N + 1 KRANK = 0 if (N <= 0 .OR. M <= 0) go to 370 ! ! To process option vector. ! COV = .FALSE. SCLCOV = .TRUE. LAST = 1 LINK = PRGOPT(1) ! 100 if (LINK > 1) THEN KEY = PRGOPT(LAST+1) if (KEY == 1) COV = PRGOPT(LAST+2) /= 0.D0 if (KEY == 10) SCLCOV = PRGOPT(LAST+2) == 0.D0 if (KEY == 5) TOL = MAX(DRELPR,PRGOPT(LAST+2)) NEXT = PRGOPT(LINK) LAST = LINK LINK = NEXT go to 100 end if ! ! Compute matrix norm of least squares equations. ! ANORM = 0.D0 DO 110 J = 1,N ANORM = MAX(ANORM,DASUM(MA,W(1,J),1)) 110 CONTINUE ! ! Set tolerance for DHFTI( ) rank test. ! TAU = TOL*ANORM ! ! Compute Householder orthogonal decomposition of matrix. ! call dinit ( N, 0.D0, WS, 1) call DCOPY (MA, W(1, NP1), 1, WS, 1) K = MAX(M,N) MINMAN = MIN(MA,N) N1 = K + 1 N2 = N1 + N call DHFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, RNORM, WS(N2), & WS(N1), IP) FAC = 1.D0 GAM = MA - KRANK if (KRANK < MA .AND. SCLCOV) FAC = RNORM**2/GAM ! ! Reduce to DLPDP and solve. ! MAP1 = MA + 1 ! ! Compute inequality rt-hand side for DLPDP. ! if (MA < M) THEN if (MINMAN > 0) THEN DO 120 I = MAP1,M W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) 120 CONTINUE ! ! Apply permutations to col. of inequality constraint matrix. ! DO 130 I = 1,MINMAN call DSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) 130 CONTINUE ! ! Apply Householder transformations to constraint matrix. ! if (KRANK > 0 .AND. KRANK < N) THEN DO 140 I = KRANK,1,-1 call DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), & W(MAP1,1), MDW, 1, MG) 140 CONTINUE ENDIF ! ! Compute permuted inequality constraint matrix times r-inv. ! DO 160 I = MAP1,M DO 150 J = 1,KRANK W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) 150 CONTINUE 160 CONTINUE ENDIF ! ! Solve the reduced problem with DLPDP algorithm, ! the least projected distance problem. ! call DLPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, & XNORM, MDLPDP, WS(N2), IP(N+1)) ! ! Compute solution in original coordinates. ! if (MDLPDP == 1) THEN DO 170 I = KRANK,1,-1 X(I) = (X(I)-DDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) 170 CONTINUE ! ! Apply Householder transformation to solution vector. ! if (KRANK < N) THEN DO 180 I = 1,KRANK call DH12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), & X, 1, 1, 1) 180 CONTINUE ENDIF ! ! Repermute variables to their input order. ! if (MINMAN > 0) THEN DO 190 I = MINMAN,1,-1 call DSWAP (1, X(I), 1, X(IP(I)), 1) 190 CONTINUE ! ! Variables are now in original coordinates. ! Add solution of unconstrained problem. ! DO 200 I = 1,N X(I) = X(I) + WS(I) 200 CONTINUE ! ! Compute the residual vector norm. ! RNORM = SQRT(RNORM**2+XNORM**2) ENDIF ELSE MODE = 2 ENDIF ELSE call DCOPY (N, WS, 1, X, 1) end if ! ! Compute covariance matrix based on the orthogonal decomposition ! from DHFTI( ). ! if (.NOT.COV .OR. KRANK <= 0) go to 370 KRM1 = KRANK - 1 KRP1 = KRANK + 1 ! ! Copy diagonal terms to working array. ! call DCOPY (KRANK, W, MDW+1, WS(N2), 1) ! ! Reciprocate diagonal terms. ! DO 210 J = 1,KRANK W(J,J) = 1.D0/W(J,J) 210 CONTINUE ! ! Invert the upper triangular QR factor on itself. ! if (KRANK > 1) THEN DO 230 I = 1,KRM1 DO 220 J = I+1,KRANK W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) 220 CONTINUE 230 CONTINUE end if ! ! Compute the inverted factor times its transpose. ! DO 250 I = 1,KRANK DO 240 J = I,KRANK W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) 240 CONTINUE 250 CONTINUE ! ! Zero out lower trapezoidal part. ! Copy upper triangular to lower triangular part. ! if (KRANK < N) THEN DO 260 J = 1,KRANK call DCOPY (J, W(1,J), 1, W(J,1), MDW) 260 CONTINUE ! DO 270 I = KRP1,N call dinit ( I, 0.D0, W(I,1), MDW) 270 CONTINUE ! ! Apply right side transformations to lower triangle. ! N3 = N2 + KRP1 DO 330 I = 1,KRANK L = N1 + I K = N2 + I RB = WS(L-1)*WS(K-1) ! ! If RB >= 0.D0, transformation can be regarded as zero. ! if (RB < 0.D0) THEN RB = 1.D0/RB ! ! Store unscaled rank one Householder update in work array. ! call dinit ( N, 0.D0, WS(N3), 1) L = N1 + I K = N3 + I WS(K-1) = WS(L-1) ! DO 280 J = KRP1,N WS(N3+J-1) = W(I,J) 280 CONTINUE ! DO 290 J = 1,N WS(J) = RB*(DDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ & DDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) 290 CONTINUE ! L = N3 + I GAM = 0.5D0*RB*DDOT(N-I+1,WS(L-1),1,WS(I),1) call DAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) DO 320 J = I,N DO 300 L = 1,I-1 W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) 300 CONTINUE ! DO 310 L = I,J W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) 310 CONTINUE 320 CONTINUE ENDIF 330 CONTINUE ! ! Copy lower triangle to upper triangle to symmetrize the ! covariance matrix. ! DO 340 I = 1,N call DCOPY (I, W(I,1), MDW, W(1,I), 1) 340 CONTINUE end if ! ! Repermute rows and columns. ! DO 350 I = MINMAN,1,-1 K = IP(I) if (I /= K) THEN call DSWAP (1, W(I,I), 1, W(K,K), 1) call DSWAP (I-1, W(1,I), 1, W(1,K), 1) call DSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1) call DSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW) ENDIF 350 CONTINUE ! ! Put in normalized residual sum of squares scale factor ! and symmetrize the resulting covariance matrix. ! DO 360 J = 1,N call DSCAL (J, FAC, W(1,J), 1) call DCOPY (J, W(1,J), 1, W(J,1), MDW) 360 CONTINUE ! 370 IP(1) = KRANK IP(2) = N + MAX(M,N) + (MG+2)*(N+7) return end subroutine DLSOD (DF, NEQ, T, Y, TOUT, RTOL, ATOL, IDID, YPOUT, & YH, YH1, EWT, SAVF, ACOR, WM, IWM, DJAC, INTOUT, TSTOP, TOLFAC, & DELSGN, RPAR, IPAR) ! !! DLSOD is subsidiary to DDEBDF. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (LSOD-S, DLSOD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DDEBDF merely allocates storage for DLSOD to relieve the user of ! the inconvenience of a long call list. Consequently DLSOD is used ! as described in the comments for DDEBDF . ! !***SEE ALSO DDEBDF !***ROUTINES CALLED D1MACH, DHSTRT, DINTYD, DSTOD, DVNRMS, XERMSG !***COMMON BLOCKS DDEBD1 !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE DLSOD ! INTEGER IBAND, IBEGIN, IDID, IER, IINTEG, IJAC, INIT, INTFLG, & IOWNS, IPAR, IQUIT, ITOL, ITSTOP, IWM, JSTART, K, KFLAG, & KSTEPS, L, LACOR, LDUM, LEWT, LSAVF, LTOL, LWM, LYH, MAXNUM, & MAXORD, METH, MITER, N, NATOLP, NEQ, NFE, NJE, NQ, NQU, & NRTOLP, NST DOUBLE PRECISION ABSDEL, ACOR, ATOL, BIG, D1MACH, DEL, & DELSGN, DT, DVNRMS, EL0, EWT, & H, HA, HMIN, HMXI, HU, ROWNS, RPAR, RTOL, SAVF, T, TOL, & TOLD, TOLFAC, TOUT, TSTOP, U, WM, X, Y, YH, YH1, YPOUT LOGICAL INTOUT CHARACTER*8 XERN1 CHARACTER*16 XERN3, XERN4 ! DIMENSION Y(*),YPOUT(*),YH(NEQ,6),YH1(*),EWT(*),SAVF(*), & ACOR(*),WM(*),IWM(*),RTOL(*),ATOL(*),RPAR(*),IPAR(*) ! ! COMMON /DDEBD1/ TOLD,ROWNS(210),EL0,H,HMIN,HMXI,HU,X,U,IQUIT,INIT, & LYH,LEWT,LACOR,LSAVF,LWM,KSTEPS,IBEGIN,ITOL, & IINTEG,ITSTOP,IJAC,IBAND,IOWNS(6),IER,JSTART, & KFLAG,LDUM,METH,MITER,MAXORD,N,NQ,NST,NFE,NJE,NQU ! EXTERNAL DF, DJAC ! ! .................................................................. ! ! THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE ! NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE ! COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE ! EXCESSIVE WORK. SAVE MAXNUM ! DATA MAXNUM /500/ ! ! .................................................................. ! !***FIRST EXECUTABLE STATEMENT DLSOD if (IBEGIN == 0) THEN ! ! ON THE FIRST call , PERFORM INITIALIZATION -- ! DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE ! FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE ! VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. ! U = D1MACH(4) ! -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER WM(1) = SQRT(U) ! -- SET TERMINATION FLAG IQUIT = 0 ! -- SET INITIALIZATION INDICATOR INIT = 0 ! -- SET COUNTER FOR ATTEMPTED STEPS KSTEPS = 0 ! -- SET INDICATOR FOR INTERMEDIATE-OUTPUT INTOUT = .FALSE. ! -- SET START INDICATOR FOR DSTOD CODE JSTART = 0 ! -- SET BDF METHOD INDICATOR METH = 2 ! -- SET MAXIMUM ORDER FOR BDF METHOD MAXORD = 5 ! -- SET ITERATION MATRIX INDICATOR ! if (IJAC == 0 .AND. IBAND == 0) MITER = 2 if (IJAC == 1 .AND. IBAND == 0) MITER = 1 if (IJAC == 0 .AND. IBAND == 1) MITER = 5 if (IJAC == 1 .AND. IBAND == 1) MITER = 4 ! ! -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK N = NEQ NST = 0 NJE = 0 HMXI = 0.0D0 NQ = 1 H = 1.0D0 ! -- RESET IBEGIN FOR SUBSEQUENT CALLS IBEGIN = 1 end if ! ! .................................................................. ! ! CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY ! if (NEQ < 1) THEN WRITE (XERN1, '(I8)') NEQ call XERMSG ('SLATEC', 'DLSOD', & 'IN DDEBDF, THE NUMBER OF EQUATIONS MUST BE A ' // & 'POSITIVE INTEGER.$$YOU HAVE CALLED THE CODE WITH NEQ = ' // & XERN1, 6, 1) IDID=-33 end if ! NRTOLP = 0 NATOLP = 0 DO 60 K = 1, NEQ if (NRTOLP <= 0) THEN if (RTOL(K) < 0.) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') RTOL(K) call XERMSG ('SLATEC', 'DLSOD', & 'IN DDEBDF, THE RELATIVE ERROR TOLERANCES MUST ' // & 'BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE WITH ' // & 'RTOL(' // XERN1 // ') = ' // XERN3 // '$$IN THE ' // & 'CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' // & 'CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) IDID = -33 if (NATOLP > 0) go to 70 NRTOLP = 1 ELSEIF (NATOLP > 0) THEN go to 50 ENDIF ENDIF ! if (ATOL(K) < 0.) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') ATOL(K) call XERMSG ('SLATEC', 'DLSOD', & 'IN DDEBDF, THE ABSOLUTE ERROR ' // & 'TOLERANCES MUST BE NON-NEGATIVE.$$YOU HAVE CALLED ' // & 'THE CODE WITH ATOL(' // XERN1 // ') = ' // XERN3 // & '$$IN THE CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' & // 'CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) IDID=-33 if (NRTOLP > 0) go to 70 NATOLP=1 ENDIF 50 if (ITOL == 0) go to 70 60 CONTINUE ! 70 if (ITSTOP == 1) THEN if (SIGN(1.0D0,TOUT-T) /= SIGN(1.0D0,TSTOP-T) .OR. & ABS(TOUT-T) > ABS(TSTOP-T)) THEN WRITE (XERN3, '(1PE15.6)') TOUT WRITE (XERN4, '(1PE15.6)') TSTOP call XERMSG ('SLATEC', 'DLSOD', & 'IN DDEBDF, YOU HAVE CALLED THE ' // & 'CODE WITH TOUT = ' // XERN3 // '$$BUT YOU HAVE ' // & 'ALSO TOLD THE CODE NOT TO INTEGRATE PAST THE POINT ' // & 'TSTOP = ' // XERN4 // ' BY SETTING INFO(4) = 1.$$' // & 'THESE INSTRUCTIONS CONFLICT.', 14, 1) IDID=-33 ENDIF end if ! ! CHECK SOME CONTINUATION POSSIBILITIES ! if (INIT /= 0) THEN if (T == TOUT) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DLSOD', & 'IN DDEBDF, YOU HAVE CALLED THE CODE WITH T = TOUT = ' // & XERN3 // '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', & 9, 1) IDID=-33 ENDIF ! if (T /= TOLD) THEN WRITE (XERN3, '(1PE15.6)') TOLD WRITE (XERN4, '(1PE15.6)') T call XERMSG ('SLATEC', 'DLSOD', & 'IN DDEBDF, YOU HAVE CHANGED THE VALUE OF T FROM ' // & XERN3 // ' TO ' // XERN4 // & ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) IDID=-33 ENDIF ! if (INIT /= 1) THEN if (DELSGN*(TOUT-T) < 0.0D0) THEN WRITE (XERN3, '(1PE15.6)') TOUT call XERMSG ('SLATEC', 'DLSOD', & 'IN DDEBDF, BY CALLING THE CODE WITH TOUT = ' // & XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // & 'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' // & 'WITHOUT RESTARTING.', 11, 1) IDID=-33 ENDIF ENDIF end if ! if (IDID == (-33)) THEN if (IQUIT /= (-33)) THEN ! INVALID INPUT DETECTED IQUIT=-33 IBEGIN=-1 ELSE call XERMSG ('SLATEC', 'DLSOD', & 'IN DDEBDF, INVALID INPUT WAS DETECTED ON ' // & 'SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE TO PROCEED ' // & 'BECAUSE YOU HAVE NOT CORRECTED THE PROBLEM, ' // & 'SO EXECUTION IS BEING TERMINATED.', 12, 2) ENDIF return end if ! ! ............................................................... ! ! RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED ! AS ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS ! CASE, THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE ! SMALLEST VALUE 100*U WHICH IS LIKELY TO BE REASONABLE FOR ! THIS METHOD AND MACHINE ! DO 180 K = 1, NEQ if (RTOL(K) + ATOL(K) > 0.0D0) go to 170 RTOL(K) = 100.0D0*U IDID = -2 170 CONTINUE ! ...EXIT if (ITOL == 0) go to 190 180 CONTINUE 190 CONTINUE ! if (IDID /= (-2)) go to 200 ! RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A ! SMALL POSITIVE VALUE IBEGIN = -1 go to 460 200 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 450 ! BEGIN BLOCK PERMITTING ...EXITS TO 430 ! BEGIN BLOCK PERMITTING ...EXITS TO 260 ! BEGIN BLOCK PERMITTING ...EXITS TO 230 ! ! BRANCH ON STATUS OF INITIALIZATION INDICATOR ! INIT=0 MEANS INITIAL DERIVATIVES AND ! NOMINAL STEP SIZE ! AND DIRECTION NOT YET SET ! INIT=1 MEANS NOMINAL STEP SIZE AND ! DIRECTION NOT YET SET INIT=2 MEANS NO ! FURTHER INITIALIZATION REQUIRED ! if (INIT == 0) go to 210 ! ......EXIT if (INIT == 1) go to 230 ! .........EXIT go to 260 210 CONTINUE ! ! ................................................ ! ! MORE INITIALIZATION -- ! -- EVALUATE INITIAL ! DERIVATIVES ! INIT = 1 call DF(T,Y,YH(1,2),RPAR,IPAR) NFE = 1 ! ...EXIT if (T /= TOUT) go to 230 IDID = 2 DO 220 L = 1, NEQ YPOUT(L) = YH(L,2) 220 CONTINUE TOLD = T ! ............EXIT go to 450 230 CONTINUE ! ! -- COMPUTE INITIAL STEP SIZE ! -- SAVE SIGN OF INTEGRATION DIRECTION ! -- SET INDEPENDENT AND DEPENDENT VARIABLES ! X AND YH(*) FOR DSTOD ! LTOL = 1 DO 240 L = 1, NEQ if (ITOL == 1) LTOL = L TOL = RTOL(LTOL)*ABS(Y(L)) + ATOL(LTOL) if (TOL == 0.0D0) go to 390 EWT(L) = TOL 240 CONTINUE ! BIG = SQRT(D1MACH(2)) call DHSTRT(DF,NEQ,T,TOUT,Y,YH(1,2),EWT,1,U,BIG, & YH(1,3),YH(1,4),YH(1,5),YH(1,6),RPAR, & IPAR,H) ! DELSGN = SIGN(1.0D0,TOUT-T) X = T DO 250 L = 1, NEQ YH(L,1) = Y(L) YH(L,2) = H*YH(L,2) 250 CONTINUE INIT = 2 260 CONTINUE ! ! ...................................................... ! ! ON EACH call SET INFORMATION WHICH DETERMINES THE ! ALLOWED INTERVAL OF INTEGRATION BEFORE RETURNING ! WITH AN ANSWER AT TOUT ! DEL = TOUT - T ABSDEL = ABS(DEL) ! ! ...................................................... ! ! if ALREADY PAST OUTPUT POINT, INTERPOLATE AND ! return ! 270 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 400 ! BEGIN BLOCK PERMITTING ...EXITS TO 380 if (ABS(X-T) < ABSDEL) go to 290 call DINTYD(TOUT,0,YH,NEQ,Y,INTFLG) call DINTYD(TOUT,1,YH,NEQ,YPOUT,INTFLG) IDID = 3 if (X /= TOUT) go to 280 IDID = 2 INTOUT = .FALSE. 280 CONTINUE T = TOUT TOLD = T ! ..................EXIT go to 450 290 CONTINUE ! ! if CANNOT GO PAST TSTOP AND SUFFICIENTLY ! CLOSE, EXTRAPOLATE AND RETURN ! if (ITSTOP /= 1) go to 310 if (ABS(TSTOP-X) >= 100.0D0*U*ABS(X)) & go to 310 DT = TOUT - X DO 300 L = 1, NEQ Y(L) = YH(L,1) + (DT/H)*YH(L,2) 300 CONTINUE call DF(TOUT,Y,YPOUT,RPAR,IPAR) NFE = NFE + 1 IDID = 3 T = TOUT TOLD = T ! ..................EXIT go to 450 310 CONTINUE ! if (IINTEG == 0 .OR. .NOT.INTOUT) go to 320 ! ! INTERMEDIATE-OUTPUT MODE ! IDID = 1 go to 370 320 CONTINUE ! ! ............................................. ! ! MONITOR NUMBER OF STEPS ATTEMPTED ! if (KSTEPS <= MAXNUM) go to 330 ! ! A SIGNIFICANT AMOUNT OF WORK HAS BEEN ! EXPENDED IDID = -1 KSTEPS = 0 IBEGIN = -1 go to 370 330 CONTINUE ! ! .......................................... ! ! LIMIT STEP SIZE AND SET WEIGHT VECTOR ! HMIN = 100.0D0*U*ABS(X) HA = MAX(ABS(H),HMIN) if (ITSTOP == 1) & HA = MIN(HA,ABS(TSTOP-X)) H = SIGN(HA,H) LTOL = 1 DO 340 L = 1, NEQ if (ITOL == 1) LTOL = L EWT(L) = RTOL(LTOL)*ABS(YH(L,1)) & + ATOL(LTOL) ! .........EXIT if (EWT(L) <= 0.0D0) go to 380 340 CONTINUE TOLFAC = U*DVNRMS(NEQ,YH,EWT) ! .........EXIT if (TOLFAC <= 1.0D0) go to 400 ! ! TOLERANCES TOO SMALL IDID = -2 TOLFAC = 2.0D0*TOLFAC RTOL(1) = TOLFAC*RTOL(1) ATOL(1) = TOLFAC*ATOL(1) if (ITOL == 0) go to 360 DO 350 L = 2, NEQ RTOL(L) = TOLFAC*RTOL(L) ATOL(L) = TOLFAC*ATOL(L) 350 CONTINUE 360 CONTINUE IBEGIN = -1 370 CONTINUE ! ............EXIT go to 430 380 CONTINUE ! ! RELATIVE ERROR CRITERION INAPPROPRIATE 390 CONTINUE IDID = -3 IBEGIN = -1 ! .........EXIT go to 430 400 CONTINUE ! ! ................................................... ! ! TAKE A STEP ! call DSTOD(NEQ,Y,YH,NEQ,YH1,EWT,SAVF,ACOR,WM,IWM, & DF,DJAC,RPAR,IPAR) ! JSTART = -2 INTOUT = .TRUE. if (KFLAG == 0) go to 270 ! ! ...................................................... ! if (KFLAG == -1) go to 410 ! ! REPEATED CORRECTOR CONVERGENCE FAILURES IDID = -6 IBEGIN = -1 go to 420 410 CONTINUE ! ! REPEATED ERROR TEST FAILURES IDID = -7 IBEGIN = -1 420 CONTINUE 430 CONTINUE ! ! ......................................................... ! ! STORE VALUES BEFORE RETURNING TO ! DDEBDF DO 440 L = 1, NEQ Y(L) = YH(L,1) YPOUT(L) = YH(L,2)/H 440 CONTINUE T = X TOLD = T INTOUT = .FALSE. 450 CONTINUE 460 CONTINUE return end subroutine DLSSUD (A, X, B, N, M, NRDA, U, NRDU, IFLAG, MLSO, & IRANK, ISCALE, Q, DIAG, KPIVOT, S, DIV, TD, ISFLG, SCALES) ! !! DLSSUD is subsidiary to DBVSUP and DSUDS. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (LSSUDS-S, DLSSUD-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DLSSUD solves the underdetermined system of equations A Z = B, ! where A is N by M and N <= M. In particular, if rank A equals ! IRA, a vector X and a matrix U are determined such that X is the ! UNIQUE solution of smallest length, satisfying A X = B, and the ! columns of U form an orthonormal basis for the null space of A, ! satisfying A U = 0 . Then all solutions Z are given by ! Z = X + C(1)*U(1) + ..... + C(M-IRA)*U(M-IRA) ! where U(J) represents the J-th column of U and the C(J) are ! arbitrary constants. ! If the system of equations are not compatible, only the least ! squares solution of minimal length is computed. ! ! ********************************************************************* ! INPUT ! ********************************************************************* ! ! A -- Contains the matrix of N equations in M unknowns, A remains ! unchanged, must be dimensioned NRDA by M. ! X -- Solution array of length at least M. ! B -- Given constant vector of length N, B remains unchanged. ! N -- Number of equations, N greater or equal to 1. ! M -- Number of unknowns, M greater or equal to N. ! NRDA -- Row dimension of A, NRDA greater or equal to N. ! U -- Matrix used for solution, must be dimensioned NRDU by ! (M - rank of A). ! (storage for U may be ignored when only the minimal length ! solution X is desired) ! NRDU -- Row dimension of U, NRDU greater or equal to M. ! (if only the minimal length solution is wanted, ! NRDU=0 is acceptable) ! IFLAG -- Status indicator ! =0 for the first call (and for each new problem defined by ! a new matrix A) when the matrix data is treated as exact ! =-K for the first call (and for each new problem defined by ! a new matrix A) when the matrix data is assumed to be ! accurate to about K digits. ! =1 for subsequent calls whenever the matrix A has already ! been decomposed (problems with new vectors B but ! same matrix A can be handled efficiently). ! MLSO -- =0 if only the minimal length solution is wanted. ! =1 if the complete solution is wanted, includes the ! linear space defined by the matrix U. ! IRANK -- Variable used for the rank of A, set by the code. ! ISCALE -- Scaling indicator ! =-1 if the matrix A is to be pre-scaled by ! columns when appropriate. ! If the scaling indicator is not equal to -1 ! no scaling will be attempted. ! For most problems scaling will probably not be necessary. ! Q -- Matrix used for the transformation, must be dimensioned ! NRDA by M. ! DIAG,KPIVOT,S, -- Arrays of length at least N used for internal ! DIV,TD,SCALES storage (except for SCALES which is M). ! ISFLG -- Storage for an internal variable. ! ! ********************************************************************* ! OUTPUT ! ********************************************************************* ! ! IFLAG -- Status indicator ! =1 if solution was obtained. ! =2 if improper input is detected. ! =3 if rank of matrix is less than N. ! To continue, simply reset IFLAG=1 and call DLSSUD again. ! =4 if the system of equations appears to be inconsistent. ! However, the least squares solution of minimal length ! was obtained. ! X -- Minimal length least squares solution of A Z = B ! IRANK -- Numerically determined rank of A, must not be altered ! on succeeding calls with input values of IFLAG=1. ! U -- Matrix whose M-IRANK columns are mutually orthogonal unit ! vectors which span the null space of A. This is to be ignored ! when MLSO was set to zero or IFLAG=4 on output. ! Q -- Contains the strictly upper triangular part of the reduced ! matrix and transformation information. ! DIAG -- Contains the diagonal elements of the triangular reduced ! matrix. ! KPIVOT -- Contains the pivotal information. The row interchanges ! performed on the original matrix are recorded here. ! S -- Contains the solution of the lower triangular system. ! DIV,TD -- Contains transformation information for rank ! deficient problems. ! SCALES -- Contains the column scaling parameters. ! ! ********************************************************************* ! !***SEE ALSO DBVSUP, DSUDS !***REFERENCES H. A. Watts, Solving linear least squares problems ! using SODS/SUDS/CODS, Sandia Report SAND77-0683, ! Sandia Laboratories, 1977. !***ROUTINES CALLED D1MACH, DDOT, DOHTRL, DORTHR, J4SAVE, XERMAX, ! XERMSG, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DLSSUD INTEGER J4SAVE DOUBLE PRECISION DDOT, D1MACH INTEGER I, IFLAG, IRANK, IRP, ISCALE, ISFLG, J, JR, K, KP, & KPIVOT(*), L, M, MAXMES, MJ, MLSO, N, NFAT, NFATAL, NMIR, & NRDA, NRDU, NU DOUBLE PRECISION A(NRDA,*), B(*), DIAG(*), DIV(*), GAM, GAMMA, & Q(NRDA,*), RES, S(*), SCALES(*), SS, TD(*), U(NRDU,*), URO, & X(*) ! ! ****************************************************************** ! ! MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED ! BY THE FUNCTION D1MACH. ! ! ****************************************************************** ! ! BEGIN BLOCK PERMITTING ...EXITS TO 310 ! BEGIN BLOCK PERMITTING ...EXITS TO 80 !***FIRST EXECUTABLE STATEMENT DLSSUD URO = D1MACH(4) ! if (N < 1 .OR. M < N .OR. NRDA < N) go to 70 if (NRDU /= 0 .AND. NRDU < M) go to 70 if (IFLAG > 0) go to 60 ! call XGETF(NFATAL) MAXMES = J4SAVE(4,0,.FALSE.) ISFLG = -15 if (IFLAG == 0) go to 10 ISFLG = IFLAG NFAT = -1 if (NFATAL == 0) NFAT = 0 call XSETF(NFAT) call XERMAX(1) 10 CONTINUE ! ! COPY MATRIX A INTO MATRIX Q ! DO 30 K = 1, M DO 20 J = 1, N Q(J,K) = A(J,K) 20 CONTINUE 30 CONTINUE ! ! USE ORTHOGONAL TRANSFORMATIONS TO REDUCE Q TO LOWER ! TRIANGULAR FORM ! call DORTHR(Q,N,M,NRDA,IFLAG,IRANK,ISCALE,DIAG,KPIVOT, & SCALES,DIV,TD) ! call XSETF(NFATAL) call XERMAX(MAXMES) if (IRANK == N) go to 40 ! ! FOR RANK DEFICIENT PROBLEMS USE ADDITIONAL ! ORTHOGONAL TRANSFORMATIONS TO FURTHER REDUCE Q ! if (IRANK /= 0) & call DOHTRL(Q,N,NRDA,DIAG,IRANK,DIV,TD) ! ...............EXIT go to 310 40 CONTINUE ! ! STORE DIVISORS FOR THE TRIANGULAR SOLUTION ! DO 50 K = 1, N DIV(K) = DIAG(K) 50 CONTINUE ! .........EXIT go to 80 60 CONTINUE ! ......EXIT if (IFLAG == 1) go to 80 70 CONTINUE ! ! INVALID INPUT FOR DLSSUD IFLAG = 2 call XERMSG ('SLATEC', 'DLSSUD', & 'INVALID IMPUT PARAMETERS.', 2, 1) ! ......EXIT go to 310 80 CONTINUE ! ! if (IRANK > 0) go to 130 ! ! SPECIAL CASE FOR THE NULL MATRIX DO 110 K = 1, M X(K) = 0.0D0 if (MLSO == 0) go to 100 U(K,K) = 1.0D0 DO 90 J = 1, M if (J /= K) U(J,K) = 0.0D0 90 CONTINUE 100 CONTINUE 110 CONTINUE DO 120 K = 1, N if (B(K) > 0.0D0) IFLAG = 4 120 CONTINUE go to 300 130 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 180 ! ! COPY CONSTANT VECTOR INTO S AFTER FIRST INTERCHANGING ! THE ELEMENTS ACCORDING TO THE PIVOTAL SEQUENCE ! DO 140 K = 1, N KP = KPIVOT(K) X(K) = B(KP) 140 CONTINUE DO 150 K = 1, N S(K) = X(K) 150 CONTINUE ! IRP = IRANK + 1 NU = 1 if (MLSO == 0) NU = 0 ! ...EXIT if (IRANK == N) go to 180 ! ! FOR RANK DEFICIENT PROBLEMS WE MUST APPLY THE ! ORTHOGONAL TRANSFORMATION TO S ! WE ALSO CHECK TO SEE if THE SYSTEM APPEARS TO BE ! INCONSISTENT ! NMIR = N - IRANK SS = DDOT(N,S(1),1,S(1),1) DO 170 L = 1, IRANK K = IRP - L GAM = ((TD(K)*S(K)) + DDOT(NMIR,Q(IRP,K),1,S(IRP),1)) & /(TD(K)*DIV(K)) S(K) = S(K) + GAM*TD(K) DO 160 J = IRP, N S(J) = S(J) + GAM*Q(J,K) 160 CONTINUE 170 CONTINUE RES = DDOT(NMIR,S(IRP),1,S(IRP),1) ! ...EXIT if (RES & <= SS*(10.0D0*MAX(10.0D0**ISFLG,10.0D0*URO))**2) & go to 180 ! ! INCONSISTENT SYSTEM IFLAG = 4 NU = 0 180 CONTINUE ! ! APPLY FORWARD SUBSTITUTION TO SOLVE LOWER TRIANGULAR SYSTEM ! S(1) = S(1)/DIV(1) if (IRANK < 2) go to 200 DO 190 K = 2, IRANK S(K) = (S(K) - DDOT(K-1,Q(K,1),NRDA,S(1),1))/DIV(K) 190 CONTINUE 200 CONTINUE ! ! INITIALIZE X VECTOR AND THEN APPLY ORTHOGONAL TRANSFORMATION ! DO 210 K = 1, M X(K) = 0.0D0 if (K <= IRANK) X(K) = S(K) 210 CONTINUE ! DO 230 JR = 1, IRANK J = IRP - JR MJ = M - J + 1 GAMMA = DDOT(MJ,Q(J,J),NRDA,X(J),1)/(DIAG(J)*Q(J,J)) DO 220 K = J, M X(K) = X(K) + GAMMA*Q(J,K) 220 CONTINUE 230 CONTINUE ! ! RESCALE ANSWERS AS DICTATED ! DO 240 K = 1, M X(K) = X(K)*SCALES(K) 240 CONTINUE ! if (NU == 0 .OR. M == IRANK) go to 290 ! ! INITIALIZE U MATRIX AND THEN APPLY ORTHOGONAL ! TRANSFORMATION ! L = M - IRANK DO 280 K = 1, L DO 250 I = 1, M U(I,K) = 0.0D0 if (I == IRANK + K) U(I,K) = 1.0D0 250 CONTINUE ! DO 270 JR = 1, IRANK J = IRP - JR MJ = M - J + 1 GAMMA = DDOT(MJ,Q(J,J),NRDA,U(J,K),1) & /(DIAG(J)*Q(J,J)) DO 260 I = J, M U(I,K) = U(I,K) + GAMMA*Q(J,I) 260 CONTINUE 270 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE 310 CONTINUE ! return end subroutine DMACON ! !! DMACON is subsidiary to DBVSUP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (MACON-S, DMACON-D) !***AUTHOR (UNKNOWN) !***SEE ALSO DBVSUP !***ROUTINES CALLED D1MACH !***COMMON BLOCKS DML5MC !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DMACON DOUBLE PRECISION D1MACH INTEGER KE, LPAR DOUBLE PRECISION DD, EPS, FOURU, SQOVFL, SRU, TWOU, URO COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR !***FIRST EXECUTABLE STATEMENT DMACON URO = D1MACH(4) SRU = SQRT(URO) DD = -LOG10(URO) LPAR = 0.5D0*DD KE = 0.5D0 + 0.75D0*DD EPS = 10.0D0**(-2*KE) SQOVFL = SQRT(D1MACH(2)) TWOU = 2.0D0*URO FOURU = 4.0D0*URO return end subroutine DMGSBV (M, N, A, IA, NIV, IFLAG, S, P, IP, INHOMO, V, & W, WCND) ! !! DMGSBV orthogonalizes a set of vectors and determines their rank. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DBVSUP !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (MGSBV-S, DMGSBV-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! Orthogonalize a set of N double precision vectors and determine their ! rank. ! ! ********************************************************************** ! INPUT ! ********************************************************************** ! M = dimension of vectors. ! N = no. of vectors. ! A = array whose first N cols contain the vectors. ! IA = first dimension of array A (col length). ! NIV = number of independent vectors needed. ! INHOMO = 1 corresponds to having a non-zero particular solution. ! V = particular solution vector (not included in the pivoting). ! INDPVT = 1 means pivoting will not be used. ! ! ********************************************************************** ! OUTPUT ! ********************************************************************** ! NIV = no. of linear independent vectors in input set. ! A = matrix whose first NIV cols. contain NIV orthogonal vectors ! which span the vector space determined by the input vectors. ! IFLAG ! = 0 success ! = 1 incorrect input ! = 2 rank of new vectors less than N ! P = decomposition matrix. P is upper triangular and ! (old vectors) = (new vectors) * P. ! The old vectors will be reordered due to pivoting. ! The dimension of P must be >= N*(N+1)/2. ! ( N*(2*N+1) when N /= NFCC ) ! IP = pivoting vector. The dimension of IP must be >= N. ! ( 2*N when N /= NFCC ) ! S = square of norms of incoming vectors. ! V = vector which is orthogonal to the vectors of A. ! W = orthogonalization information for the vector V. ! WCND = worst case (smallest) norm decrement value of the ! vectors being orthogonalized (represents a test ! for linear dependence of the vectors). ! ********************************************************************** ! !***SEE ALSO DBVSUP !***ROUTINES CALLED DDOT, DPRVEC !***COMMON BLOCKS DML18J, DML5MC !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 890921 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DMGSBV ! DOUBLE PRECISION DDOT, DPRVEC INTEGER I, IA, ICOCO, IFLAG, INDPVT, INHOMO, INTEG, IP(*), IP1, & IX, IZ, J, JK, JP, JQ, JY, JZ, K, KD, KJ, KP, L, LIX, LPAR, & LR, M, M2, MXNON, N, NDISK, NEQ, NEQIVP, NFCC, NIC, NIV, & NIVN, NMNR, NN, NOPG, NP1, NPS, NR, NRM1, NTAPE, NTP, & NUMORT, NXPTS DOUBLE PRECISION A(IA,*), AE, DOT, EPS, FOURU, P(*), PJP, PSAVE, & RE, RY, S(*), SQOVFL, SRU, SV, T, TOL, TWOU, URO, V(*), VL, & VNORM, W(*), WCND, Y ! ! COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, & ICOCO ! COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR ! !***FIRST EXECUTABLE STATEMENT DMGSBV if (M > 0 .AND. N > 0 .AND. IA >= M) go to 10 IFLAG = 1 go to 280 10 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 270 ! BEGIN BLOCK PERMITTING ...EXITS TO 260 ! JP = 0 IFLAG = 0 NP1 = N + 1 Y = 0.0D0 M2 = M/2 ! ! CALCULATE SQUARE OF NORMS OF INCOMING VECTORS AND SEARCH ! FOR VECTOR WITH LARGEST MAGNITUDE ! J = 0 DO 40 I = 1, N VL = DDOT(M,A(1,I),1,A(1,I),1) S(I) = VL if (N == NFCC) go to 20 J = 2*I - 1 P(J) = VL IP(J) = J 20 CONTINUE J = J + 1 P(J) = VL IP(J) = J if (VL <= Y) go to 30 Y = VL IX = I 30 CONTINUE 40 CONTINUE if (INDPVT /= 1) go to 50 IX = 1 Y = P(1) 50 CONTINUE LIX = IX if (N /= NFCC) LIX = 2*IX - 1 P(LIX) = P(1) S(NP1) = 0.0D0 if (INHOMO == 1) S(NP1) = DDOT(M,V,1,V,1) WCND = 1.0D0 NIVN = NIV NIV = 0 ! ! ...EXIT if (Y == 0.0D0) go to 260 ! ********************************************************* DO 240 NR = 1, N ! BEGIN BLOCK PERMITTING ...EXITS TO 230 ! ......EXIT if (NIVN == NIV) go to 250 NIV = NR if (IX == NR) go to 130 ! ! PIVOTING OF COLUMNS OF P MATRIX ! NN = N LIX = IX LR = NR if (N == NFCC) go to 60 NN = NFCC LIX = 2*IX - 1 LR = 2*NR - 1 60 CONTINUE if (NR == 1) go to 80 KD = LIX - LR KJ = LR NRM1 = LR - 1 DO 70 J = 1, NRM1 PSAVE = P(KJ) JK = KJ + KD P(KJ) = P(JK) P(JK) = PSAVE KJ = KJ + NN - J 70 CONTINUE JY = JK + NMNR JZ = JY - KD P(JY) = P(JZ) 80 CONTINUE IZ = IP(LIX) IP(LIX) = IP(LR) IP(LR) = IZ SV = S(IX) S(IX) = S(NR) S(NR) = SV if (N == NFCC) go to 110 if (NR == 1) go to 100 KJ = LR + 1 DO 90 K = 1, NRM1 PSAVE = P(KJ) JK = KJ + KD P(KJ) = P(JK) P(JK) = PSAVE KJ = KJ + NFCC - K 90 CONTINUE 100 CONTINUE IZ = IP(LIX+1) IP(LIX+1) = IP(LR+1) IP(LR+1) = IZ 110 CONTINUE ! ! PIVOTING OF COLUMNS OF VECTORS ! DO 120 L = 1, M T = A(L,IX) A(L,IX) = A(L,NR) A(L,NR) = T 120 CONTINUE 130 CONTINUE ! ! CALCULATE P(NR,NR) AS NORM SQUARED OF PIVOTAL ! VECTOR ! JP = JP + 1 P(JP) = Y RY = 1.0D0/Y NMNR = N - NR if (N == NFCC) go to 140 NMNR = NFCC - (2*NR - 1) JP = JP + 1 P(JP) = 0.0D0 KP = JP + NMNR P(KP) = Y 140 CONTINUE if (NR == N .OR. NIVN == NIV) go to 200 ! ! CALCULATE ORTHOGONAL PROJECTION VECTORS AND ! SEARCH FOR LARGEST NORM ! Y = 0.0D0 IP1 = NR + 1 IX = IP1 ! ************************************************ DO 190 J = IP1, N DOT = DDOT(M,A(1,NR),1,A(1,J),1) JP = JP + 1 JQ = JP + NMNR if (N /= NFCC) JQ = JQ + NMNR - 1 P(JQ) = P(JP) - DOT*(DOT*RY) P(JP) = DOT*RY DO 150 I = 1, M A(I,J) = A(I,J) - P(JP)*A(I,NR) 150 CONTINUE if (N == NFCC) go to 170 KP = JP + NMNR JP = JP + 1 PJP = RY*DPRVEC(M,A(1,NR),A(1,J)) P(JP) = PJP P(KP) = -PJP KP = KP + 1 P(KP) = RY*DOT DO 160 K = 1, M2 L = M2 + K A(K,J) = A(K,J) - PJP*A(L,NR) A(L,J) = A(L,J) + PJP*A(K,NR) 160 CONTINUE P(JQ) = P(JQ) - PJP*(PJP/RY) 170 CONTINUE ! ! TEST FOR CANCELLATION IN RECURRENCE RELATION ! if (P(JQ) <= S(J)*SRU) & P(JQ) = DDOT(M,A(1,J),1,A(1,J),1) if (P(JQ) <= Y) go to 180 Y = P(JQ) IX = J 180 CONTINUE 190 CONTINUE if (N /= NFCC) JP = KP ! ************************************************ if (INDPVT == 1) IX = IP1 ! ! RECOMPUTE NORM SQUARED OF PIVOTAL VECTOR WITH ! SCALAR PRODUCT ! Y = DDOT(M,A(1,IX),1,A(1,IX),1) ! ............EXIT if (Y <= EPS*S(IX)) go to 260 WCND = MIN(WCND,Y/S(IX)) 200 CONTINUE ! ! COMPUTE ORTHOGONAL PROJECTION OF PARTICULAR ! SOLUTION ! ! ...EXIT if (INHOMO /= 1) go to 230 LR = NR if (N /= NFCC) LR = 2*NR - 1 W(LR) = DDOT(M,A(1,NR),1,V,1)*RY DO 210 I = 1, M V(I) = V(I) - W(LR)*A(I,NR) 210 CONTINUE ! ...EXIT if (N == NFCC) go to 230 LR = 2*NR W(LR) = RY*DPRVEC(M,V,A(1,NR)) DO 220 K = 1, M2 L = M2 + K V(K) = V(K) + W(LR)*A(L,NR) V(L) = V(L) - W(LR)*A(K,NR) 220 CONTINUE 230 CONTINUE 240 CONTINUE 250 CONTINUE ! ********************************************************* ! ! TEST FOR LINEAR DEPENDENCE OF PARTICULAR SOLUTION ! ! ......EXIT if (INHOMO /= 1) go to 270 if ((N > 1) .AND. (S(NP1) < 1.0)) go to 270 VNORM = DDOT(M,V,1,V,1) if (S(NP1) /= 0.0D0) WCND = MIN(WCND,VNORM/S(NP1)) ! ......EXIT if (VNORM >= EPS*S(NP1)) go to 270 260 CONTINUE IFLAG = 2 WCND = EPS 270 CONTINUE 280 CONTINUE return end subroutine DMOUT (M, N, LDA, A, IFMT, IDIGIT) ! !! DMOUT prints a double precision matrix. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DBOCLS and DFC !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SMOUT-S, DMOUT-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! DOUBLE PRECISION MATRIX OUTPUT ROUTINE. ! ! INPUT.. ! ! M,N,LDA,A(*,*) PRINT THE DOUBLE PRECISION ARRAY A(I,J),I = 1,...,M, ! J=1,...,N, ON OUTPUT UNIT LOUT=6. LDA IS THE DECLARED ! FIRST DIMENSION OF A(*,*) AS SPECIFIED IN THE CALLING ! PROGRAM. THE HEADING IN THE FORTRAN FORMAT STATEMENT ! IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST STEP. ! THE COMPONENTS A(I,J) ARE INDEXED, ON OUTPUT, IN A ! PLEASANT FORMAT. ! IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON ! OUTPUT UNIT LOUT=6 WITH THE VARIABLE FORMAT FORTRAN ! STATEMENT ! WRITE(LOUT,IFMT). ! IDIGIT PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. ! THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,14,20 OR ! 28 WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF ! PLACES. if IDIGIT < 0, 72 PRINTING COLUMNS ARE ! UTILIZED TO WRITE EACH LINE OF OUTPUT OF THE ARRAY ! A(*,*). (THIS CAN BE USED ON MOST TIME-SHARING ! TERMINALS). if IDIGIT >= 0, 133 PRINTING COLUMNS ARE ! UTILIZED. (THIS CAN BE USED ON MOST LINE PRINTERS). ! ! EXAMPLE.. ! ! PRINT AN ARRAY CALLED (SIMPLEX TABLEAU ) OF SIZE 10 BY 20 SHOWING ! 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING ! SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. ! ! DOUBLE PRECISION TABLEU(20,20) ! M = 10 ! N = 20 ! LDTABL = 20 ! IDIGIT = -6 ! call DMOUT(M,N,LDTABL,TABLEU,21H(16H1SIMPLEX TABLEAU),IDIGIT) ! !***SEE ALSO DBOCLS, DFC !***ROUTINES CALLED I1MACH !***REVISION HISTORY (YYMMDD) ! 821220 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891107 Added comma after 1P edit descriptor in FORMAT ! statements. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910403 Updated AUTHOR section. (WRB) !***END PROLOGUE DMOUT DOUBLE PRECISION A(LDA,*) CHARACTER IFMT*(*),ICOL*3 SAVE ICOL DATA ICOL /'COL'/ !***FIRST EXECUTABLE STATEMENT DMOUT LOUT=I1MACH(2) WRITE(LOUT,IFMT) if ( M <= 0.OR.N <= 0.OR.LDA <= 0) RETURN NDIGIT = IDIGIT if ( IDIGIT == 0) NDIGIT = 4 if ( IDIGIT >= 0) go to 80 ! NDIGIT = -IDIGIT if ( NDIGIT > 4) go to 9 ! DO 5 K1=1,N,5 K2 = MIN(N,K1+4) WRITE(LOUT,1010) (ICOL,I,I = K1, K2) DO 5 I = 1, M WRITE(LOUT,1009) I,(A(I,J),J = K1, K2) 5 CONTINUE return ! 9 CONTINUE if ( NDIGIT > 6) go to 20 ! DO 10 K1=1,N,4 K2 = MIN(N,K1+3) WRITE(LOUT,1000) (ICOL,I,I = K1, K2) DO 10 I = 1, M WRITE(LOUT,1004) I,(A(I,J),J = K1, K2) 10 CONTINUE return ! 20 CONTINUE if ( NDIGIT > 14) go to 40 ! DO 30 K1=1,N,2 K2 = MIN(N,K1+1) WRITE(LOUT,1001) (ICOL,I,I = K1, K2) DO 30 I = 1, M WRITE(LOUT,1005) I,(A(I,J),J = K1, K2) 30 CONTINUE return ! 40 CONTINUE if ( NDIGIT > 20) go to 60 ! DO 50 K1=1,N,2 K2=MIN(N,K1+1) WRITE(LOUT,1002) (ICOL,I,I = K1, K2) DO 50 I = 1, M WRITE(LOUT,1006) I,(A(I,J),J = K1, K2) 50 CONTINUE return ! 60 CONTINUE DO 70 K1=1,N K2 = K1 WRITE(LOUT,1003) (ICOL,I,I = K1, K2) DO 70 I = 1, M WRITE(LOUT,1007) I,(A(I,J),J = K1, K2) 70 CONTINUE return ! 80 CONTINUE if ( NDIGIT > 4) go to 86 ! DO 85 K1=1,N,10 K2 = MIN(N,K1+9) WRITE(LOUT,1000) (ICOL,I,I = K1, K2) DO 85 I = 1, M WRITE(LOUT,1009) I,(A(I,J),J = K1, K2) 85 CONTINUE ! 86 if (NDIGIT > 6) go to 100 ! DO 90 K1=1,N,8 K2 = MIN(N,K1+7) WRITE(LOUT,1000) (ICOL,I,I = K1, K2) DO 90 I = 1, M WRITE(LOUT,1004) I,(A(I,J),J = K1, K2) 90 CONTINUE return ! 100 CONTINUE if ( NDIGIT > 14) go to 120 ! DO 110 K1=1,N,5 K2 = MIN(N,K1+4) WRITE(LOUT,1001) (ICOL,I,I = K1, K2) DO 110 I = 1, M WRITE(LOUT,1005) I,(A(I,J),J = K1, K2) 110 CONTINUE return ! 120 CONTINUE if ( NDIGIT > 20) go to 140 ! DO 130 K1=1,N,4 K2 = MIN(N,K1+3) WRITE(LOUT,1002) (ICOL,I,I = K1, K2) DO 130 I = 1, M WRITE(LOUT,1006) I,(A(I,J),J = K1, K2) 130 CONTINUE return ! 140 CONTINUE DO 150 K1=1,N,3 K2 = MIN(N,K1+2) WRITE(LOUT,1003) (ICOL,I,I = K1, K2) DO 150 I = 1, M WRITE(LOUT,1007) I,(A(I,J),J = K1, K2) 150 CONTINUE return 1000 FORMAT(10X,8(5X,A,I4,2X)) 1001 FORMAT(10X,5(9X,A,I4,6X)) 1002 FORMAT(10X,4(12X,A,I4,9X)) 1003 FORMAT(10X,3(16X,A,I4,13X)) 1004 FORMAT(1X,3HROW,I4,2X,1P,8D14.5) 1005 FORMAT(1X,3HROW,I4,2X,1P,5D22.13) 1006 FORMAT(1X,3HROW,I4,2X,1P,4D28.19) 1007 FORMAT(1X,3HROW,I4,2X,1P,3D36.27) 1009 FORMAT(1X,3HROW,I4,2X,1P,10D12.3) 1010 FORMAT(10X,10(4X,A,I4,1X)) end subroutine DMPAR (N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, X, & SIGMA, WA1, WA2) ! !! DMPAR is subsidiary to DNLS1 and DNLS1E. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DNLS1 and DNLS1E !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (LMPAR-S, DMPAR-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! **** Double Precision version of LMPAR **** ! ! Given an M by N matrix A, an N by N nonsingular DIAGONAL ! matrix D, an M-vector B, and a positive number DELTA, ! the problem is to determine a value for the parameter ! PAR such that if X solves the system ! ! A*X = B , SQRT(PAR)*D*X = 0 , ! ! in the least squares sense, and DXNORM is the Euclidean ! norm of D*X, then either PAR is zero and ! ! (DXNORM-DELTA) <= 0.1*DELTA , ! ! or PAR is positive and ! ! ABS(DXNORM-DELTA) <= 0.1*DELTA . ! ! This subroutine completes the solution of the problem ! if it is provided with the necessary information from the ! QR factorization, with column pivoting, of A. That is, if ! A*P = Q*R, where P is a permutation matrix, Q has orthogonal ! columns, and R is an upper triangular matrix with diagonal ! elements of nonincreasing magnitude, then DMPAR expects ! the full upper triangle of R, the permutation matrix P, ! and the first N components of (Q TRANSPOSE)*B. On output ! DMPAR also provides an upper triangular matrix S such that ! ! T T T ! P *(A *A + PAR*D*D)*P = S *S . ! ! S is employed within DMPAR and may be of separate interest. ! ! Only a few iterations are generally needed for convergence ! of the algorithm. If, however, the limit of 10 iterations ! is reached, then the output PAR will contain the best ! value obtained so far. ! ! The subroutine statement is ! ! SUBROUTINE DMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SIGMA, ! WA1,WA2) ! ! where ! ! N is a positive integer input variable set to the order of R. ! ! R is an N by N array. On input the full upper triangle ! must contain the full upper triangle of the matrix R. ! On output the full upper triangle is unaltered, and the ! strict lower triangle contains the strict upper triangle ! (transposed) of the upper triangular matrix S. ! ! LDR is a positive integer input variable not less than N ! which specifies the leading dimension of the array R. ! ! IPVT is an integer input array of length N which defines the ! permutation matrix P such that A*P = Q*R. Column J of P ! is column IPVT(J) of the identity matrix. ! ! DIAG is an input array of length N which must contain the ! diagonal elements of the matrix D. ! ! QTB is an input array of length N which must contain the first ! N elements of the vector (Q TRANSPOSE)*B. ! ! DELTA is a positive input variable which specifies an upper ! bound on the Euclidean norm of D*X. ! ! PAR is a nonnegative variable. On input PAR contains an ! initial estimate of the Levenberg-Marquardt parameter. ! On output PAR contains the final estimate. ! ! X is an output array of length N which contains the least ! squares solution of the system A*X = B, SQRT(PAR)*D*X = 0, ! for the output PAR. ! ! SIGMA is an output array of length N which contains the ! diagonal elements of the upper triangular matrix S. ! ! WA1 and WA2 are work arrays of length N. ! !***SEE ALSO DNLS1, DNLS1E !***ROUTINES CALLED D1MACH, DENORM, DQRSLV !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DMPAR INTEGER N,LDR INTEGER IPVT(*) DOUBLE PRECISION DELTA,PAR DOUBLE PRECISION R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA1(*), & WA2(*) INTEGER I,ITER,J,JM1,JP1,K,L,NSING DOUBLE PRECISION DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001, & SUM,TEMP,ZERO DOUBLE PRECISION D1MACH,DENORM SAVE P1, P001, ZERO DATA P1,P001,ZERO /1.0D-1,1.0D-3,0.0D0/ !***FIRST EXECUTABLE STATEMENT DMPAR DWARF = D1MACH(1) ! ! COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. if THE ! JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. ! NSING = N DO 10 J = 1, N WA1(J) = QTB(J) if (R(J,J) == ZERO .AND. NSING == N) NSING = J - 1 if (NSING < N) WA1(J) = ZERO 10 CONTINUE if (NSING < 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 < 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 ! ! INITIALIZE THE ITERATION COUNTER. ! EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST ! FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. ! ITER = 0 DO 70 J = 1, N WA2(J) = DIAG(J)*X(J) 70 CONTINUE DXNORM = DENORM(N,WA2) FP = DXNORM - DELTA if (FP <= P1*DELTA) go to 220 ! ! if THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON ! STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF ! THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. ! PARL = ZERO if (NSING < 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 < 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 = DENORM(N,WA1) PARL = ((FP/DELTA)/TEMP)/TEMP 120 CONTINUE ! ! CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. ! 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 = DENORM(N,WA1) PARU = GNORM/DELTA if (PARU == ZERO) PARU = DWARF/MIN(DELTA,P1) ! ! if THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), ! SET PAR TO THE CLOSER ENDPOINT. ! PAR = MAX(PAR,PARL) PAR = MIN(PAR,PARU) if (PAR == ZERO) PAR = GNORM/DXNORM ! ! BEGINNING OF AN ITERATION. ! 150 CONTINUE ITER = ITER + 1 ! ! EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. ! if (PAR == ZERO) PAR = MAX(DWARF,P001*PARU) TEMP = SQRT(PAR) DO 160 J = 1, N WA1(J) = TEMP*DIAG(J) 160 CONTINUE call DQRSLV(N,R,LDR,IPVT,WA1,QTB,X,SIGMA,WA2) DO 170 J = 1, N WA2(J) = DIAG(J)*X(J) 170 CONTINUE DXNORM = DENORM(N,WA2) TEMP = FP FP = DXNORM - DELTA ! ! if THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE ! OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL ! IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. ! if (ABS(FP) <= P1*DELTA & .OR. PARL == ZERO .AND. FP <= TEMP & .AND. TEMP < ZERO .OR. ITER == 10) go to 220 ! ! COMPUTE THE NEWTON CORRECTION. ! 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)/SIGMA(J) TEMP = WA1(J) JP1 = J + 1 if (N < JP1) go to 200 DO 190 I = JP1, N WA1(I) = WA1(I) - R(I,J)*TEMP 190 CONTINUE 200 CONTINUE 210 CONTINUE TEMP = DENORM(N,WA1) PARC = ((FP/DELTA)/TEMP)/TEMP ! ! DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. ! if (FP > ZERO) PARL = MAX(PARL,PAR) if (FP < ZERO) PARU = MIN(PARU,PAR) ! ! COMPUTE AN IMPROVED ESTIMATE FOR PAR. ! PAR = MAX(PARL,PAR+PARC) ! ! END OF AN ITERATION. ! go to 150 220 CONTINUE ! ! TERMINATION. ! if (ITER == 0) PAR = ZERO return ! ! LAST CARD OF SUBROUTINE DMPAR. ! end subroutine DNBCO (ABE, LDA, N, ML, MU, IPVT, RCOND, Z) ! !! DNBCO factors a band matrix using Gaussian elimination and ... ! estimate the condition number. ! !***LIBRARY SLATEC !***CATEGORY D2A2 !***TYPE DOUBLE PRECISION (SNBCO-S, DNBCO-D, CNBCO-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, ! NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! DNBCO factors a double precision band matrix by Gaussian ! elimination and estimates the condition of the matrix. ! ! If RCOND is not needed, DNBFA is slightly faster. ! To solve A*X = B , follow DNBCO by DNBSL. ! To compute INVERSE(A)*C , follow DNBCO by DNBSL. ! To compute DETERMINANT(A) , follow DNBCO by DNBDI. ! ! On Entry ! ! ABE DOUBLE PRECISION(LDA, NC) ! contains the matrix in band storage. The rows ! of the original matrix are stored in the rows ! of ABE and the diagonals of the original matrix ! are stored in columns 1 through ML+MU+1 of ABE. ! NC must be >= 2*ML+MU+1 . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABE. ! LDA must be >= N . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! ! On Return ! ! ABE an upper triangular matrix in band storage ! and the multipliers which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND DOUBLE PRECISION ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z DOUBLE PRECISION(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 through ML+MU+1 of ABE . ! Furthermore, ML additional columns are needed in ! ABE starting with column ML+MU+2 for elements ! generated during the triangularization. The total ! number of columns needed in ABE is 2*ML+MU+1 . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 + , * = not used ! 21222324 + , + = used for pivoting ! 32333435 + ! 43444546 + ! 545556 * + ! 6566 * * + ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DASUM, DAXPY, DDOT, DNBFA, DSCAL !***REVISION HISTORY (YYMMDD) ! 800728 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DNBCO INTEGER LDA,N,ML,MU,IPVT(*) DOUBLE PRECISION ABE(LDA,*),Z(*) DOUBLE PRECISION RCOND ! DOUBLE PRECISION DDOT,EK,T,WK,WKM DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM INTEGER I,INFO,J,JU,K,KB,KP1,L,LDB,LM,LZ,M,ML1,MM,NL,NU !***FIRST EXECUTABLE STATEMENT DNBCO ML1=ML+1 LDB = LDA - 1 ANORM = 0.0D0 DO 10 J = 1, N NU = MIN(MU,J-1) NL = MIN(ML,N-J) L = 1 + NU + NL ANORM = MAX(ANORM,DASUM(L,ABE(J+NL,ML1-NL),LDB)) 10 CONTINUE ! ! FACTOR ! call DNBFA(ABE,LDA,N,ML,MU,IPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . ! TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE ! CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE ! TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID ! OVERFLOW. ! ! SOLVE TRANS(U)*W = E ! EK = 1.0D0 DO 20 J = 1, N Z(J) = 0.0D0 20 CONTINUE M = ML + MU + 1 JU = 0 DO 100 K = 1, N if (Z(K) /= 0.0D0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= ABS(ABE(K,ML1))) go to 30 S = ABS(ABE(K,ML1))/ABS(EK-Z(K)) call DSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) if (ABE(K,ML1) == 0.0D0) go to 40 WK = WK/ABE(K,ML1) WKM = WKM/ABE(K,ML1) go to 50 40 CONTINUE WK = 1.0D0 WKM = 1.0D0 50 CONTINUE KP1 = K + 1 JU = MIN(MAX(JU,MU+IPVT(K)),N) MM = ML1 if (KP1 > JU) go to 90 DO 60 I = KP1, JU MM = MM + 1 SM = SM + ABS(Z(I)+WKM*ABE(K,MM)) Z(I) = Z(I) + WK*ABE(K,MM) S = S + ABS(Z(I)) 60 CONTINUE if (S >= SM) go to 80 T = WKM -WK WK = WKM MM = ML1 DO 70 I = KP1, JU MM = MM + 1 Z(I) = Z(I) + T*ABE(K,MM) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) ! ! SOLVE TRANS(L)*Y = W ! DO 120 KB = 1, N K = N + 1 - KB NL = MIN(ML,N-K) if (K < N) Z(K) = Z(K) + DDOT(NL,ABE(K+NL,ML1-NL),-LDB,Z(K+1) & ,1) if (ABS(Z(K)) <= 1.0D0) go to 110 S = 1.0D0/ABS(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) ! YNORM = 1.0D0 ! ! SOLVE L*V = Y ! DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T NL = MIN(ML,N-K) if (K < N) call DAXPY(NL,T,ABE(K+NL,ML1-NL),-LDB,Z(K+1),1) if (ABS(Z(K)) <= 1.0D0) go to 130 S = 1.0D0/ABS(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 ! ! SOLVE U*Z = V ! DO 160 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= ABS(ABE(K,ML1))) go to 150 S = ABS(ABE(K,ML1))/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE if (ABE(K,ML1) /= 0.0D0) Z(K) = Z(K)/ABE(K,ML1) if (ABE(K,ML1) == 0.0D0) Z(K) = 1.0D0 LM = MIN(K,M) - 1 LZ = K - LM T = -Z(K) call DAXPY(LM,T,ABE(K-1,ML+2),-LDB,Z(LZ),1) 160 CONTINUE ! MAKE ZNORM = 1.0D0 S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0D0) RCOND = YNORM/ANORM if (ANORM == 0.0D0) RCOND = 0.0D0 return end subroutine DNBDI (ABE, LDA, N, ML, MU, IPVT, DET) ! !! DNBDI computes the determinant of a band matrix using the factors ... ! computed by DNBCO or DNBFA. ! !***LIBRARY SLATEC !***CATEGORY D3A2 !***TYPE DOUBLE PRECISION (SNBDI-S, DNBDI-D, CNBDI-C) !***KEYWORDS BANDED, DETERMINANT, LINEAR EQUATIONS, NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! DNBDI computes the determinant of a band matrix ! using the factors computed by DNBCO or DNBFA. ! If the inverse is needed, use DNBSL N times. ! ! On Entry ! ! ABE DOUBLE PRECISION(LDA, NC) ! the output from DNBCO or DNBFA. ! NC must be >= 2*ML+MU+1 . ! ! LDA INTEGER ! the leading dimension of the array ABE . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from DNBCO or DNBFA. ! ! On Return ! ! DET DOUBLE PRECISION(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800728 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DNBDI INTEGER LDA,N,ML,MU,IPVT(*) DOUBLE PRECISION ABE(LDA,*),DET(2) ! DOUBLE PRECISION TEN INTEGER I !***FIRST EXECUTABLE STATEMENT DNBDI DET(1) = 1.0D0 DET(2) = 0.0D0 TEN = 10.0D0 DO 50 I = 1, N if (IPVT(I) /= I) DET(1) = -DET(1) DET(1) = ABE(I,ML+1)*DET(1) if (DET(1) == 0.0D0) go to 60 10 if (ABS(DET(1)) >= 1.0D0) go to 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 go to 10 20 CONTINUE 30 if (ABS(DET(1)) < TEN) go to 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0D0 go to 30 40 CONTINUE 50 CONTINUE 60 CONTINUE return end subroutine DNBFA (ABE, LDA, N, ML, MU, IPVT, INFO) ! !! DNBFA factors a band matrix by elimination. ! !***LIBRARY SLATEC !***CATEGORY D2A2 !***TYPE DOUBLE PRECISION (SNBFA-S, DNBFA-D, CNBFA-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, ! NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! DNBFA factors a double precision band matrix by elimination. ! ! DNBFA is usually called by DNBCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! ! On Entry ! ! ABE DOUBLE PRECISION(LDA, NC) ! contains the matrix in band storage. The rows ! of the original matrix are stored in the rows ! of ABE and the diagonals of the original matrix ! are stored in columns 1 through ML+MU+1 of ABE. ! NC must be >= 2*ML+MU+1 . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABE. ! LDA must be >= N . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! ! On Return ! ! ABE an upper triangular matrix in band storage ! and the multipliers which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! =0 normal value ! =K if U(K,K) == 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that DNBSL will divide by zero if ! called. Use RCOND in DNBCO for a reliable ! indication of singularity. ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 through ML+MU+1 of ABE . ! Furthermore, ML additional columns are needed in ! ABE starting with column ML+MU+2 for elements ! generated during the triangularization. The total ! number of columns needed in ABE is 2*ML+MU+1 . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 + , * = not used ! 21222324 + , + = used for pivoting ! 32333435 + ! 43444546 + ! 545556 * + ! 6566 * * + ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DSCAL, DSWAP, IDAMAX !***REVISION HISTORY (YYMMDD) ! 800728 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DNBFA INTEGER LDA,N,ML,MU,IPVT(*),INFO DOUBLE PRECISION ABE(LDA,*) ! INTEGER ML1,MB,M,N1,LDB,I,J,K,L,LM,LM1,LM2,MP,IDAMAX DOUBLE PRECISION T !***FIRST EXECUTABLE STATEMENT DNBFA ML1=ML+1 MB=ML+MU M=ML+MU+1 N1=N-1 LDB=LDA-1 INFO=0 ! ! SET FILL-IN COLUMNS TO ZERO ! if ( N <= 1)go to 50 if ( ML <= 0)go to 7 DO 6 J=1,ML DO 5 I=1,N ABE(I,M+J)=0.0D0 5 CONTINUE 6 CONTINUE 7 CONTINUE ! ! GAUSSIAN ELIMINATION WITH PARTIAL ELIMINATION ! DO 40 K=1,N1 LM=MIN(N-K,ML) LM1=LM+1 LM2=ML1-LM ! ! SEARCH FOR PIVOT INDEX ! L=-IDAMAX(LM1,ABE(LM+K,LM2),LDB)+LM1+K IPVT(K)=L MP=MIN(MB,N-K) ! ! SWAP ROWS if NECESSARY ! if ( L /= K)CALL DSWAP(MP+1,ABE(K,ML1),LDA,ABE(L,ML1+K-L),LDA) ! ! SKIP COLUMN REDUCTION if PIVOT IS ZERO ! if ( ABE(K,ML1) == 0.0D0) go to 20 ! ! COMPUTE MULTIPLIERS ! T=-1.0/ABE(K,ML1) call DSCAL(LM,T,ABE(LM+K,LM2),LDB) ! ! ROW ELIMINATION WITH COLUMN INDEXING ! DO 10 J=1,MP call DAXPY (LM,ABE(K,ML1+J),ABE(LM+K,LM2),LDB,ABE(LM+K,LM2+J), & LDB) 10 CONTINUE go to 30 20 CONTINUE INFO=K 30 CONTINUE 40 CONTINUE 50 CONTINUE IPVT(N)=N if ( ABE(N,ML1) == 0.0D0) INFO=N return end subroutine DNBFS (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK) ! !! DNBFS solves a general nonsymmetric banded system of linear equations. ! !***LIBRARY SLATEC !***CATEGORY D2A2 !***TYPE DOUBLE PRECISION (SNBFS-S, DNBFS-D, CNBFS-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine DNBFS solves a general nonsymmetric banded NxN ! system of double precision real linear equations using ! SLATEC subroutines DNBCO and DNBSL. These are adaptations ! of the LINPACK subroutines DGBCO and DGBSL which require ! a different format for storing the matrix elements. If ! A is an NxN double precision matrix and if X and B are ! double precision N-vectors, then DNBFS solves the equation ! ! A*X=B. ! ! A band matrix is a matrix whose nonzero elements are all ! fairly near the main diagonal, specifically A(I,J) = 0 ! if I-J is greater than ML or J-I is greater than ! MU . The integers ML and MU are called the lower and upper ! band widths and M = ML+MU+1 is the total band width. ! DNBFS uses less time and storage than the corresponding ! program for general matrices (DGEFS) if 2*ML+MU < N . ! ! The matrix A is first factored into upper and lower tri- ! angular matrices U and L using partial pivoting. These ! factors and the pivoting information are used to find the ! solution vector X. An approximate condition number is ! calculated to provide a rough estimate of the number of ! digits of accuracy in the computed solution. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N and IWORK must not have been altered by the user follow- ! ing factorization (ITASK=1). IND will not be changed by DNBFS ! in this case. ! ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 through ML+MU+1 of ABE . ! Furthermore, ML additional columns are needed in ! ABE starting with column ML+MU+2 for elements ! generated during the triangularization. The total ! number of columns needed in ABE is 2*ML+MU+1 . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 + , * = not used ! 21222324 + , + = used for pivoting ! 32333435 + ! 43444546 + ! 545556 * + ! 6566 * * + ! ! ! Argument Description *** ! ! ABE DOUBLE PRECISION(LDA,NC) ! on entry, contains the matrix in band storage as ! described above. NC must not be less than ! 2*ML+MU+1 . The user is cautioned to specify NC ! with care since it is not an argument and cannot ! be checked by DNBFS. The rows of the original ! matrix are stored in the rows of ABE and the ! diagonals of the original matrix are stored in ! columns 1 through ML+MU+1 of ABE . ! on return, contains an upper triangular matrix U and ! the multipliers necessary to construct a matrix L ! so that A=L*U. ! LDA INTEGER ! the leading dimension of array ABE. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. N must be greater ! than or equal to 1 . (terminal error message IND=-2) ! ML INTEGER ! the number of diagonals below the main diagonal. ! ML must not be less than zero nor greater than or ! equal to N . (terminal error message IND=-5) ! MU INTEGER ! the number of diagonals above the main diagonal. ! MU must not be less than zero nor greater than or ! equal to N . (terminal error message IND=-6) ! V DOUBLE PRECISION(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! If ITASK=1, the matrix A is factored and then the ! linear equation is solved. ! If ITASK > 1, the equation is solved using the existing ! factored matrix A and IWORK. ! If ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. ! LT. 0 See error message corresponding to IND below. ! WORK DOUBLE PRECISION(N) ! a singly subscripted array of dimension at least N. ! IWORK INTEGER(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than 1. ! IND=-3 terminal ITASK is less than 1. ! IND=-4 terminal The matrix A is computationally singular. ! A solution has not been computed. ! IND=-5 terminal ML is less than zero or is greater than ! or equal to N . ! IND=-6 terminal MU is less than zero or is greater than ! or equal to N . ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! Note- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED D1MACH, DNBCO, DNBSL, XERMSG !***REVISION HISTORY (YYMMDD) ! 800812 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls, changed GOTOs to ! IF-THEN-ELSEs. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DNBFS ! INTEGER LDA,N,ITASK,IND,IWORK(*),ML,MU DOUBLE PRECISION ABE(LDA,*),V(*),WORK(*),D1MACH DOUBLE PRECISION RCOND CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT DNBFS if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'DNBFS', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'DNBFS', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'DNBFS', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ML < 0 .OR. ML >= N) THEN IND = -5 WRITE (XERN1, '(I8)') ML call XERMSG ('SLATEC', 'DNBFS', & 'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1) return end if ! if (MU < 0 .OR. MU >= N) THEN IND = -6 WRITE (XERN1, '(I8)') MU call XERMSG ('SLATEC', 'DNBFS', & 'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1) return end if ! if (ITASK == 1) THEN ! ! FACTOR MATRIX A INTO LU ! call DNBCO(ABE,LDA,N,ML,MU,IWORK,RCOND,WORK) ! ! CHECK FOR COMPUTATIONALLY SINGULAR MATRIX ! if (RCOND == 0.0D0) THEN IND = -4 call XERMSG ('SLATEC', 'DNBFS', & 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) return ENDIF ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(D1MACH(4)/RCOND) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'DNBFS', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) ENDIF end if ! ! SOLVE AFTER FACTORING ! call DNBSL(ABE,LDA,N,ML,MU,IWORK,V,0) return end subroutine DNBSL (ABE, LDA, N, ML, MU, IPVT, B, JOB) ! !! DNBSL solves a real band system using the factors computed by DNBCO or DNBFA. ! !***LIBRARY SLATEC !***CATEGORY D2A2 !***TYPE DOUBLE PRECISION (SNBSL-S, DNBSL-D, CNBSL-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC, SOLVE !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! DNBSL solves the double precision band system ! A * X = B or TRANS(A) * X = B ! using the factors computed by DNBCO or DNBFA. ! ! On Entry ! ! ABE DOUBLE PRECISION(LDA, NC) ! the output from DNBCO or DNBFA. ! NC must be >= 2*ML+MU+1 . ! ! LDA INTEGER ! the leading dimension of the array ABE . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from DNBCO or DNBFA. ! ! B DOUBLE PRECISION(N) ! the right hand side vector. ! ! JOB INTEGER ! = 0 to solve A*X = B . ! = nonzero to solve TRANS(A)*X = B , where ! TRANS(A) is the transpose. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically this indicates singularity ! but it is often caused by improper arguments or improper ! setting of LDA. It will not occur if the subroutines are ! called correctly and if DNBCO has set RCOND > 0.0 ! or DNBFA has set INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call DNBCO(ABE,LDA,N,ML,MU,IPVT,RCOND,Z) ! if (RCOND is too small) go to ... ! DO 10 J = 1, P ! call DNBSL(ABE,LDA,N,ML,MU,IPVT,C(1,J),0) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT !***REVISION HISTORY (YYMMDD) ! 800728 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DNBSL INTEGER LDA,N,ML,MU,IPVT(*),JOB DOUBLE PRECISION ABE(LDA,*),B(*) ! DOUBLE PRECISION DDOT,T INTEGER K,KB,L,LB,LDB,LM,M,MLM,NM1 !***FIRST EXECUTABLE STATEMENT DNBSL M=MU+ML+1 NM1=N-1 LDB=1-LDA if ( JOB /= 0)go to 50 ! ! JOB = 0 , SOLVE A * X = B ! FIRST SOLVE L*Y = B ! if ( ML == 0)go to 30 if ( NM1 < 1)go to 30 DO 20 K=1,NM1 LM=MIN(ML,N-K) L=IPVT(K) T=B(L) if ( L == K)go to 10 B(L)=B(K) B(K)=T 10 CONTINUE MLM=ML-(LM-1) call DAXPY(LM,T,ABE(K+LM,MLM),LDB,B(K+1),1) 20 CONTINUE 30 CONTINUE ! ! NOW SOLVE U*X = Y ! DO 40 KB=1,N K=N+1-KB B(K)=B(K)/ABE(K,ML+1) LM=MIN(K,M)-1 LB=K-LM T=-B(K) call DAXPY(LM,T,ABE(K-1,ML+2),LDB,B(LB),1) 40 CONTINUE go to 100 50 CONTINUE ! ! JOB = NONZERO, SOLVE TRANS(A) * X = B ! FIRST SOLVE TRANS(U)*Y = B ! DO 60 K = 1, N LM = MIN(K,M) - 1 LB = K - LM T = DDOT(LM,ABE(K-1,ML+2),LDB,B(LB),1) B(K) = (B(K) - T)/ABE(K,ML+1) 60 CONTINUE ! ! NOW SOLVE TRANS(L)*X = Y ! if (ML == 0) go to 90 if (NM1 < 1) go to 90 DO 80 KB = 1, NM1 K = N - KB LM = MIN(ML,N-K) MLM = ML - (LM - 1) B(K) = B(K) + DDOT(LM,ABE(K+LM,MLM),LDB,B(K+1),1) L = IPVT(K) if (L == 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 DNLS1E (FCN, IOPT, M, N, X, FVEC, TOL, NPRINT, INFO, & IW, WA, LWA) ! !! DNLS1E is an easy-to-use code which minimizes the sum of the squares ... ! of M nonlinear functions in N variables by a modification ! of the Levenberg-Marquardt algorithm. ! !***LIBRARY SLATEC !***CATEGORY K1B1A1, K1B1A2 !***TYPE DOUBLE PRECISION (SNLS1E-S, DNLS1E-D) !***KEYWORDS EASY-TO-USE, LEVENBERG-MARQUARDT, NONLINEAR DATA FITTING, ! NONLINEAR LEAST SQUARES !***AUTHOR Hiebert, K. L., (SNLA) !***DESCRIPTION ! ! 1. Purpose. ! ! The purpose of DNLS1E is to minimize the sum of the squares of M ! nonlinear functions in N variables by a modification of the ! Levenberg-Marquardt algorithm. This is done by using the more ! general least-squares solver DNLS1. The user must provide a ! subroutine which calculates the functions. The user has the ! option of how the Jacobian will be supplied. The user can ! supply the full Jacobian, or the rows of the Jacobian (to avoid ! storing the full Jacobian), or let the code approximate the ! Jacobian by forward-differencing. This code is the combination ! of the MINPACK codes (Argonne) LMDER1, LMDIF1, and LMSTR1. ! ! ! 2. Subroutine and Type Statements. ! ! SUBROUTINE DNLS1E(FCN,IOPT,M,N,X,FVEC,TOL,NPRINT, ! * INFO,IW,WA,LWA) ! INTEGER IOPT,M,N,NPRINT,INFO,LWAC,IW(N) ! DOUBLE PRECISION TOL,X(N),FVEC(M),WA(LWA) ! EXTERNAL FCN ! ! ! 3. Parameters. ALL TYPE REAL parameters are DOUBLE PRECISION ! ! Parameters designated as input parameters must be specified on ! entry to DNLS1E and are not changed on exit, while parameters ! designated as output parameters need not be specified on entry ! and are set to appropriate values on exit from DNLS1E. ! ! FCN is the name of the user-supplied subroutine which calculates ! the functions. If the user wants to supply the Jacobian ! (IOPT=2 or 3), then FCN must be written to calculate the ! Jacobian, as well as the functions. See the explanation ! of the IOPT argument below. ! If the user wants the iterates printed (NPRINT positive), then ! FCN must do the printing. See the explanation of NPRINT ! below. FCN must be declared in an EXTERNAL statement in the ! calling program and should be written as follows. ! ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! INTEGER IFLAG,LDFJAC,M,N ! DOUBLE PRECISION X(N),FVEC(M) ! ---------- ! FJAC and LDFJAC may be ignored , if IOPT=1. ! DOUBLE PRECISION FJAC(LDFJAC,N) , if IOPT=2. ! DOUBLE PRECISION FJAC(N) , if IOPT=3. ! ---------- ! If IFLAG=0, the values in X and FVEC are available ! for printing. See the explanation of NPRINT below. ! IFLAG will never be zero unless NPRINT is positive. ! The values of X and FVEC must not be changed. ! return ! ---------- ! If IFLAG=1, calculate the functions at X and return ! this vector in FVEC. ! return ! ---------- ! If IFLAG=2, calculate the full Jacobian at X and return ! this matrix in FJAC. Note that IFLAG will never be 2 unless ! IOPT=2. FVEC contains the function values at X and must ! not be altered. FJAC(I,J) must be set to the derivative ! of FVEC(I) with respect to X(J). ! return ! ---------- ! If IFLAG=3, calculate the LDFJAC-th row of the Jacobian ! and return this vector in FJAC. Note that IFLAG will ! never be 3 unless IOPT=3. FVEC contains the function ! values at X and must not be altered. FJAC(J) must be ! set to the derivative of FVEC(LDFJAC) with respect to X(J). ! return ! ---------- ! END ! ! ! The value of IFLAG should not be changed by FCN unless the ! user wants to terminate execution of DNLS1E. In this case, ! set IFLAG to a negative integer. ! ! ! IOPT is an input variable which specifies how the Jacobian will ! be calculated. If IOPT=2 or 3, then the user must supply the ! Jacobian, as well as the function values, through the ! subroutine FCN. If IOPT=2, the user supplies the full ! Jacobian with one call to FCN. If IOPT=3, the user supplies ! one row of the Jacobian with each call. (In this manner, ! storage can be saved because the full Jacobian is not stored.) ! If IOPT=1, the code will approximate the Jacobian by forward ! differencing. ! ! M is a positive integer input variable set to the number of ! functions. ! ! N is a positive integer input variable set to the number of ! variables. N must not exceed M. ! ! X is an array of length N. On input, X must contain an initial ! estimate of the solution vector. On output, X contains the ! final estimate of the solution vector. ! ! FVEC is an output array of length M which contains the functions ! evaluated at the output X. ! ! TOL is a non-negative input variable. Termination occurs when ! the algorithm estimates either that the relative error in the ! sum of squares is at most TOL or that the relative error ! between X and the solution is at most TOL. Section 4 contains ! more details about TOL. ! ! NPRINT is an integer input variable that enables controlled ! printing of iterates if it is positive. In this case, FCN is ! called with IFLAG = 0 at the beginning of the first iteration ! and every NPRINT iterations thereafter and immediately prior ! to return, with X and FVEC available for printing. Appropriate ! print statements must be added to FCN (see example) and ! FVEC should not be altered. If NPRINT is not positive, no ! special calls of FCN with IFLAG = 0 are made. ! ! INFO is an integer output variable. If the user has terminated ! execution, INFO is set to the (negative) value of IFLAG. See ! description of FCN and JAC. Otherwise, INFO is set as follows. ! ! INFO = 0 improper input parameters. ! ! INFO = 1 algorithm estimates that the relative error in the ! sum of squares is at most TOL. ! ! INFO = 2 algorithm estimates that the relative error between ! X and the solution is at most TOL. ! ! INFO = 3 conditions for INFO = 1 and INFO = 2 both hold. ! ! INFO = 4 FVEC is orthogonal to the columns of the Jacobian to ! machine precision. ! ! INFO = 5 number of calls to FCN has reached 100*(N+1) ! for IOPT=2 or 3 or 200*(N+1) for IOPT=1. ! ! INFO = 6 TOL is too small. No further reduction in the sum ! of squares is possible. ! ! INFO = 7 TOL is too small. No further improvement in the ! approximate solution X is possible. ! ! Sections 4 and 5 contain more details about INFO. ! ! IW is an INTEGER work array of length N. ! ! WA is a work array of length LWA. ! ! LWA is a positive integer input variable not less than ! N*(M+5)+M for IOPT=1 and 2 or N*(N+5)+M for IOPT=3. ! ! ! 4. Successful Completion. ! ! The accuracy of DNLS1E is controlled by the convergence parame- ! ter TOL. This parameter is used in tests which make three types ! of comparisons between the approximation X and a solution XSOL. ! DNLS1E terminates when any of the tests is satisfied. If TOL is ! less than the machine precision (as defined by the function ! R1MACH(4)), then DNLS1E only attempts to satisfy the test ! defined by the machine precision. Further progress is not usu- ! ally possible. Unless high precision solutions are required, ! the recommended value for TOL is the square root of the machine ! precision. ! ! The tests assume that the functions are reasonably well behaved, ! and, if the Jacobian is supplied by the user, that the functions ! and the Jacobian are coded consistently. If these conditions ! are not satisfied, then DNLS1E may incorrectly indicate conver- ! gence. If the Jacobian is coded correctly or IOPT=1, ! then the validity of the answer can be checked, for example, by ! rerunning DNLS1E with tighter tolerances. ! ! First Convergence Test. If ENORM(Z) denotes the Euclidean norm ! of a vector Z, then this test attempts to guarantee that ! ! ENORM(FVEC) <= (1+TOL)*ENORM(FVECS), ! ! where FVECS denotes the functions evaluated at XSOL. If this ! condition is satisfied with TOL = 10**(-K), then the final ! residual norm ENORM(FVEC) has K significant decimal digits and ! INFO is set to 1 (or to 3 if the second test is also satis- ! fied). ! ! Second Convergence Test. If D is a diagonal matrix (implicitly ! generated by DNLS1E) whose entries contain scale factors for ! the variables, then this test attempts to guarantee that ! ! ENORM(D*(X-XSOL)) <= TOL*ENORM(D*XSOL). ! ! If this condition is satisfied with TOL = 10**(-K), then the ! larger components of D*X have K significant decimal digits and ! INFO is set to 2 (or to 3 if the first test is also satis- ! fied). There is a danger that the smaller components of D*X ! may have large relative errors, but the choice of D is such ! that the accuracy of the components of X is usually related to ! their sensitivity. ! ! Third Convergence Test. This test is satisfied when FVEC is ! orthogonal to the columns of the Jacobian to machine preci- ! sion. There is no clear relationship between this test and ! the accuracy of DNLS1E, and furthermore, the test is equally ! well satisfied at other critical points, namely maximizers and ! saddle points. Therefore, termination caused by this test ! (INFO = 4) should be examined carefully. ! ! ! 5. Unsuccessful Completion. ! ! Unsuccessful termination of DNLS1E can be due to improper input ! parameters, arithmetic interrupts, or an excessive number of ! function evaluations. ! ! Improper Input Parameters. INFO is set to 0 if IOPT < 1 ! or IOPT > 3, or N <= 0, or M < N, or TOL < 0.E0, ! or for IOPT=1 or 2 LWA < N*(M+5)+M, or for IOPT=3 ! LWA < N*(N+5)+M. ! ! Arithmetic Interrupts. If these interrupts occur in the FCN ! subroutine during an early stage of the computation, they may ! be caused by an unacceptable choice of X by DNLS1E. In this ! case, it may be possible to remedy the situation by not evalu- ! ating the functions here, but instead setting the components ! of FVEC to numbers that exceed those in the initial FVEC. ! ! Excessive Number of Function Evaluations. If the number of ! calls to FCN reaches 100*(N+1) for IOPT=2 or 3 or 200*(N+1) ! for IOPT=1, then this indicates that the routine is converging ! very slowly as measured by the progress of FVEC, and INFO is ! set to 5. In this case, it may be helpful to restart DNLS1E, ! thereby forcing it to disregard old (and possibly harmful) ! information. ! ! ! 6. Characteristics of the Algorithm. ! ! DNLS1E is a modification of the Levenberg-Marquardt algorithm. ! Two of its main characteristics involve the proper use of ! implicitly scaled variables and an optimal choice for the cor- ! rection. The use of implicitly scaled variables achieves scale ! invariance of DNLS1E and limits the size of the correction in ! any direction where the functions are changing rapidly. The ! optimal choice of the correction guarantees (under reasonable ! conditions) global convergence from starting points far from the ! solution and a fast rate of convergence for problems with small ! residuals. ! ! Timing. The time required by DNLS1E to solve a given problem ! depends on M and N, the behavior of the functions, the accu- ! racy requested, and the starting point. The number of arith- ! metic operations needed by DNLS1E is about N**3 to process ! each evaluation of the functions (call to FCN) and to process ! each evaluation of the Jacobian DNLS1E takes M*N**2 for IOPT=2 ! (one call to JAC), M*N**2 for IOPT=1 (N calls to FCN) and ! 1.5*M*N**2 for IOPT=3 (M calls to FCN). Unless FCN ! can be evaluated quickly, the timing of DNLS1E will be ! strongly influenced by the time spent in FCN. ! ! Storage. DNLS1E requires (M*N + 2*M + 6*N) for IOPT=1 or 2 and ! (N**2 + 2*M + 6*N) for IOPT=3 single precision storage ! locations and N integer storage locations, in addition to ! the storage required by the program. There are no internally ! declared storage arrays. ! ! *Long Description: ! ! 7. Example. ! ! The problem is to determine the values of X(1), X(2), and X(3) ! which provide the best fit (in the least squares sense) of ! ! X(1) + U(I)/(V(I)*X(2) + W(I)*X(3)), I = 1, 15 ! ! to the data ! ! Y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, ! 0.37,0.58,0.73,0.96,1.34,2.10,4.39), ! ! where U(I) = I, V(I) = 16 - I, and W(I) = MIN(U(I),V(I)). The ! I-th component of FVEC is thus defined by ! ! Y(I) - (X(1) + U(I)/(V(I)*X(2) + W(I)*X(3))). ! ! ********** ! ! PROGRAM TEST ! C ! C Driver for DNLS1E example. ! C ! INTEGER I,IOPT,M,N,NPRINT,JNFO,LWA,NWRITE ! INTEGER IW(3) ! DOUBLE PRECISION TOL,FNORM,X(3),FVEC(15),WA(75) ! DOUBLE PRECISION DENORM,D1MACH ! EXTERNAL FCN ! DATA NWRITE /6/ ! C ! IOPT = 1 ! M = 15 ! N = 3 ! C ! C The following starting values provide a rough fit. ! C ! X(1) = 1.E0 ! X(2) = 1.E0 ! X(3) = 1.E0 ! C ! LWA = 75 ! NPRINT = 0 ! C ! C Set TOL to the square root of the machine precision. ! C Unless high precision solutions are required, ! C this is the recommended setting. ! C ! TOL = SQRT(R1MACH(4)) ! C ! call DNLS1E(FCN,IOPT,M,N,X,FVEC,TOL,NPRINT, ! * INFO,IW,WA,LWA) ! FNORM = ENORM(M,FVEC) ! WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) ! STOP ! 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // ! * 5X,' EXIT ! * 5X,' FINAL APPROXIMATE SOLUTION' // 5X,3E15.7) ! END ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,DUM,IDUM) ! C This is the form of the FCN routine if IOPT=1, ! C that is, if the user does not calculate the Jacobian. ! INTEGER I,M,N,IFLAG ! DOUBLE PRECISION X(N),FVEC(M),Y(15) ! DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! END ! ! ! Results obtained with different compilers or machines ! may be slightly different. ! ! FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 ! ! EXIT PARAMETER 1 ! ! FINAL APPROXIMATE SOLUTION ! ! 0.8241058E-01 0.1133037E+01 0.2343695E+01 ! ! ! For IOPT=2, FCN would be modified as follows to also ! calculate the full Jacobian when IFLAG=2. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! C ! C This is the form of the FCN routine if IOPT=2, ! C that is, if the user calculates the full Jacobian. ! C ! INTEGER I,LDFJAC,M,N,IFLAG ! DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),Y(15) ! DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! if ( IFLAG /= 1) go to 20 ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! C ! C Below, calculate the full Jacobian. ! C ! 20 CONTINUE ! C ! DO 30 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 ! FJAC(I,1) = -1.E0 ! FJAC(I,2) = TMP1*TMP2/TMP4 ! FJAC(I,3) = TMP1*TMP3/TMP4 ! 30 CONTINUE ! return ! END ! ! ! For IOPT = 3, FJAC would be dimensioned as FJAC(3,3), ! LDFJAC would be set to 3, and FCN would be written as ! follows to calculate a row of the Jacobian when IFLAG=3. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! C This is the form of the FCN routine if IOPT=3, ! C that is, if the user calculates the Jacobian row by row. ! INTEGER I,M,N,IFLAG ! DOUBLE PRECISION X(N),FVEC(M),FJAC(N),Y(15) ! DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! if ( IFLAG /= 1) go to 20 ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! C ! C Below, calculate the LDFJAC-th row of the Jacobian. ! C ! 20 CONTINUE ! ! I = LDFJAC ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 ! FJAC(1) = -1.E0 ! FJAC(2) = TMP1*TMP2/TMP4 ! FJAC(3) = TMP1*TMP3/TMP4 ! return ! END ! !***REFERENCES Jorge J. More, The Levenberg-Marquardt algorithm: ! implementation and theory. In Numerical Analysis ! Proceedings (Dundee, June 28 - July 1, 1977, G. A. ! Watson, Editor), Lecture Notes in Mathematics 630, ! Springer-Verlag, 1978. !***ROUTINES CALLED DNLS1, XERMSG !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DNLS1E IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER M,N,NPRINT,INFO,LWA,IOPT INTEGER INDEX,IW(*) DOUBLE PRECISION TOL DOUBLE PRECISION X(*),FVEC(*),WA(*) EXTERNAL FCN INTEGER MAXFEV,MODE,NFEV,NJEV DOUBLE PRECISION FACTOR,FTOL,GTOL,XTOL,ZERO,EPSFCN SAVE FACTOR, ZERO DATA FACTOR,ZERO /1.0D2,0.0D0/ !***FIRST EXECUTABLE STATEMENT DNLS1E INFO = 0 ! ! CHECK THE INPUT PARAMETERS FOR ERRORS. ! if (IOPT < 1 .OR. IOPT > 3 .OR. & N <= 0 .OR. M < N .OR. TOL < ZERO & .OR. LWA < N*(N+5) + M) go to 10 if (IOPT < 3 .AND. LWA < N*(M+5) + M) go to 10 ! ! call DNLS1. ! MAXFEV = 100*(N + 1) if (IOPT == 1) MAXFEV = 2*MAXFEV FTOL = TOL XTOL = TOL GTOL = ZERO EPSFCN = ZERO MODE = 1 INDEX = 5*N+M call DNLS1(FCN,IOPT,M,N,X,FVEC,WA(INDEX+1),M,FTOL,XTOL,GTOL, & MAXFEV,EPSFCN,WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, & IW,WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) if (INFO == 8) INFO = 4 10 CONTINUE if (INFO == 0) call XERMSG ('SLATEC', 'DNLS1E', & 'INVALID INPUT PARAMETER.', 2, 1) return ! ! LAST CARD OF SUBROUTINE DNLS1E. ! end subroutine DNLS1 (FCN, IOPT, M, N, X, FVEC, FJAC, LDFJAC, FTOL, & XTOL, GTOL, MAXFEV, EPSFCN, DIAG, MODE, FACTOR, NPRINT, INFO, & NFEV, NJEV, IPVT, QTF, WA1, WA2, WA3, WA4) ! !! DNLS1 minimizes the sum of the squares of M nonlinear functions ... ! in N variables by a modification of the Levenberg-Marquardt algorithm. ! !***LIBRARY SLATEC !***CATEGORY K1B1A1, K1B1A2 !***TYPE DOUBLE PRECISION (SNLS1-S, DNLS1-D) !***KEYWORDS LEVENBERG-MARQUARDT, NONLINEAR DATA FITTING, ! NONLINEAR LEAST SQUARES !***AUTHOR Hiebert, K. L., (SNLA) !***DESCRIPTION ! ! 1. Purpose. ! ! The purpose of DNLS1 is to minimize the sum of the squares of M ! nonlinear functions in N variables by a modification of the ! Levenberg-Marquardt algorithm. The user must provide a subrou- ! tine which calculates the functions. The user has the option ! of how the Jacobian will be supplied. The user can supply the ! full Jacobian, or the rows of the Jacobian (to avoid storing ! the full Jacobian), or let the code approximate the Jacobian by ! forward-differencing. This code is the combination of the ! MINPACK codes (Argonne) LMDER, LMDIF, and LMSTR. ! ! ! 2. Subroutine and Type Statements. ! ! SUBROUTINE DNLS1(FCN,IOPT,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL, ! * GTOL,MAXFEV,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO ! * ,NFEV,NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) ! INTEGER IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV ! INTEGER IPVT(N) ! DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR ! DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), ! * WA1(N),WA2(N),WA3(N),WA4(M) ! ! ! 3. Parameters. ! ! Parameters designated as input parameters must be specified on ! entry to DNLS1 and are not changed on exit, while parameters ! designated as output parameters need not be specified on entry ! and are set to appropriate values on exit from DNLS1. ! ! FCN is the name of the user-supplied subroutine which calculate ! the functions. If the user wants to supply the Jacobian ! (IOPT=2 or 3), then FCN must be written to calculate the ! Jacobian, as well as the functions. See the explanation ! of the IOPT argument below. ! If the user wants the iterates printed (NPRINT positive), then ! FCN must do the printing. See the explanation of NPRINT ! below. FCN must be declared in an EXTERNAL statement in the ! calling program and should be written as follows. ! ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! INTEGER IFLAG,LDFJAC,M,N ! DOUBLE PRECISION X(N),FVEC(M) ! ---------- ! FJAC and LDFJAC may be ignored , if IOPT=1. ! DOUBLE PRECISION FJAC(LDFJAC,N) , if IOPT=2. ! DOUBLE PRECISION FJAC(N) , if IOPT=3. ! ---------- ! If IFLAG=0, the values in X and FVEC are available ! for printing. See the explanation of NPRINT below. ! IFLAG will never be zero unless NPRINT is positive. ! The values of X and FVEC must not be changed. ! return ! ---------- ! If IFLAG=1, calculate the functions at X and return ! this vector in FVEC. ! return ! ---------- ! If IFLAG=2, calculate the full Jacobian at X and return ! this matrix in FJAC. Note that IFLAG will never be 2 unless ! IOPT=2. FVEC contains the function values at X and must ! not be altered. FJAC(I,J) must be set to the derivative ! of FVEC(I) with respect to X(J). ! return ! ---------- ! If IFLAG=3, calculate the LDFJAC-th row of the Jacobian ! and return this vector in FJAC. Note that IFLAG will ! never be 3 unless IOPT=3. FVEC contains the function ! values at X and must not be altered. FJAC(J) must be ! set to the derivative of FVEC(LDFJAC) with respect to X(J). ! return ! ---------- ! END ! ! ! The value of IFLAG should not be changed by FCN unless the ! user wants to terminate execution of DNLS1. In this case, set ! IFLAG to a negative integer. ! ! ! IOPT is an input variable which specifies how the Jacobian will ! be calculated. If IOPT=2 or 3, then the user must supply the ! Jacobian, as well as the function values, through the ! subroutine FCN. If IOPT=2, the user supplies the full ! Jacobian with one call to FCN. If IOPT=3, the user supplies ! one row of the Jacobian with each call. (In this manner, ! storage can be saved because the full Jacobian is not stored.) ! If IOPT=1, the code will approximate the Jacobian by forward ! differencing. ! ! M is a positive integer input variable set to the number of ! functions. ! ! N is a positive integer input variable set to the number of ! variables. N must not exceed M. ! ! X is an array of length N. On input, X must contain an initial ! estimate of the solution vector. On output, X contains the ! final estimate of the solution vector. ! ! FVEC is an output array of length M which contains the functions ! evaluated at the output X. ! ! FJAC is an output array. For IOPT=1 and 2, FJAC is an M by N ! array. For IOPT=3, FJAC is an N by N array. The upper N by N ! submatrix of FJAC contains an upper triangular matrix R with ! diagonal elements of nonincreasing magnitude such that ! ! T T T ! P *(JAC *JAC)*P = R *R, ! ! where P is a permutation matrix and JAC is the final calcu- ! lated Jacobian. Column J of P is column IPVT(J) (see below) ! of the identity matrix. The lower part of FJAC contains ! information generated during the computation of R. ! ! LDFJAC is a positive integer input variable which specifies ! the leading dimension of the array FJAC. For IOPT=1 and 2, ! LDFJAC must not be less than M. For IOPT=3, LDFJAC must not ! be less than N. ! ! FTOL is a non-negative input variable. Termination occurs when ! both the actual and predicted relative reductions in the sum ! of squares are at most FTOL. Therefore, FTOL measures the ! relative error desired in the sum of squares. Section 4 con- ! tains more details about FTOL. ! ! XTOL is a non-negative input variable. Termination occurs when ! the relative error between two consecutive iterates is at most ! XTOL. Therefore, XTOL measures the relative error desired in ! the approximate solution. Section 4 contains more details ! about XTOL. ! ! GTOL is a non-negative input variable. Termination occurs when ! the cosine of the angle between FVEC and any column of the ! Jacobian is at most GTOL in absolute value. Therefore, GTOL ! measures the orthogonality desired between the function vector ! and the columns of the Jacobian. Section 4 contains more ! details about GTOL. ! ! MAXFEV is a positive integer input variable. Termination occurs ! when the number of calls to FCN to evaluate the functions ! has reached MAXFEV. ! ! EPSFCN is an input variable used in determining a suitable step ! for the forward-difference approximation. This approximation ! assumes that the relative errors in the functions are of the ! order of EPSFCN. If EPSFCN is less than the machine preci- ! sion, it is assumed that the relative errors in the functions ! are of the order of the machine precision. If IOPT=2 or 3, ! then EPSFCN can be ignored (treat it as a dummy argument). ! ! DIAG is an array of length N. If MODE = 1 (see below), DIAG is ! internally set. If MODE = 2, DIAG must contain positive ! entries that serve as implicit (multiplicative) scale factors ! for the variables. ! ! MODE is an integer input variable. If MODE = 1, the variables ! will be scaled internally. If MODE = 2, the scaling is speci- ! fied by the input DIAG. Other values of MODE are equivalent ! to MODE = 1. ! ! FACTOR is a positive input variable used in determining the ini- ! tial step bound. This bound is set to the product of FACTOR ! and the Euclidean norm of DIAG*X if nonzero, or else to FACTOR ! itself. In most cases FACTOR should lie in the interval ! (.1,100.). 100. is a generally recommended value. ! ! NPRINT is an integer input variable that enables controlled ! printing of iterates if it is positive. In this case, FCN is ! called with IFLAG = 0 at the beginning of the first iteration ! and every NPRINT iterations thereafter and immediately prior ! to return, with X and FVEC available for printing. Appropriate ! print statements must be added to FCN (see example) and ! FVEC should not be altered. If NPRINT is not positive, no ! special calls to FCN with IFLAG = 0 are made. ! ! INFO is an integer output variable. If the user has terminated ! execution, INFO is set to the (negative) value of IFLAG. See ! description of FCN and JAC. Otherwise, INFO is set as follows ! ! INFO = 0 improper input parameters. ! ! INFO = 1 both actual and predicted relative reductions in the ! sum of squares are at most FTOL. ! ! INFO = 2 relative error between two consecutive iterates is ! at most XTOL. ! ! INFO = 3 conditions for INFO = 1 and INFO = 2 both hold. ! ! INFO = 4 the cosine of the angle between FVEC and any column ! of the Jacobian is at most GTOL in absolute value. ! ! INFO = 5 number of calls to FCN for function evaluation ! has reached MAXFEV. ! ! INFO = 6 FTOL is too small. No further reduction in the sum ! of squares is possible. ! ! INFO = 7 XTOL is too small. No further improvement in the ! approximate solution X is possible. ! ! INFO = 8 GTOL is too small. FVEC is orthogonal to the ! columns of the Jacobian to machine precision. ! ! Sections 4 and 5 contain more details about INFO. ! ! NFEV is an integer output variable set to the number of calls to ! FCN for function evaluation. ! ! NJEV is an integer output variable set to the number of ! evaluations of the full Jacobian. If IOPT=2, only one call to ! FCN is required for each evaluation of the full Jacobian. ! If IOPT=3, the M calls to FCN are required. ! If IOPT=1, then NJEV is set to zero. ! ! IPVT is an integer output array of length N. IPVT defines a ! permutation matrix P such that JAC*P = Q*R, where JAC is the ! final calculated Jacobian, Q is orthogonal (not stored), and R ! is upper triangular with diagonal elements of nonincreasing ! magnitude. Column J of P is column IPVT(J) of the identity ! matrix. ! ! QTF is an output array of length N which contains the first N ! elements of the vector (Q transpose)*FVEC. ! ! WA1, WA2, and WA3 are work arrays of length N. ! ! WA4 is a work array of length M. ! ! ! 4. Successful Completion. ! ! The accuracy of DNLS1 is controlled by the convergence parame- ! ters FTOL, XTOL, and GTOL. These parameters are used in tests ! which make three types of comparisons between the approximation ! X and a solution XSOL. DNLS1 terminates when any of the tests ! is satisfied. If any of the convergence parameters is less than ! the machine precision (as defined by the function R1MACH(4)), ! then DNLS1 only attempts to satisfy the test defined by the ! machine precision. Further progress is not usually possible. ! ! The tests assume that the functions are reasonably well behaved, ! and, if the Jacobian is supplied by the user, that the functions ! and the Jacobian are coded consistently. If these conditions ! are not satisfied, then DNLS1 may incorrectly indicate conver- ! gence. If the Jacobian is coded correctly or IOPT=1, ! then the validity of the answer can be checked, for example, by ! rerunning DNLS1 with tighter tolerances. ! ! First Convergence Test. If ENORM(Z) denotes the Euclidean norm ! of a vector Z, then this test attempts to guarantee that ! ! ENORM(FVEC) <= (1+FTOL)*ENORM(FVECS), ! ! where FVECS denotes the functions evaluated at XSOL. If this ! condition is satisfied with FTOL = 10**(-K), then the final ! residual norm ENORM(FVEC) has K significant decimal digits and ! INFO is set to 1 (or to 3 if the second test is also satis- ! fied). Unless high precision solutions are required, the ! recommended value for FTOL is the square root of the machine ! precision. ! ! Second Convergence Test. If D is the diagonal matrix whose ! entries are defined by the array DIAG, then this test attempts ! to guarantee that ! ! ENORM(D*(X-XSOL)) <= XTOL*ENORM(D*XSOL). ! ! If this condition is satisfied with XTOL = 10**(-K), then the ! larger components of D*X have K significant decimal digits and ! INFO is set to 2 (or to 3 if the first test is also satis- ! fied). There is a danger that the smaller components of D*X ! may have large relative errors, but if MODE = 1, then the ! accuracy of the components of X is usually related to their ! sensitivity. Unless high precision solutions are required, ! the recommended value for XTOL is the square root of the ! machine precision. ! ! Third Convergence Test. This test is satisfied when the cosine ! of the angle between FVEC and any column of the Jacobian at X ! is at most GTOL in absolute value. There is no clear rela- ! tionship between this test and the accuracy of DNLS1, and ! furthermore, the test is equally well satisfied at other crit- ! ical points, namely maximizers and saddle points. Therefore, ! termination caused by this test (INFO = 4) should be examined ! carefully. The recommended value for GTOL is zero. ! ! ! 5. Unsuccessful Completion. ! ! Unsuccessful termination of DNLS1 can be due to improper input ! parameters, arithmetic interrupts, or an excessive number of ! function evaluations. ! ! Improper Input Parameters. INFO is set to 0 if IOPT < 1 ! or IOPT > 3, or N <= 0, or M < N, or for IOPT=1 or 2 ! LDFJAC < M, or for IOPT=3 LDFJAC < N, or FTOL < 0.E0, ! or XTOL < 0.E0, or GTOL < 0.E0, or MAXFEV <= 0, or ! FACTOR <= 0.E0. ! ! Arithmetic Interrupts. If these interrupts occur in the FCN ! subroutine during an early stage of the computation, they may ! be caused by an unacceptable choice of X by DNLS1. In this ! case, it may be possible to remedy the situation by rerunning ! DNLS1 with a smaller value of FACTOR. ! ! Excessive Number of Function Evaluations. A reasonable value ! for MAXFEV is 100*(N+1) for IOPT=2 or 3 and 200*(N+1) for ! IOPT=1. If the number of calls to FCN reaches MAXFEV, then ! this indicates that the routine is converging very slowly ! as measured by the progress of FVEC, and INFO is set to 5. ! In this case, it may be helpful to restart DNLS1 with MODE ! set to 1. ! ! ! 6. Characteristics of the Algorithm. ! ! DNLS1 is a modification of the Levenberg-Marquardt algorithm. ! Two of its main characteristics involve the proper use of ! implicitly scaled variables (if MODE = 1) and an optimal choice ! for the correction. The use of implicitly scaled variables ! achieves scale invariance of DNLS1 and limits the size of the ! correction in any direction where the functions are changing ! rapidly. The optimal choice of the correction guarantees (under ! reasonable conditions) global convergence from starting points ! far from the solution and a fast rate of convergence for ! problems with small residuals. ! ! Timing. The time required by DNLS1 to solve a given problem ! depends on M and N, the behavior of the functions, the accu- ! racy requested, and the starting point. The number of arith- ! metic operations needed by DNLS1 is about N**3 to process each ! evaluation of the functions (call to FCN) and to process each ! evaluation of the Jacobian it takes M*N**2 for IOPT=2 (one ! call to FCN), M*N**2 for IOPT=1 (N calls to FCN) and ! 1.5*M*N**2 for IOPT=3 (M calls to FCN). Unless FCN ! can be evaluated quickly, the timing of DNLS1 will be ! strongly influenced by the time spent in FCN. ! ! Storage. DNLS1 requires (M*N + 2*M + 6*N) for IOPT=1 or 2 and ! (N**2 + 2*M + 6*N) for IOPT=3 single precision storage ! locations and N integer storage locations, in addition to ! the storage required by the program. There are no internally ! declared storage arrays. ! ! *Long Description: ! ! 7. Example. ! ! The problem is to determine the values of X(1), X(2), and X(3) ! which provide the best fit (in the least squares sense) of ! ! X(1) + U(I)/(V(I)*X(2) + W(I)*X(3)), I = 1, 15 ! ! to the data ! ! Y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, ! 0.37,0.58,0.73,0.96,1.34,2.10,4.39), ! ! where U(I) = I, V(I) = 16 - I, and W(I) = MIN(U(I),V(I)). The ! I-th component of FVEC is thus defined by ! ! Y(I) - (X(1) + U(I)/(V(I)*X(2) + W(I)*X(3))). ! ! ********** ! ! PROGRAM TEST ! C ! C Driver for DNLS1 example. ! C ! INTEGER J,IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV, ! * NWRITE ! INTEGER IPVT(3) ! DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR,FNORM,EPSFCN ! DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3), ! * WA1(3),WA2(3),WA3(3),WA4(15) ! DOUBLE PRECISION DENORM,D1MACH ! EXTERNAL FCN ! DATA NWRITE /6/ ! C ! IOPT = 1 ! M = 15 ! N = 3 ! C ! C The following starting values provide a rough fit. ! C ! X(1) = 1.E0 ! X(2) = 1.E0 ! X(3) = 1.E0 ! C ! LDFJAC = 15 ! C ! C Set FTOL and XTOL to the square root of the machine precision ! C and GTOL to zero. Unless high precision solutions are ! C required, these are the recommended settings. ! C ! FTOL = SQRT(R1MACH(4)) ! XTOL = SQRT(R1MACH(4)) ! GTOL = 0.E0 ! C ! MAXFEV = 400 ! EPSFCN = 0.0 ! MODE = 1 ! FACTOR = 1.E2 ! NPRINT = 0 ! C ! call DNLS1(FCN,IOPT,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL, ! * GTOL,MAXFEV,EPSFCN,DIAG,MODE,FACTOR,NPRINT, ! * INFO,NFEV,NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) ! FNORM = ENORM(M,FVEC) ! WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) ! STOP ! 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // ! * 5X,' NUMBER OF FUNCTION EVALUATIONS',I10 // ! * 5X,' NUMBER OF JACOBIAN EVALUATIONS',I10 // ! * 5X,' EXIT PARAMETER',16X,I10 // ! * 5X,' FINAL APPROXIMATE SOLUTION' // 5X,3E15.7) ! END ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,DUM,IDUM) ! C This is the form of the FCN routine if IOPT=1, ! C that is, if the user does not calculate the Jacobian. ! INTEGER I,M,N,IFLAG ! DOUBLE PRECISION X(N),FVEC(M),Y(15) ! DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! END ! ! ! Results obtained with different compilers or machines ! may be slightly different. ! ! FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 ! ! NUMBER OF FUNCTION EVALUATIONS 25 ! ! NUMBER OF JACOBIAN EVALUATIONS 0 ! ! EXIT PARAMETER 1 ! ! FINAL APPROXIMATE SOLUTION ! ! 0.8241058E-01 0.1133037E+01 0.2343695E+01 ! ! ! For IOPT=2, FCN would be modified as follows to also ! calculate the full Jacobian when IFLAG=2. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! C ! C This is the form of the FCN routine if IOPT=2, ! C that is, if the user calculates the full Jacobian. ! C ! INTEGER I,LDFJAC,M,N,IFLAG ! DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),Y(15) ! DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! if ( IFLAG /= 1) go to 20 ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! C ! C Below, calculate the full Jacobian. ! C ! 20 CONTINUE ! C ! DO 30 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 ! FJAC(I,1) = -1.E0 ! FJAC(I,2) = TMP1*TMP2/TMP4 ! FJAC(I,3) = TMP1*TMP3/TMP4 ! 30 CONTINUE ! return ! END ! ! ! For IOPT = 3, FJAC would be dimensioned as FJAC(3,3), ! LDFJAC would be set to 3, and FCN would be written as ! follows to calculate a row of the Jacobian when IFLAG=3. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! C This is the form of the FCN routine if IOPT=3, ! C that is, if the user calculates the Jacobian row by row. ! INTEGER I,M,N,IFLAG ! DOUBLE PRECISION X(N),FVEC(M),FJAC(N),Y(15) ! DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! if ( IFLAG /= 1) go to 20 ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! C ! C Below, calculate the LDFJAC-th row of the Jacobian. ! C ! 20 CONTINUE ! ! I = LDFJAC ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 ! FJAC(1) = -1.E0 ! FJAC(2) = TMP1*TMP2/TMP4 ! FJAC(3) = TMP1*TMP3/TMP4 ! return ! END ! !***REFERENCES Jorge J. More, The Levenberg-Marquardt algorithm: ! implementation and theory. In Numerical Analysis ! Proceedings (Dundee, June 28 - July 1, 1977, G. A. ! Watson, Editor), Lecture Notes in Mathematics 630, ! Springer-Verlag, 1978. !***ROUTINES CALLED D1MACH, DCKDER, DENORM, DFDJC3, DMPAR, DQRFAC, ! DWUPDT, XERMSG !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920205 Corrected XERN1 declaration. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DNLS1 IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV INTEGER IJUNK,NROW,IPVT(*) DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR,EPSFCN DOUBLE PRECISION X(*),FVEC(*),FJAC(LDFJAC,*),DIAG(*),QTF(*), & WA1(*),WA2(*),WA3(*),WA4(*) LOGICAL SING EXTERNAL FCN INTEGER I,IFLAG,ITER,J,L,MODECH DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM, & ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP, & TEMP1,TEMP2,XNORM,ZERO DOUBLE PRECISION D1MACH,DENORM,ERR,CHKLIM CHARACTER*8 XERN1 CHARACTER*16 XERN3 SAVE CHKLIM, ONE, P1, P5, P25, P75, P0001, ZERO ! DATA CHKLIM/.1D0/ DATA ONE,P1,P5,P25,P75,P0001,ZERO & /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/ !***FIRST EXECUTABLE STATEMENT DNLS1 EPSMCH = D1MACH(4) ! INFO = 0 IFLAG = 0 NFEV = 0 NJEV = 0 ! ! CHECK THE INPUT PARAMETERS FOR ERRORS. ! if (IOPT < 1 .OR. IOPT > 3 .OR. N <= 0 .OR. & M < N .OR. LDFJAC < N .OR. FTOL < ZERO & .OR. XTOL < ZERO .OR. GTOL < ZERO & .OR. MAXFEV <= 0 .OR. FACTOR <= ZERO) go to 300 if (IOPT < 3 .AND. LDFJAC < M) go to 300 if (MODE /= 2) go to 20 DO 10 J = 1, N if (DIAG(J) <= ZERO) go to 300 10 CONTINUE 20 CONTINUE ! ! EVALUATE THE FUNCTION AT THE STARTING POINT ! AND CALCULATE ITS NORM. ! IFLAG = 1 IJUNK = 1 call FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) NFEV = 1 if (IFLAG < 0) go to 300 FNORM = DENORM(M,FVEC) ! ! INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. ! PAR = ZERO ITER = 1 ! ! BEGINNING OF THE OUTER LOOP. ! 30 CONTINUE ! ! if REQUESTED, call FCN TO ENABLE PRINTING OF ITERATES. ! if (NPRINT <= 0) go to 40 IFLAG = 0 if (MOD(ITER-1,NPRINT) == 0) & call FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) if (IFLAG < 0) go to 300 40 CONTINUE ! ! CALCULATE THE JACOBIAN MATRIX. ! if (IOPT == 3) go to 475 ! ! STORE THE FULL JACOBIAN USING M*N STORAGE ! if (IOPT == 1) go to 410 ! ! THE USER SUPPLIES THE JACOBIAN ! IFLAG = 2 call FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) NJEV = NJEV + 1 ! ! ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN ! if (ITER <= 1) THEN if (IFLAG < 0) go to 300 ! ! GET THE INCREMENTED X-VALUES INTO WA1(*). ! MODECH = 1 call DCKDER(M,N,X,FVEC,FJAC,LDFJAC,WA1,WA4,MODECH,ERR) ! ! EVALUATE FUNCTION AT INCREMENTED VALUE AND PUT IN WA4(*). ! IFLAG = 1 call FCN(IFLAG,M,N,WA1,WA4,FJAC,LDFJAC) NFEV = NFEV + 1 if ( IFLAG < 0) go to 300 DO 350 I = 1, M MODECH = 2 call DCKDER(1,N,X,FVEC(I),FJAC(I,1),LDFJAC,WA1, & WA4(I),MODECH,ERR) if (ERR < CHKLIM) THEN WRITE (XERN1, '(I8)') I WRITE (XERN3, '(1PE15.6)') ERR call XERMSG ('SLATEC', 'DNLS1', 'DERIVATIVE OF ' // & 'FUNCTION ' // XERN1 // ' MAY BE WRONG, ERR = ' // & XERN3 // ' TOO CLOSE TO 0.', 7, 0) ENDIF 350 CONTINUE ENDIF ! go to 420 ! ! THE CODE APPROXIMATES THE JACOBIAN ! 410 IFLAG = 1 call DFDJC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) NFEV = NFEV + N 420 if (IFLAG < 0) go to 300 ! ! COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. ! call DQRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) ! ! FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN ! QTF. ! DO 430 I = 1, M WA4(I) = FVEC(I) 430 CONTINUE DO 470 J = 1, N if (FJAC(J,J) == ZERO) go to 460 SUM = ZERO DO 440 I = J, M SUM = SUM + FJAC(I,J)*WA4(I) 440 CONTINUE TEMP = -SUM/FJAC(J,J) DO 450 I = J, M WA4(I) = WA4(I) + FJAC(I,J)*TEMP 450 CONTINUE 460 CONTINUE FJAC(J,J) = WA1(J) QTF(J) = WA4(J) 470 CONTINUE go to 560 ! ! ACCUMULATE THE JACOBIAN BY ROWS IN ORDER TO SAVE STORAGE. ! COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX ! CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY ! FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST ! N COMPONENTS IN QTF. ! 475 DO 490 J = 1, N QTF(J) = ZERO DO 480 I = 1, N FJAC(I,J) = ZERO 480 CONTINUE 490 CONTINUE DO 500 I = 1, M NROW = I IFLAG = 3 call FCN(IFLAG,M,N,X,FVEC,WA3,NROW) if (IFLAG < 0) go to 300 ! ! ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN. ! if ( ITER > 1) go to 498 ! ! GET THE INCREMENTED X-VALUES INTO WA1(*). ! MODECH = 1 call DCKDER(M,N,X,FVEC,FJAC,LDFJAC,WA1,WA4,MODECH,ERR) ! ! EVALUATE AT INCREMENTED VALUES, if NOT ALREADY EVALUATED. ! if ( I /= 1) go to 495 ! ! EVALUATE FUNCTION AT INCREMENTED VALUE AND PUT INTO WA4(*). ! IFLAG = 1 call FCN(IFLAG,M,N,WA1,WA4,FJAC,NROW) NFEV = NFEV + 1 if ( IFLAG < 0) go to 300 495 CONTINUE MODECH = 2 call DCKDER(1,N,X,FVEC(I),WA3,1,WA1,WA4(I),MODECH,ERR) if (ERR < CHKLIM) THEN WRITE (XERN1, '(I8)') I WRITE (XERN3, '(1PE15.6)') ERR call XERMSG ('SLATEC', 'DNLS1', 'DERIVATIVE OF FUNCTION ' & // XERN1 // ' MAY BE WRONG, ERR = ' // XERN3 // & ' TOO CLOSE TO 0.', 7, 0) ENDIF 498 CONTINUE ! TEMP = FVEC(I) call DWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2) 500 CONTINUE NJEV = NJEV + 1 ! ! if THE JACOBIAN IS RANK DEFICIENT, call DQRFAC TO ! REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF. ! SING = .FALSE. DO 510 J = 1, N if (FJAC(J,J) == ZERO) SING = .TRUE. IPVT(J) = J WA2(J) = DENORM(J,FJAC(1,J)) 510 CONTINUE if (.NOT.SING) go to 560 call DQRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) DO 550 J = 1, N if (FJAC(J,J) == ZERO) go to 540 SUM = ZERO DO 520 I = J, N SUM = SUM + FJAC(I,J)*QTF(I) 520 CONTINUE TEMP = -SUM/FJAC(J,J) DO 530 I = J, N QTF(I) = QTF(I) + FJAC(I,J)*TEMP 530 CONTINUE 540 CONTINUE FJAC(J,J) = WA1(J) 550 CONTINUE 560 CONTINUE ! ! ON THE FIRST ITERATION AND if MODE IS 1, SCALE ACCORDING ! TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. ! if (ITER /= 1) go to 80 if (MODE == 2) go to 60 DO 50 J = 1, N DIAG(J) = WA2(J) if (WA2(J) == ZERO) DIAG(J) = ONE 50 CONTINUE 60 CONTINUE ! ! ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X ! AND INITIALIZE THE STEP BOUND DELTA. ! DO 70 J = 1, N WA3(J) = DIAG(J)*X(J) 70 CONTINUE XNORM = DENORM(N,WA3) DELTA = FACTOR*XNORM if (DELTA == ZERO) DELTA = FACTOR 80 CONTINUE ! ! COMPUTE THE NORM OF THE SCALED GRADIENT. ! GNORM = ZERO if (FNORM == ZERO) go to 170 DO 160 J = 1, N L = IPVT(J) if (WA2(L) == ZERO) go to 150 SUM = ZERO DO 140 I = 1, J SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) 140 CONTINUE GNORM = MAX(GNORM,ABS(SUM/WA2(L))) 150 CONTINUE 160 CONTINUE 170 CONTINUE ! ! TEST FOR CONVERGENCE OF THE GRADIENT NORM. ! if (GNORM <= GTOL) INFO = 4 if (INFO /= 0) go to 300 ! ! RESCALE if NECESSARY. ! if (MODE == 2) go to 190 DO 180 J = 1, N DIAG(J) = MAX(DIAG(J),WA2(J)) 180 CONTINUE 190 CONTINUE ! ! BEGINNING OF THE INNER LOOP. ! 200 CONTINUE ! ! DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. ! call DMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, & WA3,WA4) ! ! STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. ! DO 210 J = 1, N WA1(J) = -WA1(J) WA2(J) = X(J) + WA1(J) WA3(J) = DIAG(J)*WA1(J) 210 CONTINUE PNORM = DENORM(N,WA3) ! ! ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. ! if (ITER == 1) DELTA = MIN(DELTA,PNORM) ! ! EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. ! IFLAG = 1 call FCN(IFLAG,M,N,WA2,WA4,FJAC,IJUNK) NFEV = NFEV + 1 if (IFLAG < 0) go to 300 FNORM1 = DENORM(M,WA4) ! ! COMPUTE THE SCALED ACTUAL REDUCTION. ! ACTRED = -ONE if (P1*FNORM1 < FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 ! ! COMPUTE THE SCALED PREDICTED REDUCTION AND ! THE SCALED DIRECTIONAL DERIVATIVE. ! DO 230 J = 1, N WA3(J) = ZERO L = IPVT(J) TEMP = WA1(L) DO 220 I = 1, J WA3(I) = WA3(I) + FJAC(I,J)*TEMP 220 CONTINUE 230 CONTINUE TEMP1 = DENORM(N,WA3)/FNORM TEMP2 = (SQRT(PAR)*PNORM)/FNORM PRERED = TEMP1**2 + TEMP2**2/P5 DIRDER = -(TEMP1**2 + TEMP2**2) ! ! COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED ! REDUCTION. ! RATIO = ZERO if (PRERED /= ZERO) RATIO = ACTRED/PRERED ! ! UPDATE THE STEP BOUND. ! if (RATIO > P25) go to 240 if (ACTRED >= ZERO) TEMP = P5 if (ACTRED < ZERO) & TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) if (P1*FNORM1 >= FNORM .OR. TEMP < P1) TEMP = P1 DELTA = TEMP*MIN(DELTA,PNORM/P1) PAR = PAR/TEMP go to 260 240 CONTINUE if (PAR /= ZERO .AND. RATIO < P75) go to 250 DELTA = PNORM/P5 PAR = P5*PAR 250 CONTINUE 260 CONTINUE ! ! TEST FOR SUCCESSFUL ITERATION. ! if (RATIO < P0001) go to 290 ! ! SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. ! 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 = DENORM(N,WA2) FNORM = FNORM1 ITER = ITER + 1 290 CONTINUE ! ! TESTS FOR CONVERGENCE. ! if (ABS(ACTRED) <= FTOL .AND. PRERED <= FTOL & .AND. P5*RATIO <= ONE) INFO = 1 if (DELTA <= XTOL*XNORM) INFO = 2 if (ABS(ACTRED) <= FTOL .AND. PRERED <= FTOL & .AND. P5*RATIO <= ONE .AND. INFO == 2) INFO = 3 if (INFO /= 0) go to 300 ! ! TESTS FOR TERMINATION AND STRINGENT TOLERANCES. ! if (NFEV >= MAXFEV) INFO = 5 if (ABS(ACTRED) <= EPSMCH .AND. PRERED <= EPSMCH & .AND. P5*RATIO <= ONE) INFO = 6 if (DELTA <= EPSMCH*XNORM) INFO = 7 if (GNORM <= EPSMCH) INFO = 8 if (INFO /= 0) go to 300 ! ! END OF THE INNER LOOP. REPEAT if ITERATION UNSUCCESSFUL. ! if (RATIO < P0001) go to 200 ! ! END OF THE OUTER LOOP. ! go to 30 300 CONTINUE ! ! TERMINATION, EITHER NORMAL OR USER IMPOSED. ! if (IFLAG < 0) INFO = IFLAG IFLAG = 0 if (NPRINT > 0) call FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) if (INFO < 0) call XERMSG ('SLATEC', 'DNLS1', & 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) if (INFO == 0) call XERMSG ('SLATEC', 'DNLS1', & 'INVALID INPUT PARAMETER.', 2, 1) if (INFO == 4) call XERMSG ('SLATEC', 'DNLS1', & 'THIRD CONVERGENCE CONDITION, CHECK RESULTS BEFORE ACCEPTING.', & 1, 1) if (INFO == 5) call XERMSG ('SLATEC', 'DNLS1', & 'TOO MANY FUNCTION EVALUATIONS.', 9, 1) if (INFO >= 6) call XERMSG ('SLATEC', 'DNLS1', & 'TOLERANCES TOO SMALL, NO FURTHER IMPROVEMENT POSSIBLE.', 3, 1) return end DOUBLE PRECISION FUNCTION DNRM2 (N, DX, INCX) ! !! DNRM2 computes the Euclidean length (L2 norm) of a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A3B !***TYPE DOUBLE PRECISION (SNRM2-S, DNRM2-D, SCNRM2-C) !***KEYWORDS BLAS, EUCLIDEAN LENGTH, EUCLIDEAN NORM, L2, ! LINEAR ALGEBRA, UNITARY, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of parameters ! ! --Input-- ! N number of elements in input vector(s) ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! ! --Output-- ! DNRM2 double precision result (zero if N <= 0) ! ! Euclidean norm of the N-vector stored in DX with storage ! increment INCX. ! If N <= 0, return with result = 0. ! If N >= 1, then INCX must be >= 1 ! ! Four phase method using two built-in constants that are ! hopefully applicable to all machines. ! CUTLO = maximum of SQRT(U/EPS) over all known machines. ! CUTHI = minimum of SQRT(V) over all known machines. ! where ! EPS = smallest no. such that EPS + 1. > 1. ! U = smallest positive no. (underflow limit) ! V = largest no. (overflow limit) ! ! Brief outline of algorithm. ! ! Phase 1 scans zero components. ! move to phase 2 when a component is nonzero and <= CUTLO ! move to phase 3 when a component is > CUTLO ! move to phase 4 when a component is >= CUTHI/M ! where M = N for X() real and M = 2*N for complex. ! ! Values for CUTLO and CUTHI. ! From the environmental parameters listed in the IMSL converter ! document the limiting values are as follows: ! CUTLO, S.P. U/EPS = 2**(-102) for Honeywell. Close seconds are ! Univac and DEC at 2**(-103) ! Thus CUTLO = 2**(-51) = 4.44089E-16 ! CUTHI, S.P. V = 2**127 for Univac, Honeywell, and DEC. ! Thus CUTHI = 2**(63.5) = 1.30438E19 ! CUTLO, D.P. U/EPS = 2**(-67) for Honeywell and DEC. ! Thus CUTLO = 2**(-33.5) = 8.23181D-11 ! CUTHI, D.P. same as S.P. CUTHI = 1.30438D19 ! DATA CUTLO, CUTHI /8.232D-11, 1.304D19/ ! DATA CUTLO, CUTHI /4.441E-16, 1.304E19/ ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DNRM2 INTEGER NEXT DOUBLE PRECISION DX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, & ONE SAVE CUTLO, CUTHI, ZERO, ONE DATA ZERO, ONE /0.0D0, 1.0D0/ ! DATA CUTLO, CUTHI /8.232D-11, 1.304D19/ !***FIRST EXECUTABLE STATEMENT DNRM2 if (N > 0) go to 10 DNRM2 = ZERO go to 300 ! 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX ! ! BEGIN MAIN LOOP ! I = 1 20 go to NEXT,(30, 50, 70, 110) 30 if (ABS(DX(I)) > CUTLO) go to 85 ASSIGN 50 TO NEXT XMAX = ZERO ! ! PHASE 1. SUM IS ZERO ! 50 if (DX(I) == ZERO) go to 200 if (ABS(DX(I)) > CUTLO) go to 85 ! ! PREPARE FOR PHASE 2. ! ASSIGN 70 TO NEXT go to 105 ! ! PREPARE FOR PHASE 4. ! 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / DX(I)) / DX(I) 105 XMAX = ABS(DX(I)) go to 115 ! ! PHASE 2. SUM IS SMALL. ! SCALE TO AVOID DESTRUCTIVE UNDERFLOW. ! 70 if (ABS(DX(I)) > CUTLO) go to 75 ! ! COMMON CODE FOR PHASES 2 AND 4. ! IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. ! 110 if (ABS(DX(I)) <= XMAX) go to 115 SUM = ONE + SUM * (XMAX / DX(I))**2 XMAX = ABS(DX(I)) go to 200 ! 115 SUM = SUM + (DX(I)/XMAX)**2 go to 200 ! ! PREPARE FOR PHASE 3. ! 75 SUM = (SUM * XMAX) * XMAX ! ! FOR REAL OR D.P. SET HITEST = CUTHI/N ! FOR COMPLEX SET HITEST = CUTHI/(2*N) ! 85 HITEST = CUTHI / N ! ! PHASE 3. SUM IS MID-RANGE. NO SCALING. ! DO 95 J = I,NN,INCX if (ABS(DX(J)) >= HITEST) go to 100 95 SUM = SUM + DX(J)**2 DNRM2 = SQRT(SUM) go to 300 ! 200 CONTINUE I = I + INCX if (I <= NN) go to 20 ! ! END OF MAIN LOOP. ! ! COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. ! DNRM2 = XMAX * SQRT(SUM) 300 CONTINUE return end subroutine DNSQE (FCN, JAC, IOPT, N, X, FVEC, TOL, NPRINT, INFO, & WA, LWA) ! !! DNSQE is an easy-to-use code to find a zero of a system of N nonlinear ... ! functions in N variables by a modification of the Powell hybrid method. ! !***LIBRARY SLATEC !***CATEGORY F2A !***TYPE DOUBLE PRECISION (SNSQE-S, DNSQE-D) !***KEYWORDS EASY-TO-USE, NONLINEAR SQUARE SYSTEM, ! POWELL HYBRID METHOD, ZEROS !***AUTHOR Hiebert, K. L. (SNLA) !***DESCRIPTION ! ! 1. Purpose. ! ! The purpose of DNSQE is to find a zero of a system of N ! nonlinear functions in N variables by a modification of the ! Powell hybrid method. This is done by using the more general ! nonlinear equation solver DNSQ. The user must provide a ! subroutine which calculates the functions. The user has the ! option of either to provide a subroutine which calculates the ! Jacobian or to let the code calculate it by a forward-difference ! approximation. This code is the combination of the MINPACK ! codes (Argonne) HYBRD1 and HYBRJ1. ! ! 2. Subroutine and Type Statements. ! ! SUBROUTINE DNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO, ! * WA,LWA) ! INTEGER IOPT,N,NPRINT,INFO,LWA ! DOUBLE PRECISION TOL ! DOUBLE PRECISION X(N),FVEC(N),WA(LWA) ! EXTERNAL FCN,JAC ! ! 3. Parameters. ! ! Parameters designated as input parameters must be specified on ! entry to DNSQE and are not changed on exit, while parameters ! designated as output parameters need not be specified on entry ! and are set to appropriate values on exit from DNSQE. ! ! FCN is the name of the user-supplied subroutine which calculates ! the functions. FCN must be declared in an external statement ! in the user calling program, and should be written as follows. ! ! SUBROUTINE FCN(N,X,FVEC,IFLAG) ! INTEGER N,IFLAG ! DOUBLE PRECISION X(N),FVEC(N) ! ---------- ! Calculate the functions at X and ! return this vector in FVEC. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by FCN unless the ! user wants to terminate execution of DNSQE. In this case set ! IFLAG to a negative integer. ! ! JAC is the name of the user-supplied subroutine which calculates ! the Jacobian. If IOPT=1, then JAC must be declared in an ! external statement in the user calling program, and should be ! written as follows. ! ! SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) ! INTEGER N,LDFJAC,IFLAG ! DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) ! ---------- ! Calculate the Jacobian at X and return this ! matrix in FJAC. FVEC contains the function ! values at X and should not be altered. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by JAC unless the ! user wants to terminate execution of DNSQE. In this case set ! IFLAG to a negative integer. ! ! If IOPT=2, JAC can be ignored (treat it as a dummy argument). ! ! IOPT is an input variable which specifies how the Jacobian will ! be calculated. If IOPT=1, then the user must supply the ! Jacobian through the subroutine JAC. If IOPT=2, then the ! code will approximate the Jacobian by forward-differencing. ! ! N is a positive integer input variable set to the number of ! functions and variables. ! ! X is an array of length N. On input X must contain an initial ! estimate of the solution vector. On output X contains the ! final estimate of the solution vector. ! ! FVEC is an output array of length N which contains the functions ! evaluated at the output X. ! ! TOL is a nonnegative input variable. Termination occurs when ! the algorithm estimates that the relative error between X and ! the solution is at most TOL. Section 4 contains more details ! about TOL. ! ! NPRINT is an integer input variable that enables controlled ! printing of iterates if it is positive. In this case, FCN is ! called with IFLAG = 0 at the beginning of the first iteration ! and every NPRINT iterations thereafter and immediately prior ! to return, with X and FVEC available for printing. Appropriate ! print statements must be added to FCN(see example). If NPRINT ! is not positive, no special calls of FCN with IFLAG = 0 are ! made. ! ! INFO is an integer output variable. If the user has terminated ! execution, INFO is set to the (negative) value of IFLAG. See ! description of FCN and JAC. Otherwise, INFO is set as follows. ! ! INFO = 0 Improper input parameters. ! ! INFO = 1 Algorithm estimates that the relative error between ! X and the solution is at most TOL. ! ! INFO = 2 Number of calls to FCN has reached or exceeded ! 100*(N+1) for IOPT=1 or 200*(N+1) for IOPT=2. ! ! INFO = 3 TOL is too small. No further improvement in the ! approximate solution X is possible. ! ! INFO = 4 Iteration is not making good progress. ! ! Sections 4 and 5 contain more details about INFO. ! ! WA is a work array of length LWA. ! ! LWA is a positive integer input variable not less than ! (3*N**2+13*N))/2. ! ! 4. Successful Completion. ! ! The accuracy of DNSQE is controlled by the convergence parameter ! TOL. This parameter is used in a test which makes a comparison ! between the approximation X and a solution XSOL. DNSQE ! terminates when the test is satisfied. If TOL is less than the ! machine precision (as defined by the function D1MACH(4)), then ! DNSQE only attempts to satisfy the test defined by the machine ! precision. Further progress is not usually possible. Unless ! high precision solutions are required, the recommended value ! for TOL is the square root of the machine precision. ! ! The test assumes that the functions are reasonably well behaved, ! and, if the Jacobian is supplied by the user, that the functions ! and the Jacobian are coded consistently. If these conditions are ! not satisfied, then DNSQE may incorrectly indicate convergence. ! The coding of the Jacobian can be checked by the subroutine ! DCKDER. If the Jacobian is coded correctly or IOPT=2, then ! the validity of the answer can be checked, for example, by ! rerunning DNSQE with a tighter tolerance. ! ! Convergence Test. If DENORM(Z) denotes the Euclidean norm of a ! vector Z, then this test attempts to guarantee that ! ! DENORM(X-XSOL) <= TOL*DENORM(XSOL). ! ! If this condition is satisfied with TOL = 10**(-K), then the ! larger components of X have K significant decimal digits and ! INFO is set to 1. There is a danger that the smaller ! components of X may have large relative errors, but the fast ! rate of convergence of DNSQE usually avoids this possibility. ! ! 5. Unsuccessful Completion. ! ! Unsuccessful termination of DNSQE can be due to improper input ! parameters, arithmetic interrupts, an excessive number of ! function evaluations, errors in the functions, or lack of good ! progress. ! ! Improper Input Parameters. INFO is set to 0 if IOPT < 1, or ! IOPT > 2, or N <= 0, or TOL < 0.E0, or ! LWA < (3*N**2+13*N)/2. ! ! Arithmetic Interrupts. If these interrupts occur in the FCN ! subroutine during an early stage of the computation, they may ! be caused by an unacceptable choice of X by DNSQE. In this ! case, it may be possible to remedy the situation by not ! evaluating the functions here, but instead setting the ! components of FVEC to numbers that exceed those in the initial ! FVEC. ! ! Excessive Number of Function Evaluations. If the number of ! calls to FCN reaches 100*(N+1) for IOPT=1 or 200*(N+1) for ! IOPT=2, then this indicates that the routine is converging ! very slowly as measured by the progress of FVEC, and INFO is ! set to 2. This situation should be unusual because, as ! indicated below, lack of good progress is usually diagnosed ! earlier by DNSQE, causing termination with INFO = 4. ! ! Errors In the Functions. When IOPT=2, the choice of step length ! in the forward-difference approximation to the Jacobian ! assumes that the relative errors in the functions are of the ! order of the machine precision. If this is not the case, ! DNSQE may fail (usually with INFO = 4). The user should ! then either use DNSQ and set the step length or use IOPT=1 ! and supply the Jacobian. ! ! Lack of Good Progress. DNSQE searches for a zero of the system ! by minimizing the sum of the squares of the functions. In so ! doing, it can become trapped in a region where the minimum ! does not correspond to a zero of the system and, in this ! situation, the iteration eventually fails to make good ! progress. In particular, this will happen if the system does ! not have a zero. If the system has a zero, rerunning DNSQE ! from a different starting point may be helpful. ! ! 6. Characteristics of The Algorithm. ! ! DNSQE is a modification of the Powell Hybrid method. Two of ! its main characteristics involve the choice of the correction as ! a convex combination of the Newton and scaled gradient ! directions, and the updating of the Jacobian by the rank-1 ! method of Broyden. The choice of the correction guarantees ! (under reasonable conditions) global convergence for starting ! points far from the solution and a fast rate of convergence. ! The Jacobian is calculated at the starting point by either the ! user-supplied subroutine or a forward-difference approximation, ! but it is not recalculated until the rank-1 method fails to ! produce satisfactory progress. ! ! Timing. The time required by DNSQE to solve a given problem ! depends on N, the behavior of the functions, the accuracy ! requested, and the starting point. The number of arithmetic ! operations needed by DNSQE is about 11.5*(N**2) to process ! each evaluation of the functions (call to FCN) and 1.3*(N**3) ! to process each evaluation of the Jacobian (call to JAC, ! if IOPT = 1). Unless FCN and JAC can be evaluated quickly, ! the timing of DNSQE will be strongly influenced by the time ! spent in FCN and JAC. ! ! Storage. DNSQE requires (3*N**2 + 17*N)/2 single precision ! storage locations, in addition to the storage required by the ! program. There are no internally declared storage arrays. ! ! *Long Description: ! ! 7. Example. ! ! The problem is to determine the values of X(1), X(2), ..., X(9), ! which solve the system of tridiagonal equations ! ! (3-2*X(1))*X(1) -2*X(2) = -1 ! -X(I-1) + (3-2*X(I))*X(I) -2*X(I+1) = -1, I=2-8 ! -X(8) + (3-2*X(9))*X(9) = -1 ! ! ********** ! ! PROGRAM TEST ! C ! C DRIVER FOR DNSQE EXAMPLE. ! C ! INTEGER J,N,IOPT,NPRINT,INFO,LWA,NWRITE ! DOUBLE PRECISION TOL,FNORM ! DOUBLE PRECISION X(9),FVEC(9),WA(180) ! DOUBLE PRECISION DENORM,D1MACH ! EXTERNAL FCN ! DATA NWRITE /6/ ! C ! IOPT = 2 ! N = 9 ! C ! C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. ! C ! DO 10 J = 1, 9 ! X(J) = -1.E0 ! 10 CONTINUE ! ! LWA = 180 ! NPRINT = 0 ! C ! C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. ! C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, ! C THIS IS THE RECOMMENDED SETTING. ! C ! TOL = SQRT(D1MACH(4)) ! C ! call DNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ! FNORM = DENORM(N,FVEC) ! WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) ! STOP ! 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // ! * 5X,' EXIT PARAMETER',16X,I10 // ! * 5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7)) ! END ! SUBROUTINE FCN(N,X,FVEC,IFLAG) ! INTEGER N,IFLAG ! DOUBLE PRECISION X(N),FVEC(N) ! INTEGER K ! DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO ! DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ ! C ! DO 10 K = 1, N ! TEMP = (THREE - TWO*X(K))*X(K) ! TEMP1 = ZERO ! if (K /= 1) TEMP1 = X(K-1) ! TEMP2 = ZERO ! if (K /= N) TEMP2 = X(K+1) ! FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE ! 10 CONTINUE ! return ! END ! ! RESULTS OBTAINED WITH DIFFERENT COMPILERS OR MACHINES ! MAY BE SLIGHTLY DIFFERENT. ! ! FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 ! ! EXIT PARAMETER 1 ! ! FINAL APPROXIMATE SOLUTION ! ! -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 ! -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 ! -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 ! !***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- ! tions. In Numerical Methods for Nonlinear Algebraic ! Equations, P. Rabinowitz, Editor. Gordon and Breach, ! 1988. !***ROUTINES CALLED DNSQ, XERMSG !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DNSQE INTEGER INDEX, INFO, IOPT, J, LR, LWA, MAXFEV, ML, MODE, MU, N, & NFEV, NJEV, NPRINT DOUBLE PRECISION EPSFCN, FACTOR, FVEC(*), ONE, TOL, WA(*), & X(*), XTOL, ZERO EXTERNAL FCN, JAC SAVE FACTOR, ONE, ZERO DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/ ! BEGIN BLOCK PERMITTING ...EXITS TO 20 !***FIRST EXECUTABLE STATEMENT DNSQE INFO = 0 ! ! CHECK THE INPUT PARAMETERS FOR ERRORS. ! ! ...EXIT if (IOPT < 1 .OR. IOPT > 2 .OR. N <= 0 & .OR. TOL < ZERO .OR. LWA < (3*N**2 + 13*N)/2) & go to 20 ! ! call DNSQ. ! MAXFEV = 100*(N + 1) if (IOPT == 2) MAXFEV = 2*MAXFEV XTOL = TOL ML = N - 1 MU = N - 1 EPSFCN = ZERO MODE = 2 DO 10 J = 1, N WA(J) = ONE 10 CONTINUE LR = (N*(N + 1))/2 INDEX = 6*N + LR call DNSQ(FCN,JAC,IOPT,N,X,FVEC,WA(INDEX+1),N,XTOL,MAXFEV,ML, & MU,EPSFCN,WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, & 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 == 5) INFO = 4 20 CONTINUE if (INFO == 0) call XERMSG ('SLATEC', 'DNSQE', & 'INVALID INPUT PARAMETER.', 2, 1) return ! ! LAST CARD OF SUBROUTINE DNSQE. ! end subroutine DNSQ (FCN, JAC, IOPT, N, X, FVEC, FJAC, LDFJAC, XTOL, & MAXFEV, ML, MU, EPSFCN, DIAG, MODE, FACTOR, NPRINT, INFO, NFEV, & NJEV, R, LR, QTF, WA1, WA2, WA3, WA4) ! !! DNSQ finds a zero of a system of a N nonlinear functions in N variables ... ! by a modification of the Powell hybrid method. ! !***LIBRARY SLATEC !***CATEGORY F2A !***TYPE DOUBLE PRECISION (SNSQ-S, DNSQ-D) !***KEYWORDS NONLINEAR SQUARE SYSTEM, POWELL HYBRID METHOD, ZEROS !***AUTHOR Hiebert, K. L. (SNLA) !***DESCRIPTION ! ! 1. Purpose. ! ! The purpose of DNSQ is to find a zero of a system of N nonlinear ! functions in N variables by a modification of the Powell ! hybrid method. The user must provide a subroutine which ! calculates the functions. The user has the option of either to ! provide a subroutine which calculates the Jacobian or to let the ! code calculate it by a forward-difference approximation. ! This code is the combination of the MINPACK codes (Argonne) ! HYBRD and HYBRDJ. ! ! 2. Subroutine and Type Statements. ! ! SUBROUTINE DNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV, ! * ML,MU,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, ! * NJEV,R,LR,QTF,WA1,WA2,WA3,WA4) ! INTEGER IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,NJEV,LR ! DOUBLE PRECISION XTOL,EPSFCN,FACTOR ! DOUBLE PRECISION ! X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N), ! * WA1(N),WA2(N),WA3(N),WA4(N) ! EXTERNAL FCN,JAC ! ! 3. Parameters. ! ! Parameters designated as input parameters must be specified on ! entry to DNSQ and are not changed on exit, while parameters ! designated as output parameters need not be specified on entry ! and are set to appropriate values on exit from DNSQ. ! ! FCN is the name of the user-supplied subroutine which calculates ! the functions. FCN must be declared in an EXTERNAL statement ! in the user calling program, and should be written as follows. ! ! SUBROUTINE FCN(N,X,FVEC,IFLAG) ! INTEGER N,IFLAG ! DOUBLE PRECISION X(N),FVEC(N) ! ---------- ! CALCULATE THE FUNCTIONS AT X AND ! return THIS VECTOR IN FVEC. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by FCN unless the ! user wants to terminate execution of DNSQ. In this case set ! IFLAG to a negative integer. ! ! JAC is the name of the user-supplied subroutine which calculates ! the Jacobian. If IOPT=1, then JAC must be declared in an ! EXTERNAL statement in the user calling program, and should be ! written as follows. ! ! SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) ! INTEGER N,LDFJAC,IFLAG ! DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) ! ---------- ! Calculate the Jacobian at X and return this ! matrix in FJAC. FVEC contains the function ! values at X and should not be altered. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by JAC unless the ! user wants to terminate execution of DNSQ. In this case set ! IFLAG to a negative integer. ! ! If IOPT=2, JAC can be ignored (treat it as a dummy argument). ! ! IOPT is an input variable which specifies how the Jacobian will ! be calculated. If IOPT=1, then the user must supply the ! Jacobian through the subroutine JAC. If IOPT=2, then the ! code will approximate the Jacobian by forward-differencing. ! ! N is a positive integer input variable set to the number of ! functions and variables. ! ! X is an array of length N. On input X must contain an initial ! estimate of the solution vector. On output X contains the ! final estimate of the solution vector. ! ! FVEC is an output array of length N which contains the functions ! evaluated at the output X. ! ! FJAC is an output N by N array which contains the orthogonal ! matrix Q produced by the QR factorization of the final ! approximate Jacobian. ! ! LDFJAC is a positive integer input variable not less than N ! which specifies the leading dimension of the array FJAC. ! ! XTOL is a nonnegative input variable. Termination occurs when ! the relative error between two consecutive iterates is at most ! XTOL. Therefore, XTOL measures the relative error desired in ! the approximate solution. Section 4 contains more details ! about XTOL. ! ! MAXFEV is a positive integer input variable. Termination occurs ! when the number of calls to FCN is at least MAXFEV by the end ! of an iteration. ! ! ML is a nonnegative integer input variable which specifies the ! number of subdiagonals within the band of the Jacobian matrix. ! If the Jacobian is not banded or IOPT=1, set ML to at ! least N - 1. ! ! MU is a nonnegative integer input variable which specifies the ! number of superdiagonals within the band of the Jacobian ! matrix. If the Jacobian is not banded or IOPT=1, set MU to at ! least N - 1. ! ! EPSFCN is an input variable used in determining a suitable step ! for the forward-difference approximation. This approximation ! assumes that the relative errors in the functions are of the ! order of EPSFCN. If EPSFCN is less than the machine ! precision, it is assumed that the relative errors in the ! functions are of the order of the machine precision. If ! IOPT=1, then EPSFCN can be ignored (treat it as a dummy ! argument). ! ! DIAG is an array of length N. If MODE = 1 (see below), DIAG is ! internally set. If MODE = 2, DIAG must contain positive ! entries that serve as implicit (multiplicative) scale factors ! for the variables. ! ! MODE is an integer input variable. If MODE = 1, the variables ! will be scaled internally. If MODE = 2, the scaling is ! specified by the input DIAG. Other values of MODE are ! equivalent to MODE = 1. ! ! FACTOR is a positive input variable used in determining the ! initial step bound. This bound is set to the product of ! FACTOR and the Euclidean norm of DIAG*X if nonzero, or else to ! FACTOR itself. In most cases FACTOR should lie in the ! interval (.1,100.). 100. is a generally recommended value. ! ! NPRINT is an integer input variable that enables controlled ! printing of iterates if it is positive. In this case, FCN is ! called with IFLAG = 0 at the beginning of the first iteration ! and every NPRINT iterations thereafter and immediately prior ! to return, with X and FVEC available for printing. appropriate ! print statements must be added to FCN(see example). If NPRINT ! is not positive, no special calls of FCN with IFLAG = 0 are ! made. ! ! INFO is an integer output variable. If the user has terminated ! execution, INFO is set to the (negative) value of IFLAG. See ! description of FCN and JAC. Otherwise, INFO is set as follows. ! ! INFO = 0 Improper input parameters. ! ! INFO = 1 Relative error between two consecutive iterates is ! at most XTOL. ! ! INFO = 2 Number of calls to FCN has reached or exceeded ! MAXFEV. ! ! INFO = 3 XTOL is too small. No further improvement in the ! approximate solution X is possible. ! ! INFO = 4 Iteration is not making good progress, as measured ! by the improvement from the last five Jacobian ! evaluations. ! ! INFO = 5 Iteration is not making good progress, as measured ! by the improvement from the last ten iterations. ! ! Sections 4 and 5 contain more details about INFO. ! ! NFEV is an integer output variable set to the number of calls to ! FCN. ! ! NJEV is an integer output variable set to the number of calls to ! JAC. (If IOPT=2, then NJEV is set to zero.) ! ! R is an output array of length LR which contains the upper ! triangular matrix produced by the QR factorization of the ! final approximate Jacobian, stored rowwise. ! ! LR is a positive integer input variable not less than ! (N*(N+1))/2. ! ! QTF is an output array of length N which contains the vector ! (Q transpose)*FVEC. ! ! WA1, WA2, WA3, and WA4 are work arrays of length N. ! ! ! 4. Successful completion. ! ! The accuracy of DNSQ is controlled by the convergence parameter ! XTOL. This parameter is used in a test which makes a comparison ! between the approximation X and a solution XSOL. DNSQ ! terminates when the test is satisfied. If the convergence ! parameter is less than the machine precision (as defined by the ! function D1MACH(4)), then DNSQ only attempts to satisfy the test ! defined by the machine precision. Further progress is not ! usually possible. ! ! The test assumes that the functions are reasonably well behaved, ! and, if the Jacobian is supplied by the user, that the functions ! and the Jacobian are coded consistently. If these conditions ! are not satisfied, then DNSQ may incorrectly indicate ! convergence. The coding of the Jacobian can be checked by the ! subroutine DCKDER. If the Jacobian is coded correctly or IOPT=2, ! then the validity of the answer can be checked, for example, by ! rerunning DNSQ with a tighter tolerance. ! ! Convergence Test. If DENORM(Z) denotes the Euclidean norm of a ! vector Z and D is the diagonal matrix whose entries are ! defined by the array DIAG, then this test attempts to ! guarantee that ! ! DENORM(D*(X-XSOL)) <= XTOL*DENORM(D*XSOL). ! ! If this condition is satisfied with XTOL = 10**(-K), then the ! larger components of D*X have K significant decimal digits and ! INFO is set to 1. There is a danger that the smaller ! components of D*X may have large relative errors, but the fast ! rate of convergence of DNSQ usually avoids this possibility. ! Unless high precision solutions are required, the recommended ! value for XTOL is the square root of the machine precision. ! ! ! 5. Unsuccessful Completion. ! ! Unsuccessful termination of DNSQ can be due to improper input ! parameters, arithmetic interrupts, an excessive number of ! function evaluations, or lack of good progress. ! ! Improper Input Parameters. INFO is set to 0 if IOPT .LT .1, ! or IOPT > 2, or N <= 0, or LDFJAC < N, or ! XTOL < 0.E0, or MAXFEV <= 0, or ML < 0, or MU < 0, ! or FACTOR <= 0.E0, or LR < (N*(N+1))/2. ! ! Arithmetic Interrupts. If these interrupts occur in the FCN ! subroutine during an early stage of the computation, they may ! be caused by an unacceptable choice of X by DNSQ. In this ! case, it may be possible to remedy the situation by rerunning ! DNSQ with a smaller value of FACTOR. ! ! Excessive Number of Function Evaluations. A reasonable value ! for MAXFEV is 100*(N+1) for IOPT=1 and 200*(N+1) for IOPT=2. ! If the number of calls to FCN reaches MAXFEV, then this ! indicates that the routine is converging very slowly as ! measured by the progress of FVEC, and INFO is set to 2. This ! situation should be unusual because, as indicated below, lack ! of good progress is usually diagnosed earlier by DNSQ, ! causing termination with info = 4 or INFO = 5. ! ! Lack of Good Progress. DNSQ searches for a zero of the system ! by minimizing the sum of the squares of the functions. In so ! doing, it can become trapped in a region where the minimum ! does not correspond to a zero of the system and, in this ! situation, the iteration eventually fails to make good ! progress. In particular, this will happen if the system does ! not have a zero. If the system has a zero, rerunning DNSQ ! from a different starting point may be helpful. ! ! ! 6. Characteristics of The Algorithm. ! ! DNSQ is a modification of the Powell Hybrid method. Two of its ! main characteristics involve the choice of the correction as a ! convex combination of the Newton and scaled gradient directions, ! and the updating of the Jacobian by the rank-1 method of ! Broyden. The choice of the correction guarantees (under ! reasonable conditions) global convergence for starting points ! far from the solution and a fast rate of convergence. The ! Jacobian is calculated at the starting point by either the ! user-supplied subroutine or a forward-difference approximation, ! but it is not recalculated until the rank-1 method fails to ! produce satisfactory progress. ! ! Timing. The time required by DNSQ to solve a given problem ! depends on N, the behavior of the functions, the accuracy ! requested, and the starting point. The number of arithmetic ! operations needed by DNSQ is about 11.5*(N**2) to process ! each evaluation of the functions (call to FCN) and 1.3*(N**3) ! to process each evaluation of the Jacobian (call to JAC, ! if IOPT = 1). Unless FCN and JAC can be evaluated quickly, ! the timing of DNSQ will be strongly influenced by the time ! spent in FCN and JAC. ! ! Storage. DNSQ requires (3*N**2 + 17*N)/2 single precision ! storage locations, in addition to the storage required by the ! program. There are no internally declared storage arrays. ! ! *Long Description: ! ! 7. Example. ! ! The problem is to determine the values of X(1), X(2), ..., X(9), ! which solve the system of tridiagonal equations ! ! (3-2*X(1))*X(1) -2*X(2) = -1 ! -X(I-1) + (3-2*X(I))*X(I) -2*X(I+1) = -1, I=2-8 ! -X(8) + (3-2*X(9))*X(9) = -1 ! C ********** ! ! PROGRAM TEST ! C ! C Driver for DNSQ example. ! C ! INTEGER J,IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR, ! * NWRITE ! DOUBLE PRECISION XTOL,EPSFCN,FACTOR,FNORM ! DOUBLE PRECISION X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9), ! * WA1(9),WA2(9),WA3(9),WA4(9) ! DOUBLE PRECISION DENORM,D1MACH ! EXTERNAL FCN ! DATA NWRITE /6/ ! C ! IOPT = 2 ! N = 9 ! C ! C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. ! C ! DO 10 J = 1, 9 ! X(J) = -1.E0 ! 10 CONTINUE ! C ! LDFJAC = 9 ! LR = 45 ! C ! C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. ! C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, ! C THIS IS THE RECOMMENDED SETTING. ! C ! XTOL = SQRT(D1MACH(4)) ! C ! MAXFEV = 2000 ! ML = 1 ! MU = 1 ! EPSFCN = 0.E0 ! MODE = 2 ! DO 20 J = 1, 9 ! DIAG(J) = 1.E0 ! 20 CONTINUE ! FACTOR = 1.E2 ! NPRINT = 0 ! C ! call DNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,ML,MU, ! * EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, ! * R,LR,QTF,WA1,WA2,WA3,WA4) ! FNORM = DENORM(N,FVEC) ! WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) ! STOP ! 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // ! * 5X,' NUMBER OF FUNCTION EVALUATIONS',I10 // ! * 5X,' EXIT PARAMETER',16X,I10 // ! * 5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7)) ! END ! SUBROUTINE FCN(N,X,FVEC,IFLAG) ! INTEGER N,IFLAG ! DOUBLE PRECISION X(N),FVEC(N) ! INTEGER K ! DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO ! DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. ! C ! return ! 5 CONTINUE ! DO 10 K = 1, N ! TEMP = (THREE - TWO*X(K))*X(K) ! TEMP1 = ZERO ! if (K /= 1) TEMP1 = X(K-1) ! TEMP2 = ZERO ! if (K /= N) TEMP2 = X(K+1) ! FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE ! 10 CONTINUE ! return ! END ! ! Results obtained with different compilers or machines ! may be slightly different. ! ! Final L2 norm of the residuals 0.1192636E-07 ! ! Number of function evaluations 14 ! ! Exit parameter 1 ! ! Final approximate solution ! ! -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 ! -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 ! -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 ! !***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- ! tions. In Numerical Methods for Nonlinear Algebraic ! Equations, P. Rabinowitz, Editor. Gordon and Breach, ! 1988. !***ROUTINES CALLED D1MACH, D1MPYQ, D1UPDT, DDOGLG, DENORM, DFDJC1, ! DQFORM, DQRFAC, XERMSG !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DNSQ DOUBLE PRECISION D1MACH,DENORM INTEGER I, IFLAG, INFO, IOPT, ITER, IWA(1), J, JM1, L, LDFJAC, & LR, MAXFEV, ML, MODE, MU, N, NCFAIL, NCSUC, NFEV, NJEV, & NPRINT, NSLOW1, NSLOW2 DOUBLE PRECISION ACTRED, DELTA, DIAG(*), EPSFCN, EPSMCH, FACTOR, & FJAC(LDFJAC,*), FNORM, FNORM1, FVEC(*), ONE, P0001, P001, & P1, P5, PNORM, PRERED, QTF(*), R(*), RATIO, SUM, TEMP, & WA1(*), WA2(*), WA3(*), WA4(*), X(*), XNORM, XTOL, ZERO EXTERNAL FCN LOGICAL JEVAL,SING SAVE ONE, P1, P5, P001, P0001, ZERO DATA ONE,P1,P5,P001,P0001,ZERO & /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/ ! ! BEGIN BLOCK PERMITTING ...EXITS TO 320 !***FIRST EXECUTABLE STATEMENT DNSQ EPSMCH = D1MACH(4) ! INFO = 0 IFLAG = 0 NFEV = 0 NJEV = 0 ! ! CHECK THE INPUT PARAMETERS FOR ERRORS. ! ! ...EXIT if (IOPT < 1 .OR. IOPT > 2 .OR. N <= 0 & .OR. XTOL < ZERO .OR. MAXFEV <= 0 .OR. ML < 0 & .OR. MU < 0 .OR. FACTOR <= ZERO .OR. LDFJAC < N & .OR. LR < (N*(N + 1))/2) go to 320 if (MODE /= 2) go to 20 DO 10 J = 1, N ! .........EXIT if (DIAG(J) <= ZERO) go to 320 10 CONTINUE 20 CONTINUE ! ! EVALUATE THE FUNCTION AT THE STARTING POINT ! AND CALCULATE ITS NORM. ! IFLAG = 1 call FCN(N,X,FVEC,IFLAG) NFEV = 1 ! ...EXIT if (IFLAG < 0) go to 320 FNORM = DENORM(N,FVEC) ! ! INITIALIZE ITERATION COUNTER AND MONITORS. ! ITER = 1 NCSUC = 0 NCFAIL = 0 NSLOW1 = 0 NSLOW2 = 0 ! ! BEGINNING OF THE OUTER LOOP. ! 30 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 90 JEVAL = .TRUE. ! ! CALCULATE THE JACOBIAN MATRIX. ! if (IOPT == 2) go to 40 ! ! USER SUPPLIES JACOBIAN ! call JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) NJEV = NJEV + 1 go to 50 40 CONTINUE ! ! CODE APPROXIMATES THE JACOBIAN ! IFLAG = 2 call DFDJC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU, & EPSFCN,WA1,WA2) NFEV = NFEV + MIN(ML+MU+1,N) 50 CONTINUE ! ! .........EXIT if (IFLAG < 0) go to 320 ! ! COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. ! call DQRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) ! ! ON THE FIRST ITERATION AND if MODE IS 1, SCALE ACCORDING ! TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. ! ! ...EXIT if (ITER /= 1) go to 90 if (MODE == 2) go to 70 DO 60 J = 1, N DIAG(J) = WA2(J) if (WA2(J) == ZERO) DIAG(J) = ONE 60 CONTINUE 70 CONTINUE ! ! ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED ! X AND INITIALIZE THE STEP BOUND DELTA. ! DO 80 J = 1, N WA3(J) = DIAG(J)*X(J) 80 CONTINUE XNORM = DENORM(N,WA3) DELTA = FACTOR*XNORM if (DELTA == ZERO) DELTA = FACTOR 90 CONTINUE ! ! FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. ! DO 100 I = 1, N QTF(I) = FVEC(I) 100 CONTINUE DO 140 J = 1, N if (FJAC(J,J) == ZERO) go to 130 SUM = ZERO DO 110 I = J, N SUM = SUM + FJAC(I,J)*QTF(I) 110 CONTINUE TEMP = -SUM/FJAC(J,J) DO 120 I = J, N QTF(I) = QTF(I) + FJAC(I,J)*TEMP 120 CONTINUE 130 CONTINUE 140 CONTINUE ! ! COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. ! SING = .FALSE. DO 170 J = 1, N L = J JM1 = J - 1 if (JM1 < 1) go to 160 DO 150 I = 1, JM1 R(L) = FJAC(I,J) L = L + N - I 150 CONTINUE 160 CONTINUE R(L) = WA1(J) if (WA1(J) == ZERO) SING = .TRUE. 170 CONTINUE ! ! ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. ! call DQFORM(N,N,FJAC,LDFJAC,WA1) ! ! RESCALE if NECESSARY. ! if (MODE == 2) go to 190 DO 180 J = 1, N DIAG(J) = MAX(DIAG(J),WA2(J)) 180 CONTINUE 190 CONTINUE ! ! BEGINNING OF THE INNER LOOP. ! 200 CONTINUE ! ! if REQUESTED, call FCN TO ENABLE PRINTING OF ITERATES. ! if (NPRINT <= 0) go to 210 IFLAG = 0 if (MOD(ITER-1,NPRINT) == 0) & call FCN(N,X,FVEC,IFLAG) ! ............EXIT if (IFLAG < 0) go to 320 210 CONTINUE ! ! DETERMINE THE DIRECTION P. ! call DDOGLG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) ! ! STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. ! DO 220 J = 1, N WA1(J) = -WA1(J) WA2(J) = X(J) + WA1(J) WA3(J) = DIAG(J)*WA1(J) 220 CONTINUE PNORM = DENORM(N,WA3) ! ! ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. ! if (ITER == 1) DELTA = MIN(DELTA,PNORM) ! ! EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. ! IFLAG = 1 call FCN(N,WA2,WA4,IFLAG) NFEV = NFEV + 1 ! .........EXIT if (IFLAG < 0) go to 320 FNORM1 = DENORM(N,WA4) ! ! COMPUTE THE SCALED ACTUAL REDUCTION. ! ACTRED = -ONE if (FNORM1 < FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 ! ! COMPUTE THE SCALED PREDICTED REDUCTION. ! L = 1 DO 240 I = 1, N SUM = ZERO DO 230 J = I, N SUM = SUM + R(L)*WA1(J) L = L + 1 230 CONTINUE WA3(I) = QTF(I) + SUM 240 CONTINUE TEMP = DENORM(N,WA3) PRERED = ZERO if (TEMP < FNORM) PRERED = ONE - (TEMP/FNORM)**2 ! ! COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED ! REDUCTION. ! RATIO = ZERO if (PRERED > ZERO) RATIO = ACTRED/PRERED ! ! UPDATE THE STEP BOUND. ! if (RATIO >= P1) go to 250 NCSUC = 0 NCFAIL = NCFAIL + 1 DELTA = P5*DELTA go to 260 250 CONTINUE NCFAIL = 0 NCSUC = NCSUC + 1 if (RATIO >= P5 .OR. NCSUC > 1) & DELTA = MAX(DELTA,PNORM/P5) if (ABS(RATIO-ONE) <= P1) DELTA = PNORM/P5 260 CONTINUE ! ! TEST FOR SUCCESSFUL ITERATION. ! if (RATIO < P0001) go to 280 ! ! SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. ! DO 270 J = 1, N X(J) = WA2(J) WA2(J) = DIAG(J)*X(J) FVEC(J) = WA4(J) 270 CONTINUE XNORM = DENORM(N,WA2) FNORM = FNORM1 ITER = ITER + 1 280 CONTINUE ! ! DETERMINE THE PROGRESS OF THE ITERATION. ! NSLOW1 = NSLOW1 + 1 if (ACTRED >= P001) NSLOW1 = 0 if (JEVAL) NSLOW2 = NSLOW2 + 1 if (ACTRED >= P1) NSLOW2 = 0 ! ! TEST FOR CONVERGENCE. ! if (DELTA <= XTOL*XNORM .OR. FNORM == ZERO) INFO = 1 ! .........EXIT if (INFO /= 0) go to 320 ! ! TESTS FOR TERMINATION AND STRINGENT TOLERANCES. ! if (NFEV >= MAXFEV) INFO = 2 if (P1*MAX(P1*DELTA,PNORM) <= EPSMCH*XNORM) INFO = 3 if (NSLOW2 == 5) INFO = 4 if (NSLOW1 == 10) INFO = 5 ! .........EXIT if (INFO /= 0) go to 320 ! ! CRITERION FOR RECALCULATING JACOBIAN ! ! ...EXIT if (NCFAIL == 2) go to 310 ! ! CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN ! AND UPDATE QTF if NECESSARY. ! DO 300 J = 1, N SUM = ZERO DO 290 I = 1, N SUM = SUM + FJAC(I,J)*WA4(I) 290 CONTINUE WA2(J) = (SUM - WA3(J))/PNORM WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) if (RATIO >= P0001) QTF(J) = SUM 300 CONTINUE ! ! COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. ! call D1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) call D1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) call D1MPYQ(1,N,QTF,1,WA2,WA3) ! ! END OF THE INNER LOOP. ! JEVAL = .FALSE. go to 200 310 CONTINUE ! ! END OF THE OUTER LOOP. ! go to 30 320 CONTINUE ! ! TERMINATION, EITHER NORMAL OR USER IMPOSED. ! if (IFLAG < 0) INFO = IFLAG IFLAG = 0 if (NPRINT > 0) call FCN(N,X,FVEC,IFLAG) if (INFO < 0) call XERMSG ('SLATEC', 'DNSQ', & 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) if (INFO == 0) call XERMSG ('SLATEC', 'DNSQ', & 'INVALID INPUT PARAMETER.', 2, 1) if (INFO == 2) call XERMSG ('SLATEC', 'DNSQ', & 'TOO MANY FUNCTION EVALUATIONS.', 9, 1) if (INFO == 3) call XERMSG ('SLATEC', 'DNSQ', & 'XTOL TOO SMALL. NO FURTHER IMPROVEMENT POSSIBLE.', 3, 1) if (INFO > 4) call XERMSG ('SLATEC', 'DNSQ', & 'ITERATION NOT MAKING GOOD PROGRESS.', 1, 1) return ! ! LAST CARD OF SUBROUTINE DNSQ. ! end subroutine DOGLEG (N, R, LR, DIAG, QTB, DELTA, X, WA1, WA2) ! !! DOGLEG is subsidiary to SNSQ and SNSQE. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (DOGLEG-S, DDOGLG-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an M by N matrix A, an N by N nonsingular DIAGONAL ! matrix D, an M-vector B, and a positive number DELTA, the ! problem is to determine the convex combination X of the ! Gauss-Newton and scaled gradient directions that minimizes ! (A*X - B) in the least squares sense, subject to the ! restriction that the Euclidean norm of D*X be at most DELTA. ! ! This subroutine completes the solution of the problem ! if it is provided with the necessary information from the ! QR factorization of A. That is, if A = Q*R, where Q has ! orthogonal columns and R is an upper triangular matrix, ! then DOGLEG expects the full upper triangle of R and ! the first N components of (Q TRANSPOSE)*B. ! ! The subroutine statement is ! ! SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) ! ! where ! ! N is a positive integer input variable set to the order of R. ! ! R is an input array of length LR which must contain the upper ! triangular matrix R stored by rows. ! ! LR is a positive integer input variable not less than ! (N*(N+1))/2. ! ! DIAG is an input array of length N which must contain the ! diagonal elements of the matrix D. ! ! QTB is an input array of length N which must contain the first ! N elements of the vector (Q TRANSPOSE)*B. ! ! DELTA is a positive input variable which specifies an upper ! bound on the Euclidean norm of D*X. ! ! X is an output array of length N which contains the desired ! convex combination of the Gauss-Newton direction and the ! scaled gradient direction. ! ! WA1 and WA2 are work arrays of length N. ! !***SEE ALSO SNSQ, SNSQE !***ROUTINES CALLED ENORM, R1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DOGLEG INTEGER N,LR REAL DELTA REAL R(LR),DIAG(*),QTB(*),X(*),WA1(*),WA2(*) INTEGER I,J,JJ,JP1,K,L REAL ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM,TEMP,ZERO REAL R1MACH,ENORM SAVE ONE, ZERO DATA ONE,ZERO /1.0E0,0.0E0/ !***FIRST EXECUTABLE STATEMENT DOGLEG EPSMCH = R1MACH(4) ! ! FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION. ! 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 = ZERO if (N < 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 /= ZERO) go to 40 L = J DO 30 I = 1, J TEMP = MAX(TEMP,ABS(R(L))) L = L + N - I 30 CONTINUE TEMP = EPSMCH*TEMP if (TEMP == ZERO) TEMP = EPSMCH 40 CONTINUE X(J) = (QTB(J) - SUM)/TEMP 50 CONTINUE ! ! TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE. ! DO 60 J = 1, N WA1(J) = ZERO WA2(J) = DIAG(J)*X(J) 60 CONTINUE QNORM = ENORM(N,WA2) if (QNORM <= DELTA) go to 140 ! ! THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE. ! NEXT, CALCULATE THE SCALED GRADIENT DIRECTION. ! 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 ! ! CALCULATE THE NORM OF THE SCALED GRADIENT DIRECTION, ! NORMALIZE, AND RESCALE THE GRADIENT. ! GNORM = ENORM(N,WA1) SGNORM = ZERO ALPHA = DELTA/QNORM if (GNORM == ZERO) go to 120 DO 90 J = 1, N WA1(J) = (WA1(J)/GNORM)/DIAG(J) 90 CONTINUE ! ! CALCULATE THE POINT ALONG THE SCALED GRADIENT ! AT WHICH THE QUADRATIC IS MINIMIZED. ! L = 1 DO 110 J = 1, N SUM = ZERO 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 ! ! TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE. ! ALPHA = ZERO if (SGNORM >= DELTA) go to 120 ! ! THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE. ! FINALLY, CALCULATE THE POINT ALONG THE DOGLEG ! AT WHICH THE QUADRATIC IS MINIMIZED. ! BNORM = ENORM(N,QTB) TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA) TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 & + SQRT((TEMP-(DELTA/QNORM))**2 & +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2)) ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP 120 CONTINUE ! ! FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON ! DIRECTION AND THE SCALED GRADIENT DIRECTION. ! TEMP = (ONE - ALPHA)*MIN(SGNORM,DELTA) DO 130 J = 1, N X(J) = TEMP*WA1(J) + ALPHA*X(J) 130 CONTINUE 140 CONTINUE return ! ! LAST CARD OF SUBROUTINE DOGLEG. ! end subroutine DOHTRL (Q, N, NRDA, DIAG, IRANK, DIV, TD) ! !! DOHTRL is subsidiary to DBVSUP and DSUDS. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (OHTROL-S, DOHTRL-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! For a rank deficient problem, additional orthogonal ! HOUSEHOLDER transformations are applied to the left side ! of Q to further reduce the triangular form. ! Thus, after application of the routines DORTHR and DOHTRL ! to the original matrix, the result is a nonsingular ! triangular matrix while the remainder of the matrix ! has been zeroed out. ! !***SEE ALSO DBVSUP, DSUDS !***ROUTINES CALLED DDOT !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DOHTRL DOUBLE PRECISION DDOT INTEGER IRANK, IRP, J, K, KIR, KIRM, L, N, NMIR, NRDA DOUBLE PRECISION DD, DIAG(*), DIAGK, DIV(*), Q(NRDA,*), QS, SIG, & SQD, TD(*), TDV !***FIRST EXECUTABLE STATEMENT DOHTRL NMIR = N - IRANK IRP = IRANK + 1 DO 40 K = 1, IRANK KIR = IRP - K DIAGK = DIAG(KIR) SIG = (DIAGK*DIAGK) + DDOT(NMIR,Q(IRP,KIR),1,Q(IRP,KIR),1) DD = SIGN(SQRT(SIG),-DIAGK) DIV(KIR) = DD TDV = DIAGK - DD TD(KIR) = TDV if (K == IRANK) go to 30 KIRM = KIR - 1 SQD = DD*DIAGK - SIG DO 20 J = 1, KIRM QS = ((TDV*Q(KIR,J)) & + DDOT(NMIR,Q(IRP,J),1,Q(IRP,KIR),1))/SQD Q(KIR,J) = Q(KIR,J) + QS*TDV DO 10 L = IRP, N Q(L,J) = Q(L,J) + QS*Q(L,KIR) 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE return end subroutine DOMN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, & EMAP, DZ, CSAV, RWORK, IWORK) ! !! DOMN is a Preconditioned Orthomin Sparse Iterative Ax=b Solver. ! ! Routine to solve a general linear system Ax = b using ! the Preconditioned Orthomin method. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SOMN-S, DOMN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, ! ORTHOMIN, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) ! DOUBLE PRECISION P(N,0:NSAVE), AP(N,0:NSAVE), EMAP(N,0:NSAVE) ! DOUBLE PRECISION DZ(N), CSAV(NSAVE), RWORK(USER DEFINED) ! EXTERNAL MATVEC, MSOLVE ! ! call DOMN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ! $ NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, ! $ Z, P, AP, EMAP, DZ, CSAV, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, for more ! details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP IA, JA, A storage for the matrix A. ! ISYM is a flag which, if non-zero, denotest that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IWORK is an integer work array ! for the same purpose as RWORK. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize ! against. NSAVE >= 0. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Breakdown of method detected. ! (p,Ap) < epsilon**2. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Double Precision R(N). ! Z :WORK Double Precision Z(N). ! P :WORK Double Precision P(N,0:NSAVE). ! AP :WORK Double Precision AP(N,0:NSAVE). ! EMAP :WORK Double Precision EMAP(N,0:NSAVE). ! DZ :WORK Double Precision DZ(N). ! CSAV :WORK Double Precision CSAV(NSAVE) ! Double Precision arrays used for workspace. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used for workspace in ! MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE. ! ! *Description ! This routine does not care what matrix data structure is ! used for A and M. It simply calls the MATVEC and MSOLVE ! routines, with the arguments as described above. The user ! could write any type of structure and the appropriate MATVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK) in some fashion. The SLAP ! routines DSDOMN and DSLUOM are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the double pre- ! cision array A. In other words, for each column in the ! matrix first put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- ! th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) ! are the last elements of the ICOL-th column. Note that we ! always have JA(N+1)=NELT+1, where N is the number of columns ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DSDOMN, DSLUOM, ISDOMN !***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, ISDOMN !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930326 Removed unused variable. (FNF) !***END PROLOGUE DOMN ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT, NSAVE ! .. Array Arguments .. DOUBLE PRECISION A(NELT), AP(N,0:NSAVE), B(N), CSAV(NSAVE), & DZ(N), EMAP(N,0:NSAVE), P(N,0:NSAVE), R(N), & RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. DOUBLE PRECISION AK, AKDEN, AKNUM, BKL, BNRM, FUZZ, SOLNRM INTEGER I, IP, IPO, K, L, LMAX ! .. External Functions .. DOUBLE PRECISION D1MACH, DDOT INTEGER ISDOMN EXTERNAL D1MACH, DDOT, ISDOMN ! .. External Subroutines .. EXTERNAL DAXPY, DCOPY ! .. Intrinsic Functions .. INTRINSIC ABS, MIN, MOD !***FIRST EXECUTABLE STATEMENT DOMN ! ! Check some of the input data. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if FUZZ = D1MACH(3) if ( TOL < 500*FUZZ ) THEN TOL = 500*FUZZ IERR = 4 end if FUZZ = FUZZ*FUZZ ! ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N R(I) = B(I) - R(I) 10 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! if ( ISDOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & R, Z, P, AP, EMAP, DZ, CSAV, & RWORK, IWORK, AK, BNRM, SOLNRM) /= 0 ) go to 200 if ( IERR /= 0 ) RETURN ! ! ! ***** iteration loop ***** ! !VD$R NOVECTOR !VD$R NOCONCUR DO 100 K = 1, ITMAX ITER = K IP = MOD( ITER-1, NSAVE+1 ) ! ! calculate direction vector p, a*p, and (m-inv)*a*p, ! and save if desired. call DCOPY(N, Z, 1, P(1,IP), 1) call MATVEC(N, P(1,IP), AP(1,IP), NELT, IA, JA, A, ISYM) call MSOLVE(N, AP(1,IP), EMAP(1,IP), NELT, IA, JA, A, ISYM, & RWORK, IWORK) if ( NSAVE == 0 ) THEN AKDEN = DDOT(N, EMAP, 1, EMAP, 1) ELSE if ( ITER > 1 ) THEN LMAX = MIN( NSAVE, ITER-1 ) DO 20 L = 1, LMAX IPO = MOD(IP+(NSAVE+1-L),NSAVE+1) BKL = DDOT(N, EMAP(1,IP), 1, EMAP(1,IPO), 1) BKL = BKL*CSAV(L) call DAXPY(N, -BKL, P(1,IPO), 1, P(1,IP), 1) call DAXPY(N, -BKL, AP(1,IPO), 1, AP(1,IP), 1) call DAXPY(N, -BKL, EMAP(1,IPO), 1, EMAP(1,IP), 1) 20 CONTINUE if ( NSAVE > 1 ) THEN DO 30 L = NSAVE-1, 1, -1 CSAV(L+1) = CSAV(L) 30 CONTINUE ENDIF ENDIF AKDEN = DDOT(N, EMAP(1,IP), 1, EMAP(1,IP), 1) if ( ABS(AKDEN) < FUZZ ) THEN IERR = 6 return ENDIF CSAV(1) = 1.0D0/AKDEN ! ! calculate coefficient ak, new iterate x, new residual r, and ! new pseudo-residual z. ENDIF AKNUM = DDOT(N, Z, 1, EMAP(1,IP), 1) AK = AKNUM/AKDEN call DAXPY(N, AK, P(1,IP), 1, X, 1) call DAXPY(N, -AK, AP(1,IP), 1, R, 1) call DAXPY(N, -AK, EMAP(1,IP), 1, Z, 1) ! ! check stopping criterion. if ( ISDOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & R, Z, P, AP, EMAP, DZ, CSAV, & RWORK, IWORK, AK, BNRM, SOLNRM) /= 0 ) go to 200 ! 100 CONTINUE ! ! ***** end of loop ***** ! ! Stopping criterion not satisfied. ITER = ITMAX + 1 IERR = 2 ! 200 return !------------- LAST LINE OF DOMN FOLLOWS ---------------------------- end subroutine DORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) ! !! DORTH is an internal routine for DGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SORTH-S, DORTH-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine orthogonalizes the vector VNEW against the ! previous KMP vectors in the V array. It uses a modified ! Gram-Schmidt orthogonalization procedure with conditional ! reorthogonalization. ! ! *Usage: ! INTEGER N, LL, LDHES, KMP ! DOUBLE PRECISION VNEW(N), V(N,LL), HES(LDHES,LL), SNORMW ! ! call DORTH(VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) ! ! *Arguments: ! VNEW :INOUT Double Precision VNEW(N) ! On input, the vector of length N containing a scaled ! product of the Jacobian and the vector V(*,LL). ! On output, the new vector orthogonal to V(*,i0) to V(*,LL), ! where i0 = max(1, LL-KMP+1). ! V :IN Double Precision V(N,LL) ! The N x LL array containing the previous LL ! orthogonal vectors V(*,1) to V(*,LL). ! HES :INOUT Double Precision HES(LDHES,LL) ! On input, an LL x LL upper Hessenberg matrix containing, ! in HES(I,K), K.lt.LL, the scaled inner products of ! A*V(*,K) and V(*,i). ! On return, column LL of HES is filled in with ! the scaled inner products of A*V(*,LL) and V(*,i). ! N :IN Integer ! The order of the matrix A, and the length of VNEW. ! LL :IN Integer ! The current order of the matrix HES. ! LDHES :IN Integer ! The leading dimension of the HES array. ! KMP :IN Integer ! The number of previous vectors the new vector VNEW ! must be made orthogonal to (KMP .le. MAXL). ! SNORMW :OUT DOUBLE PRECISION ! Scalar containing the l-2 norm of VNEW. ! !***SEE ALSO DGMRES !***ROUTINES CALLED DAXPY, DDOT, DNRM2 !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Made subsidiary to DGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE DORTH ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. DOUBLE PRECISION SNORMW INTEGER KMP, LDHES, LL, N ! .. Array Arguments .. DOUBLE PRECISION HES(LDHES,*), V(N,*), VNEW(*) ! .. Local Scalars .. DOUBLE PRECISION ARG, SUMDSQ, TEM, VNRM INTEGER I, I0 ! .. External Functions .. DOUBLE PRECISION DDOT, DNRM2 EXTERNAL DDOT, DNRM2 ! .. External Subroutines .. EXTERNAL DAXPY ! .. Intrinsic Functions .. INTRINSIC MAX, SQRT !***FIRST EXECUTABLE STATEMENT DORTH ! ! Get norm of unaltered VNEW for later use. ! VNRM = DNRM2(N, VNEW, 1) ! ------------------------------------------------------------------- ! Perform the modified Gram-Schmidt procedure on VNEW =A*V(LL). ! Scaled inner products give new column of HES. ! Projections of earlier vectors are subtracted from VNEW. ! ------------------------------------------------------------------- I0 = MAX(1,LL-KMP+1) DO 10 I = I0,LL HES(I,LL) = DDOT(N, V(1,I), 1, VNEW, 1) TEM = -HES(I,LL) call DAXPY(N, TEM, V(1,I), 1, VNEW, 1) 10 CONTINUE ! ------------------------------------------------------------------- ! Compute SNORMW = norm of VNEW. If VNEW is small compared ! to its input value (in norm), then reorthogonalize VNEW to ! V(*,1) through V(*,LL). Correct if relative correction ! exceeds 1000*(unit roundoff). Finally, correct SNORMW using ! the dot products involved. ! ------------------------------------------------------------------- SNORMW = DNRM2(N, VNEW, 1) if (VNRM + 0.001D0*SNORMW /= VNRM) RETURN SUMDSQ = 0 DO 30 I = I0,LL TEM = -DDOT(N, V(1,I), 1, VNEW, 1) if (HES(I,LL) + 0.001D0*TEM == HES(I,LL)) go to 30 HES(I,LL) = HES(I,LL) - TEM call DAXPY(N, TEM, V(1,I), 1, VNEW, 1) SUMDSQ = SUMDSQ + TEM**2 30 CONTINUE if (SUMDSQ == 0.0D0) RETURN ARG = MAX(0.0D0,SNORMW**2 - SUMDSQ) SNORMW = SQRT(ARG) ! return !------------- LAST LINE OF DORTH FOLLOWS ---------------------------- end subroutine DORTHR (A, N, M, NRDA, IFLAG, IRANK, ISCALE, DIAG, & KPIVOT, SCALES, ROWS, RS) ! !! DORTHR is subsidiary to DBVSUP and DSUDS. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (ORTHOR-S, DORTHR-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! Reduction of the matrix A to lower triangular form by a sequence of ! orthogonal HOUSEHOLDER transformations post-multiplying A. ! ! ********************************************************************* ! INPUT ! ********************************************************************* ! ! A -- Contains the matrix to be decomposed, must be dimensioned ! NRDA by N. ! N -- Number of rows in the matrix, N greater or equal to 1. ! M -- Number of columns in the matrix, M greater or equal to N. ! IFLAG -- Indicates the uncertainty in the matrix data. ! = 0 when the data is to be treated as exact. ! =-K when the data is assumed to be accurate to about ! K digits. ! ISCALE -- Scaling indicator. ! =-1 if the matrix is to be pre-scaled by ! columns when appropriate. ! Otherwise no scaling will be attempted. ! NRDA -- Row dimension of A, NRDA greater or equal to N. ! DIAG,KPIVOT,ROWS, -- Arrays of length at least N used internally ! RS,SCALES (except for SCALES which is M). ! ! ********************************************************************* ! OUTPUT ! ********************************************************************* ! ! IFLAG - Status indicator ! =1 for successful decomposition. ! =2 if improper input is detected. ! =3 if rank of the matrix is less than N. ! A -- Contains the reduced matrix in the strictly lower triangular ! part and transformation information. ! IRANK -- Contains the numerically determined matrix rank. ! DIAG -- Contains the diagonal elements of the reduced ! triangular matrix. ! KPIVOT -- Contains the pivotal information, the column ! interchanges performed on the original matrix are ! recorded here. ! SCALES -- Contains the column scaling parameters. ! ! ********************************************************************* ! !***SEE ALSO DBVSUP, DSUDS !***REFERENCES G. Golub, Numerical methods for solving linear least ! squares problems, Numerische Mathematik 7, (1965), ! pp. 206-216. ! P. Businger and G. Golub, Linear least squares ! solutions by Householder transformations, Numerische ! Mathematik 7, (1965), pp. 269-276. !***ROUTINES CALLED D1MACH, DCSCAL, DDOT, XERMSG !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DORTHR DOUBLE PRECISION DDOT, D1MACH INTEGER IFLAG, IRANK, ISCALE, J, JROW, K, KP, KPIVOT(*), L, M, & MK, N, NRDA DOUBLE PRECISION A(NRDA,*), ACC, AKK, ANORM, AS, ASAVE, DIAG(*), & DIAGK, DUM, ROWS(*), RS(*), RSS, SAD, SCALES(*), SIG, SIGMA, & SRURO, URO ! ! ****************************************************************** ! ! MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED ! BY THE FUNCTION D1MACH. ! ! ****************************************************************** ! !***FIRST EXECUTABLE STATEMENT DORTHR URO = D1MACH(4) if (M >= N .AND. N >= 1 .AND. NRDA >= N) go to 10 IFLAG = 2 call XERMSG ('SLATEC', 'DORTHR', 'INVALID INPUT PARAMETERS.', & 2, 1) go to 150 10 CONTINUE ! ACC = 10.0D0*URO if (IFLAG < 0) ACC = MAX(ACC,10.0D0**IFLAG) SRURO = SQRT(URO) IFLAG = 1 IRANK = N ! ! COMPUTE NORM**2 OF JTH ROW AND A MATRIX NORM ! ANORM = 0.0D0 DO 20 J = 1, N KPIVOT(J) = J ROWS(J) = DDOT(M,A(J,1),NRDA,A(J,1),NRDA) RS(J) = ROWS(J) ANORM = ANORM + ROWS(J) 20 CONTINUE ! ! PERFORM COLUMN SCALING ON A WHEN SPECIFIED ! call DCSCAL(A,NRDA,N,M,SCALES,DUM,ROWS,RS,ANORM,SCALES,ISCALE, & 1) ! ANORM = SQRT(ANORM) ! ! ! CONSTRUCTION OF LOWER TRIANGULAR MATRIX AND RECORDING OF ! ORTHOGONAL TRANSFORMATIONS ! ! DO 130 K = 1, N ! BEGIN BLOCK PERMITTING ...EXITS TO 80 MK = M - K + 1 ! ...EXIT if (K == N) go to 80 KP = K + 1 ! ! SEARCHING FOR PIVOTAL ROW ! DO 60 J = K, N ! BEGIN BLOCK PERMITTING ...EXITS TO 50 if (ROWS(J) >= SRURO*RS(J)) go to 30 ROWS(J) = DDOT(MK,A(J,K),NRDA,A(J,K),NRDA) RS(J) = ROWS(J) 30 CONTINUE if (J == K) go to 40 ! ......EXIT if (SIGMA >= 0.99D0*ROWS(J)) go to 50 40 CONTINUE SIGMA = ROWS(J) JROW = J 50 CONTINUE 60 CONTINUE ! ...EXIT if (JROW == K) go to 80 ! ! PERFORM ROW INTERCHANGE ! L = KPIVOT(K) KPIVOT(K) = KPIVOT(JROW) KPIVOT(JROW) = L ROWS(JROW) = ROWS(K) ROWS(K) = SIGMA RSS = RS(K) RS(K) = RS(JROW) RS(JROW) = RSS DO 70 L = 1, M ASAVE = A(K,L) A(K,L) = A(JROW,L) A(JROW,L) = ASAVE 70 CONTINUE 80 CONTINUE ! ! CHECK RANK OF THE MATRIX ! SIG = DDOT(MK,A(K,K),NRDA,A(K,K),NRDA) DIAGK = SQRT(SIG) if (DIAGK > ACC*ANORM) go to 90 ! ! RANK DEFICIENT PROBLEM IFLAG = 3 IRANK = K - 1 call XERMSG ('SLATEC', 'DORTHR', & 'RANK OF MATRIX IS LESS THAN THE NUMBER OF ROWS.', 1, & 1) ! ......EXIT go to 140 90 CONTINUE ! ! CONSTRUCT AND APPLY TRANSFORMATION TO MATRIX A ! AKK = A(K,K) if (AKK > 0.0D0) DIAGK = -DIAGK DIAG(K) = DIAGK A(K,K) = AKK - DIAGK if (K == N) go to 120 SAD = DIAGK*AKK - SIG DO 110 J = KP, N AS = DDOT(MK,A(K,K),NRDA,A(J,K),NRDA)/SAD DO 100 L = K, M A(J,L) = A(J,L) + AS*A(K,L) 100 CONTINUE ROWS(J) = ROWS(J) - A(J,K)**2 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE ! ! return end subroutine DP1VLU (L, NDER, X, YFIT, YP, A) ! !! DP1VLU uses the coefficients generated by DPOLFT to evaluate the ... ! polynomial fit of degree L, along with the first NDER of ! its derivatives, at a specified point. ! !***LIBRARY SLATEC !***CATEGORY K6 !***TYPE DOUBLE PRECISION (PVALUE-S, DP1VLU-D) !***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION !***AUTHOR Shampine, L. F., (SNLA) ! Davenport, S. M., (SNLA) !***DESCRIPTION ! ! Abstract ! ! The subroutine DP1VLU uses the coefficients generated by DPOLFT ! to evaluate the polynomial fit of degree L , along with the first ! NDER of its derivatives, at a specified point. Computationally ! stable recurrence relations are used to perform this task. ! ! The parameters for DP1VLU are ! ! Input -- ALL TYPE REAL variables are DOUBLE PRECISION ! L - the degree of polynomial to be evaluated. L may be ! any non-negative integer which is less than or equal ! to NDEG , the highest degree polynomial provided ! by DPOLFT . ! NDER - the number of derivatives to be evaluated. NDER ! may be 0 or any positive value. If NDER is less ! than 0, it will be treated as 0. ! X - the argument at which the polynomial and its ! derivatives are to be evaluated. ! A - work and output array containing values from last ! call to DPOLFT . ! ! Output -- ALL TYPE REAL variables are DOUBLE PRECISION ! YFIT - value of the fitting polynomial of degree L at X ! YP - array containing the first through NDER derivatives ! of the polynomial of degree L . YP must be ! dimensioned at least NDER in the calling program. ! !***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, ! Curve fitting by polynomials in one variable, Report ! SLA-74-0270, Sandia Laboratories, June 1974. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 740601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DP1VLU IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER I,IC,ILO,IN,INP1,IUP,K1,K1I,K2,K3,K3P1,K3PN,K4,K4P1,K4PN, & KC,L,LM1,LP1,MAXORD,N,NDER,NDO,NDP1,NORD DOUBLE PRECISION A(*),CC,DIF,VAL,X,YFIT,YP(*) CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT DP1VLU if (L < 0) go to 12 NDO = MAX(NDER,0) NDO = MIN(NDO,L) MAXORD = A(1) + 0.5D0 K1 = MAXORD + 1 K2 = K1 + MAXORD K3 = K2 + MAXORD + 2 NORD = A(K3) + 0.5D0 if (L > NORD) go to 11 K4 = K3 + L + 1 if (NDER < 1) go to 2 DO 1 I = 1,NDER 1 YP(I) = 0.0D0 2 if (L >= 2) go to 4 if (L == 1) go to 3 ! ! L IS 0 ! VAL = A(K2+1) go to 10 ! ! L IS 1 ! 3 CC = A(K2+2) VAL = A(K2+1) + (X-A(2))*CC if (NDER >= 1) YP(1) = CC go to 10 ! ! L IS GREATER THAN 1 ! 4 NDP1 = NDO + 1 K3P1 = K3 + 1 K4P1 = K4 + 1 LP1 = L + 1 LM1 = L - 1 ILO = K3 + 3 IUP = K4 + NDP1 DO 5 I = ILO,IUP 5 A(I) = 0.0D0 DIF = X - A(LP1) KC = K2 + LP1 A(K4P1) = A(KC) A(K3P1) = A(KC-1) + DIF*A(K4P1) A(K3+2) = A(K4P1) ! ! EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES ! DO 9 I = 1,LM1 IN = L - I INP1 = IN + 1 K1I = K1 + INP1 IC = K2 + IN DIF = X - A(INP1) VAL = A(IC) + DIF*A(K3P1) - A(K1I)*A(K4P1) if (NDO <= 0) go to 8 DO 6 N = 1,NDO K3PN = K3P1 + N K4PN = K4P1 + N 6 YP(N) = DIF*A(K3PN) + N*A(K3PN-1) - A(K1I)*A(K4PN) ! ! SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS ! DO 7 N = 1,NDO K3PN = K3P1 + N K4PN = K4P1 + N A(K4PN) = A(K3PN) 7 A(K3PN) = YP(N) 8 A(K4P1) = A(K3P1) 9 A(K3P1) = VAL ! ! NORMAL RETURN OR ABORT DUE TO ERROR ! 10 YFIT = VAL return ! 11 WRITE (XERN1, '(I8)') L WRITE (XERN2, '(I8)') NORD call XERMSG ('SLATEC', 'DP1VLU', & 'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 // & ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 // & ', COMPUTED BY DPOLFT -- EXECUTION TERMINATED.', 8, 2) return ! 12 call XERMSG ('SLATEC', 'DP1VLU', & 'INVALID INPUT PARAMETER. ORDER OF POLYNOMIAL EVALUATION ' // & 'REQUESTED IS NEGATIVE.', 2, 2) return end subroutine DPBCO (ABD, LDA, N, M, RCOND, Z, INFO) ! !! DPBCO factors a real symmetric positive definite matrix stored in ! band form and estimate the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B2 !***TYPE DOUBLE PRECISION (SPBCO-S, DPBCO-D, CPBCO-C) !***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPBCO factors a double precision symmetric positive definite ! matrix stored in band form and estimates the condition of the ! matrix. ! ! If RCOND is not needed, DPBFA is slightly faster. ! To solve A*X = B , follow DPBCO by DPBSL. ! To compute INVERSE(A)*C , follow DPBCO by DPBSL. ! To compute DETERMINANT(A) , follow DPBCO by DPBDI. ! ! On Entry ! ! ABD DOUBLE PRECISION(LDA, N) ! the matrix to be factored. The columns of the upper ! triangle are stored in the columns of ABD and the ! diagonals of the upper triangle are stored in the ! rows of ABD . See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= M + 1 . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! 0 <= M < N . ! ! On Return ! ! ABD an upper triangular matrix R , stored in band ! form, so that A = TRANS(R)*R . ! If INFO /= 0 , the factorization is not complete. ! ! RCOND DOUBLE PRECISION ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. If INFO /= 0 , RCOND is unchanged. ! ! Z DOUBLE PRECISION(N) ! a work vector whose contents are usually unimportant. ! If A is singular to working precision, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! If INFO /= 0 , Z is unchanged. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! ! Band Storage ! ! If A is a symmetric positive definite band matrix, ! the following program segment will set up the input. ! ! M = (band width above diagonal) ! DO 20 J = 1, N ! I1 = MAX(1, J-M) ! DO 10 I = I1, J ! K = I-J+M+1 ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses M + 1 rows of A , except for the M by M ! upper left triangle, which is ignored. ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 12222324 0 0 ! 1323333435 0 ! 02434444546 ! 0 035455556 ! 0 0 0465666 ! ! then N = 6 , M = 2 and ABD should contain ! ! * * 13243546 ! * 1223344556 ! 112233445566 ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DASUM, DAXPY, DDOT, DPBFA, DSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPBCO INTEGER LDA,N,M,INFO DOUBLE PRECISION ABD(LDA,*),Z(*) DOUBLE PRECISION RCOND ! DOUBLE PRECISION DDOT,EK,T,WK,WKM DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM INTEGER I,J,J2,K,KB,KP1,L,LA,LB,LM,MU ! ! FIND NORM OF A ! !***FIRST EXECUTABLE STATEMENT DPBCO DO 30 J = 1, N L = MIN(J,M+1) MU = MAX(M+2-J,1) Z(J) = DASUM(L,ABD(MU,J),1) K = J - L if (M < MU) go to 20 DO 10 I = MU, M K = K + 1 Z(K) = Z(K) + ABS(ABD(I,J)) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0D0 DO 40 J = 1, N ANORM = MAX(ANORM,Z(J)) 40 CONTINUE ! ! FACTOR ! call DPBFA(ABD,LDA,N,M,INFO) if (INFO /= 0) go to 180 ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE TRANS(R)*W = E ! EK = 1.0D0 DO 50 J = 1, N Z(J) = 0.0D0 50 CONTINUE DO 110 K = 1, N if (Z(K) /= 0.0D0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= ABD(M+1,K)) go to 60 S = ABD(M+1,K)/ABS(EK-Z(K)) call DSCAL(N,S,Z,1) EK = S*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) WK = WK/ABD(M+1,K) WKM = WKM/ABD(M+1,K) KP1 = K + 1 J2 = MIN(K+M,N) I = M + 1 if (KP1 > J2) go to 100 DO 70 J = KP1, J2 I = I - 1 SM = SM + ABS(Z(J)+WKM*ABD(I,J)) Z(J) = Z(J) + WK*ABD(I,J) S = S + ABS(Z(J)) 70 CONTINUE if (S >= SM) go to 90 T = WKM - WK WK = WKM I = M + 1 DO 80 J = KP1, J2 I = I - 1 Z(J) = Z(J) + T*ABD(I,J) 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) ! ! SOLVE R*Y = W ! DO 130 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= ABD(M+1,K)) go to 120 S = ABD(M+1,K)/ABS(Z(K)) call DSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/ABD(M+1,K) LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM T = -Z(K) call DAXPY(LM,T,ABD(LA,K),1,Z(LB),1) 130 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) ! YNORM = 1.0D0 ! ! SOLVE TRANS(R)*V = Y ! DO 150 K = 1, N LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM Z(K) = Z(K) - DDOT(LM,ABD(LA,K),1,Z(LB),1) if (ABS(Z(K)) <= ABD(M+1,K)) go to 140 S = ABD(M+1,K)/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/ABD(M+1,K) 150 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE R*Z = W ! DO 170 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= ABD(M+1,K)) go to 160 S = ABD(M+1,K)/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/ABD(M+1,K) LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM T = -Z(K) call DAXPY(LM,T,ABD(LA,K),1,Z(LB),1) 170 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0D0) RCOND = YNORM/ANORM if (ANORM == 0.0D0) RCOND = 0.0D0 180 CONTINUE return end subroutine DPBDI (ABD, LDA, N, M, DET) ! !! DPBDI computes the determinant of a symmetric positive definite ! band matrix using the factors computed by DPBCO or DPBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D3B2 !***TYPE DOUBLE PRECISION (SPBDI-S, DPBDI-D, CPBDI-C) !***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, ! MATRIX, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPBDI computes the determinant ! of a double precision symmetric positive definite band matrix ! using the factors computed by DPBCO or DPBFA. ! If the inverse is needed, use DPBSL N times. ! ! On Entry ! ! ABD DOUBLE PRECISION(LDA, N) ! the output from DPBCO or DPBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! ! On Return ! ! DET DOUBLE PRECISION(2) ! determinant of original matrix in the form ! DETERMINANT = DET(1) * 10.0**DET(2) ! with 1.0 <= DET(1) < 10.0 ! or DET(1) == 0.0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPBDI INTEGER LDA,N,M DOUBLE PRECISION ABD(LDA,*) DOUBLE PRECISION DET(2) ! DOUBLE PRECISION S INTEGER I !***FIRST EXECUTABLE STATEMENT DPBDI ! ! COMPUTE DETERMINANT ! DET(1) = 1.0D0 DET(2) = 0.0D0 S = 10.0D0 DO 50 I = 1, N DET(1) = ABD(M+1,I)**2*DET(1) if (DET(1) == 0.0D0) go to 60 10 if (DET(1) >= 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) < S) go to 40 DET(1) = DET(1)/S DET(2) = DET(2) + 1.0D0 go to 30 40 CONTINUE 50 CONTINUE 60 CONTINUE return end subroutine DPBFA (ABD, LDA, N, M, INFO) ! !! DPBFA factors a real symmetric positive definite matrix stored in ! in band form. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B2 !***TYPE DOUBLE PRECISION (SPBFA-S, DPBFA-D, CPBFA-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPBFA factors a double precision symmetric positive definite ! matrix stored in band form. ! ! DPBFA is usually called by DPBCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! ! On Entry ! ! ABD DOUBLE PRECISION(LDA, N) ! the matrix to be factored. The columns of the upper ! triangle are stored in the columns of ABD and the ! diagonals of the upper triangle are stored in the ! rows of ABD . See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= M + 1 . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! 0 <= M < N . ! ! On Return ! ! ABD an upper triangular matrix R , stored in band ! form, so that A = TRANS(R)*R . ! ! INFO INTEGER ! = 0 for normal return. ! = K if the leading minor of order K is not ! positive definite. ! ! Band Storage ! ! If A is a symmetric positive definite band matrix, ! the following program segment will set up the input. ! ! M = (band width above diagonal) ! DO 20 J = 1, N ! I1 = MAX(1, J-M) ! DO 10 I = I1, J ! K = I-J+M+1 ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPBFA INTEGER LDA,N,M,INFO DOUBLE PRECISION ABD(LDA,*) ! DOUBLE PRECISION DDOT,T DOUBLE PRECISION S INTEGER IK,J,JK,K,MU !***FIRST EXECUTABLE STATEMENT DPBFA DO 30 J = 1, N INFO = J S = 0.0D0 IK = M + 1 JK = MAX(J-M,1) MU = MAX(M+2-J,1) if (M < MU) go to 20 DO 10 K = MU, M T = ABD(K,J) - DDOT(K-MU,ABD(IK,JK),1,ABD(MU,J),1) T = T/ABD(M+1,JK) ABD(K,J) = T S = S + T*T IK = IK - 1 JK = JK + 1 10 CONTINUE 20 CONTINUE S = ABD(M+1,J) - S if (S <= 0.0D0) go to 40 ABD(M+1,J) = SQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE return end subroutine DPBSL (ABD, LDA, N, M, B) ! !! DPBSL solves a real symmetric positive definite band system ! using the factors computed by DPBCO or DPBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B2 !***TYPE DOUBLE PRECISION (SPBSL-S, DPBSL-D, CPBSL-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, ! POSITIVE DEFINITE, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPBSL solves the double precision symmetric positive definite ! band system A*X = B ! using the factors computed by DPBCO or DPBFA. ! ! On Entry ! ! ABD DOUBLE PRECISION(LDA, N) ! the output from DPBCO or DPBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! ! B DOUBLE PRECISION(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal. Technically this indicates ! singularity, but it is usually caused by improper subroutine ! arguments. It will not occur if the subroutines are called ! correctly, and INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call DPBCO(ABD,LDA,N,RCOND,Z,INFO) ! if (RCOND is too small .OR. INFO /= 0) go to ... ! DO 10 J = 1, P ! call DPBSL(ABD,LDA,N,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPBSL INTEGER LDA,N,M DOUBLE PRECISION ABD(LDA,*),B(*) ! DOUBLE PRECISION DDOT,T INTEGER K,KB,LA,LB,LM ! ! SOLVE TRANS(R)*Y = B ! !***FIRST EXECUTABLE STATEMENT DPBSL DO 10 K = 1, N LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM T = DDOT(LM,ABD(LA,K),1,B(LB),1) B(K) = (B(K) - T)/ABD(M+1,K) 10 CONTINUE ! ! SOLVE R*X = Y ! DO 20 KB = 1, N K = N + 1 - KB LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM B(K) = B(K)/ABD(M+1,K) T = -B(K) call DAXPY(LM,T,ABD(LA,K),1,B(LB),1) 20 CONTINUE return end subroutine DPCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, & NDIM, KORD, IERR) ! !! DPCHBS is a piecewise Cubic Hermite to B-Spline converter. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3 !***TYPE DOUBLE PRECISION (PCHBS-S, DPCHBS-D) !***KEYWORDS B-SPLINES, CONVERSION, CUBIC HERMITE INTERPOLATION, ! PIECEWISE CUBIC INTERPOLATION !***AUTHOR Fritsch, F. N., (LLNL) ! Computing and Mathematics Research Division ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! *Usage: ! ! INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR ! PARAMETER (INCFD = ...) ! DOUBLE PRECISION X(nmax), F(INCFD,nmax), D(INCFD,nmax), ! * T(2*nmax+4), BCOEF(2*nmax) ! ! call DPCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, ! * NDIM, KORD, IERR) ! ! *Arguments: ! ! N:IN is the number of data points, N.ge.2 . (not checked) ! ! X:IN is the real array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. (not checked) ! nmax, the dimension of X, must be .ge.N. ! ! F:IN is the real array of dependent variable values. ! F(1+(I-1)*INCFD) is the value corresponding to X(I). ! nmax, the second dimension of F, must be .ge.N. ! ! D:IN is the real array of derivative values at the data points. ! D(1+(I-1)*INCFD) is the value corresponding to X(I). ! nmax, the second dimension of D, must be .ge.N. ! ! INCFD:IN is the increment between successive values in F and D. ! This argument is provided primarily for 2-D applications. ! It may have the value 1 for one-dimensional applications, ! in which case F and D may be singly-subscripted arrays. ! ! KNOTYP:IN is a flag to control the knot sequence. ! The knot sequence T is normally computed from X by putting ! a double knot at each X and setting the end knot pairs ! according to the value of KNOTYP: ! KNOTYP = 0: Quadruple knots at X(1) and X(N). (default) ! KNOTYP = 1: Replicate lengths of extreme subintervals: ! T( 1 ) = T( 2 ) = X(1) - (X(2)-X(1)) ; ! T(M+4) = T(M+3) = X(N) + (X(N)-X(N-1)). ! KNOTYP = 2: Periodic placement of boundary knots: ! T( 1 ) = T( 2 ) = X(1) - (X(N)-X(N-1)); ! T(M+4) = T(M+3) = X(N) + (X(2)-X(1)) . ! Here M=NDIM=2*N. ! If the input value of KNOTYP is negative, however, it is ! assumed that NKNOTS and T were set in a previous call. ! This option is provided for improved efficiency when used ! in a parametric setting. ! ! NKNOTS:INOUT is the number of knots. ! If KNOTYP >= 0, then NKNOTS will be set to NDIM+4. ! If KNOTYP < 0, then NKNOTS is an input variable, and an ! error return will be taken if it is not equal to NDIM+4. ! ! T:INOUT is the array of 2*N+4 knots for the B-representation. ! If KNOTYP >= 0, T will be returned by DPCHBS with the ! interior double knots equal to the X-values and the ! boundary knots set as indicated above. ! If KNOTYP < 0, it is assumed that T was set by a ! previous call to DPCHBS. (This routine does **not** ! verify that T forms a legitimate knot sequence.) ! ! BCOEF:OUT is the array of 2*N B-spline coefficients. ! ! NDIM:OUT is the dimension of the B-spline space. (Set to 2*N.) ! ! KORD:OUT is the order of the B-spline. (Set to 4.) ! ! IERR:OUT is an error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -4 if KNOTYP > 2 . ! IERR = -5 if KNOTYP < 0 and NKNOTS /= (2*N+4). ! ! *Description: ! DPCHBS computes the B-spline representation of the PCH function ! determined by N,X,F,D. To be compatible with the rest of PCHIP, ! DPCHBS includes INCFD, the increment between successive values of ! the F and D arrays. ! ! The output is the B-representation for the function: NKNOTS, T, ! BCOEF, NDIM, KORD. ! ! *Caution: ! Since it is assumed that the input PCH function has been ! computed by one of the other routines in the package PCHIP, ! input arguments N, X, INCFD are **not** checked for validity. ! ! *Restrictions/assumptions: ! 1. N >= 2 . (not checked) ! 2. X(i) < X(i+1), i=1,...,N . (not checked) ! 3. INCFD > 0 . (not checked) ! 4. KNOTYP <= 2 . (error return if not) ! *5. NKNOTS = NDIM+4 = 2*N+4 . (error return if not) ! *6. T(2*k+1) = T(2*k) = X(k), k=1,...,N . (not checked) ! ! * Indicates this applies only if KNOTYP < 0 . ! ! *Portability: ! Argument INCFD is used only to cause the compiler to generate ! efficient code for the subscript expressions (1+(I-1)*INCFD) . ! The normal usage, in which DPCHBS is called with one-dimensional ! arrays F and D, is probably non-Fortran 77, in the strict sense, ! but it works on all systems on which DPCHBS has been tested. ! ! *See Also: ! PCHIC, PCHIM, or PCHSP can be used to determine an interpolating ! PCH function from a set of data. ! The B-spline routine DBVALU can be used to evaluate the ! B-representation that is output by DPCHBS. ! (See BSPDOC for more information.) ! !***REFERENCES F. N. Fritsch, "Representations for parametric cubic ! splines," Computer Aided Geometric Design 6 (1989), ! pp.79-82. !***ROUTINES CALLED DPCHKT, XERMSG !***REVISION HISTORY (YYMMDD) ! 870701 DATE WRITTEN ! 900405 Converted Fortran to upper case. ! 900405 Removed requirement that X be dimensioned N+1. ! 900406 Modified to make PCHKT a subsidiary routine to simplify ! usage. In the process, added argument INCFD to be com- ! patible with the rest of PCHIP. ! 900410 Converted prologue to SLATEC 4.0 format. ! 900410 Added calls to XERMSG and changed constant 3. to 3 to ! reduce single/double differences. ! 900411 Added reference. ! 900430 Produced double precision version. ! 900501 Corrected declarations. ! 930317 Minor cosmetic changes. (FNF) ! 930514 Corrected problems with dimensioning of arguments and ! clarified DESCRIPTION. (FNF) ! 930604 Removed NKNOTS from DPCHKT call list. (FNF) !***END PROLOGUE DPCHBS ! !*Internal Notes: ! !**End ! ! Declare arguments. ! INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), T(*), BCOEF(*) ! ! Declare local variables. ! INTEGER K, KK DOUBLE PRECISION DOV3, HNEW, HOLD CHARACTER*8 LIBNAM, SUBNAM !***FIRST EXECUTABLE STATEMENT DPCHBS ! ! Initialize. ! NDIM = 2*N KORD = 4 IERR = 0 LIBNAM = 'SLATEC' SUBNAM = 'DPCHBS' ! ! Check argument validity. Set up knot sequence if OK. ! if ( KNOTYP > 2 ) THEN IERR = -1 call XERMSG (LIBNAM, SUBNAM, 'KNOTYP GREATER THAN 2', IERR, 1) return end if if ( KNOTYP < 0 ) THEN if ( NKNOTS /= NDIM+4 ) THEN IERR = -2 call XERMSG (LIBNAM, SUBNAM, & 'KNOTYP < 0 AND NKNOTS /= (2*N+4)', IERR, 1) return ENDIF ELSE ! Set up knot sequence. NKNOTS = NDIM + 4 call DPCHKT (N, X, KNOTYP, T) end if ! ! Compute B-spline coefficients. ! HNEW = T(3) - T(1) DO 40 K = 1, N KK = 2*K HOLD = HNEW ! The following requires mixed mode arithmetic. DOV3 = D(1,K)/3 BCOEF(KK-1) = F(1,K) - HOLD*DOV3 ! The following assumes T(2*K+1) = X(K). HNEW = T(KK+3) - T(KK+1) BCOEF(KK) = F(1,K) + HNEW*DOV3 40 CONTINUE ! ! Terminate. ! return !------------- LAST LINE OF DPCHBS FOLLOWS ----------------------------- end subroutine DPCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) ! !! DPCHCE sets boundary conditions for DPCHIC. ! !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHCE-S, DPCHCE-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHCE: DPCHIC End Derivative Setter. ! ! Called by DPCHIC to set end derivatives as requested by the user. ! It must be called after interior derivative values have been set. ! ----- ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the D array. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER IC(2), N, IERR ! DOUBLE PRECISION VC(2), X(N), H(N), SLOPE(N), D(INCFD,N) ! ! call DPCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) ! ! Parameters: ! ! IC -- (input) integer array of length 2 specifying desired ! boundary conditions: ! IC(1) = IBEG, desired condition at beginning of data. ! IC(2) = IEND, desired condition at end of data. ! ( see prologue to DPCHIC for details. ) ! ! VC -- (input) real*8 array of length 2 specifying desired boundary ! values. VC(1) need be set only if IC(1) = 2 or 3 . ! VC(2) need be set only if IC(2) = 2 or 3 . ! ! N -- (input) number of data points. (assumes N >= 2) ! ! X -- (input) real*8 array of independent variable values. (the ! elements of X are assumed to be strictly increasing.) ! ! H -- (input) real*8 array of interval lengths. ! SLOPE -- (input) real*8 array of data slopes. ! If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: ! H(I) = X(I+1)-X(I), ! SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. ! ! D -- (input) real*8 array of derivative values at the data points. ! The value corresponding to X(I) must be stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! (output) the value of D at X(1) and/or X(N) is changed, if ! necessary, to produce the requested boundary conditions. ! no other entries in D are changed. ! ! INCFD -- (input) increment between successive values in D. ! This argument is provided primarily for 2-D applications. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning errors: ! IERR = 1 if IBEG < 0 and D(1) had to be adjusted for ! monotonicity. ! IERR = 2 if IEND < 0 and D(1+(N-1)*INCFD) had to be ! adjusted for monotonicity. ! IERR = 3 if both of the above are true. ! ! ------- ! WARNING: This routine does no validity-checking of arguments. ! ------- ! ! Fortran intrinsics used: ABS. ! !***SEE ALSO DPCHIC !***ROUTINES CALLED DPCHDF, DPCHST, XERMSG !***REVISION HISTORY (YYMMDD) ! 820218 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 870707 Corrected XERROR calls for d.p. name(s). ! 890206 Corrected XERROR calls. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR section in prologue. (WRB) ! 930503 Improved purpose. (FNF) !***END PROLOGUE DPCHCE ! ! Programming notes: ! 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if ! either argument is zero, +1 if they are of the same sign, and ! -1 if they are of opposite sign. ! 2. One could reduce the number of arguments and amount of local ! storage, at the expense of reduced code clarity, by passing in ! the array WK (rather than splitting it into H and SLOPE) and ! increasing its length enough to incorporate STEMP and XTEMP. ! 3. The two monotonicity checks only use the sufficient conditions. ! Thus, it is possible (but unlikely) for a boundary condition to ! be changed, even though the original interpolant was monotonic. ! (At least the result is a continuous function of the data.) !**End ! ! DECLARE ARGUMENTS. ! INTEGER IC(2), N, INCFD, IERR DOUBLE PRECISION VC(2), X(*), H(*), SLOPE(*), D(INCFD,*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER IBEG, IEND, IERF, INDEX, J, K DOUBLE PRECISION HALF, STEMP(3), THREE, TWO, XTEMP(4), ZERO SAVE ZERO, HALF, TWO, THREE DOUBLE PRECISION DPCHDF, DPCHST ! ! INITIALIZE. ! DATA ZERO /0.D0/, HALF/.5D0/, TWO/2.D0/, THREE/3.D0/ ! !***FIRST EXECUTABLE STATEMENT DPCHCE IBEG = IC(1) IEND = IC(2) IERR = 0 ! ! SET TO DEFAULT BOUNDARY CONDITIONS if N IS TOO SMALL. ! if ( ABS(IBEG) > N ) IBEG = 0 if ( ABS(IEND) > N ) IEND = 0 ! ! TREAT BEGINNING BOUNDARY CONDITION. ! if (IBEG == 0) go to 2000 K = ABS(IBEG) if (K == 1) THEN ! BOUNDARY VALUE PROVIDED. D(1,1) = VC(1) ELSE if (K == 2) THEN ! BOUNDARY SECOND DERIVATIVE PROVIDED. D(1,1) = HALF*( (THREE*SLOPE(1) - D(1,2)) - HALF*VC(1)*H(1) ) ELSE if (K < 5) THEN ! USE K-POINT DERIVATIVE FORMULA. ! PICK UP FIRST K POINTS, IN REVERSE ORDER. DO 10 J = 1, K INDEX = K-J+1 ! INDEX RUNS FROM K DOWN TO 1. XTEMP(J) = X(INDEX) if (J < K) STEMP(J) = SLOPE(INDEX-1) 10 CONTINUE ! ----------------------------- D(1,1) = DPCHDF (K, XTEMP, STEMP, IERF) ! ----------------------------- if (IERF /= 0) go to 5001 ELSE ! USE 'NOT A KNOT' CONDITION. D(1,1) = ( THREE*(H(1)*SLOPE(2) + H(2)*SLOPE(1)) & - TWO*(H(1)+H(2))*D(1,2) - H(1)*D(1,3) ) / H(2) end if ! if (IBEG > 0) go to 2000 ! ! CHECK D(1,1) FOR COMPATIBILITY WITH MONOTONICITY. ! if (SLOPE(1) == ZERO) THEN if (D(1,1) /= ZERO) THEN D(1,1) = ZERO IERR = IERR + 1 ENDIF ELSE if ( DPCHST(D(1,1),SLOPE(1)) < ZERO) THEN D(1,1) = ZERO IERR = IERR + 1 ELSE if ( ABS(D(1,1)) > THREE*ABS(SLOPE(1)) ) THEN D(1,1) = THREE*SLOPE(1) IERR = IERR + 1 end if ! ! TREAT END BOUNDARY CONDITION. ! 2000 CONTINUE if (IEND == 0) go to 5000 K = ABS(IEND) if (K == 1) THEN ! BOUNDARY VALUE PROVIDED. D(1,N) = VC(2) ELSE if (K == 2) THEN ! BOUNDARY SECOND DERIVATIVE PROVIDED. D(1,N) = HALF*( (THREE*SLOPE(N-1) - D(1,N-1)) + & HALF*VC(2)*H(N-1) ) ELSE if (K < 5) THEN ! USE K-POINT DERIVATIVE FORMULA. ! PICK UP LAST K POINTS. DO 2010 J = 1, K INDEX = N-K+J ! INDEX RUNS FROM N+1-K UP TO N. XTEMP(J) = X(INDEX) if (J < K) STEMP(J) = SLOPE(INDEX) 2010 CONTINUE ! ----------------------------- D(1,N) = DPCHDF (K, XTEMP, STEMP, IERF) ! ----------------------------- if (IERF /= 0) go to 5001 ELSE ! USE 'NOT A KNOT' CONDITION. D(1,N) = ( THREE*(H(N-1)*SLOPE(N-2) + H(N-2)*SLOPE(N-1)) & - TWO*(H(N-1)+H(N-2))*D(1,N-1) - H(N-1)*D(1,N-2) ) & / H(N-2) end if ! if (IEND > 0) go to 5000 ! ! CHECK D(1,N) FOR COMPATIBILITY WITH MONOTONICITY. ! if (SLOPE(N-1) == ZERO) THEN if (D(1,N) /= ZERO) THEN D(1,N) = ZERO IERR = IERR + 2 ENDIF ELSE if ( DPCHST(D(1,N),SLOPE(N-1)) < ZERO) THEN D(1,N) = ZERO IERR = IERR + 2 ELSE if ( ABS(D(1,N)) > THREE*ABS(SLOPE(N-1)) ) THEN D(1,N) = THREE*SLOPE(N-1) IERR = IERR + 2 end if ! ! NORMAL RETURN. ! 5000 CONTINUE return ! ! ERROR RETURN. ! 5001 CONTINUE ! ERROR RETURN FROM DPCHDF. ! *** THIS CASE SHOULD NEVER OCCUR *** IERR = -1 call XERMSG ('SLATEC', 'DPCHCE', 'ERROR RETURN FROM DPCHDF', & IERR, 1) return !------------- LAST LINE OF DPCHCE FOLLOWS ----------------------------- end subroutine DPCHCI (N, H, SLOPE, D, INCFD) ! !! DPCHCI sets interior derivatives for DPCHIC. ! !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHCI-S, DPCHCI-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHCI: DPCHIC Initial Derivative Setter. ! ! Called by DPCHIC to set derivatives needed to determine a monotone ! piecewise cubic Hermite interpolant to the data. ! ! Default boundary conditions are provided which are compatible ! with monotonicity. If the data are only piecewise monotonic, the ! interpolant will have an extremum at each point where monotonicity ! switches direction. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the D array. ! ! The resulting piecewise cubic Hermite function should be identical ! (within roundoff error) to that produced by DPCHIM. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N ! DOUBLE PRECISION H(N), SLOPE(N), D(INCFD,N) ! ! call DPCHCI (N, H, SLOPE, D, INCFD) ! ! Parameters: ! ! N -- (input) number of data points. ! If N=2, simply does linear interpolation. ! ! H -- (input) real*8 array of interval lengths. ! SLOPE -- (input) real*8 array of data slopes. ! If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: ! H(I) = X(I+1)-X(I), ! SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. ! ! D -- (output) real*8 array of derivative values at data points. ! If the data are monotonic, these values will determine a ! a monotone cubic Hermite function. ! The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! No other entries in D are changed. ! ! INCFD -- (input) increment between successive values in D. ! This argument is provided primarily for 2-D applications. ! ! ------- ! WARNING: This routine does no validity-checking of arguments. ! ------- ! ! Fortran intrinsics used: ABS, MAX, MIN. ! !***SEE ALSO DPCHIC !***ROUTINES CALLED DPCHST !***REVISION HISTORY (YYMMDD) ! 820218 DATE WRITTEN ! 820601 Modified end conditions to be continuous functions of ! data when monotonicity switches in next interval. ! 820602 1. Modified formulas so end conditions are less prone ! to over/underflow problems. ! 2. Minor modification to HSUM calculation. ! 820805 Converted to SLATEC library version. ! 870813 Minor cosmetic changes. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR section in prologue. (WRB) ! 930503 Improved purpose. (FNF) !***END PROLOGUE DPCHCI ! ! Programming notes: ! 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if ! either argument is zero, +1 if they are of the same sign, and ! -1 if they are of opposite sign. !**End ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD DOUBLE PRECISION H(*), SLOPE(*), D(INCFD,*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, NLESS1 DOUBLE PRECISION DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, HSUM, & HSUMT3, THREE, W1, W2, ZERO SAVE ZERO, THREE DOUBLE PRECISION DPCHST ! ! INITIALIZE. ! DATA ZERO /0.D0/, THREE/3.D0/ !***FIRST EXECUTABLE STATEMENT DPCHCI NLESS1 = N - 1 DEL1 = SLOPE(1) ! ! SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. ! if (NLESS1 > 1) go to 10 D(1,1) = DEL1 D(1,N) = DEL1 go to 5000 ! ! NORMAL CASE (N >= 3). ! 10 CONTINUE DEL2 = SLOPE(2) ! ! SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE ! SHAPE-PRESERVING. ! HSUM = H(1) + H(2) W1 = (H(1) + HSUM)/HSUM W2 = -H(1)/HSUM D(1,1) = W1*DEL1 + W2*DEL2 if ( DPCHST(D(1,1),DEL1) <= ZERO) THEN D(1,1) = ZERO ELSE if ( DPCHST(DEL1,DEL2) < ZERO) THEN ! NEED DO THIS CHECK ONLY if MONOTONICITY SWITCHES. DMAX = THREE*DEL1 if (ABS(D(1,1)) > ABS(DMAX)) D(1,1) = DMAX end if ! ! LOOP THROUGH INTERIOR POINTS. ! DO 50 I = 2, NLESS1 if (I == 2) go to 40 ! HSUM = H(I-1) + H(I) DEL1 = DEL2 DEL2 = SLOPE(I) 40 CONTINUE ! ! SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. ! D(1,I) = ZERO if ( DPCHST(DEL1,DEL2) <= ZERO) go to 50 ! ! USE BRODLIE MODIFICATION OF BUTLAND FORMULA. ! HSUMT3 = HSUM+HSUM+HSUM W1 = (HSUM + H(I-1))/HSUMT3 W2 = (HSUM + H(I) )/HSUMT3 DMAX = MAX( ABS(DEL1), ABS(DEL2) ) DMIN = MIN( ABS(DEL1), ABS(DEL2) ) DRAT1 = DEL1/DMAX DRAT2 = DEL2/DMAX D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) ! 50 CONTINUE ! ! SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE ! SHAPE-PRESERVING. ! W1 = -H(N-1)/HSUM W2 = (H(N-1) + HSUM)/HSUM D(1,N) = W1*DEL1 + W2*DEL2 if ( DPCHST(D(1,N),DEL2) <= ZERO) THEN D(1,N) = ZERO ELSE if ( DPCHST(DEL1,DEL2) < ZERO) THEN ! NEED DO THIS CHECK ONLY if MONOTONICITY SWITCHES. DMAX = THREE*DEL2 if (ABS(D(1,N)) > ABS(DMAX)) D(1,N) = DMAX end if ! ! NORMAL RETURN. ! 5000 CONTINUE return !------------- LAST LINE OF DPCHCI FOLLOWS ----------------------------- end subroutine DPCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) ! !! DPCHCM checks a cubic Hermite function for monotonicity. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3 !***TYPE DOUBLE PRECISION (PCHCM-S, DPCHCM-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, ! PCHIP, PIECEWISE CUBIC INTERPOLATION, UTILITY ROUTINE !***AUTHOR Fritsch, F. N., (LLNL) ! Computing & Mathematics Research Division ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! *Usage: ! ! PARAMETER (INCFD = ...) ! INTEGER N, ISMON(N), IERR ! DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) ! LOGICAL SKIP ! ! call DPCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) ! ! *Arguments: ! ! N:IN is the number of data points. (Error return if N < 2 .) ! ! X:IN is a real*8 array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F:IN is a real*8 array of function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! D:IN is a real*8 array of derivative values. D(1+(I-1)*INCFD) is ! is the value corresponding to X(I). ! ! INCFD:IN is the increment between successive values in F and D. ! (Error return if INCFD < 1 .) ! ! SKIP:INOUT is a logical variable which should be set to ! .TRUE. if the user wishes to skip checks for validity of ! preceding parameters, or to .FALSE. otherwise. ! This will save time in case these checks have already ! been performed. ! SKIP will be set to .TRUE. on normal return. ! ! ISMON:OUT is an integer array indicating on which intervals the ! PCH function defined by N, X, F, D is monotonic. ! For data interval [X(I),X(I+1)], ! ISMON(I) = -3 if function is probably decreasing; ! ISMON(I) = -1 if function is strictly decreasing; ! ISMON(I) = 0 if function is constant; ! ISMON(I) = 1 if function is strictly increasing; ! ISMON(I) = 2 if function is non-monotonic; ! ISMON(I) = 3 if function is probably increasing. ! If ABS(ISMON)=3, this means that the D values are near ! the boundary of the monotonicity region. A small ! increase produces non-monotonicity; decrease, strict ! monotonicity. ! The above applies to I=1(1)N-1. ISMON(N) indicates whether ! the entire function is monotonic on [X(1),X(N)]. ! ! IERR:OUT is an error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! (The ISMON-array has not been changed in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! ! *Description: ! ! DPCHCM: Piecewise Cubic Hermite -- Check Monotonicity. ! ! Checks the piecewise cubic Hermite function defined by N,X,F,D ! for monotonicity. ! ! To provide compatibility with DPCHIM and DPCHIC, includes an ! increment between successive values of the F- and D arrays. ! ! *Cautions: ! This provides the same capability as old DPCHMC, except that a ! new output value, -3, was added February 1989. (Formerly, -3 ! and +3 were lumped together in the single value 3.) Codes that ! flag nonmonotonicity by "IF (ISMON == 2)" need not be changed. ! Codes that check via "IF (ISMON >= 3)" should change the test to ! "IF (IABS(ISMON) >= 3)". Codes that declare monotonicity via ! "IF (ISMON <= 1)" should change to "IF (IABS(ISMON) <= 1)". ! !***REFERENCES F. N. Fritsch and R. E. Carlson, Monotone piecewise ! cubic interpolation, SIAM Journal on Numerical Ana- ! lysis 17, 2 (April 1980), pp. 238-246. !***ROUTINES CALLED DCHFCM, XERMSG !***REVISION HISTORY (YYMMDD) ! 820518 DATE WRITTEN ! 820804 Converted to SLATEC library version. ! 831201 Reversed order of subscripts of F and D, so that the ! routine will work properly when INCFD > 1 . (Bug!) ! 870707 Corrected XERROR calls for d.p. name(s). ! 890206 Corrected XERROR calls. ! 890209 Added possible ISMON value of -3 and modified code so ! that 1,3,-1 produces ISMON(N)=2, rather than 3. ! 890306 Added caution about changed output. ! 890407 Changed name from DPCHMC to DPCHCM, as requested at the ! March 1989 SLATEC CML meeting, and made a few other ! minor modifications necessitated by this change. ! 890407 Converted to new SLATEC format. ! 890407 Modified DESCRIPTION to LDOC format. ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920429 Revised format and order of references. (WRB,FNF) !***END PROLOGUE DPCHCM ! ! Fortran intrinsics used: ISIGN. ! Other routines used: CHFCM, XERMSG. ! ! ---------------------------------------------------------------------- ! ! Programming notes: ! ! An alternate organization would have separate loops for computing ! ISMON(i), i=1,...,NSEG, and for the computation of ISMON(N). The ! first loop can be readily parallelized, since the NSEG calls to ! CHFCM are independent. The second loop can be cut short if ! ISMON(N) is ever equal to 2, for it cannot be changed further. ! ! To produce a single precision version, simply: ! a. Change DPCHCM to PCHCM wherever it occurs, ! b. Change DCHFCM to CHFCM wherever it occurs, and ! c. Change the double precision declarations to real. ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, ISMON(N), IERR DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) LOGICAL SKIP ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, NSEG DOUBLE PRECISION DELTA INTEGER DCHFCM ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT DPCHCM if (SKIP) go to 5 ! if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE SKIP = .TRUE. ! ! FUNCTION DEFINITION IS OK -- GO ON. ! 5 CONTINUE NSEG = N - 1 DO 90 I = 1, NSEG DELTA = (F(1,I+1)-F(1,I))/(X(I+1)-X(I)) ! ------------------------------- ISMON(I) = DCHFCM (D(1,I), D(1,I+1), DELTA) ! ------------------------------- if (I == 1) THEN ISMON(N) = ISMON(1) ELSE ! Need to figure out cumulative monotonicity from following ! "multiplication table": ! ! + I S M O N (I) ! + -3 -1 0 1 3 2 ! +------------------------+ ! I -3 I -3 -3 -3 2 2 2 I ! S -1 I -3 -1 -1 2 2 2 I ! M 0 I -3 -1 0 1 3 2 I ! O 1 I 2 2 1 1 3 2 I ! N 3 I 2 2 3 3 3 2 I ! (N) 2 I 2 2 2 2 2 2 I ! +------------------------+ ! Note that the 2 row and column are out of order so as not ! to obscure the symmetry in the rest of the table. ! ! No change needed if equal or constant on this interval or ! already declared nonmonotonic. if ( (ISMON(I) /= ISMON(N)) .AND. (ISMON(I) /= 0) & .AND. (ISMON(N) /= 2) ) THEN if ( (ISMON(I) == 2) .OR. (ISMON(N) == 0) ) THEN ISMON(N) = ISMON(I) ELSE if (ISMON(I)*ISMON(N) < 0) THEN ! This interval has opposite sense from curve so far. ISMON(N) = 2 ELSE ! At this point, both are nonzero with same sign, and ! we have already eliminated case both +-1. ISMON(N) = ISIGN (3, ISMON(N)) ENDIF ENDIF ENDIF 90 CONTINUE ! ! NORMAL RETURN. ! IERR = 0 return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DPCHCM', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'DPCHCM', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'DPCHCM', & 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) return !------------- LAST LINE OF DPCHCM FOLLOWS ----------------------------- end subroutine DPCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) ! !! DPCHCS adjusts derivative values for DPCHIC. ! !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHCS-S, DPCHCS-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHCS: DPCHIC Monotonicity Switch Derivative Setter. ! ! Called by DPCHIC to adjust the values of D in the vicinity of a ! switch in direction of monotonicity, to produce a more "visually ! pleasing" curve than that given by DPCHIM . ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, IERR ! DOUBLE PRECISION SWITCH, H(N), SLOPE(N), D(INCFD,N) ! ! call DPCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) ! ! Parameters: ! ! SWITCH -- (input) indicates the amount of control desired over ! local excursions from data. ! ! N -- (input) number of data points. (assumes N > 2 .) ! ! H -- (input) real*8 array of interval lengths. ! SLOPE -- (input) real*8 array of data slopes. ! If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: ! H(I) = X(I+1)-X(I), ! SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. ! ! D -- (input) real*8 array of derivative values at the data points, ! as determined by DPCHCI. ! (output) derivatives in the vicinity of switches in direction ! of monotonicity may be adjusted to produce a more "visually ! pleasing" curve. ! The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! No other entries in D are changed. ! ! INCFD -- (input) increment between successive values in D. ! This argument is provided primarily for 2-D applications. ! ! IERR -- (output) error flag. should be zero. ! If negative, trouble in DPCHSW. (should never happen.) ! ! ------- ! WARNING: This routine does no validity-checking of arguments. ! ------- ! ! Fortran intrinsics used: ABS, MAX, MIN. ! !***SEE ALSO DPCHIC !***ROUTINES CALLED DPCHST, DPCHSW !***REVISION HISTORY (YYMMDD) ! 820218 DATE WRITTEN ! 820617 Redesigned to (1) fix problem with lack of continuity ! approaching a flat-topped peak (2) be cleaner and ! easier to verify. ! Eliminated subroutines PCHSA and PCHSX in the process. ! 820622 1. Limited fact to not exceed one, so computed D is a ! convex combination of DPCHCI value and DPCHSD value. ! 2. Changed fudge from 1 to 4 (based on experiments). ! 820623 Moved PCHSD to an inline function (eliminating MSWTYP). ! 820805 Converted to SLATEC library version. ! 870707 Corrected conversion to double precision. ! 870813 Minor cosmetic changes. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Modified spacing in computation of DFLOC. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR section in prologue. (WRB) ! 930503 Improved purpose. (FNF) !***END PROLOGUE DPCHCS ! ! Programming notes: ! 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if ! either argument is zero, +1 if they are of the same sign, and ! -1 if they are of opposite sign. !**End ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, IERR DOUBLE PRECISION SWITCH, H(*), SLOPE(*), D(INCFD,*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, INDX, K, NLESS1 DOUBLE PRECISION DEL(3), DEXT, DFLOC, DFMX, FACT, FUDGE, ONE, & SLMAX, WTAVE(2), ZERO SAVE ZERO, ONE, FUDGE DOUBLE PRECISION DPCHST ! ! DEFINE INLINE FUNCTION FOR WEIGHTED AVERAGE OF SLOPES. ! DOUBLE PRECISION DPCHSD, S1, S2, H1, H2 DPCHSD(S1,S2,H1,H2) = (H2/(H1+H2))*S1 + (H1/(H1+H2))*S2 ! ! INITIALIZE. ! DATA ZERO /0.D0/, ONE/1.D0/ DATA FUDGE /4.D0/ !***FIRST EXECUTABLE STATEMENT DPCHCS IERR = 0 NLESS1 = N - 1 ! ! LOOP OVER SEGMENTS. ! DO 900 I = 2, NLESS1 if ( DPCHST(SLOPE(I-1),SLOPE(I)) ) 100, 300, 900 ! -------------------------- ! 100 CONTINUE ! !....... SLOPE SWITCHES MONOTONICITY AT I-TH POINT ..................... ! ! DO NOT CHANGE D if 'UP-DOWN-UP'. if (I > 2) THEN if ( DPCHST(SLOPE(I-2),SLOPE(I)) > ZERO) go to 900 ! -------------------------- ENDIF if (I < NLESS1) THEN if ( DPCHST(SLOPE(I+1),SLOPE(I-1)) > ZERO) go to 900 ! ---------------------------- ENDIF ! ! ....... COMPUTE PROVISIONAL VALUE FOR D(1,I). ! DEXT = DPCHSD (SLOPE(I-1), SLOPE(I), H(I-1), H(I)) ! ! ....... DETERMINE WHICH INTERVAL CONTAINS THE EXTREMUM. ! if ( DPCHST(DEXT, SLOPE(I-1)) ) 200, 900, 250 ! ----------------------- ! 200 CONTINUE ! DEXT AND SLOPE(I-1) HAVE OPPOSITE SIGNS -- ! EXTREMUM IS IN (X(I-1),X(I)). K = I-1 ! SET UP TO COMPUTE NEW VALUES FOR D(1,I-1) AND D(1,I). WTAVE(2) = DEXT if (K > 1) & WTAVE(1) = DPCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) go to 400 ! 250 CONTINUE ! DEXT AND SLOPE(I) HAVE OPPOSITE SIGNS -- ! EXTREMUM IS IN (X(I),X(I+1)). K = I ! SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). WTAVE(1) = DEXT if (K < NLESS1) & WTAVE(2) = DPCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) go to 400 ! 300 CONTINUE ! !....... AT LEAST ONE OF SLOPE(I-1) AND SLOPE(I) IS ZERO -- ! CHECK FOR FLAT-TOPPED PEAK ....................... ! if (I == NLESS1) go to 900 if ( DPCHST(SLOPE(I-1), SLOPE(I+1)) >= ZERO) go to 900 ! ----------------------------- ! ! WE HAVE FLAT-TOPPED PEAK ON (X(I),X(I+1)). K = I ! SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). WTAVE(1) = DPCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) WTAVE(2) = DPCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) ! 400 CONTINUE ! !....... AT THIS POINT WE HAVE DETERMINED THAT THERE WILL BE AN EXTREMUM ! ON (X(K),X(K+1)), WHERE K=I OR I-1, AND HAVE SET ARRAY WTAVE-- ! WTAVE(1) IS A WEIGHTED AVERAGE OF SLOPE(K-1) AND SLOPE(K), ! if K > 1 ! WTAVE(2) IS A WEIGHTED AVERAGE OF SLOPE(K) AND SLOPE(K+1), ! if K < N-1 ! SLMAX = ABS(SLOPE(K)) if (K > 1) SLMAX = MAX( SLMAX, ABS(SLOPE(K-1)) ) if (K < NLESS1) SLMAX = MAX( SLMAX, ABS(SLOPE(K+1)) ) ! if (K > 1) DEL(1) = SLOPE(K-1) / SLMAX DEL(2) = SLOPE(K) / SLMAX if (K < NLESS1) DEL(3) = SLOPE(K+1) / SLMAX ! if ((K > 1) .AND. (K < NLESS1)) THEN ! NORMAL CASE -- EXTREMUM IS NOT IN A BOUNDARY INTERVAL. FACT = FUDGE* ABS(DEL(3)*(DEL(1)-DEL(2))*(WTAVE(2)/SLMAX)) D(1,K) = D(1,K) + MIN(FACT,ONE)*(WTAVE(1) - D(1,K)) FACT = FUDGE* ABS(DEL(1)*(DEL(3)-DEL(2))*(WTAVE(1)/SLMAX)) D(1,K+1) = D(1,K+1) + MIN(FACT,ONE)*(WTAVE(2) - D(1,K+1)) ELSE ! SPECIAL CASE K=1 (WHICH CAN OCCUR ONLY if I=2) OR ! K=NLESS1 (WHICH CAN OCCUR ONLY if I=NLESS1). FACT = FUDGE* ABS(DEL(2)) D(1,I) = MIN(FACT,ONE) * WTAVE(I-K+1) ! NOTE THAT I-K+1 = 1 if K=I (=NLESS1), ! I-K+1 = 2 if K=I-1(=1). ENDIF ! ! !....... ADJUST if NECESSARY TO LIMIT EXCURSIONS FROM DATA. ! if (SWITCH <= ZERO) go to 900 ! DFLOC = H(K)*ABS(SLOPE(K)) if (K > 1) DFLOC = MAX( DFLOC, H(K-1)*ABS(SLOPE(K-1)) ) if (K < NLESS1) DFLOC = MAX( DFLOC, H(K+1)*ABS(SLOPE(K+1)) ) DFMX = SWITCH*DFLOC INDX = I-K+1 ! INDX = 1 if K=I, 2 IF K=I-1. ! --------------------------------------------------------------- call DPCHSW(DFMX, INDX, D(1,K), D(1,K+1), H(K), SLOPE(K), IERR) ! --------------------------------------------------------------- if (IERR /= 0) return ! !....... END OF SEGMENT LOOP. ! 900 CONTINUE ! return !------------- LAST LINE OF DPCHCS FOLLOWS ----------------------------- end DOUBLE PRECISION FUNCTION DPCHDF (K, X, S, IERR) ! !! DPCHDF computes divided differences for DPCHCE and DPCHSP. ! !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHDF-S, DPCHDF-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHDF: DPCHIP Finite Difference Formula ! ! Uses a divided difference formulation to compute a K-point approx- ! imation to the derivative at X(K) based on the data in X and S. ! ! Called by DPCHCE and DPCHSP to compute 3- and 4-point boundary ! derivative approximations. ! ! ---------------------------------------------------------------------- ! ! On input: ! K is the order of the desired derivative approximation. ! K must be at least 3 (error return if not). ! X contains the K values of the independent variable. ! X need not be ordered, but the values **MUST** be ! distinct. (Not checked here.) ! S contains the associated slope values: ! S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1. ! (Note that S need only be of length K-1.) ! ! On return: ! S will be destroyed. ! IERR will be set to -1 if K < 2 . ! DPCHDF will be set to the desired derivative approximation if ! IERR=0 or to zero if IERR=-1. ! ! ---------------------------------------------------------------------- ! !***SEE ALSO DPCHCE, DPCHSP !***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- ! Verlag, New York, 1978, pp. 10-16. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 820503 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 870707 Corrected XERROR calls for d.p. name(s). ! 870813 Minor cosmetic changes. ! 890206 Corrected XERROR calls. ! 890411 Added SAVE statements (Vers. 3.2). ! 890411 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) ! 920429 Revised format and order of references. (WRB,FNF) ! 930503 Improved purpose. (FNF) !***END PROLOGUE DPCHDF ! !**End ! ! DECLARE ARGUMENTS. ! INTEGER K, IERR DOUBLE PRECISION X(K), S(K) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, J DOUBLE PRECISION VALUE, ZERO SAVE ZERO DATA ZERO /0.D0/ ! ! CHECK FOR LEGAL VALUE OF K. ! !***FIRST EXECUTABLE STATEMENT DPCHDF if (K < 3) go to 5001 ! ! COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL. ! DO 10 J = 2, K-1 DO 9 I = 1, K-J S(I) = (S(I+1)-S(I))/(X(I+J)-X(I)) 9 CONTINUE 10 CONTINUE ! ! EVALUATE DERIVATIVE AT X(K). ! VALUE = S(1) DO 20 I = 2, K-1 VALUE = S(I) + VALUE*(X(K)-X(I)) 20 CONTINUE ! ! NORMAL RETURN. ! IERR = 0 DPCHDF = VALUE return ! ! ERROR RETURN. ! 5001 CONTINUE ! K < 3 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DPCHDF', 'K LESS THAN THREE', IERR, 1) DPCHDF = ZERO return !------------- LAST LINE OF DPCHDF FOLLOWS ----------------------------- end subroutine DPCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) ! !! DPCHFD evaluates a piecewise cubic Hermite function and its first ... ! derivative at an array of points. May be used by itself ! for Hermite interpolation, or as an evaluator for DPCHIM ! or DPCHIC. If only function values are required, use ! DPCHFE instead. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3, H1 !***TYPE DOUBLE PRECISION (PCHFD-S, DPCHFD-D) !***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, ! HERMITE INTERPOLATION, PCHIP, PIECEWISE CUBIC EVALUATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! DPCHFD: Piecewise Cubic Hermite Function and Derivative ! evaluator ! ! Evaluates the cubic Hermite function defined by N, X, F, D, to- ! gether with its first derivative, at the points XE(J), J=1(1)NE. ! ! If only function values are required, use DPCHFE, instead. ! ! To provide compatibility with DPCHIM and DPCHIC, includes an ! increment between successive values of the F- and D arrays. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, NE, IERR ! DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE), ! DE(NE) ! LOGICAL SKIP ! ! call DPCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) ! ! Parameters: ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real*8 array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) ! is the value corresponding to X(I). ! ! INCFD -- (input) increment between successive values in F and D. ! (Error return if INCFD < 1 .) ! ! SKIP -- (input/output) logical variable which should be set to ! .TRUE. if the user wishes to skip checks for validity of ! preceding parameters, or to .FALSE. otherwise. ! This will save time in case these checks have already ! been performed (say, in DPCHIM or DPCHIC). ! SKIP will be set to .TRUE. on normal return. ! ! NE -- (input) number of evaluation points. (Error return if ! NE < 1 .) ! ! XE -- (input) real*8 array of points at which the functions are to ! be evaluated. ! ! ! NOTES: ! 1. The evaluation will be most efficient if the elements ! of XE are increasing relative to X; ! that is, XE(J) >= X(I) ! implies XE(K) >= X(I), all K >= J . ! 2. If any of the XE are outside the interval [X(1),X(N)], ! values are extrapolated from the nearest extreme cubic, ! and a warning error is returned. ! ! FE -- (output) real*8 array of values of the cubic Hermite ! function defined by N, X, F, D at the points XE. ! ! DE -- (output) real*8 array of values of the first derivative of ! the same function at the points XE. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning error: ! IERR > 0 means that extrapolation was performed at ! IERR points. ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! IERR = -4 if NE < 1 . ! (Output arrays have not been changed in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! IERR = -5 if an error has occurred in the lower-level ! routine DCHFDV. NB: this should never happen. ! Notify the author **IMMEDIATELY** if it does. ! !***REFERENCES (NONE) !***ROUTINES CALLED DCHFDV, XERMSG !***REVISION HISTORY (YYMMDD) ! 811020 DATE WRITTEN ! 820803 Minor cosmetic changes for release 1. ! 870707 Corrected XERROR calls for d.p. name(s). ! 890206 Corrected XERROR calls. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DPCHFD ! Programming notes: ! ! 1. To produce a single precision version, simply: ! a. Change DPCHFD to PCHFD, and DCHFDV to CHFDV, wherever they ! occur, ! b. Change the double precision declaration to real, ! ! 2. Most of the coding between the call to DCHFDV and the end of ! the IR-loop could be eliminated if it were permissible to ! assume that XE is ordered relative to X. ! ! 3. DCHFDV does not assume that X1 is less than X2. thus, it would ! be possible to write a version of DPCHFD that assumes a strict- ! ly decreasing X-array by simply running the IR-loop backwards ! (and reversing the order of appropriate tests). ! ! 4. The present code has a minor bug, which I have decided is not ! worth the effort that would be required to fix it. ! If XE contains points in [X(N-1),X(N)], followed by points < ! X(N-1), followed by points > X(N), the extrapolation points ! will be counted (at least) twice in the total returned in IERR. ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, NE, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*), & DE(*) LOGICAL SKIP ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT DPCHFD if (SKIP) go to 5 ! if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! ! FUNCTION DEFINITION IS OK, GO ON. ! 5 CONTINUE if ( NE < 1 ) go to 5004 IERR = 0 SKIP = .TRUE. ! ! LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) ! ( INTERVAL IS X(IL) <= X < X(IR) . ) JFIRST = 1 IR = 2 10 CONTINUE ! ! SKIP OUT OF LOOP if HAVE PROCESSED ALL EVALUATION POINTS. ! if (JFIRST > NE) go to 5000 ! ! LOCATE ALL POINTS IN INTERVAL. ! DO 20 J = JFIRST, NE if (XE(J) >= X(IR)) go to 30 20 CONTINUE J = NE + 1 go to 40 ! ! HAVE LOCATED FIRST POINT BEYOND INTERVAL. ! 30 CONTINUE if (IR == N) J = NE + 1 ! 40 CONTINUE NJ = J - JFIRST ! ! SKIP EVALUATION if NO POINTS IN INTERVAL. ! if (NJ == 0) go to 50 ! ! EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . ! ! ---------------------------------------------------------------- call DCHFDV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR) & ,NJ, XE(JFIRST), FE(JFIRST), DE(JFIRST), NEXT, IERC) ! ---------------------------------------------------------------- if (IERC < 0) go to 5005 ! if (NEXT(2) == 0) go to 42 ! if (NEXT(2) > 0) THEN ! IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE ! RIGHT OF X(IR). ! if (IR < N) go to 41 ! if (IR == N) THEN ! THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(2) go to 42 41 CONTINUE ! ELSE ! WE SHOULD NEVER HAVE GOTTEN HERE. go to 5005 ! ENDIF ! ENDIF 42 CONTINUE ! if (NEXT(1) == 0) go to 49 ! if (NEXT(1) > 0) THEN ! IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE ! LEFT OF X(IR-1). ! if (IR > 2) go to 43 ! if (IR == 2) THEN ! THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(1) go to 49 43 CONTINUE ! ELSE ! XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST ! EVALUATION INTERVAL. ! ! FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). DO 44 I = JFIRST, J-1 if (XE(I) < X(IR-1)) go to 45 44 CONTINUE ! NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR ! IN DCHFDV. go to 5005 ! 45 CONTINUE ! RESET J. (THIS WILL BE THE NEW JFIRST.) J = I ! ! NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. DO 46 I = 1, IR-1 if (XE(J) < X(I)) go to 47 46 CONTINUE ! NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J) < X(IR-1). ! 47 CONTINUE ! AT THIS POINT, EITHER XE(J) < X(1) ! OR X(I-1) <= XE(J) < X(I) . ! RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE ! CYCLING. IR = MAX(1, I-1) ! ENDIF ! ENDIF 49 CONTINUE ! JFIRST = J ! ! END OF IR-LOOP. ! 50 CONTINUE IR = IR + 1 if (IR <= N) go to 10 ! ! NORMAL RETURN. ! 5000 CONTINUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DPCHFD', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'DPCHFD', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'DPCHFD', & 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) return ! 5004 CONTINUE ! NE < 1 RETURN. IERR = -4 call XERMSG ('SLATEC', 'DPCHFD', & 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) return ! 5005 CONTINUE ! ERROR RETURN FROM DCHFDV. ! *** THIS CASE SHOULD NEVER OCCUR *** IERR = -5 call XERMSG ('SLATEC', 'DPCHFD', & 'ERROR RETURN FROM DCHFDV -- FATAL', IERR, 2) return !------------- LAST LINE OF DPCHFD FOLLOWS ----------------------------- end subroutine DPCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) ! !! DPCHFE evaluate a piecewise cubic Hermite function at an array of points. ! ! May be used by itself for Hermite interpolation, ! or as an evaluator for DPCHIM or DPCHIC. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3 !***TYPE DOUBLE PRECISION (PCHFE-S, DPCHFE-D) !***KEYWORDS CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP, ! PIECEWISE CUBIC EVALUATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! DPCHFE: Piecewise Cubic Hermite Function Evaluator ! ! Evaluates the cubic Hermite function defined by N, X, F, D at ! the points XE(J), J=1(1)NE. ! ! To provide compatibility with DPCHIM and DPCHIC, includes an ! increment between successive values of the F- and D arrays. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, NE, IERR ! DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE) ! LOGICAL SKIP ! ! call DPCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) ! ! Parameters: ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real*8 array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) ! is the value corresponding to X(I). ! ! INCFD -- (input) increment between successive values in F and D. ! (Error return if INCFD < 1 .) ! ! SKIP -- (input/output) logical variable which should be set to ! .TRUE. if the user wishes to skip checks for validity of ! preceding parameters, or to .FALSE. otherwise. ! This will save time in case these checks have already ! been performed (say, in DPCHIM or DPCHIC). ! SKIP will be set to .TRUE. on normal return. ! ! NE -- (input) number of evaluation points. (Error return if ! NE < 1 .) ! ! XE -- (input) real*8 array of points at which the function is to ! be evaluated. ! ! NOTES: ! 1. The evaluation will be most efficient if the elements ! of XE are increasing relative to X; ! that is, XE(J) >= X(I) ! implies XE(K) >= X(I), all K >= J . ! 2. If any of the XE are outside the interval [X(1),X(N)], ! values are extrapolated from the nearest extreme cubic, ! and a warning error is returned. ! ! FE -- (output) real*8 array of values of the cubic Hermite ! function defined by N, X, F, D at the points XE. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning error: ! IERR > 0 means that extrapolation was performed at ! IERR points. ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! IERR = -4 if NE < 1 . ! (The FE-array has not been changed in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! !***REFERENCES (NONE) !***ROUTINES CALLED DCHFEV, XERMSG !***REVISION HISTORY (YYMMDD) ! 811020 DATE WRITTEN ! 820803 Minor cosmetic changes for release 1. ! 870707 Corrected XERROR calls for d.p. name(s). ! 890206 Corrected XERROR calls. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DPCHFE ! Programming notes: ! ! 1. To produce a single precision version, simply: ! a. Change DPCHFE to PCHFE, and DCHFEV to CHFEV, wherever they ! occur, ! b. Change the double precision declaration to real, ! ! 2. Most of the coding between the call to DCHFEV and the end of ! the IR-loop could be eliminated if it were permissible to ! assume that XE is ordered relative to X. ! ! 3. DCHFEV does not assume that X1 is less than X2. thus, it would ! be possible to write a version of DPCHFE that assumes a ! decreasing X-array by simply running the IR-loop backwards ! (and reversing the order of appropriate tests). ! ! 4. The present code has a minor bug, which I have decided is not ! worth the effort that would be required to fix it. ! If XE contains points in [X(N-1),X(N)], followed by points < ! X(N-1), followed by points > X(N), the extrapolation points ! will be counted (at least) twice in the total returned in IERR. ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, NE, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*) LOGICAL SKIP ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT DPCHFE if (SKIP) go to 5 ! if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! ! FUNCTION DEFINITION IS OK, GO ON. ! 5 CONTINUE if ( NE < 1 ) go to 5004 IERR = 0 SKIP = .TRUE. ! ! LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) ! ( INTERVAL IS X(IL) <= X < X(IR) . ) JFIRST = 1 IR = 2 10 CONTINUE ! ! SKIP OUT OF LOOP if HAVE PROCESSED ALL EVALUATION POINTS. ! if (JFIRST > NE) go to 5000 ! ! LOCATE ALL POINTS IN INTERVAL. ! DO 20 J = JFIRST, NE if (XE(J) >= X(IR)) go to 30 20 CONTINUE J = NE + 1 go to 40 ! ! HAVE LOCATED FIRST POINT BEYOND INTERVAL. ! 30 CONTINUE if (IR == N) J = NE + 1 ! 40 CONTINUE NJ = J - JFIRST ! ! SKIP EVALUATION if NO POINTS IN INTERVAL. ! if (NJ == 0) go to 50 ! ! EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . ! ! ---------------------------------------------------------------- call DCHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR) & ,NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC) ! ---------------------------------------------------------------- if (IERC < 0) go to 5005 ! if (NEXT(2) == 0) go to 42 ! if (NEXT(2) > 0) THEN ! IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE ! RIGHT OF X(IR). ! if (IR < N) go to 41 ! if (IR == N) THEN ! THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(2) go to 42 41 CONTINUE ! ELSE ! WE SHOULD NEVER HAVE GOTTEN HERE. go to 5005 ! ENDIF ! ENDIF 42 CONTINUE ! if (NEXT(1) == 0) go to 49 ! if (NEXT(1) > 0) THEN ! IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE ! LEFT OF X(IR-1). ! if (IR > 2) go to 43 ! if (IR == 2) THEN ! THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(1) go to 49 43 CONTINUE ! ELSE ! XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST ! EVALUATION INTERVAL. ! ! FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). DO 44 I = JFIRST, J-1 if (XE(I) < X(IR-1)) go to 45 44 CONTINUE ! NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR ! IN DCHFEV. go to 5005 ! 45 CONTINUE ! RESET J. (THIS WILL BE THE NEW JFIRST.) J = I ! ! NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. DO 46 I = 1, IR-1 if (XE(J) < X(I)) go to 47 46 CONTINUE ! NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J) < X(IR-1). ! 47 CONTINUE ! AT THIS POINT, EITHER XE(J) < X(1) ! OR X(I-1) <= XE(J) < X(I) . ! RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE ! CYCLING. IR = MAX(1, I-1) ! ENDIF ! ENDIF 49 CONTINUE ! JFIRST = J ! ! END OF IR-LOOP. ! 50 CONTINUE IR = IR + 1 if (IR <= N) go to 10 ! ! NORMAL RETURN. ! 5000 CONTINUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DPCHFE', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'DPCHFE', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'DPCHFE', & 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) return ! 5004 CONTINUE ! NE < 1 RETURN. IERR = -4 call XERMSG ('SLATEC', 'DPCHFE', & 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) return ! 5005 CONTINUE ! ERROR RETURN FROM DCHFEV. ! *** THIS CASE SHOULD NEVER OCCUR *** IERR = -5 call XERMSG ('SLATEC', 'DPCHFE', & 'ERROR RETURN FROM DCHFEV -- FATAL', IERR, 2) return !------------- LAST LINE OF DPCHFE FOLLOWS ----------------------------- end DOUBLE PRECISION FUNCTION DPCHIA (N, X, F, D, INCFD, SKIP, A, B, & IERR) ! !! DPCHIA evaluates the definite integral of a piecewise cubic Hermite ... ! function over an arbitrary interval. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3, H2A1B2 !***TYPE DOUBLE PRECISION (PCHIA-S, DPCHIA-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, ! QUADRATURE !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! DPCHIA: Piecewise Cubic Hermite Integrator, Arbitrary limits ! ! Evaluates the definite integral of the cubic Hermite function ! defined by N, X, F, D over the interval [A, B]. ! ! To provide compatibility with DPCHIM and DPCHIC, includes an ! increment between successive values of the F- and D arrays. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, IERR ! DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N), A, B ! DOUBLE PRECISION VALUE, DPCHIA ! LOGICAL SKIP ! ! VALUE = DPCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR) ! ! Parameters: ! ! VALUE -- (output) value of the requested integral. ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real*8 array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) ! is the value corresponding to X(I). ! ! INCFD -- (input) increment between successive values in F and D. ! (Error return if INCFD < 1 .) ! ! SKIP -- (input/output) logical variable which should be set to ! .TRUE. if the user wishes to skip checks for validity of ! preceding parameters, or to .FALSE. otherwise. ! This will save time in case these checks have already ! been performed (say, in DPCHIM or DPCHIC). ! SKIP will be set to .TRUE. on return with IERR >= 0 . ! ! A,B -- (input) the limits of integration. ! NOTE: There is no requirement that [A,B] be contained in ! [X(1),X(N)]. However, the resulting integral value ! will be highly suspect, if not. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning errors: ! IERR = 1 if A is outside the interval [X(1),X(N)]. ! IERR = 2 if B is outside the interval [X(1),X(N)]. ! IERR = 3 if both of the above are true. (Note that this ! means that either [A,B] contains data interval ! or the intervals do not intersect at all.) ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! (VALUE will be zero in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! IERR = -4 in case of an error return from DPCHID (which ! should never occur). ! !***REFERENCES (NONE) !***ROUTINES CALLED DCHFIE, DPCHID, XERMSG !***REVISION HISTORY (YYMMDD) ! 820730 DATE WRITTEN ! 820804 Converted to SLATEC library version. ! 870707 Corrected XERROR calls for d.p. name(s). ! 870707 Corrected conversion to double precision. ! 870813 Minor cosmetic changes. ! 890206 Corrected XERROR calls. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 930503 Corrected to set VALUE=0 when IERR.lt.0. (FNF) ! 930504 Changed DCHFIV to DCHFIE. (FNF) !***END PROLOGUE DPCHIA ! ! Programming notes: ! 1. The error flag from DPCHID is tested, because a logic flaw ! could conceivably result in IERD=-4, which should be reported. !**End ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), A, B LOGICAL SKIP ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, IA, IB, IERD, IL, IR DOUBLE PRECISION VALUE, XA, XB, ZERO SAVE ZERO DOUBLE PRECISION DCHFIE, DPCHID ! ! INITIALIZE. ! DATA ZERO /0.D0/ !***FIRST EXECUTABLE STATEMENT DPCHIA VALUE = ZERO ! ! VALIDITY-CHECK ARGUMENTS. ! if (SKIP) go to 5 ! if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! ! FUNCTION DEFINITION IS OK, GO ON. ! 5 CONTINUE SKIP = .TRUE. IERR = 0 if ( (A < X(1)) .OR. (A > X(N)) ) IERR = IERR + 1 if ( (B < X(1)) .OR. (B > X(N)) ) IERR = IERR + 2 ! ! COMPUTE INTEGRAL VALUE. ! if (A /= B) THEN XA = MIN (A, B) XB = MAX (A, B) if (XB <= X(2)) THEN ! INTERVAL IS TO LEFT OF X(2), SO USE FIRST CUBIC. ! --------------------------------------- VALUE = DCHFIE (X(1),X(2), F(1,1),F(1,2), & D(1,1),D(1,2), A, B) ! --------------------------------------- ELSE if (XA >= X(N-1)) THEN ! INTERVAL IS TO RIGHT OF X(N-1), SO USE LAST CUBIC. ! ------------------------------------------ VALUE = DCHFIE(X(N-1),X(N), F(1,N-1),F(1,N), & D(1,N-1),D(1,N), A, B) ! ------------------------------------------ ELSE ! 'NORMAL' CASE -- XA < XB, XA < X(N-1), XB > X(2). ! ......LOCATE IA AND IB SUCH THAT ! X(IA-1) < XA <= X(IA) <= X(IB) <= XB <= X(IB+1) IA = 1 DO 10 I = 1, N-1 if (XA > X(I)) IA = I + 1 10 CONTINUE ! IA = 1 IMPLIES XA < X(1) . OTHERWISE, ! IA IS LARGEST INDEX SUCH THAT X(IA-1) < XA,. ! IB = N DO 20 I = N, IA, -1 if (XB < X(I)) IB = I - 1 20 CONTINUE ! IB = N IMPLIES XB > X(N) . OTHERWISE, ! IB IS SMALLEST INDEX SUCH THAT XB < X(IB+1) . ! ! ......COMPUTE THE INTEGRAL. if (IB < IA) THEN ! THIS MEANS IB = IA-1 AND ! (A,B) IS A SUBSET OF (X(IB),X(IA)). ! ------------------------------------------- VALUE = DCHFIE (X(IB),X(IA), F(1,IB),F(1,IA), & D(1,IB),D(1,IA), A, B) ! ------------------------------------------- ELSE ! ! FIRST COMPUTE INTEGRAL OVER (X(IA),X(IB)). ! (Case (IB == IA) is taken care of by initialization ! of VALUE to ZERO.) if (IB > IA) THEN ! --------------------------------------------- VALUE = DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERD) ! --------------------------------------------- if (IERD < 0) go to 5004 ENDIF ! ! THEN ADD ON INTEGRAL OVER (XA,X(IA)). if (XA < X(IA)) THEN IL = MAX(1, IA-1) IR = IL + 1 ! ------------------------------------- VALUE = VALUE + DCHFIE (X(IL),X(IR), F(1,IL),F(1,IR), & D(1,IL),D(1,IR), XA, X(IA)) ! ------------------------------------- ENDIF ! ! THEN ADD ON INTEGRAL OVER (X(IB),XB). if (XB > X(IB)) THEN IR = MIN (IB+1, N) IL = IR - 1 ! ------------------------------------- VALUE = VALUE + DCHFIE (X(IL),X(IR), F(1,IL),F(1,IR), & D(1,IL),D(1,IR), X(IB), XB) ! ------------------------------------- ENDIF ! ! FINALLY, ADJUST SIGN if NECESSARY. if (A > B) VALUE = -VALUE ENDIF ENDIF end if ! ! NORMAL RETURN. ! 5000 CONTINUE DPCHIA = VALUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DPCHIA', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) go to 5000 ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'DPCHIA', 'INCREMENT LESS THAN ONE', IERR, & 1) go to 5000 ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'DPCHIA', & 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) go to 5000 ! 5004 CONTINUE ! TROUBLE IN DPCHID. (SHOULD NEVER OCCUR.) IERR = -4 call XERMSG ('SLATEC', 'DPCHIA', 'TROUBLE IN DPCHID', IERR, 1) go to 5000 !------------- LAST LINE OF DPCHIA FOLLOWS ----------------------------- end subroutine DPCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, & IERR) ! !! DPCHIC sets derivatives needed to determine a piecewise monotone ... ! piecewise cubic Hermite interpolant to given data. ! User control is available over boundary conditions and/or ! treatment of points where monotonicity switches direction. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E1A !***TYPE DOUBLE PRECISION (PCHIC-S, DPCHIC-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, ! PCHIP, PIECEWISE CUBIC INTERPOLATION, ! SHAPE-PRESERVING INTERPOLATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! DPCHIC: Piecewise Cubic Hermite Interpolation Coefficients. ! ! Sets derivatives needed to determine a piecewise monotone piece- ! wise cubic interpolant to the data given in X and F satisfying the ! boundary conditions specified by IC and VC. ! ! The treatment of points where monotonicity switches direction is ! controlled by argument SWITCH. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the F- and D arrays. ! ! The resulting piecewise cubic Hermite function may be evaluated ! by DPCHFE or DPCHFD. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER IC(2), N, NWK, IERR ! DOUBLE PRECISION VC(2), SWITCH, X(N), F(INCFD,N), D(INCFD,N), ! WK(NWK) ! ! call DPCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, IERR) ! ! Parameters: ! ! IC -- (input) integer array of length 2 specifying desired ! boundary conditions: ! IC(1) = IBEG, desired condition at beginning of data. ! IC(2) = IEND, desired condition at end of data. ! ! IBEG = 0 for the default boundary condition (the same as ! used by DPCHIM). ! If IBEG /= 0, then its sign indicates whether the boundary ! derivative is to be adjusted, if necessary, to be ! compatible with monotonicity: ! IBEG > 0 if no adjustment is to be performed. ! IBEG < 0 if the derivative is to be adjusted for ! monotonicity. ! ! Allowable values for the magnitude of IBEG are: ! IBEG = 1 if first derivative at X(1) is given in VC(1). ! IBEG = 2 if second derivative at X(1) is given in VC(1). ! IBEG = 3 to use the 3-point difference formula for D(1). ! (Reverts to the default b.c. if N < 3 .) ! IBEG = 4 to use the 4-point difference formula for D(1). ! (Reverts to the default b.c. if N < 4 .) ! IBEG = 5 to set D(1) so that the second derivative is con- ! tinuous at X(2). (Reverts to the default b.c. if N < 4.) ! This option is somewhat analogous to the "not a knot" ! boundary condition provided by DPCHSP. ! ! NOTES (IBEG): ! 1. An error return is taken if ABS(IBEG) > 5 . ! 2. Only in case IBEG <= 0 is it guaranteed that the ! interpolant will be monotonic in the first interval. ! If the returned value of D(1) lies between zero and ! 3*SLOPE(1), the interpolant will be monotonic. This ! is **NOT** checked if IBEG > 0 . ! 3. If IBEG < 0 and D(1) had to be changed to achieve mono- ! tonicity, a warning error is returned. ! ! IEND may take on the same values as IBEG, but applied to ! derivative at X(N). In case IEND = 1 or 2, the value is ! given in VC(2). ! ! NOTES (IEND): ! 1. An error return is taken if ABS(IEND) > 5 . ! 2. Only in case IEND <= 0 is it guaranteed that the ! interpolant will be monotonic in the last interval. ! If the returned value of D(1+(N-1)*INCFD) lies between ! zero and 3*SLOPE(N-1), the interpolant will be monotonic. ! This is **NOT** checked if IEND > 0 . ! 3. If IEND < 0 and D(1+(N-1)*INCFD) had to be changed to ! achieve monotonicity, a warning error is returned. ! ! VC -- (input) real*8 array of length 2 specifying desired boundary ! values, as indicated above. ! VC(1) need be set only if IC(1) = 1 or 2 . ! VC(2) need be set only if IC(2) = 1 or 2 . ! ! SWITCH -- (input) indicates desired treatment of points where ! direction of monotonicity switches: ! Set SWITCH to zero if interpolant is required to be mono- ! tonic in each interval, regardless of monotonicity of data. ! NOTES: ! 1. This will cause D to be set to zero at all switch ! points, thus forcing extrema there. ! 2. The result of using this option with the default boun- ! dary conditions will be identical to using DPCHIM, but ! will generally cost more compute time. ! This option is provided only to facilitate comparison ! of different switch and/or boundary conditions. ! Set SWITCH nonzero to use a formula based on the 3-point ! difference formula in the vicinity of switch points. ! If SWITCH is positive, the interpolant on each interval ! containing an extremum is controlled to not deviate from ! the data by more than SWITCH*DFLOC, where DFLOC is the ! maximum of the change of F on this interval and its two ! immediate neighbors. ! If SWITCH is negative, no such control is to be imposed. ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real*8 array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real*8 array of dependent variable values to be ! interpolated. F(1+(I-1)*INCFD) is value corresponding to ! X(I). ! ! D -- (output) real*8 array of derivative values at the data ! points. These values will determine a monotone cubic ! Hermite function on each subinterval on which the data ! are monotonic, except possibly adjacent to switches in ! monotonicity. The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! No other entries in D are changed. ! ! INCFD -- (input) increment between successive values in F and D. ! This argument is provided primarily for 2-D applications. ! (Error return if INCFD < 1 .) ! ! WK -- (scratch) real*8 array of working storage. The user may ! wish to know that the returned values are: ! WK(I) = H(I) = X(I+1) - X(I) ; ! WK(N-1+I) = SLOPE(I) = (F(1,I+1) - F(1,I)) / H(I) ! for I = 1(1)N-1. ! ! NWK -- (input) length of work array. ! (Error return if NWK < 2*(N-1) .) ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning errors: ! IERR = 1 if IBEG < 0 and D(1) had to be adjusted for ! monotonicity. ! IERR = 2 if IEND < 0 and D(1+(N-1)*INCFD) had to be ! adjusted for monotonicity. ! IERR = 3 if both of the above are true. ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! IERR = -4 if ABS(IBEG) > 5 . ! IERR = -5 if ABS(IEND) > 5 . ! IERR = -6 if both of the above are true. ! IERR = -7 if NWK < 2*(N-1) . ! (The D array has not been changed in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! !***REFERENCES 1. F. N. Fritsch, Piecewise Cubic Hermite Interpolation ! Package, Report UCRL-87285, Lawrence Livermore Natio- ! nal Laboratory, July 1982. [Poster presented at the ! SIAM 30th Anniversary Meeting, 19-23 July 1982.] ! 2. F. N. Fritsch and J. Butland, A method for construc- ! ting local monotone piecewise cubic interpolants, SIAM ! Journal on Scientific and Statistical Computing 5, 2 ! (June 1984), pp. 300-304. ! 3. F. N. Fritsch and R. E. Carlson, Monotone piecewise ! cubic interpolation, SIAM Journal on Numerical Ana- ! lysis 17, 2 (April 1980), pp. 238-246. !***ROUTINES CALLED DPCHCE, DPCHCI, DPCHCS, XERMSG !***REVISION HISTORY (YYMMDD) ! 820218 DATE WRITTEN ! 820804 Converted to SLATEC library version. ! 870707 Corrected XERROR calls for d.p. name(s). ! 870813 Updated Reference 2. ! 890206 Corrected XERROR calls. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920429 Revised format and order of references. (WRB,FNF) !***END PROLOGUE DPCHIC ! Programming notes: ! ! To produce a single precision version, simply: ! a. Change DPCHIC to PCHIC wherever it occurs, ! b. Change DPCHCE to PCHCE wherever it occurs, ! c. Change DPCHCI to PCHCI wherever it occurs, ! d. Change DPCHCS to PCHCS wherever it occurs, ! e. Change the double precision declarations to real, and ! f. Change the constant ZERO to single precision. ! ! DECLARE ARGUMENTS. ! INTEGER IC(2), N, INCFD, NWK, IERR DOUBLE PRECISION VC(2), SWITCH, X(*), F(INCFD,*), D(INCFD,*), & WK(NWK) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, IBEG, IEND, NLESS1 DOUBLE PRECISION ZERO SAVE ZERO DATA ZERO /0.D0/ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT DPCHIC if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! IBEG = IC(1) IEND = IC(2) IERR = 0 if (ABS(IBEG) > 5) IERR = IERR - 1 if (ABS(IEND) > 5) IERR = IERR - 2 if (IERR < 0) go to 5004 ! ! FUNCTION DEFINITION IS OK -- GO ON. ! NLESS1 = N - 1 if ( NWK < 2*NLESS1 ) go to 5007 ! ! SET UP H AND SLOPE ARRAYS. ! DO 20 I = 1, NLESS1 WK(I) = X(I+1) - X(I) WK(NLESS1+I) = (F(1,I+1) - F(1,I)) / WK(I) 20 CONTINUE ! ! SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. ! if (NLESS1 > 1) go to 1000 D(1,1) = WK(2) D(1,N) = WK(2) go to 3000 ! ! NORMAL CASE (N >= 3) . ! 1000 CONTINUE ! ! SET INTERIOR DERIVATIVES AND DEFAULT END CONDITIONS. ! ! -------------------------------------- call DPCHCI (N, WK(1), WK(N), D, INCFD) ! -------------------------------------- ! ! SET DERIVATIVES AT POINTS WHERE MONOTONICITY SWITCHES DIRECTION. ! if (SWITCH == ZERO) go to 3000 ! ---------------------------------------------------- call DPCHCS (SWITCH, N, WK(1), WK(N), D, INCFD, IERR) ! ---------------------------------------------------- if (IERR /= 0) go to 5008 ! ! SET END CONDITIONS. ! 3000 CONTINUE if ( (IBEG == 0) .AND. (IEND == 0) ) go to 5000 ! ------------------------------------------------------- call DPCHCE (IC, VC, N, X, WK(1), WK(N), D, INCFD, IERR) ! ------------------------------------------------------- if (IERR < 0) go to 5009 ! ! NORMAL RETURN. ! 5000 CONTINUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DPCHIC', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'DPCHIC', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'DPCHIC', & 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) return ! 5004 CONTINUE ! IC OUT OF RANGE RETURN. IERR = IERR - 3 call XERMSG ('SLATEC', 'DPCHIC', 'IC OUT OF RANGE', IERR, 1) return ! 5007 CONTINUE ! NWK < 2*(N-1) return. IERR = -7 call XERMSG ('SLATEC', 'DPCHIC', 'WORK ARRAY TOO SMALL', IERR, 1) return ! 5008 CONTINUE ! ERROR RETURN FROM DPCHCS. IERR = -8 call XERMSG ('SLATEC', 'DPCHIC', 'ERROR RETURN FROM DPCHCS', & IERR, 1) return ! 5009 CONTINUE ! ERROR RETURN FROM DPCHCE. ! *** THIS CASE SHOULD NEVER OCCUR *** IERR = -9 call XERMSG ('SLATEC', 'DPCHIC', 'ERROR RETURN FROM DPCHCE', & IERR, 1) return !------------- LAST LINE OF DPCHIC FOLLOWS ----------------------------- end DOUBLE PRECISION FUNCTION DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, & IERR) ! !! DPCHID evaluates the definite integral of a piecewise cubic Hermite ... ! function over an interval whose endpoints are data points. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3, H2A1B2 !***TYPE DOUBLE PRECISION (PCHID-S, DPCHID-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, ! QUADRATURE !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! DPCHID: Piecewise Cubic Hermite Integrator, Data limits ! ! Evaluates the definite integral of the cubic Hermite function ! defined by N, X, F, D over the interval [X(IA), X(IB)]. ! ! To provide compatibility with DPCHIM and DPCHIC, includes an ! increment between successive values of the F- and D arrays. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, IA, IB, IERR ! DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) ! LOGICAL SKIP ! ! VALUE = DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERR) ! ! Parameters: ! ! VALUE -- (output) value of the requested integral. ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real*8 array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) ! is the value corresponding to X(I). ! ! INCFD -- (input) increment between successive values in F and D. ! (Error return if INCFD < 1 .) ! ! SKIP -- (input/output) logical variable which should be set to ! .TRUE. if the user wishes to skip checks for validity of ! preceding parameters, or to .FALSE. otherwise. ! This will save time in case these checks have already ! been performed (say, in DPCHIM or DPCHIC). ! SKIP will be set to .TRUE. on return with IERR = 0 or -4. ! ! IA,IB -- (input) indices in X-array for the limits of integration. ! both must be in the range [1,N]. (Error return if not.) ! No restrictions on their relative values. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! IERR = -4 if IA or IB is out of range. ! (VALUE will be zero in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 820723 DATE WRITTEN ! 820804 Converted to SLATEC library version. ! 870707 Corrected XERROR calls for d.p. name(s). ! 870813 Minor cosmetic changes. ! 890206 Corrected XERROR calls. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 930504 Corrected to set VALUE=0 when IERR.ne.0. (FNF) !***END PROLOGUE DPCHID ! ! Programming notes: ! 1. This routine uses a special formula that is valid only for ! integrals whose limits coincide with data values. This is ! mathematically equivalent to, but much more efficient than, ! calls to DCHFIE. !**End ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, IA, IB, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*) LOGICAL SKIP ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, IUP, LOW DOUBLE PRECISION H, HALF, SIX, SUM, VALUE, ZERO SAVE ZERO, HALF, SIX ! ! INITIALIZE. ! DATA ZERO /0.D0/, HALF/.5D0/, SIX/6.D0/ !***FIRST EXECUTABLE STATEMENT DPCHID VALUE = ZERO ! ! VALIDITY-CHECK ARGUMENTS. ! if (SKIP) go to 5 ! if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! ! FUNCTION DEFINITION IS OK, GO ON. ! 5 CONTINUE SKIP = .TRUE. if ((IA < 1) .OR. (IA > N)) go to 5004 if ((IB < 1) .OR. (IB > N)) go to 5004 IERR = 0 ! ! COMPUTE INTEGRAL VALUE. ! if (IA /= IB) THEN LOW = MIN(IA, IB) IUP = MAX(IA, IB) - 1 SUM = ZERO DO 10 I = LOW, IUP H = X(I+1) - X(I) SUM = SUM + H*( (F(1,I) + F(1,I+1)) + & (D(1,I) - D(1,I+1))*(H/SIX) ) 10 CONTINUE VALUE = HALF * SUM if (IA > IB) VALUE = -VALUE end if ! ! NORMAL RETURN. ! 5000 CONTINUE DPCHID = VALUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DPCHID', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) go to 5000 ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'DPCHID', 'INCREMENT LESS THAN ONE', IERR, & 1) go to 5000 ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'DPCHID', & 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) go to 5000 ! 5004 CONTINUE ! IA OR IB OUT OF RANGE RETURN. IERR = -4 call XERMSG ('SLATEC', 'DPCHID', 'IA OR IB OUT OF RANGE', IERR, & 1) go to 5000 !------------- LAST LINE OF DPCHID FOLLOWS ----------------------------- end subroutine DPCHIM (N, X, F, D, INCFD, IERR) ! !! DPCHIM sets derivatives needed to determine a monotone piecewise ... ! cubic Hermite interpolant to given data. Boundary values ! are provided which are compatible with monotonicity. The ! interpolant will have an extremum at each point where mono- ! tonicity switches direction. (See DPCHIC if user control ! is desired over boundary or switch conditions.) ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E1A !***TYPE DOUBLE PRECISION (PCHIM-S, DPCHIM-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, ! PCHIP, PIECEWISE CUBIC INTERPOLATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! DPCHIM: Piecewise Cubic Hermite Interpolation to ! Monotone data. ! ! Sets derivatives needed to determine a monotone piecewise cubic ! Hermite interpolant to the data given in X and F. ! ! Default boundary conditions are provided which are compatible ! with monotonicity. (See DPCHIC if user control of boundary con- ! ditions is desired.) ! ! If the data are only piecewise monotonic, the interpolant will ! have an extremum at each point where monotonicity switches direc- ! tion. (See DPCHIC if user control is desired in such cases.) ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the F- and D arrays. ! ! The resulting piecewise cubic Hermite function may be evaluated ! by DPCHFE or DPCHFD. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, IERR ! DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) ! ! call DPCHIM (N, X, F, D, INCFD, IERR) ! ! Parameters: ! ! N -- (input) number of data points. (Error return if N < 2 .) ! If N=2, simply does linear interpolation. ! ! X -- (input) real*8 array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real*8 array of dependent variable values to be ! interpolated. F(1+(I-1)*INCFD) is value corresponding to ! X(I). DPCHIM is designed for monotonic data, but it will ! work for any F-array. It will force extrema at points where ! monotonicity switches direction. If some other treatment of ! switch points is desired, DPCHIC should be used instead. ! ----- ! D -- (output) real*8 array of derivative values at the data ! points. If the data are monotonic, these values will ! determine a monotone cubic Hermite function. ! The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! No other entries in D are changed. ! ! INCFD -- (input) increment between successive values in F and D. ! This argument is provided primarily for 2-D applications. ! (Error return if INCFD < 1 .) ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning error: ! IERR > 0 means that IERR switches in the direction ! of monotonicity were detected. ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! (The D array has not been changed in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! !***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- ! ting local monotone piecewise cubic interpolants, SIAM ! Journal on Scientific and Statistical Computing 5, 2 ! (June 1984), pp. 300-304. ! 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise ! cubic interpolation, SIAM Journal on Numerical Ana- ! lysis 17, 2 (April 1980), pp. 238-246. !***ROUTINES CALLED DPCHST, XERMSG !***REVISION HISTORY (YYMMDD) ! 811103 DATE WRITTEN ! 820201 1. Introduced DPCHST to reduce possible over/under- ! flow problems. ! 2. Rearranged derivative formula for same reason. ! 820602 1. Modified end conditions to be continuous functions ! of data when monotonicity switches in next interval. ! 2. Modified formulas so end conditions are less prone ! of over/underflow problems. ! 820803 Minor cosmetic changes for release 1. ! 870707 Corrected XERROR calls for d.p. name(s). ! 870813 Updated Reference 1. ! 890206 Corrected XERROR calls. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920429 Revised format and order of references. (WRB,FNF) !***END PROLOGUE DPCHIM ! Programming notes: ! ! 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if ! either argument is zero, +1 if they are of the same sign, and ! -1 if they are of opposite sign. ! 2. To produce a single precision version, simply: ! a. Change DPCHIM to PCHIM wherever it occurs, ! b. Change DPCHST to PCHST wherever it occurs, ! c. Change all references to the Fortran intrinsics to their ! single precision equivalents, ! d. Change the double precision declarations to real, and ! e. Change the constants ZERO and THREE to single precision. ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, NLESS1 DOUBLE PRECISION DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, & H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO SAVE ZERO, THREE DOUBLE PRECISION DPCHST DATA ZERO /0.D0/, THREE/3.D0/ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT DPCHIM if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! ! FUNCTION DEFINITION IS OK, GO ON. ! IERR = 0 NLESS1 = N - 1 H1 = X(2) - X(1) DEL1 = (F(1,2) - F(1,1))/H1 DSAVE = DEL1 ! ! SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. ! if (NLESS1 > 1) go to 10 D(1,1) = DEL1 D(1,N) = DEL1 go to 5000 ! ! NORMAL CASE (N >= 3). ! 10 CONTINUE H2 = X(3) - X(2) DEL2 = (F(1,3) - F(1,2))/H2 ! ! SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE ! SHAPE-PRESERVING. ! HSUM = H1 + H2 W1 = (H1 + HSUM)/HSUM W2 = -H1/HSUM D(1,1) = W1*DEL1 + W2*DEL2 if ( DPCHST(D(1,1),DEL1) <= ZERO) THEN D(1,1) = ZERO ELSE if ( DPCHST(DEL1,DEL2) < ZERO) THEN ! NEED DO THIS CHECK ONLY if MONOTONICITY SWITCHES. DMAX = THREE*DEL1 if (ABS(D(1,1)) > ABS(DMAX)) D(1,1) = DMAX end if ! ! LOOP THROUGH INTERIOR POINTS. ! DO 50 I = 2, NLESS1 if (I == 2) go to 40 ! H1 = H2 H2 = X(I+1) - X(I) HSUM = H1 + H2 DEL1 = DEL2 DEL2 = (F(1,I+1) - F(1,I))/H2 40 CONTINUE ! ! SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. ! D(1,I) = ZERO if ( DPCHST(DEL1,DEL2) ) 42, 41, 45 ! ! COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. ! 41 CONTINUE if (DEL2 == ZERO) go to 50 if ( DPCHST(DSAVE,DEL2) < ZERO) IERR = IERR + 1 DSAVE = DEL2 go to 50 ! 42 CONTINUE IERR = IERR + 1 DSAVE = DEL2 go to 50 ! ! USE BRODLIE MODIFICATION OF BUTLAND FORMULA. ! 45 CONTINUE HSUMT3 = HSUM+HSUM+HSUM W1 = (HSUM + H1)/HSUMT3 W2 = (HSUM + H2)/HSUMT3 DMAX = MAX( ABS(DEL1), ABS(DEL2) ) DMIN = MIN( ABS(DEL1), ABS(DEL2) ) DRAT1 = DEL1/DMAX DRAT2 = DEL2/DMAX D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) ! 50 CONTINUE ! ! SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE ! SHAPE-PRESERVING. ! W1 = -H2/HSUM W2 = (H2 + HSUM)/HSUM D(1,N) = W1*DEL1 + W2*DEL2 if ( DPCHST(D(1,N),DEL2) <= ZERO) THEN D(1,N) = ZERO ELSE if ( DPCHST(DEL1,DEL2) < ZERO) THEN ! NEED DO THIS CHECK ONLY if MONOTONICITY SWITCHES. DMAX = THREE*DEL2 if (ABS(D(1,N)) > ABS(DMAX)) D(1,N) = DMAX end if ! ! NORMAL RETURN. ! 5000 CONTINUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DPCHIM', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'DPCHIM', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'DPCHIM', & 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) return end subroutine DPCHKT (N, X, KNOTYP, T) ! !! DPCHKT computes B-spline knot sequence for DPCHBS. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3 !***TYPE DOUBLE PRECISION (PCHKT-S, DPCHKT-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! Set a knot sequence for the B-spline representation of a PCH ! function with breakpoints X. All knots will be at least double. ! Endknots are set as: ! (1) quadruple knots at endpoints if KNOTYP=0; ! (2) extrapolate the length of end interval if KNOTYP=1; ! (3) periodic if KNOTYP=2. ! ! Input arguments: N, X, KNOTYP. ! Output arguments: T. ! ! Restrictions/assumptions: ! 1. N >= 2 . (not checked) ! 2. X(i) < X(i+1), i=1,...,N . (not checked) ! 3. 0 <= KNOTYP <= 2 . (Acts like KNOTYP=0 for any other value.) ! !***SEE ALSO DPCHBS !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 870701 DATE WRITTEN ! 900405 Converted Fortran to upper case. ! 900410 Converted prologue to SLATEC 4.0 format. ! 900410 Minor cosmetic changes. ! 900430 Produced double precision version. ! 930514 Changed NKNOTS from an output to an input variable. (FNF) ! 930604 Removed unused variable NKNOTS from argument list. (FNF) !***END PROLOGUE DPCHKT ! !*Internal Notes: ! ! Since this is subsidiary to DPCHBS, which validates its input before ! calling, it is unnecessary for such validation to be done here. ! !**End ! ! Declare arguments. ! INTEGER N, KNOTYP DOUBLE PRECISION X(*), T(*) ! ! Declare local variables. ! INTEGER J, K, NDIM DOUBLE PRECISION HBEG, HEND !***FIRST EXECUTABLE STATEMENT DPCHKT ! ! Initialize. ! NDIM = 2*N ! ! Set interior knots. ! J = 1 DO 20 K = 1, N J = J + 2 T(J) = X(K) T(J+1) = T(J) 20 CONTINUE ! Assertion: At this point T(3),...,T(NDIM+2) have been set and ! J=NDIM+1. ! ! Set end knots according to KNOTYP. ! HBEG = X(2) - X(1) HEND = X(N) - X(N-1) if (KNOTYP == 1 ) THEN ! Extrapolate. T(2) = X(1) - HBEG T(NDIM+3) = X(N) + HEND ELSE if ( KNOTYP == 2 ) THEN ! Periodic. T(2) = X(1) - HEND T(NDIM+3) = X(N) + HBEG ELSE ! Quadruple end knots. T(2) = X(1) T(NDIM+3) = X(N) end if T(1) = T(2) T(NDIM+4) = T(NDIM+3) ! ! Terminate. ! return end subroutine DPCHNG (II, XVAL, IPLACE, SX, IX, IRCX) ! !! DPCHNG is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PCHNGS-S, DPCHNG-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! SUBROUTINE DPCHNG CHANGES ELEMENT II IN VECTOR +/- IRCX TO THE ! VALUE XVAL. ! DPCHNG LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. ! SPARSE MATRIX ELEMENT ALTERATION SUBROUTINE. ! ! II THE ABSOLUTE VALUE OF THIS INTEGER IS THE SUBSCRIPT FOR ! THE ELEMENT TO BE CHANGED. ! XVAL NEW VALUE OF THE MATRIX ELEMENT BEING CHANGED. ! IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE. ! SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE ! MATRIX. THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY THE ! PACKAGE FOR THE USER. ! IRCX POINTS TO THE VECTOR OF THE MATRIX BEING UPDATED. ! A NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS ! BEING UPDATED. A POSITIVE VALUE OF IRCX INDICATES THAT ! COLUMN IRCX IS BEING UPDATED. A ZERO VALUE OF IRCX IS ! AN ERROR. ! ! SINCE DATA ITEMS ARE KEPT SORTED IN THE SEQUENTIAL DATA STRUCTURE, ! CHANGING A MATRIX ELEMENT CAN REQUIRE THE MOVEMENT OF ALL THE DATA ! ITEMS IN THE MATRIX. FOR THIS REASON, IT IS SUGGESTED THAT DATA ! ITEMS BE ADDED A COL. AT A TIME, IN ASCENDING COL. SEQUENCE. ! FURTHERMORE, SINCE DELETING ITEMS FROM THE DATA STRUCTURE MAY ALSO ! REQUIRE MOVING LARGE AMOUNTS OF DATA, ZERO ELEMENTS ARE EXPLICITLY ! STORED IN THE MATRIX. ! ! THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LCHNGS, ! SANDIA LABS. REPT. SAND78-0785. ! MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON ! REVISED 811130-1000 ! REVISED YYMMDD-HHMM ! !***SEE ALSO DSPLP !***ROUTINES CALLED DPRWPG, IDLOC, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890606 Changed references from IPLOC to IDLOC. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) !***END PROLOGUE DPCHNG DIMENSION IX(*) INTEGER IDLOC DOUBLE PRECISION SX(*),XVAL,ZERO,ONE,SXLAST,SXVAL SAVE ZERO, ONE DATA ZERO,ONE /0.D0,1.D0/ !***FIRST EXECUTABLE STATEMENT DPCHNG IOPT=1 ! ! DETERMINE NULL-CASES.. if ( II == 0) RETURN ! ! CHECK VALIDITY OF ROW/COL. INDEX. ! if (.NOT.(IRCX == 0)) go to 20002 NERR=55 call XERMSG ('SLATEC', 'DPCHNG', 'IRCX=0', NERR, IOPT) 20002 LMX = IX(1) ! ! LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA. ! if (.NOT.(IRCX < 0)) go to 20005 ! ! CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE <= M AND ! THE INDEX MUST BE <= N. ! if (.NOT.(IX(2) < -IRCX .OR. IX(3) < ABS(II))) go to 20008 NERR=55 call XERMSG ('SLATEC', 'DPCHNG', & 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // & 'BOUNDS', NERR, IOPT) 20008 go to 20006 ! ! CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE <= N AND ! THE INDEX MUST BE <= M. ! 20005 if (.NOT.(IX(3) < IRCX .OR. IX(2) < ABS(II))) go to 20011 NERR=55 call XERMSG ('SLATEC', 'DPCHNG', & 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // & 'BOUNDS', NERR, IOPT) 20011 CONTINUE ! ! SET I TO BE THE ELEMENT OF ROW/COLUMN J TO BE CHANGED. ! 20006 if (.NOT.(IRCX > 0)) go to 20014 I = ABS(II) J = ABS(IRCX) go to 20015 20014 I = ABS(IRCX) J = ABS(II) ! ! THE INTEGER LL POINTS TO THE START OF THE MATRIX ELEMENT DATA. ! 20015 LL=IX(3)+4 II = ABS(II) LPG = LMX - LL ! ! SET IPLACE TO START OUR SCAN FOR THE ELEMENT AT THE BEGINNING ! OF THE VECTOR. ! if (.NOT.(J == 1)) go to 20017 IPLACE=LL+1 go to 20018 20017 IPLACE=IX(J+3)+1 ! ! IEND POINTS TO THE LAST ELEMENT OF THE VECTOR TO BE SCANNED. ! 20018 IEND = IX(J+4) ! ! SCAN THROUGH SEVERAL PAGES, if NECESSARY, TO FIND MATRIX ELEMENT. ! IPL = IDLOC(IPLACE,SX,IX) NP = ABS(IX(LMX-1)) go to 20021 20020 if (ILAST == IEND) go to 20022 ! ! THE VIRTUAL END OF DATA FOR THIS PAGE IS ILAST. ! 20021 ILAST = MIN(IEND,NP*LPG+LL-2) ! ! THE RELATIVE END OF DATA FOR THIS PAGE IS IL. ! SEARCH FOR A MATRIX VALUE WITH AN INDEX >= I ON THE PRESENT ! PAGE. ! IL = IDLOC(ILAST,SX,IX) IL = MIN(IL,LMX-2) 20023 if (.NOT.(.NOT.(IPL >= IL .OR. IX(IPL) >= I))) go to 20024 IPL=IPL+1 go to 20023 ! ! SET IPLACE AND STORE DATA ITEM if FOUND. ! 20024 if (.NOT.(IX(IPL) == I .AND. IPL <= IL)) go to 20025 SX(IPL) = XVAL SX(LMX) = ONE return ! ! EXIT FROM LOOP if ITEM WAS FOUND. ! 20025 if ( IX(IPL) > I .AND. IPL <= IL) ILAST = IEND if (.NOT.(ILAST /= IEND)) go to 20028 IPL = LL + 1 NP = NP + 1 20028 go to 20020 ! ! INSERT NEW DATA ITEM INTO LOCATION AT IPLACE(IPL). ! 20022 if (.NOT.(IPL > IL.OR.(IPL == IL.AND.I > IX(IPL)))) go to 20031 IPL = IL + 1 if ( IPL == LMX-1) IPL = IPL + 2 20031 IPLACE = (NP-1)*LPG + IPL ! ! go to A NEW PAGE, if NECESSARY, TO INSERT THE ITEM. ! if (.NOT.(IPL <= LMX .OR. IX(LMX-1) >= 0)) go to 20034 IPL=IDLOC(IPLACE,SX,IX) 20034 IEND = IX(LL) NP = ABS(IX(LMX-1)) SXVAL = XVAL ! ! LOOP THROUGH ALL SUBSEQUENT PAGES OF THE MATRIX MOVING DATA DOWN. ! THIS IS NECESSARY TO MAKE ROOM FOR THE NEW MATRIX ELEMENT AND ! KEEP THE ENTRIES SORTED. ! go to 20038 20037 if (IX(LMX-1) <= 0) go to 20039 20038 ILAST = MIN(IEND,NP*LPG+LL-2) IL = IDLOC(ILAST,SX,IX) IL = MIN(IL,LMX-2) SXLAST = SX(IL) IXLAST = IX(IL) ISTART = IPL + 1 if (.NOT.(ISTART <= IL)) go to 20040 K = ISTART + IL DO 50 JJ=ISTART,IL SX(K-JJ) = SX(K-JJ-1) IX(K-JJ) = IX(K-JJ-1) 50 CONTINUE SX(LMX) = ONE 20040 if (.NOT.(IPL <= LMX)) go to 20043 SX(IPL) = SXVAL IX(IPL) = I SXVAL = SXLAST I = IXLAST SX(LMX) = ONE if (.NOT.(IX(LMX-1) > 0)) go to 20046 IPL = LL + 1 NP = NP + 1 20046 CONTINUE 20043 go to 20037 20039 NP = ABS(IX(LMX-1)) ! ! DETERMINE if A NEW PAGE IS TO BE CREATED FOR THE LAST ELEMENT ! MOVED DOWN. ! IL = IL + 1 if (.NOT.(IL == LMX-1)) go to 20049 ! ! CREATE A NEW PAGE. ! IX(LMX-1) = NP ! ! WRITE THE OLD PAGE. ! SX(LMX) = ZERO KEY = 2 call DPRWPG(KEY,NP,LPG,SX,IX) SX(LMX) = ONE ! ! STORE LAST ELEMENT MOVED DOWN IN A NEW PAGE. ! IPL = LL + 1 NP = NP + 1 IX(LMX-1) = -NP SX(IPL) = SXVAL IX(IPL) = I go to 20050 ! ! LAST ELEMENT MOVED REMAINED ON THE OLD PAGE. ! 20049 if (.NOT.(IPL /= IL)) go to 20052 SX(IL) = SXVAL IX(IL) = I SX(LMX) = ONE 20052 CONTINUE ! ! INCREMENT POINTERS TO LAST ELEMENT IN VECTORS J,J+1,... . ! 20050 JSTART = J + 4 JJ=JSTART N20055=LL go to 20056 20055 JJ=JJ+1 20056 if ((N20055-JJ) < 0) go to 20057 IX(JJ) = IX(JJ) + 1 if ( MOD(IX(JJ)-LL,LPG) == LPG-1) IX(JJ) = IX(JJ) + 2 go to 20055 ! ! IPLACE POINTS TO THE INSERTED DATA ITEM. ! 20057 IPL=IDLOC(IPLACE,SX,IX) return end subroutine DPCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) ! !! DPCHSP sets derivatives needed to determine the Hermite representation ... ! of the cubic spline interpolant to given data, with specified boundary ! conditions. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E1A !***TYPE DOUBLE PRECISION (PCHSP-S, DPCHSP-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, PCHIP, ! PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! DPCHSP: Piecewise Cubic Hermite Spline ! ! Computes the Hermite representation of the cubic spline inter- ! polant to the data given in X and F satisfying the boundary ! conditions specified by IC and VC. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the F- and D arrays. ! ! The resulting piecewise cubic Hermite function may be evaluated ! by DPCHFE or DPCHFD. ! ! NOTE: This is a modified version of C. de Boor's cubic spline ! routine CUBSPL. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER IC(2), N, NWK, IERR ! DOUBLE PRECISION VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK) ! ! call DPCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) ! ! Parameters: ! ! IC -- (input) integer array of length 2 specifying desired ! boundary conditions: ! IC(1) = IBEG, desired condition at beginning of data. ! IC(2) = IEND, desired condition at end of data. ! ! IBEG = 0 to set D(1) so that the third derivative is con- ! tinuous at X(2). This is the "not a knot" condition ! provided by de Boor's cubic spline routine CUBSPL. ! < This is the default boundary condition. > ! IBEG = 1 if first derivative at X(1) is given in VC(1). ! IBEG = 2 if second derivative at X(1) is given in VC(1). ! IBEG = 3 to use the 3-point difference formula for D(1). ! (Reverts to the default b.c. if N < 3 .) ! IBEG = 4 to use the 4-point difference formula for D(1). ! (Reverts to the default b.c. if N < 4 .) ! NOTES: ! 1. An error return is taken if IBEG is out of range. ! 2. For the "natural" boundary condition, use IBEG=2 and ! VC(1)=0. ! ! IEND may take on the same values as IBEG, but applied to ! derivative at X(N). In case IEND = 1 or 2, the value is ! given in VC(2). ! ! NOTES: ! 1. An error return is taken if IEND is out of range. ! 2. For the "natural" boundary condition, use IEND=2 and ! VC(2)=0. ! ! VC -- (input) real*8 array of length 2 specifying desired boundary ! values, as indicated above. ! VC(1) need be set only if IC(1) = 1 or 2 . ! VC(2) need be set only if IC(2) = 1 or 2 . ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real*8 array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real*8 array of dependent variable values to be ! interpolated. F(1+(I-1)*INCFD) is value corresponding to ! X(I). ! ! D -- (output) real*8 array of derivative values at the data ! points. These values will determine the cubic spline ! interpolant with the requested boundary conditions. ! The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! No other entries in D are changed. ! ! INCFD -- (input) increment between successive values in F and D. ! This argument is provided primarily for 2-D applications. ! (Error return if INCFD < 1 .) ! ! WK -- (scratch) real*8 array of working storage. ! ! NWK -- (input) length of work array. ! (Error return if NWK < 2*N .) ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! IERR = -4 if IBEG < 0 or IBEG > 4 . ! IERR = -5 if IEND < 0 of IEND > 4 . ! IERR = -6 if both of the above are true. ! IERR = -7 if NWK is too small. ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! (The D array has not been changed in any of these cases.) ! IERR = -8 in case of trouble solving the linear system ! for the interior derivative values. ! (The D array may have been changed in this case.) ! ( Do **NOT** use it! ) ! !***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- ! Verlag, New York, 1978, pp. 53-59. !***ROUTINES CALLED DPCHDF, XERMSG !***REVISION HISTORY (YYMMDD) ! 820503 DATE WRITTEN ! 820804 Converted to SLATEC library version. ! 870707 Corrected XERROR calls for d.p. name(s). ! 890206 Corrected XERROR calls. ! 890411 Added SAVE statements (Vers. 3.2). ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920429 Revised format and order of references. (WRB,FNF) !***END PROLOGUE DPCHSP ! Programming notes: ! ! To produce a single precision version, simply: ! a. Change DPCHSP to PCHSP wherever it occurs, ! b. Change the double precision declarations to real, and ! c. Change the constants ZERO, HALF, ... to single precision. ! ! DECLARE ARGUMENTS. ! INTEGER IC(2), N, INCFD, NWK, IERR DOUBLE PRECISION VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER IBEG, IEND, INDEX, J, NM1 DOUBLE PRECISION G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), & ZERO SAVE ZERO, HALF, ONE, TWO, THREE DOUBLE PRECISION DPCHDF ! DATA ZERO /0.D0/, HALF/.5D0/, ONE/1.D0/, TWO/2.D0/, THREE/3.D0/ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT DPCHSP if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 J = 2, N if ( X(J) <= X(J-1) ) go to 5003 1 CONTINUE ! IBEG = IC(1) IEND = IC(2) IERR = 0 if ( (IBEG < 0).OR.(IBEG > 4) ) IERR = IERR - 1 if ( (IEND < 0).OR.(IEND > 4) ) IERR = IERR - 2 if ( IERR < 0 ) go to 5004 ! ! FUNCTION DEFINITION IS OK -- GO ON. ! if ( NWK < 2*N ) go to 5007 ! ! COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO, ! COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.). DO 5 J=2,N WK(1,J) = X(J) - X(J-1) WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J) 5 CONTINUE ! ! SET TO DEFAULT BOUNDARY CONDITIONS if N IS TOO SMALL. ! if ( IBEG > N ) IBEG = 0 if ( IEND > N ) IEND = 0 ! ! SET UP FOR BOUNDARY CONDITIONS. ! if ( (IBEG == 1).OR.(IBEG == 2) ) THEN D(1,1) = VC(1) ELSE if (IBEG > 2) THEN ! PICK UP FIRST IBEG POINTS, IN REVERSE ORDER. DO 10 J = 1, IBEG INDEX = IBEG-J+1 ! INDEX RUNS FROM IBEG DOWN TO 1. XTEMP(J) = X(INDEX) if (J < IBEG) STEMP(J) = WK(2,INDEX) 10 CONTINUE ! -------------------------------- D(1,1) = DPCHDF (IBEG, XTEMP, STEMP, IERR) ! -------------------------------- if (IERR /= 0) go to 5009 IBEG = 1 end if ! if ( (IEND == 1).OR.(IEND == 2) ) THEN D(1,N) = VC(2) ELSE if (IEND > 2) THEN ! PICK UP LAST IEND POINTS. DO 15 J = 1, IEND INDEX = N-IEND+J ! INDEX RUNS FROM N+1-IEND UP TO N. XTEMP(J) = X(INDEX) if (J < IEND) STEMP(J) = WK(2,INDEX+1) 15 CONTINUE ! -------------------------------- D(1,N) = DPCHDF (IEND, XTEMP, STEMP, IERR) ! -------------------------------- if (IERR /= 0) go to 5009 IEND = 1 end if ! ! --------------------( BEGIN CODING FROM CUBSPL )-------------------- ! ! **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF ! F AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM- ! INATION, WITH S(J) ENDING UP IN D(1,J), ALL J. ! WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE. ! ! CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM ! WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1) ! if (IBEG == 0) THEN if (N == 2) THEN ! NO CONDITION AT LEFT END AND N = 2. WK(2,1) = ONE WK(1,1) = ONE D(1,1) = TWO*WK(2,2) ELSE ! NOT-A-KNOT CONDITION AT LEFT END AND N > 2. WK(2,1) = WK(1,3) WK(1,1) = WK(1,2) + WK(1,3) D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3) & + WK(1,2)**2*WK(2,3)) / WK(1,1) ENDIF ELSE if (IBEG == 1) THEN ! SLOPE PRESCRIBED AT LEFT END. WK(2,1) = ONE WK(1,1) = ZERO ELSE ! SECOND DERIVATIVE PRESCRIBED AT LEFT END. WK(2,1) = TWO WK(1,1) = ONE D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1) end if ! ! if THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND ! CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH ! EQUATION READS WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J). ! NM1 = N-1 if (NM1 > 1) THEN DO 20 J=2,NM1 if (WK(2,J-1) == ZERO) go to 5008 G = -WK(1,J+1)/WK(2,J-1) D(1,J) = G*D(1,J-1) & + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J)) WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1)) 20 CONTINUE end if ! ! CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM ! (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N) ! ! if SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK- ! SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT ! AT THIS POINT. if (IEND == 1) go to 30 ! if (IEND == 0) THEN if (N == 2 .AND. IBEG == 0) THEN ! NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2. D(1,2) = WK(2,2) go to 30 ELSE if ((N == 2) .OR. (N == 3 .AND. IBEG == 0)) THEN ! EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT* ! NOT-A-KNOT AT LEFT END POINT). D(1,N) = TWO*WK(2,N) WK(2,N) = ONE if (WK(2,N-1) == ZERO) go to 5008 G = -ONE/WK(2,N-1) ELSE ! NOT-A-KNOT AND N >= 3, AND EITHER N > 3 OR ALSO NOT-A- ! KNOT AT LEFT END POINT. G = WK(1,N-1) + WK(1,N) ! DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES). D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1) & + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G if (WK(2,N-1) == ZERO) go to 5008 G = -G/WK(2,N-1) WK(2,N) = WK(1,N-1) ENDIF ELSE ! SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT. D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N) WK(2,N) = TWO if (WK(2,N-1) == ZERO) go to 5008 G = -ONE/WK(2,N-1) end if ! ! COMPLETE FORWARD PASS OF GAUSS ELIMINATION. ! WK(2,N) = G*WK(1,N-1) + WK(2,N) if (WK(2,N) == ZERO) go to 5008 D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N) ! ! CARRY OUT BACK SUBSTITUTION ! 30 CONTINUE DO 40 J=NM1,1,-1 if (WK(2,J) == ZERO) go to 5008 D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J) 40 CONTINUE ! --------------------( END CODING FROM CUBSPL )-------------------- ! ! NORMAL RETURN. ! return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'DPCHSP', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'DPCHSP', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'DPCHSP', & 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) return ! 5004 CONTINUE ! IC OUT OF RANGE RETURN. IERR = IERR - 3 call XERMSG ('SLATEC', 'DPCHSP', 'IC OUT OF RANGE', IERR, 1) return ! 5007 CONTINUE ! NWK TOO SMALL RETURN. IERR = -7 call XERMSG ('SLATEC', 'DPCHSP', 'WORK ARRAY TOO SMALL', IERR, 1) return ! 5008 CONTINUE ! SINGULAR SYSTEM. ! *** THEORETICALLY, THIS CAN ONLY OCCUR if SUCCESSIVE X-VALUES *** ! *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). *** IERR = -8 call XERMSG ('SLATEC', 'DPCHSP', 'SINGULAR LINEAR SYSTEM', IERR, & 1) return ! 5009 CONTINUE ! ERROR RETURN FROM DPCHDF. ! *** THIS CASE SHOULD NEVER OCCUR *** IERR = -9 call XERMSG ('SLATEC', 'DPCHSP', 'ERROR RETURN FROM DPCHDF', & IERR, 1) return end DOUBLE PRECISION FUNCTION DPCHST (ARG1, ARG2) ! !! DPCHST is the DPCHIP Sign-Testing Routine. ! !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHST-S, DPCHST-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHST: DPCHIP Sign-Testing Routine. ! ! ! Returns: ! -1. if ARG1 and ARG2 are of opposite sign. ! 0. if either argument is zero. ! +1. if ARG1 and ARG2 are of the same sign. ! ! The object is to do this without multiplying ARG1*ARG2, to avoid ! possible over/underflow problems. ! ! Fortran intrinsics used: SIGN. ! !***SEE ALSO DPCHCE, DPCHCI, DPCHCS, DPCHIM !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811103 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 870813 Minor cosmetic changes. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) ! 930503 Improved purpose. (FNF) !***END PROLOGUE DPCHST ! !**End ! ! DECLARE ARGUMENTS. ! DOUBLE PRECISION ARG1, ARG2 ! ! DECLARE LOCAL VARIABLES. ! DOUBLE PRECISION ONE, ZERO SAVE ZERO, ONE DATA ZERO /0.D0/, ONE/1.D0/ ! ! PERFORM THE TEST. ! !***FIRST EXECUTABLE STATEMENT DPCHST DPCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) if ((ARG1 == ZERO) .OR. (ARG2 == ZERO)) DPCHST = ZERO ! return end subroutine DPCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) ! !! DPCHSW limits excursion from data for DPCHCS. ! !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHSW-S, DPCHSW-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHSW: DPCHCS Switch Excursion Limiter. ! ! Called by DPCHCS to adjust D1 and D2 if necessary to insure that ! the extremum on this interval is not further than DFMAX from the ! extreme data value. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! INTEGER IEXTRM, IERR ! DOUBLE PRECISION DFMAX, D1, D2, H, SLOPE ! ! call DPCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) ! ! Parameters: ! ! DFMAX -- (input) maximum allowed difference between F(IEXTRM) and ! the cubic determined by derivative values D1,D2. (assumes ! DFMAX > 0.) ! ! IEXTRM -- (input) index of the extreme data value. (assumes ! IEXTRM = 1 or 2 . Any value /= 1 is treated as 2.) ! ! D1,D2 -- (input) derivative values at the ends of the interval. ! (Assumes D1*D2 <= 0.) ! (output) may be modified if necessary to meet the restriction ! imposed by DFMAX. ! ! H -- (input) interval length. (Assumes H > 0.) ! ! SLOPE -- (input) data slope on the interval. ! ! IERR -- (output) error flag. should be zero. ! If IERR=-1, assumption on D1 and D2 is not satisfied. ! If IERR=-2, quadratic equation locating extremum has ! negative discriminant (should never occur). ! ! ------- ! WARNING: This routine does no validity-checking of arguments. ! ------- ! ! Fortran intrinsics used: ABS, SIGN, SQRT. ! !***SEE ALSO DPCHCS !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 820218 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 870707 Corrected XERROR calls for d.p. name(s). ! 870707 Replaced DATA statement for SMALL with a use of D1MACH. ! 870813 Minor cosmetic changes. ! 890206 Corrected XERROR calls. ! 890411 1. Added SAVE statements (Vers. 3.2). ! 2. Added DOUBLE PRECISION declaration for D1MACH. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) ! 920526 Eliminated possible divide by zero problem. (FNF) ! 930503 Improved purpose. (FNF) !***END PROLOGUE DPCHSW ! !**End ! ! DECLARE ARGUMENTS. ! INTEGER IEXTRM, IERR DOUBLE PRECISION DFMAX, D1, D2, H, SLOPE ! ! DECLARE LOCAL VARIABLES. ! DOUBLE PRECISION CP, FACT, HPHI, LAMBDA, NU, ONE, PHI, RADCAL, & RHO, SIGMA, SMALL, THAT, THIRD, THREE, TWO, ZERO SAVE ZERO, ONE, TWO, THREE, FACT SAVE THIRD DOUBLE PRECISION D1MACH ! DATA ZERO /0.D0/, ONE /1.D0/, TWO /2.D0/, THREE /3.D0/, & FACT /100.D0/ ! THIRD SHOULD BE SLIGHTLY LESS THAN 1/3. DATA THIRD /0.33333D0/ ! ! NOTATION AND GENERAL REMARKS. ! ! RHO IS THE RATIO OF THE DATA SLOPE TO THE DERIVATIVE BEING TESTED. ! LAMBDA IS THE RATIO OF D2 TO D1. ! THAT = T-HAT(RHO) IS THE NORMALIZED LOCATION OF THE EXTREMUM. ! PHI IS THE NORMALIZED VALUE OF P(X)-F1 AT X = XHAT = X-HAT(RHO), ! WHERE THAT = (XHAT - X1)/H . ! THAT IS, P(XHAT)-F1 = D*H*PHI, WHERE D=D1 OR D2. ! SIMILARLY, P(XHAT)-F2 = D*H*(PHI-RHO) . ! ! SMALL SHOULD BE A FEW ORDERS OF MAGNITUDE GREATER THAN MACHEPS. !***FIRST EXECUTABLE STATEMENT DPCHSW SMALL = FACT*D1MACH(4) ! ! DO MAIN CALCULATION. ! if (D1 == ZERO) THEN ! ! SPECIAL CASE -- D1 == ZERO . ! ! if D2 IS ALSO ZERO, THIS ROUTINE SHOULD NOT HAVE BEEN CALLED. if (D2 == ZERO) go to 5001 ! RHO = SLOPE/D2 ! EXTREMUM IS OUTSIDE INTERVAL WHEN RHO >= 1/3 . if (RHO >= THIRD) go to 5000 THAT = (TWO*(THREE*RHO-ONE)) / (THREE*(TWO*RHO-ONE)) PHI = THAT**2 * ((THREE*RHO-ONE)/THREE) ! ! CONVERT TO DISTANCE FROM F2 if IEXTRM /= 1 . if (IEXTRM /= 1) PHI = PHI - RHO ! ! TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. HPHI = H * ABS(PHI) if (HPHI*ABS(D2) > DFMAX) THEN ! AT THIS POINT, HPHI > 0, SO DIVIDE IS OK. D2 = SIGN (DFMAX/HPHI, D2) ENDIF ELSE ! RHO = SLOPE/D1 LAMBDA = -D2/D1 if (D2 == ZERO) THEN ! ! SPECIAL CASE -- D2 == ZERO . ! ! EXTREMUM IS OUTSIDE INTERVAL WHEN RHO >= 1/3 . if (RHO >= THIRD) go to 5000 CP = TWO - THREE*RHO NU = ONE - TWO*RHO THAT = ONE / (THREE*NU) ELSE if (LAMBDA <= ZERO) go to 5001 ! ! NORMAL CASE -- D1 AND D2 BOTH NONZERO, OPPOSITE SIGNS. ! NU = ONE - LAMBDA - TWO*RHO SIGMA = ONE - RHO CP = NU + SIGMA if (ABS(NU) > SMALL) THEN RADCAL = (NU - (TWO*RHO+ONE))*NU + SIGMA**2 if (RADCAL < ZERO) go to 5002 THAT = (CP - SQRT(RADCAL)) / (THREE*NU) ELSE THAT = ONE/(TWO*SIGMA) ENDIF ENDIF PHI = THAT*((NU*THAT - CP)*THAT + ONE) ! ! CONVERT TO DISTANCE FROM F2 if IEXTRM /= 1 . if (IEXTRM /= 1) PHI = PHI - RHO ! ! TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. HPHI = H * ABS(PHI) if (HPHI*ABS(D1) > DFMAX) THEN ! AT THIS POINT, HPHI > 0, SO DIVIDE IS OK. D1 = SIGN (DFMAX/HPHI, D1) D2 = -LAMBDA*D1 ENDIF end if ! ! NORMAL RETURN. ! 5000 CONTINUE IERR = 0 return ! ! ERROR RETURNS. ! 5001 CONTINUE ! D1 AND D2 BOTH ZERO, OR BOTH NONZERO AND SAME SIGN. IERR = -1 call XERMSG ('SLATEC', 'DPCHSW', 'D1 AND/OR D2 INVALID', IERR, 1) return ! 5002 CONTINUE ! NEGATIVE VALUE OF RADICAL (SHOULD NEVER OCCUR). IERR = -2 call XERMSG ('SLATEC', 'DPCHSW', 'NEGATIVE RADICAL', IERR, 1) return !------------- LAST LINE OF DPCHSW FOLLOWS ----------------------------- end subroutine DPCOEF (L, C, TC, A) ! !! DPCOEF converts the DPOLFT coefficients to Taylor series form. ! !***LIBRARY SLATEC !***CATEGORY K1A1A2 !***TYPE DOUBLE PRECISION (PCOEF-S, DPCOEF-D) !***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT !***AUTHOR Shampine, L. F., (SNLA) ! Davenport, S. M., (SNLA) !***DESCRIPTION ! ! Abstract ! ! DPOLFT computes the least squares polynomial fit of degree L as ! a sum of orthogonal polynomials. DPCOEF changes this fit to its ! Taylor expansion about any point C , i.e. writes the polynomial ! as a sum of powers of (X-C). Taking C=0. gives the polynomial ! in powers of X, but a suitable non-zero C often leads to ! polynomials which are better scaled and more accurately evaluated. ! ! The parameters for DPCOEF are ! ! INPUT -- All TYPE REAL variables are DOUBLE PRECISION ! L - Indicates the degree of polynomial to be changed to ! its Taylor expansion. To obtain the Taylor ! coefficients in reverse order, input L as the ! negative of the degree desired. The absolute value ! of L must be less than or equal to NDEG, the highest ! degree polynomial fitted by DPOLFT . ! C - The point about which the Taylor expansion is to be ! made. ! A - Work and output array containing values from last ! call to DPOLFT . ! ! OUTPUT -- All TYPE REAL variables are DOUBLE PRECISION ! TC - Vector containing the first LL+1 Taylor coefficients ! where LL=ABS(L). If L > 0 , the coefficients are ! in the usual Taylor series order, i.e. ! P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N ! If L < 0, the coefficients are in reverse order, ! i.e. ! P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) ! !***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, ! Curve fitting by polynomials in one variable, Report ! SLA-74-0270, Sandia Laboratories, June 1974. !***ROUTINES CALLED DP1VLU !***REVISION HISTORY (YYMMDD) ! 740601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPCOEF ! INTEGER I,L,LL,LLP1,LLP2,NEW,NR DOUBLE PRECISION A(*),C,FAC,SAVE,TC(*) !***FIRST EXECUTABLE STATEMENT DPCOEF LL = ABS(L) LLP1 = LL + 1 call DP1VLU (LL,LL,C,TC(1),TC(2),A) if (LL < 2) go to 2 FAC = 1.0D0 DO 1 I = 3,LLP1 FAC = FAC*(I-1) 1 TC(I) = TC(I)/FAC 2 if (L >= 0) go to 4 NR = LLP1/2 LLP2 = LL + 2 DO 3 I = 1,NR SAVE = TC(I) NEW = LLP2 - I TC(I) = TC(NEW) 3 TC(NEW) = SAVE 4 return end subroutine DPFQAD (F, LDC, C, XI, LXI, K, ID, X1, X2, TOL, QUAD, & IERR) ! !! DPFQAD computes the integral on (X1,X2) of a product of a ... ! function F and the ID-th derivative of a B-spline, ! (PP-representation). ! !***LIBRARY SLATEC !***CATEGORY H2A2A1, E3, K6 !***TYPE DOUBLE PRECISION (PFQAD-S, DPFQAD-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract **** a double precision routine **** ! DPFQAD computes the integral on (X1,X2) of a product of a ! function F and the ID-th derivative of a B-spline, using the ! PP-representation (C,XI,LXI,K). (X1,X2) is normally a sub- ! interval of XI(1) <= X <= XI(LXI+1). An integration ! routine, DPPGQ8 (a modification of GAUS8), integrates the ! product on subintervals of (X1,X2) formed by the included ! break points. Integration outside of (XI(1),XI(LXI+1)) is ! permitted provided F is defined. ! ! The maximum number of significant digits obtainable in ! DBSQAD is the smaller of 18 and the number of digits ! carried in double precision arithmetic. ! ! Description of arguments ! Input F,C,XI,X1,X2,TOL are double precision ! F - external function of one argument for the ! integrand PF(X)=F(X)*DPPVAL(LDC,C,XI,LXI,K,ID,X, ! INPPV) ! LDC - leading dimension of matrix C, LDC >= K ! C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI ! XI(*) - break point array of length LXI+1 ! LXI - number of polynomial pieces ! K - order of B-spline, K >= 1 ! ID - order of the spline derivative, 0 <= ID <= K-1 ! ID=0 gives the spline function ! X1,X2 - end points of quadrature interval, normally in ! XI(1) <= X <= XI(LXI+1) ! TOL - desired accuracy for the quadrature, suggest ! 10.*DTOL < TOL <= 0.1 where DTOL is the ! maximum of 1.0D-18 and double precision unit ! roundoff for the machine = D1MACH(4) ! ! Output QUAD is double precision ! QUAD - integral of PF(X) on (X1,X2) ! IERR - a status code ! IERR=1 normal return ! 2 some quadrature does not meet the ! requested tolerance ! ! Error Conditions ! Improper input is a fatal error. ! Some quadrature does not meet the requested tolerance. ! !***REFERENCES D. E. Amos, Quadrature subroutines for splines and ! B-splines, Report SAND79-1825, Sandia Laboratories, ! December 1979. !***ROUTINES CALLED D1MACH, DINTRV, DPPGQ8, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPFQAD ! INTEGER ID,IERR,IFLG,ILO,IL1,IL2,INPPV,K,LDC,LEFT,LXI,MF1,MF2 DOUBLE PRECISION A,AA,ANS,B,BB,C,Q,QUAD,TA,TB,TOL,WTOL,XI,X1,X2 DOUBLE PRECISION D1MACH, F DIMENSION XI(*), C(LDC,*) EXTERNAL F ! !***FIRST EXECUTABLE STATEMENT DPFQAD IERR = 1 QUAD = 0.0D0 if ( K < 1) go to 100 if ( LDC < K) go to 105 if ( ID < 0 .OR. ID >= K) go to 110 if ( LXI < 1) go to 115 WTOL = D1MACH(4) WTOL = MAX(WTOL,1.0D-18) if (TOL < WTOL .OR. TOL > 0.1D0) go to 20 AA = MIN(X1,X2) BB = MAX(X1,X2) if (AA == BB) RETURN ILO = 1 call DINTRV(XI, LXI, AA, ILO, IL1, MF1) call DINTRV(XI, LXI, BB, ILO, IL2, MF2) Q = 0.0D0 INPPV = 1 DO 10 LEFT=IL1,IL2 TA = XI(LEFT) A = MAX(AA,TA) if (LEFT == 1) A = AA TB = BB if (LEFT < LXI) TB = XI(LEFT+1) B = MIN(BB,TB) call DPPGQ8(F,LDC,C,XI,LXI,K,ID,A,B,INPPV,TOL,ANS,IFLG) if (IFLG > 1) IERR = 2 Q = Q + ANS 10 CONTINUE if (X1 > X2) Q = -Q QUAD = Q return ! 20 CONTINUE call XERMSG ('SLATEC', 'DPFQAD', & 'TOL IS LESS DTOL OR GREATER THAN 0.1', 2, 1) return 100 CONTINUE call XERMSG ('SLATEC', 'DPFQAD', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'DPFQAD', 'LDC DOES NOT SATISFY LDC >= K', & 2, 1) return 110 CONTINUE call XERMSG ('SLATEC', 'DPFQAD', & 'ID DOES NOT SATISFY 0 <= ID < K', 2, 1) return 115 CONTINUE call XERMSG ('SLATEC', 'DPFQAD', 'LXI DOES NOT SATISFY LXI >= 1', & 2, 1) return end subroutine DPIGMR (N, R0, SR, SZ, JSCAL, MAXL, MAXLP1, KMP, NRSTS, & JPRE, MATVEC, MSOLVE, NMSL, Z, V, HES, Q, LGMR, RPAR, IPAR, WK, & DL, RHOL, NRMAX, B, BNRM, X, XL, ITOL, TOL, NELT, IA, JA, A, & ISYM, IUNIT, IFLAG, ERR) ! !! DPIGMR is an internal routine for DGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SPIGMR-S, DPIGMR-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine solves the linear system A * Z = R0 using a ! scaled preconditioned version of the generalized minimum ! residual method. An initial guess of Z = 0 is assumed. ! ! *Usage: ! INTEGER N, JSCAL, MAXL, MAXLP1, KMP, NRSTS, JPRE, NMSL, LGMR ! INTEGER IPAR(USER DEFINED), NRMAX, ITOL, NELT, IA(NELT), JA(NELT) ! INTEGER ISYM, IUNIT, IFLAG ! DOUBLE PRECISION R0(N), SR(N), SZ(N), Z(N), V(N,MAXLP1), ! $ HES(MAXLP1,MAXL), Q(2*MAXL), RPAR(USER DEFINED), ! $ WK(N), DL(N), RHOL, B(N), BNRM, X(N), XL(N), ! $ TOL, A(NELT), ERR ! EXTERNAL MATVEC, MSOLVE ! ! call DPIGMR(N, R0, SR, SZ, JSCAL, MAXL, MAXLP1, KMP, ! $ NRSTS, JPRE, MATVEC, MSOLVE, NMSL, Z, V, HES, Q, LGMR, ! $ RPAR, IPAR, WK, DL, RHOL, NRMAX, B, BNRM, X, XL, ! $ ITOL, TOL, NELT, IA, JA, A, ISYM, IUNIT, IFLAG, ERR) ! ! *Arguments: ! N :IN Integer ! The order of the matrix A, and the lengths ! of the vectors SR, SZ, R0 and Z. ! R0 :IN Double Precision R0(N) ! R0 = the right hand side of the system A*Z = R0. ! R0 is also used as workspace when computing ! the final approximation. ! (R0 is the same as V(*,MAXL+1) in the call to DPIGMR.) ! SR :IN Double Precision SR(N) ! SR is a vector of length N containing the non-zero ! elements of the diagonal scaling matrix for R0. ! SZ :IN Double Precision SZ(N) ! SZ is a vector of length N containing the non-zero ! elements of the diagonal scaling matrix for Z. ! JSCAL :IN Integer ! A flag indicating whether arrays SR and SZ are used. ! JSCAL=0 means SR and SZ are not used and the ! algorithm will perform as if all ! SR(i) = 1 and SZ(i) = 1. ! JSCAL=1 means only SZ is used, and the algorithm ! performs as if all SR(i) = 1. ! JSCAL=2 means only SR is used, and the algorithm ! performs as if all SZ(i) = 1. ! JSCAL=3 means both SR and SZ are used. ! MAXL :IN Integer ! The maximum allowable order of the matrix H. ! MAXLP1 :IN Integer ! MAXPL1 = MAXL + 1, used for dynamic dimensioning of HES. ! KMP :IN Integer ! The number of previous vectors the new vector VNEW ! must be made orthogonal to. (KMP .le. MAXL) ! NRSTS :IN Integer ! Counter for the number of restarts on the current ! call to DGMRES. If NRSTS .gt. 0, then the residual ! R0 is already scaled, and so scaling of it is ! not necessary. ! JPRE :IN Integer ! Preconditioner type flag. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC(N, X, Y, NELT, IA, JA, A, ISYM) ! where N is the number of unknowns, Y is the product A*X ! upon return, X is an input vector, and NELT is the number of ! non-zeros in the SLAP IA, JA, A storage for the matrix A. ! ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of the routine which solves a linear system Mz = r for ! z given r with the preconditioning matrix M (M is supplied via ! RPAR and IPAR arrays. The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as below. RPAR is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IPAR is an integer work array ! for the same purpose as RPAR. ! NMSL :OUT Integer ! The number of calls to MSOLVE. ! Z :OUT Double Precision Z(N) ! The final computed approximation to the solution ! of the system A*Z = R0. ! V :OUT Double Precision V(N,MAXLP1) ! The N by (LGMR+1) array containing the LGMR ! orthogonal vectors V(*,1) to V(*,LGMR). ! HES :OUT Double Precision HES(MAXLP1,MAXL) ! The upper triangular factor of the QR decomposition ! of the (LGMR+1) by LGMR upper Hessenberg matrix whose ! entries are the scaled inner-products of A*V(*,I) ! and V(*,K). ! Q :OUT Double Precision Q(2*MAXL) ! A double precision array of length 2*MAXL containing the ! components of the Givens rotations used in the QR ! decomposition of HES. It is loaded in DHEQR and used in ! DHELS. ! LGMR :OUT Integer ! The number of iterations performed and ! the current order of the upper Hessenberg ! matrix HES. ! RPAR :IN Double Precision RPAR(USER DEFINED) ! Double Precision workspace passed directly to the MSOLVE ! routine. ! IPAR :IN Integer IPAR(USER DEFINED) ! Integer workspace passed directly to the MSOLVE routine. ! WK :IN Double Precision WK(N) ! A double precision work array of length N used by routines ! MATVEC and MSOLVE. ! DL :INOUT Double Precision DL(N) ! On input, a double precision work array of length N used for ! calculation of the residual norm RHO when the method is ! incomplete (KMP.lt.MAXL), and/or when using restarting. ! On output, the scaled residual vector RL. It is only loaded ! when performing restarts of the Krylov iteration. ! RHOL :OUT Double Precision ! A double precision scalar containing the norm of the final ! residual. ! NRMAX :IN Integer ! The maximum number of restarts of the Krylov iteration. ! NRMAX .gt. 0 means restarting is active, while ! NRMAX = 0 means restarting is not being used. ! B :IN Double Precision B(N) ! The right hand side of the linear system A*X = b. ! BNRM :IN Double Precision ! The scaled norm of b. ! X :IN Double Precision X(N) ! The current approximate solution as of the last ! restart. ! XL :IN Double Precision XL(N) ! An array of length N used to hold the approximate ! solution X(L) when ITOL=11. ! ITOL :IN Integer ! A flag to indicate the type of convergence criterion ! used. See the driver for its description. ! TOL :IN Double Precision ! The tolerance on residuals R0-A*Z in scaled norm. ! NELT :IN Integer ! The length of arrays IA, JA and A. ! IA :IN Integer IA(NELT) ! An integer array of length NELT containing matrix data. ! It is passed directly to the MATVEC and MSOLVE routines. ! JA :IN Integer JA(NELT) ! An integer array of length NELT containing matrix data. ! It is passed directly to the MATVEC and MSOLVE routines. ! A :IN Double Precision A(NELT) ! A double precision array of length NELT containing matrix ! data. It is passed directly to the MATVEC and MSOLVE routines. ! ISYM :IN Integer ! A flag to indicate symmetric matrix storage. ! If ISYM=0, all non-zero entries of the matrix are ! stored. If ISYM=1, the matrix is symmetric and ! only the upper or lower triangular part is stored. ! IUNIT :IN Integer ! The i/o unit number for writing intermediate residual ! norm values. ! IFLAG :OUT Integer ! An integer error flag.. ! 0 means convergence in LGMR iterations, LGMR.le.MAXL. ! 1 means the convergence test did not pass in MAXL ! iterations, but the residual norm is .lt. norm(R0), ! and so Z is computed. ! 2 means the convergence test did not pass in MAXL ! iterations, residual .ge. norm(R0), and Z = 0. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DGMRES !***ROUTINES CALLED DAXPY, DCOPY, DHELS, DHEQR, DNRM2, DORTH, DRLCAL, ! DSCAL, ISDGMR !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to DGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE DPIGMR ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. DOUBLE PRECISION BNRM, ERR, RHOL, TOL INTEGER IFLAG, ISYM, ITOL, IUNIT, JPRE, JSCAL, KMP, LGMR, MAXL, & MAXLP1, N, NELT, NMSL, NRMAX, NRSTS ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(*), DL(*), HES(MAXLP1,*), Q(*), R0(*), & RPAR(*), SR(*), SZ(*), V(N,*), WK(*), X(*), & XL(*), Z(*) INTEGER IA(NELT), IPAR(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. DOUBLE PRECISION C, DLNRM, PROD, R0NRM, RHO, S, SNORMW, TEM INTEGER I, I2, INFO, IP1, ITER, ITMAX, J, K, LL, LLP1 ! .. External Functions .. DOUBLE PRECISION DNRM2 INTEGER ISDGMR EXTERNAL DNRM2, ISDGMR ! .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DHELS, DHEQR, DORTH, DRLCAL, DSCAL ! .. Intrinsic Functions .. INTRINSIC ABS !***FIRST EXECUTABLE STATEMENT DPIGMR ! ! Zero out the Z array. ! DO 5 I = 1,N Z(I) = 0 5 CONTINUE ! IFLAG = 0 LGMR = 0 NMSL = 0 ! Load ITMAX, the maximum number of iterations. ITMAX =(NRMAX+1)*MAXL ! ------------------------------------------------------------------- ! The initial residual is the vector R0. ! Apply left precon. if JPRE < 0 and this is not a restart. ! Apply scaling to R0 if JSCAL = 2 or 3. ! ------------------------------------------------------------------- if ((JPRE < 0) .AND.(NRSTS == 0)) THEN call DCOPY(N, R0, 1, WK, 1) call MSOLVE(N, WK, R0, NELT, IA, JA, A, ISYM, RPAR, IPAR) NMSL = NMSL + 1 end if if (((JSCAL == 2) .OR.(JSCAL == 3)) .AND.(NRSTS == 0)) THEN DO 10 I = 1,N V(I,1) = R0(I)*SR(I) 10 CONTINUE ELSE DO 20 I = 1,N V(I,1) = R0(I) 20 CONTINUE end if R0NRM = DNRM2(N, V, 1) ITER = NRSTS*MAXL ! ! Call stopping routine ISDGMR. ! if (ISDGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, & NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, V(1,1), Z, WK, & RPAR, IPAR, R0NRM, BNRM, SR, SZ, JSCAL, & KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, & HES, JPRE) /= 0) RETURN TEM = 1.0D0/R0NRM call DSCAL(N, TEM, V(1,1), 1) ! ! Zero out the HES array. ! DO 50 J = 1,MAXL DO 40 I = 1,MAXLP1 HES(I,J) = 0 40 CONTINUE 50 CONTINUE ! ------------------------------------------------------------------- ! Main loop to compute the vectors V(*,2) to V(*,MAXL). ! The running product PROD is needed for the convergence test. ! ------------------------------------------------------------------- PROD = 1 DO 90 LL = 1,MAXL LGMR = LL ! ------------------------------------------------------------------- ! Unscale the current V(LL) and store in WK. Call routine ! MSOLVE to compute(M-inverse)*WK, where M is the ! preconditioner matrix. Save the answer in Z. Call routine ! MATVEC to compute VNEW = A*Z, where A is the the system ! matrix. save the answer in V(LL+1). Scale V(LL+1). Call ! routine DORTH to orthogonalize the new vector VNEW = ! V(*,LL+1). Call routine DHEQR to update the factors of HES. ! ------------------------------------------------------------------- if ((JSCAL == 1) .OR.(JSCAL == 3)) THEN DO 60 I = 1,N WK(I) = V(I,LL)/SZ(I) 60 CONTINUE ELSE call DCOPY(N, V(1,LL), 1, WK, 1) ENDIF if (JPRE > 0) THEN call MSOLVE(N, WK, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) NMSL = NMSL + 1 call MATVEC(N, Z, V(1,LL+1), NELT, IA, JA, A, ISYM) ELSE call MATVEC(N, WK, V(1,LL+1), NELT, IA, JA, A, ISYM) ENDIF if (JPRE < 0) THEN call DCOPY(N, V(1,LL+1), 1, WK, 1) call MSOLVE(N,WK,V(1,LL+1),NELT,IA,JA,A,ISYM,RPAR,IPAR) NMSL = NMSL + 1 ENDIF if ((JSCAL == 2) .OR.(JSCAL == 3)) THEN DO 65 I = 1,N V(I,LL+1) = V(I,LL+1)*SR(I) 65 CONTINUE ENDIF call DORTH(V(1,LL+1), V, HES, N, LL, MAXLP1, KMP, SNORMW) HES(LL+1,LL) = SNORMW call DHEQR(HES, MAXLP1, LL, Q, INFO, LL) if (INFO == LL) go to 120 ! ------------------------------------------------------------------- ! Update RHO, the estimate of the norm of the residual R0-A*ZL. ! If KMP < MAXL, then the vectors V(*,1),...,V(*,LL+1) are not ! necessarily orthogonal for LL > KMP. The vector DL must then ! be computed, and its norm used in the calculation of RHO. ! ------------------------------------------------------------------- PROD = PROD*Q(2*LL) RHO = ABS(PROD*R0NRM) if ((LL > KMP) .AND.(KMP < MAXL)) THEN if (LL == KMP+1) THEN call DCOPY(N, V(1,1), 1, DL, 1) DO 75 I = 1,KMP IP1 = I + 1 I2 = I*2 S = Q(I2) C = Q(I2-1) DO 70 K = 1,N DL(K) = S*DL(K) + C*V(K,IP1) 70 CONTINUE 75 CONTINUE ENDIF S = Q(2*LL) C = Q(2*LL-1)/SNORMW LLP1 = LL + 1 DO 80 K = 1,N DL(K) = S*DL(K) + C*V(K,LLP1) 80 CONTINUE DLNRM = DNRM2(N, DL, 1) RHO = RHO*DLNRM ENDIF RHOL = RHO ! ------------------------------------------------------------------- ! Test for convergence. If passed, compute approximation ZL. ! If failed and LL < MAXL, then continue iterating. ! ------------------------------------------------------------------- ITER = NRSTS*MAXL + LGMR if (ISDGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, & NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, DL, Z, WK, & RPAR, IPAR, RHOL, BNRM, SR, SZ, JSCAL, & KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, & HES, JPRE) /= 0) go to 200 if (LL == MAXL) go to 100 ! ------------------------------------------------------------------- ! Rescale so that the norm of V(1,LL+1) is one. ! ------------------------------------------------------------------- TEM = 1.0D0/SNORMW call DSCAL(N, TEM, V(1,LL+1), 1) 90 CONTINUE 100 CONTINUE if (RHO < R0NRM) go to 150 120 CONTINUE IFLAG = 2 ! ! Load approximate solution with zero. ! DO 130 I = 1,N Z(I) = 0 130 CONTINUE return 150 IFLAG = 1 ! ! Tolerance not met, but residual norm reduced. ! if (NRMAX > 0) THEN ! ! If performing restarting (NRMAX > 0) calculate the residual ! vector RL and store it in the DL array. If the incomplete ! version is being used (KMP < MAXL) then DL has already been ! calculated up to a scaling factor. Use DRLCAL to calculate ! the scaled residual vector. ! call DRLCAL(N, KMP, MAXL, MAXL, V, Q, DL, SNORMW, PROD, & R0NRM) end if ! ------------------------------------------------------------------- ! Compute the approximation ZL to the solution. Since the ! vector Z was used as workspace, and the initial guess ! of the linear iteration is zero, Z must be reset to zero. ! ------------------------------------------------------------------- 200 CONTINUE LL = LGMR LLP1 = LL + 1 DO 210 K = 1,LLP1 R0(K) = 0 210 CONTINUE R0(1) = R0NRM call DHELS(HES, MAXLP1, LL, Q, R0) DO 220 K = 1,N Z(K) = 0 220 CONTINUE DO 230 I = 1,LL call DAXPY(N, R0(I), V(1,I), 1, Z, 1) 230 CONTINUE if ((JSCAL == 1) .OR.(JSCAL == 3)) THEN DO 240 I = 1,N Z(I) = Z(I)/SZ(I) 240 CONTINUE end if if (JPRE > 0) THEN call DCOPY(N, Z, 1, WK, 1) call MSOLVE(N, WK, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) NMSL = NMSL + 1 end if return !------------- LAST LINE OF DPIGMR FOLLOWS ---------------------------- end subroutine DPINCW (MRELAS, NVARS, LMX, LBM, NPP, JSTRT, IBASIS, & IMAT, IBRC, IPR, IWR, IND, IBB, COSTSC, GG, ERDNRM, DULNRM, & AMAT, BASMAT, CSC, WR, WW, RZ, RG, COSTS, COLNRM, DUALS, & STPEDG) ! !! DPINCW is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPINCW-S, DPINCW-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/, ! REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/,/SDOT/DDOT/. ! ! THIS SUBPROGRAM IS PART OF THE DSPLP( ) PACKAGE. ! IT IMPLEMENTS THE PROCEDURE (INITIALIZE REDUCED COSTS AND ! STEEPEST EDGE WEIGHTS). ! !***SEE ALSO DSPLP !***ROUTINES CALLED DCOPY, DDOT, DPRWPG, IDLOC, LA05BD !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 890606 Changed references from IPLOC to IDLOC. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DPINCW INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),RZ(*),RG(*), & COSTS(*),COLNRM(*),DUALS(*),COSTSC,ERDNRM,DULNRM,GG,ONE,RZJ, & SCALR,ZERO,RCOST,CNORM DOUBLE PRECISION DDOT LOGICAL STPEDG,PAGEPL,TRANS !***FIRST EXECUTABLE STATEMENT DPINCW LPG=LMX-(NVARS+4) ZERO=0.D0 ONE=1.D0 ! ! FORM REDUCED COSTS, RZ(*), AND STEEPEST EDGE WEIGHTS, RG(*). PAGEPL=.TRUE. RZ(1)=ZERO call DCOPY(NVARS+MRELAS,RZ,0,RZ,1) RG(1)=ONE call DCOPY(NVARS+MRELAS,RG,0,RG,1) NNEGRC=0 J=JSTRT 20002 if (.NOT.(IBB(J) <= 0)) go to 20004 PAGEPL=.TRUE. go to 20005 ! ! THESE ARE NONBASIC INDEPENDENT VARIABLES. THE COLS. ARE IN SPARSE ! MATRIX FORMAT. 20004 if (.NOT.(J <= NVARS)) go to 20007 RZJ=COSTSC*COSTS(J) WW(1)=ZERO call DCOPY(MRELAS,WW,0,WW,1) if (.NOT.(J == 1)) go to 20010 ILOW=NVARS+5 go to 20011 20010 ILOW=IMAT(J+3)+1 20011 CONTINUE if (.NOT.(PAGEPL)) go to 20013 IL1=IDLOC(ILOW,AMAT,IMAT) if (.NOT.(IL1 >= LMX-1)) go to 20016 ILOW=ILOW+2 IL1=IDLOC(ILOW,AMAT,IMAT) 20016 CONTINUE IPAGE=ABS(IMAT(LMX-1)) go to 20014 20013 IL1=IHI+1 20014 CONTINUE IHI=IMAT(J+4)-(ILOW-IL1) 20019 IU1=MIN(LMX-2,IHI) if (.NOT.(IL1 > IU1)) go to 20021 go to 20020 20021 CONTINUE DO 60 I=IL1,IU1 RZJ=RZJ-AMAT(I)*DUALS(IMAT(I)) WW(IMAT(I))=AMAT(I)*CSC(J) 60 CONTINUE if (.NOT.(IHI <= LMX-2)) go to 20024 go to 20020 20024 CONTINUE IPAGE=IPAGE+1 KEY=1 call DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG go to 20019 20020 PAGEPL=IHI == (LMX-2) RZ(J)=RZJ*CSC(J) if (.NOT.(STPEDG)) go to 20027 TRANS=.FALSE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) RG(J)=DDOT(MRELAS,WW,1,WW,1)+ONE 20027 CONTINUE ! ! THESE ARE NONBASIC DEPENDENT VARIABLES. THE COLS. ARE IMPLICITLY ! DEFINED. go to 20008 20007 PAGEPL=.TRUE. WW(1)=ZERO call DCOPY(MRELAS,WW,0,WW,1) SCALR=-ONE if (IND(J) == 2) SCALR=ONE I=J-NVARS RZ(J)=-SCALR*DUALS(I) WW(I)=SCALR if (.NOT.(STPEDG)) go to 20030 TRANS=.FALSE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) RG(J)=DDOT(MRELAS,WW,1,WW,1)+ONE 20030 CONTINUE CONTINUE 20008 CONTINUE ! 20005 RCOST=RZ(J) if (MOD(IBB(J),2) == 0) RCOST=-RCOST if (IND(J) == 4) RCOST=-ABS(RCOST) CNORM=ONE if (J <= NVARS) CNORM=COLNRM(J) if (RCOST+ERDNRM*DULNRM*CNORM < ZERO) NNEGRC=NNEGRC+1 J=MOD(J,MRELAS+NVARS)+1 if (.NOT.(NNEGRC >= NPP .OR. J == JSTRT)) go to 20033 go to 20003 20033 go to 20002 20003 JSTRT=J return end subroutine DPINIT (MRELAS, NVARS, COSTS, BL, BU, IND, PRIMAL, & INFO, AMAT, CSC, COSTSC, COLNRM, XLAMDA, ANORM, RHS, RHSNRM, & IBASIS, IBB, IMAT, LOPT) ! !! DPINIT is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPINIT-S, DPINIT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/ ! REVISED 810519-0900 ! REVISED YYMMDD-HHMM ! ! INITIALIZATION SUBROUTINE FOR DSPLP(*) PACKAGE. ! !***SEE ALSO DSPLP !***ROUTINES CALLED DASUM, DCOPY, DPNNZR !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DPINIT DOUBLE PRECISION AIJ,AMAT(*),ANORM,BL(*),BU(*),CMAX, & COLNRM(*),COSTS(*),COSTSC,CSC(*),CSUM,ONE,PRIMAL(*), & RHS(*),RHSNRM,SCALR,TESTSC,XLAMDA,ZERO DOUBLE PRECISION DASUM INTEGER IBASIS(*),IBB(*),IMAT(*),IND(*) LOGICAL CONTIN,USRBAS,COLSCP,CSTSCP,MINPRB,LOPT(8) ! !***FIRST EXECUTABLE STATEMENT DPINIT ZERO=0.D0 ONE=1.D0 CONTIN=LOPT(1) USRBAS=LOPT(2) COLSCP=LOPT(5) CSTSCP=LOPT(6) MINPRB=LOPT(7) ! ! SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS. go to 30001 ! ! INITIALIZE ACTIVE BASIS MATRIX. 20002 CONTINUE go to 30002 20003 RETURN ! ! PROCEDURE (SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS) ! ! DO COLUMN SCALING if NOT PROVIDED BY THE USER. 30001 if (.NOT.(.NOT. COLSCP)) go to 20004 J=1 N20007=NVARS go to 20008 20007 J=J+1 20008 if ((N20007-J) < 0) go to 20009 CMAX=ZERO I=0 20011 call DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I == 0)) go to 20013 go to 20012 20013 CONTINUE CMAX=MAX(CMAX,ABS(AIJ)) go to 20011 20012 if (.NOT.(CMAX == ZERO)) go to 20016 CSC(J)=ONE go to 20017 20016 CSC(J)=ONE/CMAX 20017 CONTINUE go to 20007 20009 CONTINUE ! ! FORM CHECK SUMS OF COLUMNS. COMPUTE MATRIX NORM OF SCALED MATRIX. 20004 ANORM = ZERO J=1 N20019=NVARS go to 20020 20019 J=J+1 20020 if ((N20019-J) < 0) go to 20021 PRIMAL(J)=ZERO CSUM = ZERO I=0 20023 call DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I <= 0)) go to 20025 go to 20024 20025 CONTINUE PRIMAL(J)=PRIMAL(J)+AIJ CSUM = CSUM+ABS(AIJ) go to 20023 20024 if (IND(J) == 2) CSC(J)=-CSC(J) PRIMAL(J)=PRIMAL(J)*CSC(J) COLNRM(J)=ABS(CSC(J)*CSUM) ANORM = MAX(ANORM,COLNRM(J)) go to 20019 ! ! if THE USER HAS NOT PROVIDED COST VECTOR SCALING THEN SCALE IT ! USING THE MAX. NORM OF THE TRANSFORMED COST VECTOR, if NONZERO. 20021 TESTSC=ZERO J=1 N20028=NVARS go to 20029 20028 J=J+1 20029 if ((N20028-J) < 0) go to 20030 TESTSC=MAX(TESTSC,ABS(CSC(J)*COSTS(J))) go to 20028 20030 if (.NOT.(.NOT.CSTSCP)) go to 20032 if (.NOT.(TESTSC > ZERO)) go to 20035 COSTSC=ONE/TESTSC go to 20036 20035 COSTSC=ONE 20036 CONTINUE CONTINUE 20032 XLAMDA=(COSTSC+COSTSC)*TESTSC if (XLAMDA == ZERO) XLAMDA=ONE ! ! if MAXIMIZATION PROBLEM, THEN CHANGE SIGN OF COSTSC AND LAMDA ! =WEIGHT FOR PENALTY-FEASIBILITY METHOD. if (.NOT.(.NOT.MINPRB)) go to 20038 COSTSC=-COSTSC 20038 go to 20002 !:CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (INITIALIZE RHS(*),IBASIS(*), AND IBB(*)) ! ! INITIALLY SET RIGHT-HAND SIDE VECTOR TO ZERO. 30002 call dinit ( MRELAS,ZERO,RHS,1) ! ! TRANSLATE RHS ACCORDING TO CLASSIFICATION OF INDEPENDENT VARIABLES J=1 N20041=NVARS go to 20042 20041 J=J+1 20042 if ((N20041-J) < 0) go to 20043 if (.NOT.(IND(J) == 1)) go to 20045 SCALR=-BL(J) go to 20046 20045 if (.NOT.(IND(J) == 2)) go to 10001 SCALR=-BU(J) go to 20046 10001 if (.NOT.(IND(J) == 3)) go to 10002 SCALR=-BL(J) go to 20046 10002 if (.NOT.(IND(J) == 4)) go to 10003 SCALR=ZERO 10003 CONTINUE 20046 CONTINUE if (.NOT.(SCALR /= ZERO)) go to 20048 I=0 20051 call DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I <= 0)) go to 20053 go to 20052 20053 CONTINUE RHS(I)=SCALR*AIJ+RHS(I) go to 20051 20052 CONTINUE 20048 CONTINUE go to 20041 ! ! TRANSLATE RHS ACCORDING TO CLASSIFICATION OF DEPENDENT VARIABLES. 20043 I=NVARS+1 N20056=NVARS+MRELAS go to 20057 20056 I=I+1 20057 if ((N20056-I) < 0) go to 20058 if (.NOT.(IND(I) == 1)) go to 20060 SCALR=BL(I) go to 20061 20060 if (.NOT.(IND(I) == 2)) go to 10004 SCALR=BU(I) go to 20061 10004 if (.NOT.(IND(I) == 3)) go to 10005 SCALR=BL(I) go to 20061 10005 if (.NOT.(IND(I) == 4)) go to 10006 SCALR=ZERO 10006 CONTINUE 20061 CONTINUE RHS(I-NVARS)=RHS(I-NVARS)+SCALR go to 20056 20058 RHSNRM=DASUM(MRELAS,RHS,1) ! ! if THIS IS NOT A CONTINUATION OR THE USER HAS NOT PROVIDED THE ! INITIAL BASIS, THEN THE INITIAL BASIS IS COMPRISED OF THE ! DEPENDENT VARIABLES. if (.NOT.(.NOT.(CONTIN .OR. USRBAS))) go to 20063 J=1 N20066=MRELAS go to 20067 20066 J=J+1 20067 if ((N20066-J) < 0) go to 20068 IBASIS(J)=NVARS+J go to 20066 20068 CONTINUE ! ! DEFINE THE ARRAY IBB(*) 20063 J=1 N20070=NVARS+MRELAS go to 20071 20070 J=J+1 20071 if ((N20070-J) < 0) go to 20072 IBB(J)=1 go to 20070 20072 J=1 N20074=MRELAS go to 20075 20074 J=J+1 20075 if ((N20074-J) < 0) go to 20076 IBB(IBASIS(J))=-1 go to 20074 ! ! DEFINE THE REST OF IBASIS(*) 20076 IP=MRELAS J=1 N20078=NVARS+MRELAS go to 20079 20078 J=J+1 20079 if ((N20078-J) < 0) go to 20080 if (.NOT.(IBB(J) > 0)) go to 20082 IP=IP+1 IBASIS(IP)=J 20082 go to 20078 20080 go to 20003 end subroutine DPINTM (M, N, SX, IX, LMX, IPAGEF) ! !! DPINTM is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PINITM-S, DPINTM-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! DPINTM LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. ! THE MATRIX IS STORED BY COLUMNS. ! SPARSE MATRIX INITIALIZATION SUBROUTINE. ! ! M=NUMBER OF ROWS OF THE MATRIX. ! N=NUMBER OF COLUMNS OF THE MATRIX. ! SX(*),IX(*)=THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE ! MATRIX. THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY ! THE PACKAGE FOR THE USER. ! LMX=LENGTH OF THE WORK ARRAY SX(*). ! LMX MUST BE AT LEAST N+7 WHERE ! FOR GREATEST EFFICIENCY LMX SHOULD BE AT LEAST N+NZ+6 ! WHERE NZ IS THE MAXIMUM NUMBER OF NONZEROES TO BE ! STORED IN THE MATRIX. VALUES OF LMX BETWEEN N+7 AND ! N+NZ+6 WILL CAUSE DEMAND PAGING TO OCCUR. ! THIS IS IMPLEMENTED BY THE PACKAGE. ! IX(*) MUST BE DIMENSIONED AT LEAST LMX ! IPAGEF=UNIT NUMBER WHERE DEMAND PAGES WILL BE STORED. ! ! THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LINITM, ! SANDIA LABS. REPT. SAND78-0785. ! MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON ! REVISED 811130-1000 ! REVISED YYMMDD-HHMM ! !***SEE ALSO DSPLP !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) !***END PROLOGUE DPINTM DOUBLE PRECISION SX(*),ZERO,ONE DIMENSION IX(*) SAVE ZERO, ONE DATA ZERO,ONE /0.D0,1.D0/ !***FIRST EXECUTABLE STATEMENT DPINTM IOPT=1 ! ! CHECK FOR INPUT ERRORS. ! if (.NOT.(M <= 0 .OR. N <= 0)) go to 20002 NERR=55 call XERMSG ('SLATEC', 'DPINTM', & 'MATRIX DIMENSION M OR N <= 0', NERR, IOPT) ! ! VERIFY if VALUE OF LMX IS LARGE ENOUGH. ! 20002 if (.NOT.(LMX < N+7)) go to 20005 NERR=55 call XERMSG ('SLATEC', 'DPINTM', & 'THE VALUE OF LMX IS TOO SMALL', NERR, IOPT) ! ! INITIALIZE DATA STRUCTURE INDEPENDENT VALUES. ! 20005 SX(1)=ZERO SX(2)=ZERO SX(3)=IPAGEF IX(1)=LMX IX(2)=M IX(3)=N IX(4)=0 SX(LMX-1)=ZERO SX(LMX)=-ONE IX(LMX-1)=-1 LP4=N+4 ! ! INITIALIZE DATA STRUCTURE DEPENDENT VALUES. ! I=4 N20008=LP4 go to 20009 20008 I=I+1 20009 if ((N20008-I) < 0) go to 20010 SX(I)=ZERO go to 20008 20010 I=5 N20012=LP4 go to 20013 20012 I=I+1 20013 if ((N20012-I) < 0) go to 20014 IX(I)=LP4 go to 20012 20014 SX(N+5)=ZERO IX(N+5)=0 IX(LMX)=0 ! ! INITIALIZATION COMPLETE. ! return end subroutine DPJAC (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, DF, & DJAC, RPAR, IPAR) ! !! DPJAC is subsidiary to DDEBDF. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PJAC-S, DPJAC-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DPJAC sets up the iteration matrix (involving the Jacobian) for the ! integration package DDEBDF. ! !***SEE ALSO DDEBDF !***ROUTINES CALLED DGBFA, DGEFA, DVNRMS !***COMMON BLOCKS DDEBD1 !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920422 Changed DIMENSION statement. (WRB) !***END PROLOGUE DPJAC ! INTEGER I, I1, I2, IER, II, IOWND, IOWNS, IPAR, IWM, J, J1, & JJ, JSTART, KFLAG, L, LENP, MAXORD, MBA, MBAND, & MEB1, MEBAND, METH, MITER, ML, ML3, MU, N, NEQ, & NFE, NJE, NQ, NQU, NST, NYH DOUBLE PRECISION CON, DI, DVNRMS, EL0, EWT, & FAC, FTEM, H, HL0, HMIN, HMXI, HU, R, R0, ROWND, ROWNS, & RPAR, SAVF, SRUR, TN, UROUND, WM, Y, YH, YI, YJ, YJJ EXTERNAL DF, DJAC DIMENSION Y(*),YH(NYH,*),EWT(*),FTEM(*),SAVF(*),WM(*),IWM(*), & RPAR(*),IPAR(*) COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, & IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, & MAXORD,N,NQ,NST,NFE,NJE,NQU ! ------------------------------------------------------------------ ! DPJAC IS CALLED BY DSTOD TO COMPUTE AND PROCESS THE MATRIX ! P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. ! HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE DJAC IF ! MITER = 1 OR 4, OR BY FINITE DIFFERENCING if MITER = 2, 3, OR 5. ! if MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. ! J IS STORED IN WM AND REPLACED BY P. if MITER /= 3, P IS THEN ! SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION ! OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE ! BY DGEFA if MITER = 1 OR 2, AND BY DGBFA IF MITER = 4 OR 5. ! ! IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION ! WITH DPJAC USES THE FOLLOWING.. ! Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. ! FTEM = WORK ARRAY OF LENGTH N (ACOR IN DSTOD ). ! SAVF = ARRAY CONTAINING DF EVALUATED AT PREDICTED Y. ! WM = DOUBLE PRECISION WORK SPACE FOR MATRICES. ON OUTPUT IT ! CONTAINS THE ! INVERSE DIAGONAL MATRIX if MITER = 3 AND THE LU ! DECOMPOSITION OF P if MITER IS 1, 2 , 4, OR 5. ! STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). ! WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. ! WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN ! INCREMENTS. WM(2) = H*EL0, SAVED FOR LATER USE if MITER = ! 3. ! IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING ! AT IWM(21), if MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS ! THE BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) if MITER ! IS 4 OR 5. ! EL0 = EL(1) (INPUT). ! IER = OUTPUT ERROR FLAG, = 0 if NO TROUBLE, /= 0 IF ! P MATRIX FOUND TO BE SINGULAR. ! THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, ! MITER, N, NFE, AND NJE. !----------------------------------------------------------------------- ! BEGIN BLOCK PERMITTING ...EXITS TO 240 ! BEGIN BLOCK PERMITTING ...EXITS TO 220 ! BEGIN BLOCK PERMITTING ...EXITS TO 130 ! BEGIN BLOCK PERMITTING ...EXITS TO 70 !***FIRST EXECUTABLE STATEMENT DPJAC NJE = NJE + 1 HL0 = H*EL0 go to (10,40,90,140,170), MITER ! if MITER = 1, call DJAC AND MULTIPLY BY SCALAR. ! ----------------------- 10 CONTINUE LENP = N*N DO 20 I = 1, LENP WM(I+2) = 0.0D0 20 CONTINUE call DJAC(TN,Y,WM(3),N,RPAR,IPAR) CON = -HL0 DO 30 I = 1, LENP WM(I+2) = WM(I+2)*CON 30 CONTINUE ! ...EXIT go to 70 ! if MITER = 2, MAKE N CALLS TO DF TO APPROXIMATE J. ! -------------------- 40 CONTINUE FAC = DVNRMS(N,SAVF,EWT) R0 = 1000.0D0*ABS(H)*UROUND*N*FAC if (R0 == 0.0D0) R0 = 1.0D0 SRUR = WM(1) J1 = 2 DO 60 J = 1, N YJ = Y(J) R = MAX(SRUR*ABS(YJ),R0*EWT(J)) Y(J) = Y(J) + R FAC = -HL0/R call DF(TN,Y,FTEM,RPAR,IPAR) DO 50 I = 1, N WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 50 CONTINUE Y(J) = YJ J1 = J1 + N 60 CONTINUE NFE = NFE + N 70 CONTINUE ! ADD IDENTITY MATRIX. ! ------------------------------------------------- J = 3 DO 80 I = 1, N WM(J) = WM(J) + 1.0D0 J = J + (N + 1) 80 CONTINUE ! DO LU DECOMPOSITION ON P. ! -------------------------------------------- call DGEFA(WM(3),N,N,IWM(21),IER) ! .........EXIT go to 240 ! if MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND ! P. --------- 90 CONTINUE WM(2) = HL0 IER = 0 R = EL0*0.1D0 DO 100 I = 1, N Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 100 CONTINUE call DF(TN,Y,WM(3),RPAR,IPAR) NFE = NFE + 1 DO 120 I = 1, N R0 = H*SAVF(I) - YH(I,2) DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) WM(I+2) = 1.0D0 if (ABS(R0) < UROUND*EWT(I)) go to 110 ! .........EXIT if (ABS(DI) == 0.0D0) go to 130 WM(I+2) = 0.1D0*R0/DI 110 CONTINUE 120 CONTINUE ! .........EXIT go to 240 130 CONTINUE IER = -1 ! ......EXIT go to 240 ! if MITER = 4, call DJAC AND MULTIPLY BY SCALAR. ! ----------------------- 140 CONTINUE ML = IWM(1) MU = IWM(2) ML3 = 3 MBAND = ML + MU + 1 MEBAND = MBAND + ML LENP = MEBAND*N DO 150 I = 1, LENP WM(I+2) = 0.0D0 150 CONTINUE call DJAC(TN,Y,WM(ML3),MEBAND,RPAR,IPAR) CON = -HL0 DO 160 I = 1, LENP WM(I+2) = WM(I+2)*CON 160 CONTINUE ! ...EXIT go to 220 ! if MITER = 5, MAKE MBAND CALLS TO DF TO APPROXIMATE J. ! ---------------- 170 CONTINUE ML = IWM(1) MU = IWM(2) MBAND = ML + MU + 1 MBA = MIN(MBAND,N) MEBAND = MBAND + ML MEB1 = MEBAND - 1 SRUR = WM(1) FAC = DVNRMS(N,SAVF,EWT) R0 = 1000.0D0*ABS(H)*UROUND*N*FAC if (R0 == 0.0D0) R0 = 1.0D0 DO 210 J = 1, MBA DO 180 I = J, N, MBAND YI = Y(I) R = MAX(SRUR*ABS(YI),R0*EWT(I)) Y(I) = Y(I) + R 180 CONTINUE call DF(TN,Y,FTEM,RPAR,IPAR) DO 200 JJ = J, N, MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = MAX(SRUR*ABS(YJJ),R0*EWT(JJ)) FAC = -HL0/R I1 = MAX(JJ-MU,1) I2 = MIN(JJ+ML,N) II = JJ*MEB1 - ML + 2 DO 190 I = I1, I2 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 190 CONTINUE 200 CONTINUE 210 CONTINUE NFE = NFE + MBA 220 CONTINUE ! ADD IDENTITY MATRIX. ! ------------------------------------------------- II = MBAND + 2 DO 230 I = 1, N WM(II) = WM(II) + 1.0D0 II = II + MEBAND 230 CONTINUE ! DO LU DECOMPOSITION OF P. ! -------------------------------------------- call DGBFA(WM(3),MEBAND,N,ML,MU,IWM(21),IER) 240 CONTINUE return ! ----------------------- END OF SUBROUTINE DPJAC ! ----------------------- end subroutine DPLINT (N, X, Y, C) ! !! DPLINT produces the polynomial which interpolates a set of discrete ... ! data points. ! !***LIBRARY SLATEC !***CATEGORY E1B !***TYPE DOUBLE PRECISION (POLINT-S, DPLINT-D) !***KEYWORDS POLYNOMIAL INTERPOLATION !***AUTHOR Huddleston, R. E., (SNLL) !***DESCRIPTION ! ! Abstract ! Subroutine DPLINT is designed to produce the polynomial which ! interpolates the data (X(I),Y(I)), I=1,...,N. DPLINT sets up ! information in the array C which can be used by subroutine DPOLVL ! to evaluate the polynomial and its derivatives and by subroutine ! DPOLCF to produce the coefficients. ! ! Formal Parameters ! *** All TYPE REAL variables are DOUBLE PRECISION *** ! N - the number of data points (N >= 1) ! X - the array of abscissas (all of which must be distinct) ! Y - the array of ordinates ! C - an array of information used by subroutines ! ******* Dimensioning Information ******* ! Arrays X,Y, and C must be dimensioned at least N in the calling ! program. ! !***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, ! Curve fitting by polynomials in one variable, Report ! SLA-74-0270, Sandia Laboratories, June 1974. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 740601 DATE WRITTEN ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPLINT INTEGER I,K,KM1,N DOUBLE PRECISION DIF,C(*),X(*),Y(*) !***FIRST EXECUTABLE STATEMENT DPLINT if (N <= 0) go to 91 C(1)=Y(1) if ( N == 1) RETURN DO 10010 K=2,N C(K)=Y(K) KM1=K-1 DO 10010 I=1,KM1 ! CHECK FOR DISTINCT X VALUES DIF = X(I)-X(K) if (DIF == 0.0) go to 92 C(K) = (C(I)-C(K))/DIF 10010 CONTINUE return 91 call XERMSG ('SLATEC', 'DPLINT', 'N IS ZERO OR NEGATIVE.', 2, 1) return 92 call XERMSG ('SLATEC', 'DPLINT', & 'THE ABSCISSAS ARE NOT DISTINCT.', 2, 1) return end subroutine DPLPCE (MRELAS, NVARS, LMX, LBM, ITLP, ITBRC, IBASIS, & IMAT, IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, TUNE, GG, AMAT, & BASMAT, CSC, WR, WW, PRIMAL, ERD, ERP, SINGLR, REDBAS) ! !! DPLPCE is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPLPCE-S, DPLPCE-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/, ! /SASUM/DASUM/,/DCOPY/,DCOPY/. ! ! REVISED 811219-1630 ! REVISED YYMMDD-HHMM ! ! THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE. IT CALCULATES ! THE APPROXIMATE ERROR IN THE PRIMAL AND DUAL SYSTEMS. IT IS ! THE MAIN PART OF THE PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL ! SYSTEMS). ! !***SEE ALSO DSPLP !***ROUTINES CALLED DASUM, DCOPY, DPRWPG, IDLOC, LA05BD !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 890606 Changed references from IPLOC to IDLOC. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DPLPCE INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),PRIMAL(*), & ERD(*),ERP(*),EPS,ERDNRM,FACTOR,GG,ONE,ZERO,TEN,TUNE DOUBLE PRECISION DASUM LOGICAL SINGLR,REDBAS,TRANS,PAGEPL !***FIRST EXECUTABLE STATEMENT DPLPCE ZERO=0.D0 ONE=1.D0 TEN=10.D0 LPG=LMX-(NVARS+4) SINGLR=.FALSE. FACTOR=0.01 ! ! COPY COLSUMS IN WW(*), AND SOLVE TRANSPOSED SYSTEM. I=1 N20002=MRELAS go to 20003 20002 I=I+1 20003 if ((N20002-I) < 0) go to 20004 J=IBASIS(I) if (.NOT.(J <= NVARS)) go to 20006 WW(I) = PRIMAL(J) go to 20007 20006 if (.NOT.(IND(J) == 2)) go to 20009 WW(I)=ONE go to 20010 20009 WW(I)=-ONE 20010 CONTINUE 20007 CONTINUE go to 20002 ! ! PERTURB RIGHT-SIDE IN UNITS OF LAST BITS TO BETTER REFLECT ! ERRORS IN THE CHECK SUM SOLNS. 20004 I=1 N20012=MRELAS go to 20013 20012 I=I+1 20013 if ((N20012-I) < 0) go to 20014 WW(I)=WW(I)+TEN*EPS*WW(I) go to 20012 20014 TRANS = .TRUE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) I=1 N20016=MRELAS go to 20017 20016 I=I+1 20017 if ((N20016-I) < 0) go to 20018 ERD(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE ! ! SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS > FACTOR. ! THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED. SINGLR=SINGLR.OR.(ERD(I) >= FACTOR) go to 20016 20018 ERDNRM=DASUM(MRELAS,ERD,1) ! ! RECALCULATE ROW CHECK SUMS EVERY ITBRC ITERATIONS OR WHEN ! A REDECOMPOSITION HAS OCCURRED. if (.NOT.(MOD(ITLP,ITBRC) == 0 .OR. REDBAS)) go to 20020 ! ! COMPUTE ROW SUMS, STORE IN WW(*), SOLVE PRIMAL SYSTEM. WW(1)=ZERO call DCOPY(MRELAS,WW,0,WW,1) PAGEPL=.TRUE. J=1 N20023=NVARS go to 20024 20023 J=J+1 20024 if ((N20023-J) < 0) go to 20025 if (.NOT.(IBB(J) >= ZERO)) go to 20027 ! ! THE VARIABLE IS NON-BASIC. PAGEPL=.TRUE. go to 20023 20027 if (.NOT.(J == 1)) go to 20030 ILOW=NVARS+5 go to 20031 20030 ILOW=IMAT(J+3)+1 20031 if (.NOT.(PAGEPL)) go to 20033 IL1=IDLOC(ILOW,AMAT,IMAT) if (.NOT.(IL1 >= LMX-1)) go to 20036 ILOW=ILOW+2 IL1=IDLOC(ILOW,AMAT,IMAT) 20036 CONTINUE IPAGE=ABS(IMAT(LMX-1)) go to 20034 20033 IL1=IHI+1 20034 IHI=IMAT(J+4)-(ILOW-IL1) 20039 IU1=MIN(LMX-2,IHI) if (.NOT.(IL1 > IU1)) go to 20041 go to 20040 20041 CONTINUE DO 20 I=IL1,IU1 WW(IMAT(I))=WW(IMAT(I))+AMAT(I)*CSC(J) 20 CONTINUE if (.NOT.(IHI <= LMX-2)) go to 20044 go to 20040 20044 CONTINUE IPAGE=IPAGE+1 KEY=1 call DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG go to 20039 20040 PAGEPL=IHI == (LMX-2) go to 20023 20025 L=1 N20047=MRELAS go to 20048 20047 L=L+1 20048 if ((N20047-L) < 0) go to 20049 J=IBASIS(L) if (.NOT.(J > NVARS)) go to 20051 I=J-NVARS if (.NOT.(IND(J) == 2)) go to 20054 WW(I)=WW(I)+ONE go to 20055 20054 WW(I)=WW(I)-ONE 20055 CONTINUE CONTINUE 20051 CONTINUE go to 20047 ! ! PERTURB RIGHT-SIDE IN UNITS OF LAST BIT POSITIONS. 20049 I=1 N20057=MRELAS go to 20058 20057 I=I+1 20058 if ((N20057-I) < 0) go to 20059 WW(I)=WW(I)+TEN*EPS*WW(I) go to 20057 20059 TRANS = .FALSE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) I=1 N20061=MRELAS go to 20062 20061 I=I+1 20062 if ((N20061-I) < 0) go to 20063 ERP(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE ! ! SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS > FACTOR. ! THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED. SINGLR=SINGLR.OR.(ERP(I) >= FACTOR) go to 20061 20063 CONTINUE ! 20020 RETURN end subroutine DPLPDM (MRELAS, NVARS, LMX, LBM, NREDC, INFO, IOPT, & IBASIS, IMAT, IBRC, IPR, IWR, IND, IBB, ANORM, EPS, UU, GG, & AMAT, BASMAT, CSC, WR, SINGLR, REDBAS) ! !! DPLPDM is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPLPDM-S, DPLPDM-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE. IT PERFORMS THE ! TASK OF DEFINING THE ENTRIES OF THE BASIS MATRIX AND ! DECOMPOSING IT USING THE LA05 PACKAGE. ! IT IS THE MAIN PART OF THE PROCEDURE (DECOMPOSE BASIS MATRIX). ! !***SEE ALSO DSPLP !***ROUTINES CALLED DASUM, DPNNZR, LA05AD, XERMSG !***COMMON BLOCKS LA05DD !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890605 Added DASUM to list of DOUBLE PRECISION variables. ! 890605 Removed unreferenced labels. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls, convert do-it-yourself ! DO loops to DO loops. (RWC) !***END PROLOGUE DPLPDM INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) DOUBLE PRECISION AIJ,AMAT(*),BASMAT(*),CSC(*),WR(*),ANORM,DASUM, & EPS,GG,ONE,SMALL,UU,ZERO LOGICAL SINGLR,REDBAS CHARACTER*16 XERN3 ! ! COMMON BLOCK USED BY LA05 () PACKAGE.. COMMON /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL ! !***FIRST EXECUTABLE STATEMENT DPLPDM ZERO = 0.D0 ONE = 1.D0 ! ! DEFINE BASIS MATRIX BY COLUMNS FOR SPARSE MATRIX EQUATION SOLVER. ! THE LA05AD() SUBPROGRAM REQUIRES THE NONZERO ENTRIES OF THE MATRIX ! TOGETHER WITH THE ROW AND COLUMN INDICES. ! NZBM = 0 ! ! DEFINE DEPENDENT VARIABLE COLUMNS. THESE ARE ! COLS. OF THE IDENTITY MATRIX AND IMPLICITLY GENERATED. ! DO 20 K = 1,MRELAS J = IBASIS(K) if (J > NVARS) THEN NZBM = NZBM+1 if (IND(J) == 2) THEN BASMAT(NZBM) = ONE ELSE BASMAT(NZBM) = -ONE ENDIF IBRC(NZBM,1) = J-NVARS IBRC(NZBM,2) = K ELSE ! ! DEFINE THE INDEP. VARIABLE COLS. THIS REQUIRES RETRIEVING ! THE COLS. FROM THE SPARSE MATRIX DATA STRUCTURE. ! I = 0 10 call DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) if (I > 0) THEN NZBM = NZBM+1 BASMAT(NZBM) = AIJ*CSC(J) IBRC(NZBM,1) = I IBRC(NZBM,2) = K go to 10 ENDIF ENDIF 20 CONTINUE ! SINGLR = .FALSE. ! ! RECOMPUTE MATRIX NORM USING CRUDE NORM = SUM OF MAGNITUDES. ! ANORM = DASUM(NZBM,BASMAT,1) SMALL = EPS*ANORM ! ! GET AN L-U FACTORIZATION OF THE BASIS MATRIX. ! NREDC = NREDC+1 REDBAS = .TRUE. call LA05AD(BASMAT,IBRC,NZBM,LBM,MRELAS,IPR,IWR,WR,GG,UU) ! ! CHECK RETURN VALUE OF ERROR FLAG, GG. ! if (GG >= ZERO) RETURN if (GG == (-7.)) THEN call XERMSG ('SLATEC', 'DPLPDM', & 'IN DSPLP, SHORT ON STORAGE FOR LA05AD. ' // & 'USE PRGOPT(*) TO GIVE MORE.', 28, IOPT) INFO = -28 ELSEIF (GG == (-5.)) THEN SINGLR = .TRUE. ELSE WRITE (XERN3, '(1PE15.6)') GG call XERMSG ('SLATEC', 'DPLPDM', & 'IN DSPLP, LA05AD RETURNED ERROR FLAG = ' // XERN3, & 27, IOPT) INFO = -27 end if return end subroutine DPLPFE (MRELAS, NVARS, LMX, LBM, IENTER, IBASIS, IMAT, & IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, GG, DULNRM, DIRNRM, & AMAT, BASMAT, CSC, WR, WW, BL, BU, RZ, RG, COLNRM, DUALS, & FOUND) ! !! DPLPFE is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPLPFE-S, DPLPFE-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/,/SASUM/DASUM/, ! /SCOPY/DCOPY/. ! ! THIS SUBPROGRAM IS PART OF THE DSPLP( ) PACKAGE. ! IT IMPLEMENTS THE PROCEDURE (FIND VARIABLE TO ENTER BASIS ! AND GET SEARCH DIRECTION). ! REVISED 811130-1100 ! REVISED YYMMDD-HHMM ! !***SEE ALSO DSPLP !***ROUTINES CALLED DASUM, DCOPY, DPRWPG, IDLOC, LA05BD !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 890606 Changed references from IPLOC to IDLOC. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DPLPFE INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),BL(*),BU(*), & RZ(*),RG(*),COLNRM(*),DUALS(*),CNORM,DIRNRM,DULNRM,EPS,ERDNRM,GG, & ONE,RATIO,RCOST,RMAX,ZERO DOUBLE PRECISION DASUM LOGICAL FOUND,TRANS !***FIRST EXECUTABLE STATEMENT DPLPFE LPG=LMX-(NVARS+4) ZERO=0.D0 ONE=1.D0 RMAX=ZERO FOUND=.FALSE. I=MRELAS+1 N20002=MRELAS+NVARS go to 20003 20002 I=I+1 20003 if ((N20002-I) < 0) go to 20004 J=IBASIS(I) ! ! if J=IBASIS(I) < 0 THEN THE VARIABLE LEFT AT A ZERO LEVEL ! AND IS NOT CONSIDERED AS A CANDIDATE TO ENTER. if (.NOT.(J > 0)) go to 20006 ! ! DO NOT CONSIDER VARIABLES CORRESPONDING TO UNBOUNDED STEP LENGTHS. if (.NOT.(IBB(J) == 0)) go to 20009 go to 20002 20009 CONTINUE ! ! if A VARIABLE CORRESPONDS TO AN EQUATION(IND=3 AND BL=BU), ! THEN DO NOT CONSIDER IT AS A CANDIDATE TO ENTER. if (.NOT.(IND(J) == 3)) go to 20012 if (.NOT.((BU(J)-BL(J)) <= EPS*(ABS(BL(J))+ABS(BU(J))))) & go to 20015 go to 20002 20015 CONTINUE CONTINUE 20012 CONTINUE RCOST=RZ(J) ! ! if VARIABLE IS AT UPPER BOUND IT CAN ONLY DECREASE. THIS ! ACCOUNTS FOR THE POSSIBLE CHANGE OF SIGN. if ( MOD(IBB(J),2) == 0) RCOST=-RCOST ! ! if THE VARIABLE IS FREE, USE THE NEGATIVE MAGNITUDE OF THE ! REDUCED COST FOR THAT VARIABLE. if ( IND(J) == 4) RCOST=-ABS(RCOST) CNORM=ONE if ( J <= NVARS)CNORM=COLNRM(J) ! ! TEST FOR NEGATIVITY OF REDUCED COSTS. if (.NOT.(RCOST+ERDNRM*DULNRM*CNORM < ZERO)) go to 20018 FOUND=.TRUE. RATIO=RCOST**2/RG(J) if (.NOT.(RATIO > RMAX)) go to 20021 RMAX=RATIO IENTER=I 20021 CONTINUE CONTINUE 20018 CONTINUE CONTINUE 20006 go to 20002 ! ! USE COL. CHOSEN TO COMPUTE SEARCH DIRECTION. 20004 if (.NOT.(FOUND)) go to 20024 J=IBASIS(IENTER) WW(1)=ZERO call DCOPY(MRELAS,WW,0,WW,1) if (.NOT.(J <= NVARS)) go to 20027 if (.NOT.(J == 1)) go to 20030 ILOW=NVARS+5 go to 20031 20030 ILOW=IMAT(J+3)+1 20031 CONTINUE IL1=IDLOC(ILOW,AMAT,IMAT) if (.NOT.(IL1 >= LMX-1)) go to 20033 ILOW=ILOW+2 IL1=IDLOC(ILOW,AMAT,IMAT) 20033 CONTINUE IPAGE=ABS(IMAT(LMX-1)) IHI=IMAT(J+4)-(ILOW-IL1) 20036 IU1=MIN(LMX-2,IHI) if (.NOT.(IL1 > IU1)) go to 20038 go to 20037 20038 CONTINUE DO 30 I=IL1,IU1 WW(IMAT(I))=AMAT(I)*CSC(J) 30 CONTINUE if (.NOT.(IHI <= LMX-2)) go to 20041 go to 20037 20041 CONTINUE IPAGE=IPAGE+1 KEY=1 call DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG go to 20036 20037 go to 20028 20027 if (.NOT.(IND(J) == 2)) go to 20044 WW(J-NVARS)=ONE go to 20045 20044 WW(J-NVARS)=-ONE 20045 CONTINUE CONTINUE ! ! COMPUTE SEARCH DIRECTION. 20028 TRANS=.FALSE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) ! ! THE SEARCH DIRECTION REQUIRES THE FOLLOWING SIGN CHANGE if EITHER ! VARIABLE ENTERING IS AT ITS UPPER BOUND OR IS FREE AND HAS ! POSITIVE REDUCED COST. if (.NOT.(MOD(IBB(J),2) == 0.OR.(IND(J) == 4 .AND. RZ(J) > ZERO)) & ) go to 20047 I=1 N20050=MRELAS go to 20051 20050 I=I+1 20051 if ((N20050-I) < 0) go to 20052 WW(I)=-WW(I) go to 20050 20052 CONTINUE 20047 DIRNRM=DASUM(MRELAS,WW,1) ! ! COPY CONTENTS OF WR(*) TO DUALS(*) FOR USE IN ! ADD-DROP (EXCHANGE) STEP, LA05CD( ). call DCOPY(MRELAS,WR,1,DUALS,1) 20024 RETURN end subroutine DPLPFL (MRELAS, NVARS, IENTER, ILEAVE, IBASIS, IND, & IBB, THETA, DIRNRM, RPRNRM, CSC, WW, BL, BU, ERP, RPRIM, & PRIMAL, FINITE, ZEROLV) ! !! DPLPFL is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPLPFL-S, DPLPFL-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/. ! ! THIS SUBPROGRAM IS PART OF THE DSPLP( ) PACKAGE. ! IT IMPLEMENTS THE PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS). ! REVISED 811130-1045 ! REVISED YYMMDD-HHMM ! !***SEE ALSO DSPLP !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DPLPFL INTEGER IBASIS(*),IND(*),IBB(*) DOUBLE PRECISION CSC(*),WW(*),BL(*),BU(*),ERP(*),RPRIM(*), & PRIMAL(*),BOUND,DIRNRM,RATIO,RPRNRM,THETA,ZERO LOGICAL FINITE,ZEROLV !***FIRST EXECUTABLE STATEMENT DPLPFL ZERO=0.D0 ! ! SEE if THE ENTERING VARIABLE IS RESTRICTING THE STEP LENGTH ! BECAUSE OF AN UPPER BOUND. FINITE=.FALSE. J=IBASIS(IENTER) if (.NOT.(IND(J) == 3)) go to 20002 THETA=BU(J)-BL(J) if ( J <= NVARS)THETA=THETA/CSC(J) FINITE=.TRUE. ILEAVE=IENTER ! ! NOW USE THE BASIC VARIABLES TO POSSIBLY RESTRICT THE STEP ! LENGTH EVEN FURTHER. 20002 I=1 N20005=MRELAS go to 20006 20005 I=I+1 20006 if ((N20005-I) < 0) go to 20007 J=IBASIS(I) ! ! if THIS IS A FREE VARIABLE, DO NOT USE IT TO ! RESTRICT THE STEP LENGTH. if (.NOT.(IND(J) == 4)) go to 20009 go to 20005 ! ! if DIRECTION COMPONENT IS ABOUT ZERO, IGNORE IT FOR COMPUTING ! THE STEP LENGTH. 20009 if (.NOT.(ABS(WW(I)) <= DIRNRM*ERP(I))) go to 20012 go to 20005 20012 if (.NOT.(WW(I) > ZERO)) go to 20015 ! ! if RPRIM(I) IS ESSENTIALLY ZERO, SET RATIO TO ZERO AND EXIT LOOP. if (.NOT.(ABS(RPRIM(I)) <= RPRNRM*ERP(I))) go to 20018 THETA=ZERO ILEAVE=I FINITE=.TRUE. go to 20008 ! ! THE VALUE OF RPRIM(I) WILL DECREASE ONLY TO ITS LOWER BOUND OR ! ONLY TO ITS UPPER BOUND. if IT DECREASES TO ITS ! UPPER BOUND, THEN RPRIM(I) HAS ALREADY BEEN TRANSLATED ! TO ITS UPPER BOUND AND NOTHING NEEDS TO BE DONE TO IBB(J). 20018 if (.NOT.(RPRIM(I) > ZERO)) go to 10001 RATIO=RPRIM(I)/WW(I) if (.NOT.(.NOT.FINITE)) go to 20021 ILEAVE=I THETA=RATIO FINITE=.TRUE. go to 20022 20021 if (.NOT.(RATIO < THETA)) go to 10002 ILEAVE=I THETA=RATIO 10002 CONTINUE 20022 CONTINUE go to 20019 ! ! THE VALUE RPRIM(I) < ZERO WILL NOT RESTRICT THE STEP. 10001 CONTINUE ! ! THE DIRECTION COMPONENT IS NEGATIVE, THEREFORE THE VARIABLE WILL ! INCREASE. 20019 go to 20016 ! ! if THE VARIABLE IS LESS THAN ITS LOWER BOUND, IT CAN ! INCREASE ONLY TO ITS LOWER BOUND. 20015 if (.NOT.(PRIMAL(I+NVARS) < ZERO)) go to 20024 RATIO=RPRIM(I)/WW(I) if (RATIO < ZERO) RATIO=ZERO if (.NOT.(.NOT.FINITE)) go to 20027 ILEAVE=I THETA=RATIO FINITE=.TRUE. go to 20028 20027 if (.NOT.(RATIO < THETA)) go to 10003 ILEAVE=I THETA=RATIO 10003 CONTINUE 20028 CONTINUE ! ! if THE BASIC VARIABLE IS FEASIBLE AND IS NOT AT ITS UPPER BOUND, ! THEN IT CAN INCREASE TO ITS UPPER BOUND. go to 20025 20024 if (.NOT.(IND(J) == 3 .AND. PRIMAL(I+NVARS) == ZERO)) go to 10004 BOUND=BU(J)-BL(J) if ( J <= NVARS) BOUND=BOUND/CSC(J) RATIO=(BOUND-RPRIM(I))/(-WW(I)) if (.NOT.(.NOT.FINITE)) go to 20030 ILEAVE=-I THETA=RATIO FINITE=.TRUE. go to 20031 20030 if (.NOT.(RATIO < THETA)) go to 10005 ILEAVE=-I THETA=RATIO 10005 CONTINUE 20031 CONTINUE CONTINUE 10004 CONTINUE 20025 CONTINUE 20016 go to 20005 20007 CONTINUE ! ! if STEP LENGTH IS FINITE, SEE IF STEP LENGTH IS ABOUT ZERO. 20008 if (.NOT.(FINITE)) go to 20033 ZEROLV=.TRUE. I=1 N20036=MRELAS go to 20037 20036 I=I+1 20037 if ((N20036-I) < 0) go to 20038 ZEROLV=ZEROLV.AND. ABS(THETA*WW(I)) <= ERP(I)*RPRNRM if (.NOT.(.NOT. ZEROLV)) go to 20040 go to 20039 20040 go to 20036 20038 CONTINUE 20039 CONTINUE 20033 CONTINUE return end subroutine DPLPMN (DUSRMT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, & BL, BU, IND, INFO, PRIMAL, DUALS, AMAT, CSC, COLNRM, ERD, ERP, & BASMAT, WR, RZ, RG, RPRIM, RHS, WW, LMX, LBM, IBASIS, IBB, & IMAT, IBRC, IPR, IWR) ! !! DPLPMN is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPLPMN-S, DPLPMN-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT. ! THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR. ! ! MAIN SUBROUTINE FOR DSPLP PACKAGE. ! !***SEE ALSO DSPLP !***ROUTINES CALLED DASUM, DCOPY, DDOT, DPINCW, DPINIT, DPINTM, DPLPCE, ! DPLPDM, DPLPFE, DPLPFL, DPLPMU, DPLPUP, DPNNZR, ! DPOPT, DPRWPG, DVOUT, IVOUT, LA05BD, SCLOSM, XERMSG !***COMMON BLOCKS LA05DD !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE DPLPMN DOUBLE PRECISION ABIG,AIJ,AMAT(*),ANORM,ASMALL,BASMAT(*), & BL(*),BU(*),COLNRM(*),COSTS(*),COSTSC,CSC(*),DATTRV(*), & DIRNRM,DUALS(*),DULNRM,EPS,TUNE,ERD(*),ERDNRM,ERP(*),FACTOR,GG, & ONE,PRGOPT(*),PRIMAL(*),RESNRM,RG(*),RHS(*),RHSNRM,ROPT(07), & RPRIM(*),RPRNRM,RZ(*),RZJ,SCALR,SCOSTS,SIZE,SMALL,THETA, & TOLLS,UPBND,UU,WR(*),WW(*),XLAMDA,XVAL,ZERO,RDUM(01),TOLABS DOUBLE PRECISION DDOT,DASUM ! INTEGER IBASIS(*),IBB(*),IBRC(LBM,2),IMAT(*),IND(*), & IPR(*),IWR(*),INTOPT(08),IDUM(01) ! ! ARRAY LOCAL VARIABLES ! NAME(LENGTH) DESCRIPTION ! ! COSTS(NVARS) COST COEFFICIENTS ! PRGOPT( ) OPTION VECTOR ! DATTRV( ) DATA TRANSFER VECTOR ! PRIMAL(NVARS+MRELAS) AS OUTPUT IT IS PRIMAL SOLUTION OF LP. ! INTERNALLY, THE FIRST NVARS POSITIONS HOLD ! THE COLUMN CHECK SUMS. THE NEXT MRELAS ! POSITIONS HOLD THE CLASSIFICATION FOR THE ! BASIC VARIABLES -1 VIOLATES LOWER ! BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND ! DUALS(MRELAS+NVARS) DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE ! AS FIRST MRELAS ENTRIES. ! AMAT(LMX) SPARSE FORM OF DATA MATRIX ! IMAT(LMX) SPARSE FORM OF DATA MATRIX ! BL(NVARS+MRELAS) LOWER BOUNDS FOR VARIABLES ! BU(NVARS+MRELAS) UPPER BOUNDS FOR VARIABLES ! IND(NVARS+MRELAS) INDICATOR FOR VARIABLES ! CSC(NVARS) COLUMN SCALING ! IBASIS(NVARS+MRELAS) COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC ! IBB(NVARS+MRELAS) INDICATOR FOR NON-BASIC VARS., POLARITY OF ! VARS., AND POTENTIALLY INFINITE VARS. ! if IBB(J) < 0, VARIABLE J IS BASIC ! if IBB(J) > 0, VARIABLE J IS NON-BASIC ! if IBB(J) == 0, VARIABLE J HAS TO BE IGNORED ! BECAUSE IT WOULD CAUSE UNBOUNDED SOLN. ! WHEN MOD(IBB(J),2) == 0, VARIABLE IS AT ITS ! UPPER BOUND, OTHERWISE IT IS AT ITS LOWER ! BOUND ! COLNRM(NVARS) NORM OF COLUMNS ! ERD(MRELAS) ERRORS IN DUAL VARIABLES ! ERP(MRELAS) ERRORS IN PRIMAL VARIABLES ! BASMAT(LBM) BASIS MATRIX FOR HARWELL SPARSE CODE ! IBRC(LBM,2) ROW AND COLUMN POINTERS FOR BASMAT(*) ! IPR(2*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE ! IWR(8*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE ! WR(MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE ! RZ(NVARS+MRELAS) REDUCED COSTS ! RPRIM(MRELAS) INTERNAL PRIMAL SOLUTION ! RG(NVARS+MRELAS) COLUMN WEIGHTS ! WW(MRELAS) WORK ARRAY ! RHS(MRELAS) HOLDS TRANSLATED RIGHT HAND SIDE ! ! SCALAR LOCAL VARIABLES ! NAME TYPE DESCRIPTION ! ! LMX INTEGER LENGTH OF AMAT(*) ! LPG INTEGER LENGTH OF PAGE FOR AMAT(*) ! EPS DOUBLE MACHINE PRECISION ! TUNE DOUBLE PARAMETER TO SCALE ERROR ESTIMATES ! TOLLS DOUBLE RELATIVE TOLERANCE FOR SMALL RESIDUALS ! TOLABS DOUBLE ABSOLUTE TOLERANCE FOR SMALL RESIDUALS. ! USED if RELATIVE ERROR TEST FAILS. ! IN CONSTRAINT EQUATIONS ! FACTOR DOUBLE .01--DETERMINES if BASIS IS SINGULAR ! OR COMPONENT IS FEASIBLE. MAY NEED TO ! BE INCREASED TO 1.D0 ON SHORT WORD ! LENGTH MACHINES. ! ASMALL DOUBLE LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*) ! ABIG DOUBLE UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*) ! MXITLP INTEGER MAXIMUM NUMBER OF ITERATIONS FOR LP ! ITLP INTEGER ITERATION COUNTER FOR TOTAL LP ITERS ! COSTSC DOUBLE COSTS(*) SCALING ! SCOSTS DOUBLE TEMP LOC. FOR COSTSC. ! XLAMDA DOUBLE WEIGHT PARAMETER FOR PEN. METHOD. ! ANORM DOUBLE NORM OF DATA MATRIX AMAT(*) ! RPRNRM DOUBLE NORM OF THE SOLUTION ! DULNRM DOUBLE NORM OF THE DUALS ! ERDNRM DOUBLE NORM OF ERROR IN DUAL VARIABLES ! DIRNRM DOUBLE NORM OF THE DIRECTION VECTOR ! RHSNRM DOUBLE NORM OF TRANSLATED RIGHT HAND SIDE VECTOR ! RESNRM DOUBLE NORM OF RESIDUAL VECTOR FOR CHECKING ! FEASIBILITY ! NZBM INTEGER NUMBER OF NON-ZEROS IN BASMAT(*) ! LBM INTEGER LENGTH OF BASMAT(*) ! SMALL DOUBLE EPS*ANORM USED IN HARWELL SPARSE CODE ! LP INTEGER USED IN HARWELL LA05*() PACK AS OUTPUT ! FILE NUMBER. SET=I1MACH(4) NOW. ! UU DOUBLE 0.1--USED IN HARWELL SPARSE CODE ! FOR RELATIVE PIVOTING TOLERANCE. ! GG DOUBLE OUTPUT INFO FLAG IN HARWELL SPARSE CODE ! IPLACE INTEGER INTEGER USED BY SPARSE MATRIX CODES ! IENTER INTEGER NEXT COLUMN TO ENTER BASIS ! NREDC INTEGER NO. OF FULL REDECOMPOSITIONS ! KPRINT INTEGER LEVEL OF OUTPUT, =0-3 ! IDG INTEGER FORMAT AND PRECISION OF OUTPUT ! ITBRC INTEGER NO. OF ITERS. BETWEEN RECALCULATING ! THE ERROR IN THE PRIMAL SOLUTION. ! NPP INTEGER NO. OF NEGATIVE REDUCED COSTS REQUIRED ! IN PARTIAL PRICING ! JSTRT INTEGER STARTING PLACE FOR PARTIAL PRICING. ! LOGICAL COLSCP,SAVEDT,CONTIN,CSTSCP,UNBND, & FEAS,FINITE,FOUND,MINPRB,REDBAS, & SINGLR,SIZEUP,STPEDG,TRANS,USRBAS,ZEROLV,LOPT(08) CHARACTER*8 XERN1, XERN2 EQUIVALENCE (CONTIN,LOPT(1)),(USRBAS,LOPT(2)), & (SIZEUP,LOPT(3)),(SAVEDT,LOPT(4)),(COLSCP,LOPT(5)), & (CSTSCP,LOPT(6)),(MINPRB,LOPT(7)),(STPEDG,LOPT(8)), & (IDG,INTOPT(1)),(IPAGEF,INTOPT(2)),(ISAVE,INTOPT(3)), & (MXITLP,INTOPT(4)),(KPRINT,INTOPT(5)),(ITBRC,INTOPT(6)), & (NPP,INTOPT(7)),(LPRG,INTOPT(8)),(EPS,ROPT(1)),(ASMALL,ROPT(2)), & (ABIG,ROPT(3)),(COSTSC,ROPT(4)),(TOLLS,ROPT(5)),(TUNE,ROPT(6)), & (TOLABS,ROPT(7)) ! ! COMMON BLOCK USED BY LA05 () PACKAGE.. COMMON /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL EXTERNAL DUSRMT ! ! SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE. !***FIRST EXECUTABLE STATEMENT DPLPMN LP=0 ! ! THE VALUES ZERO AND ONE. ZERO=0.D0 ONE=1.D0 FACTOR=0.01D0 LPG=LMX-(NVARS+4) IOPT=1 INFO=0 UNBND=.FALSE. JSTRT=1 ! ! PROCESS USER OPTIONS IN PRGOPT(*). ! CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED. call DPOPT(PRGOPT,MRELAS,NVARS,INFO,CSC,IBASIS,ROPT,INTOPT,LOPT) if (.NOT.(INFO < 0)) go to 20002 go to 30001 20002 if (.NOT.(CONTIN)) go to 20003 go to 30002 20006 go to 20004 ! ! INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*). 20003 call DPINTM(MRELAS,NVARS,AMAT,IMAT,LMX,IPAGEF) ! ! UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY. 20004 call DPLPUP(DUSRMT,MRELAS,NVARS,PRGOPT,DATTRV, & BL,BU,IND,INFO,AMAT,IMAT,SIZEUP,ASMALL,ABIG) if (.NOT.(INFO < 0)) go to 20007 go to 30001 ! !++ CODE FOR OUTPUT=YES IS ACTIVE 20007 if (.NOT.(KPRINT >= 1)) go to 20008 go to 30003 20011 CONTINUE !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END ! ! INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN ! CHECK SUMS, AND FORM INITIAL BASIS MATRIX. 20008 call DPINIT(MRELAS,NVARS,COSTS,BL,BU,IND,PRIMAL,INFO, & AMAT,CSC,COSTSC,COLNRM,XLAMDA,ANORM,RHS,RHSNRM, & IBASIS,IBB,IMAT,LOPT) if (.NOT.(INFO < 0)) go to 20012 go to 30001 ! 20012 NREDC=0 ASSIGN 20013 TO NPR004 go to 30004 20013 if (.NOT.(SINGLR)) go to 20014 NERR=23 call XERMSG ('SLATEC', 'DPLPMN', & 'IN DSPLP, A SINGULAR INITIAL BASIS WAS ENCOUNTERED.', NERR, & IOPT) INFO=-NERR go to 30001 20014 ASSIGN 20018 TO NPR005 go to 30005 20018 ASSIGN 20019 TO NPR006 go to 30006 20019 ASSIGN 20020 TO NPR007 go to 30007 20020 if (.NOT.(USRBAS)) go to 20021 ASSIGN 20024 TO NPR008 go to 30008 20024 if (.NOT.(.NOT.FEAS)) go to 20025 NERR=24 call XERMSG ('SLATEC', 'DPLPMN', & 'IN DSPLP, AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.', & NERR, IOPT) INFO=-NERR go to 30001 20025 CONTINUE 20021 ITLP=0 ! ! LAMDA HAS BEEN SET TO A CONSTANT, PERFORM PENALTY METHOD. ASSIGN 20029 TO NPR009 go to 30009 20029 ASSIGN 20030 TO NPR010 go to 30010 20030 ASSIGN 20031 TO NPR006 go to 30006 20031 ASSIGN 20032 TO NPR008 go to 30008 20032 if (.NOT.(.NOT.FEAS)) go to 20033 ! ! SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF ! COSTSC) AND PERFORM STANDARD PHASE-1. if ( KPRINT >= 2)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-1'')', & IDG) SCOSTS=COSTSC COSTSC=ZERO ASSIGN 20036 TO NPR007 go to 30007 20036 ASSIGN 20037 TO NPR009 go to 30009 20037 ASSIGN 20038 TO NPR010 go to 30010 20038 ASSIGN 20039 TO NPR006 go to 30006 20039 ASSIGN 20040 TO NPR008 go to 30008 20040 if (.NOT.(FEAS)) go to 20041 ! ! SET LAMDA TO ZERO, COSTSC=SCOSTS, PERFORM STANDARD PHASE-2. if ( KPRINT > 1)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-2'')', & IDG) XLAMDA=ZERO COSTSC=SCOSTS ASSIGN 20044 TO NPR009 go to 30009 20044 CONTINUE 20041 go to 20034 ! CHECK if ANY BASIC VARIABLES ARE STILL CLASSIFIED AS ! INFEASIBLE. if ANY ARE, THEN THIS MAY NOT YET BE AN ! OPTIMAL POINT. THEREFORE SET LAMDA TO ZERO AND TRY ! TO PERFORM MORE SIMPLEX STEPS. 20033 I=1 N20046=MRELAS go to 20047 20046 I=I+1 20047 if ((N20046-I) < 0) go to 20048 if (PRIMAL(I+NVARS) /= ZERO) go to 20045 go to 20046 20048 go to 20035 20045 XLAMDA=ZERO ASSIGN 20050 TO NPR009 go to 30009 20050 CONTINUE 20034 CONTINUE ! 20035 ASSIGN 20051 TO NPR011 go to 30011 20051 if (.NOT.(FEAS.AND.(.NOT.UNBND))) go to 20052 INFO=1 go to 20053 20052 if (.NOT.((.NOT.FEAS).AND.(.NOT.UNBND))) go to 10001 NERR=1 call XERMSG ('SLATEC', 'DPLPMN', & 'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE', NERR, IOPT) INFO=-NERR go to 20053 10001 if (.NOT.(FEAS .AND. UNBND)) go to 10002 NERR=2 call XERMSG ('SLATEC', 'DPLPMN', & 'IN DSPLP, THE PROBLEM APPEARS TO HAVE NO FINITE SOLUTION.', & NERR, IOPT) INFO=-NERR go to 20053 10002 if (.NOT.((.NOT.FEAS).AND.UNBND)) go to 10003 NERR=3 call XERMSG ('SLATEC', 'DPLPMN', & 'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO ' // & 'HAVE NO FINITE SOLN.', NERR, IOPT) INFO=-NERR 10003 CONTINUE 20053 CONTINUE ! if (.NOT.(INFO == (-1) .OR. INFO == (-3))) go to 20055 SIZE=DASUM(NVARS,PRIMAL,1)*ANORM SIZE=SIZE/DASUM(NVARS,CSC,1) SIZE=SIZE+DASUM(MRELAS,PRIMAL(NVARS+1),1) I=1 N20058=NVARS+MRELAS go to 20059 20058 I=I+1 20059 if ((N20058-I) < 0) go to 20060 NX0066=IND(I) if (NX0066 < 1.OR.NX0066 > 4) go to 20066 go to (20062,20063,20064,20065), NX0066 20062 if (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR == SIZE)) go to 20068 go to 20058 20068 if (.NOT.(PRIMAL(I) > BL(I))) go to 10004 go to 20058 10004 IND(I)=-4 go to 20067 20063 if (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR == SIZE)) go to 20071 go to 20058 20071 if (.NOT.(PRIMAL(I) < BU(I))) go to 10005 go to 20058 10005 IND(I)=-4 go to 20067 20064 if (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR == SIZE)) go to 20074 go to 20058 20074 if (.NOT.(PRIMAL(I) < BL(I))) go to 10006 IND(I)=-4 go to 20075 10006 if (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR == SIZE)) go to 10007 go to 20058 10007 if (.NOT.(PRIMAL(I) > BU(I))) go to 10008 IND(I)=-4 go to 20075 10008 go to 20058 20075 go to 20067 20065 go to 20058 20066 CONTINUE 20067 go to 20058 20060 CONTINUE 20055 CONTINUE ! if (.NOT.(INFO == (-2) .OR. INFO == (-3))) go to 20077 J=1 N20080=NVARS go to 20081 20080 J=J+1 20081 if ((N20080-J) < 0) go to 20082 if (.NOT.(IBB(J) == 0)) go to 20084 NX0091=IND(J) if (NX0091 < 1.OR.NX0091 > 4) go to 20091 go to (20087,20088,20089,20090), NX0091 20087 BU(J)=BL(J) IND(J)=-3 go to 20092 20088 BL(J)=BU(J) IND(J)=-3 go to 20092 20089 go to 20080 20090 BL(J)=ZERO BU(J)=ZERO IND(J)=-3 20091 CONTINUE 20092 CONTINUE 20084 go to 20080 20082 CONTINUE 20077 CONTINUE !++ CODE FOR OUTPUT=YES IS ACTIVE if (.NOT.(KPRINT >= 1)) go to 20093 ASSIGN 20096 TO NPR012 go to 30012 20096 CONTINUE 20093 CONTINUE !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END go to 30001 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (COMPUTE RIGHT HAND SIDE) 30010 RHS(1)=ZERO call DCOPY(MRELAS,RHS,0,RHS,1) J=1 N20098=NVARS+MRELAS go to 20099 20098 J=J+1 20099 if ((N20098-J) < 0) go to 20100 NX0106=IND(J) if (NX0106 < 1.OR.NX0106 > 4) go to 20106 go to (20102,20103,20104,20105), NX0106 20102 SCALR=-BL(J) go to 20107 20103 SCALR=-BU(J) go to 20107 20104 SCALR=-BL(J) go to 20107 20105 SCALR=ZERO 20106 CONTINUE 20107 if (.NOT.(SCALR /= ZERO)) go to 20108 if (.NOT.(J <= NVARS)) go to 20111 I=0 20114 call DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I <= 0)) go to 20116 go to 20115 20116 RHS(I)=RHS(I)+AIJ*SCALR go to 20114 20115 go to 20112 20111 RHS(J-NVARS)=RHS(J-NVARS)-SCALR 20112 CONTINUE 20108 go to 20098 20100 J=1 N20119=NVARS+MRELAS go to 20120 20119 J=J+1 20120 if ((N20119-J) < 0) go to 20121 SCALR=ZERO if ( IND(J) == 3.AND.MOD(IBB(J),2) == 0) SCALR=BU(J)-BL(J) if (.NOT.(SCALR /= ZERO)) go to 20123 if (.NOT.(J <= NVARS)) go to 20126 I=0 20129 call DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I <= 0)) go to 20131 go to 20130 20131 RHS(I)=RHS(I)-AIJ*SCALR go to 20129 20130 go to 20127 20126 RHS(J-NVARS)=RHS(J-NVARS)+SCALR 20127 CONTINUE 20123 go to 20119 20121 CONTINUE go to NPR010, (20030,20038) ! PROCEDURE (PERFORM SIMPLEX STEPS) 30009 ASSIGN 20134 TO NPR013 go to 30013 20134 ASSIGN 20135 TO NPR014 go to 30014 20135 if (.NOT.(KPRINT > 2)) go to 20136 call DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG) call DVOUT(NVARS+MRELAS,RZ,'('' REDUCED COSTS'')',IDG) 20136 CONTINUE 20139 ASSIGN 20141 TO NPR015 go to 30015 20141 if (.NOT.(.NOT. FOUND)) go to 20142 go to 30016 20145 CONTINUE 20142 if (.NOT.(FOUND)) go to 20146 if (KPRINT >= 3) call DVOUT(MRELAS,WW,'('' SEARCH DIRECTION'')', & IDG) go to 30017 20149 if (.NOT.(FINITE)) go to 20150 go to 30018 20153 ASSIGN 20154 TO NPR005 go to 30005 20154 go to 20151 20150 UNBND=.TRUE. IBB(IBASIS(IENTER))=0 20151 go to 20147 20146 go to 20140 20147 ITLP=ITLP+1 go to 30019 20155 go to 20139 20140 CONTINUE go to NPR009, (20029,20037,20044,20050) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE) 30002 LPR=NVARS+4 REWIND ISAVE READ(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR) KEY=2 IPAGE=1 go to 20157 20156 if (NP < 0) go to 20158 20157 LPR1=LPR+1 READ(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX) call DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) NP=IMAT(LMX-1) IPAGE=IPAGE+1 go to 20156 20158 NPARM=NVARS+MRELAS READ(ISAVE) (IBASIS(I),I=1,NPARM) REWIND ISAVE go to 20006 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (SAVE DATA ON FILE ISAVE) ! ! SOME PAGES MAY NOT BE WRITTEN YET. 30020 if (.NOT.(AMAT(LMX) == ONE)) go to 20159 AMAT(LMX)=ZERO KEY=2 IPAGE=ABS(IMAT(LMX-1)) call DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) ! ! FORCE PAGE FILE TO BE OPENED ON RESTARTS. 20159 KEY=AMAT(4) AMAT(4)=ZERO LPR=NVARS+4 WRITE(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR) AMAT(4)=KEY IPAGE=1 KEY=1 go to 20163 20162 if (NP < 0) go to 20164 20163 call DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) LPR1=LPR+1 WRITE(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX) NP=IMAT(LMX-1) IPAGE=IPAGE+1 go to 20162 20164 NPARM=NVARS+MRELAS WRITE(ISAVE) (IBASIS(I),I=1,NPARM) endFILE ISAVE ! ! CLOSE FILE, IPAGEF, WHERE PAGES ARE STORED. THIS IS NEEDED SO THAT ! THE PAGES MAY BE RESTORED AT A CONTINUATION OF DSPLP(). go to 20317 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (DECOMPOSE BASIS MATRIX) !++ CODE FOR OUTPUT=YES IS ACTIVE 30004 if (.NOT.(KPRINT >= 2)) go to 20165 call IVOUT(MRELAS,IBASIS, & '('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')', & IDG) !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END ! ! SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE. 20165 UU=0.1 call DPLPDM( & MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & ANORM,EPS,UU,GG, & AMAT,BASMAT,CSC,WR, & SINGLR,REDBAS) if (.NOT.(INFO < 0)) go to 20168 go to 30001 20168 CONTINUE go to NPR004, (20013,20204,20242) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (CLASSIFY VARIABLES) ! ! DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES ! -1 VIOLATES LOWER BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND. ! (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS)) ! TRANSLATE VARIABLE TO ITS UPPER BOUND, if > UPPER BOUND 30007 PRIMAL(NVARS+1)=ZERO call DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1) I=1 N20172=MRELAS go to 20173 20172 I=I+1 20173 if ((N20172-I) < 0) go to 20174 J=IBASIS(I) if (.NOT.(IND(J) /= 4)) go to 20176 if (.NOT.(RPRIM(I) < ZERO)) go to 20179 PRIMAL(I+NVARS)=-ONE go to 20180 20179 if (.NOT.(IND(J) == 3)) go to 10009 UPBND=BU(J)-BL(J) if (J <= NVARS) UPBND=UPBND/CSC(J) if (.NOT.(RPRIM(I) > UPBND)) go to 20182 RPRIM(I)=RPRIM(I)-UPBND if (.NOT.(J <= NVARS)) go to 20185 K=0 20188 call DPNNZR(K,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(K <= 0)) go to 20190 go to 20189 20190 RHS(K)=RHS(K)-UPBND*AIJ*CSC(J) go to 20188 20189 go to 20186 20185 RHS(J-NVARS)=RHS(J-NVARS)+UPBND 20186 PRIMAL(I+NVARS)=ONE 20182 CONTINUE CONTINUE 10009 CONTINUE 20180 CONTINUE 20176 go to 20172 20174 CONTINUE go to NPR007, (20020,20036) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS) 30005 NTRIES=1 go to 20195 20194 NTRIES=NTRIES+1 20195 if ((2-NTRIES) < 0) go to 20196 call DPLPCE( & MRELAS,NVARS,LMX,LBM,ITLP,ITBRC, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & ERDNRM,EPS,TUNE,GG, & AMAT,BASMAT,CSC,WR,WW,PRIMAL,ERD,ERP, & SINGLR,REDBAS) if (.NOT.(.NOT. SINGLR)) go to 20198 !++ CODE FOR OUTPUT=YES IS ACTIVE if (.NOT.(KPRINT >= 3)) go to 20201 call DVOUT(MRELAS,ERP,'('' EST. ERROR IN PRIMAL COMPS.'')',IDG) call DVOUT(MRELAS,ERD,'('' EST. ERROR IN DUAL COMPS.'')',IDG) 20201 CONTINUE !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END go to 20193 20198 if (NTRIES == 2) go to 20197 ASSIGN 20204 TO NPR004 go to 30004 20204 CONTINUE go to 20194 20196 CONTINUE 20197 NERR=26 call XERMSG ('SLATEC', 'DPLPMN', & 'IN DSPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.', & NERR, IOPT) INFO=-NERR go to 30001 20193 CONTINUE go to NPR005, (20018,20154,20243) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (CHECK FEASIBILITY) ! ! SEE if NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT ! EQUATIONS. ! ! COPY RHS INTO WW(*), THEN UPDATE WW(*). 30008 call DCOPY(MRELAS,RHS,1,WW,1) J=1 N20206=MRELAS go to 20207 20206 J=J+1 20207 if ((N20206-J) < 0) go to 20208 IBAS=IBASIS(J) XVAL=RPRIM(J) ! ! ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND. if (IND(IBAS) <= 3) XVAL=MAX(ZERO,XVAL) ! ! if THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND. if (.NOT.(IND(IBAS) == 3)) go to 20210 UPBND=BU(IBAS)-BL(IBAS) if (IBAS <= NVARS) UPBND=UPBND/CSC(IBAS) XVAL=MIN(UPBND,XVAL) 20210 CONTINUE ! ! SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*) if (.NOT.(XVAL /= ZERO)) go to 20213 if (.NOT.(IBAS <= NVARS)) go to 20216 I=0 20219 call DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,IBAS) if (.NOT.(I <= 0)) go to 20221 go to 20220 20221 WW(I)=WW(I)-XVAL*AIJ*CSC(IBAS) go to 20219 20220 go to 20217 20216 if (.NOT.(IND(IBAS) == 2)) go to 20224 WW(IBAS-NVARS)=WW(IBAS-NVARS)-XVAL go to 20225 20224 WW(IBAS-NVARS)=WW(IBAS-NVARS)+XVAL 20225 CONTINUE CONTINUE 20217 CONTINUE 20213 CONTINUE go to 20206 ! ! COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY. 20208 RESNRM=DASUM(MRELAS,WW,1) FEAS=RESNRM <= TOLLS*(RPRNRM*ANORM+RHSNRM) ! ! TRY AN ABSOLUTE ERROR TEST if THE RELATIVE TEST FAILS. if ( .NOT. FEAS)FEAS=RESNRM <= TOLABS if (.NOT.(FEAS)) go to 20227 PRIMAL(NVARS+1)=ZERO call DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1) 20227 CONTINUE go to NPR008, (20024,20032,20040) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS) 30014 call DPINCW( & MRELAS,NVARS,LMX,LBM,NPP,JSTRT, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & COSTSC,GG,ERDNRM,DULNRM, & AMAT,BASMAT,CSC,WR,WW,RZ,RG,COSTS,COLNRM,DUALS, & STPEDG) ! go to NPR014, (20135,20246) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS) 30019 if (.NOT.(ITLP > MXITLP)) go to 20230 NERR=25 ASSIGN 20233 TO NPR011 go to 30011 !++ CODE FOR OUTPUT=YES IS ACTIVE 20233 if (.NOT.(KPRINT >= 1)) go to 20234 ASSIGN 20237 TO NPR012 go to 30012 20237 CONTINUE 20234 CONTINUE !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END IDUM(1)=0 if ( SAVEDT) IDUM(1)=ISAVE WRITE (XERN1, '(I8)') MXITLP WRITE (XERN2, '(I8)') IDUM(1) call XERMSG ('SLATEC', 'DPLPMN', & 'IN DSPLP, MAX ITERATIONS = ' // XERN1 // & ' TAKEN. UP-TO-DATE RESULTS SAVED ON FILE NO. ' // XERN2 // & '. if FILE NO. = 0, NO SAVE.', NERR, IOPT) INFO=-NERR go to 30001 20230 CONTINUE go to 20155 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN) 30016 if (.NOT.(.NOT.REDBAS)) go to 20239 ASSIGN 20242 TO NPR004 go to 30004 20242 ASSIGN 20243 TO NPR005 go to 30005 20243 ASSIGN 20244 TO NPR006 go to 30006 20244 ASSIGN 20245 TO NPR013 go to 30013 20245 ASSIGN 20246 TO NPR014 go to 30014 20246 CONTINUE ! ! ERASE NON-CYCLING MARKERS NEAR COMPLETION. 20239 I=MRELAS+1 N20247=MRELAS+NVARS go to 20248 20247 I=I+1 20248 if ((N20247-I) < 0) go to 20249 IBASIS(I)=ABS(IBASIS(I)) go to 20247 20249 ASSIGN 20251 TO NPR015 go to 30015 20251 CONTINUE go to 20145 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (COMPUTE NEW PRIMAL) ! ! COPY RHS INTO WW(*), SOLVE SYSTEM. 30006 call DCOPY(MRELAS,RHS,1,WW,1) TRANS = .FALSE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) call DCOPY(MRELAS,WW,1,RPRIM,1) RPRNRM=DASUM(MRELAS,RPRIM,1) go to NPR006, (20019,20031,20039,20244,20275) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (COMPUTE NEW DUALS) ! ! SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*). 30013 I=1 N20252=MRELAS go to 20253 20252 I=I+1 20253 if ((N20252-I) < 0) go to 20254 J=IBASIS(I) if (.NOT.(J <= NVARS)) go to 20256 DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS) go to 20257 20256 DUALS(I)=XLAMDA*PRIMAL(I+NVARS) 20257 CONTINUE go to 20252 ! 20254 TRANS=.TRUE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS) DULNRM=DASUM(MRELAS,DUALS,1) go to NPR013, (20134,20245,20267) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION) 30015 call DPLPFE( & MRELAS,NVARS,LMX,LBM,IENTER, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & ERDNRM,EPS,GG,DULNRM,DIRNRM, & AMAT,BASMAT,CSC,WR,WW,BL,BU,RZ,RG,COLNRM,DUALS, & FOUND) go to NPR015, (20141,20251) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS) 30017 call DPLPFL( & MRELAS,NVARS,IENTER,ILEAVE, & IBASIS,IND,IBB, & THETA,DIRNRM,RPRNRM, & CSC,WW,BL,BU,ERP,RPRIM,PRIMAL, & FINITE,ZEROLV) go to 20149 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (MAKE MOVE AND UPDATE) 30018 call DPLPMU( & MRELAS,NVARS,LMX,LBM,NREDC,INFO,IENTER,ILEAVE,IOPT,NPP,JSTRT, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & ANORM,EPS,UU,GG,RPRNRM,ERDNRM,DULNRM,THETA,COSTSC,XLAMDA,RHSNRM, & AMAT,BASMAT,CSC,WR,RPRIM,WW,BU,BL,RHS,ERD,ERP,RZ,RG,COLNRM,COSTS, & PRIMAL,DUALS,SINGLR,REDBAS,ZEROLV,STPEDG) if (.NOT.(INFO == (-26))) go to 20259 go to 30001 !++ CODE FOR OUTPUT=YES IS ACTIVE 20259 if (.NOT.(KPRINT >= 2)) go to 20263 go to 30021 20266 CONTINUE !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END 20263 CONTINUE go to 20153 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE(RESCALE AND REARRANGE VARIABLES) ! ! RESCALE THE DUAL VARIABLES. 30011 ASSIGN 20267 TO NPR013 go to 30013 20267 if (.NOT.(COSTSC /= ZERO)) go to 20268 I=1 N20271=MRELAS go to 20272 20271 I=I+1 20272 if ((N20271-I) < 0) go to 20273 DUALS(I)=DUALS(I)/COSTSC go to 20271 20273 CONTINUE 20268 ASSIGN 20275 TO NPR006 go to 30006 ! ! REAPPLY COLUMN SCALING TO PRIMAL. 20275 I=1 N20276=MRELAS go to 20277 20276 I=I+1 20277 if ((N20276-I) < 0) go to 20278 J=IBASIS(I) if (.NOT.(J <= NVARS)) go to 20280 SCALR=CSC(J) if ( IND(J) == 2)SCALR=-SCALR RPRIM(I)=RPRIM(I)*SCALR 20280 go to 20276 ! ! REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*) 20278 PRIMAL(1)=ZERO call DCOPY(NVARS+MRELAS,PRIMAL,0,PRIMAL,1) J=1 N20283=NVARS+MRELAS go to 20284 20283 J=J+1 20284 if ((N20283-J) < 0) go to 20285 IBAS=ABS(IBASIS(J)) XVAL=ZERO if (J <= MRELAS) XVAL=RPRIM(J) if (IND(IBAS) == 1) XVAL=XVAL+BL(IBAS) if (IND(IBAS) == 2) XVAL=BU(IBAS)-XVAL if (.NOT.(IND(IBAS) == 3)) go to 20287 if (MOD(IBB(IBAS),2) == 0) XVAL=BU(IBAS)-BL(IBAS)-XVAL XVAL = XVAL+BL(IBAS) 20287 PRIMAL(IBAS)=XVAL go to 20283 ! ! COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS. ! OTHER ENTRIES ARE ZERO. 20285 J=1 N20290=NVARS go to 20291 20290 J=J+1 20291 if ((N20290-J) < 0) go to 20292 RZJ=ZERO if (.NOT.(IBB(J) > ZERO .AND. IND(J) /= 4)) go to 20294 RZJ=COSTS(J) I=0 20297 call DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I <= 0)) go to 20299 go to 20298 20299 CONTINUE RZJ=RZJ-AIJ*DUALS(I) go to 20297 20298 CONTINUE 20294 DUALS(MRELAS+J)=RZJ go to 20290 20292 CONTINUE go to NPR011, (20051,20233) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC !++ CODE FOR OUTPUT=YES IS ACTIVE ! PROCEDURE (PRINT PROLOGUE) 30003 IDUM(1)=MRELAS call IVOUT(1,IDUM,'(''1NUM. OF DEPENDENT VARS., MRELAS'')',IDG) IDUM(1)=NVARS call IVOUT(1,IDUM,'('' NUM. OF INDEPENDENT VARS., NVARS'')',IDG) call IVOUT(1,IDUM,'('' DIMENSION OF COSTS(*)='')',IDG) IDUM(1)=NVARS+MRELAS call IVOUT( 1,IDUM, & '('' DIMENSIONS OF BL(*),BU(*),IND(*),PRIMAL(*),DUALS(*) ='')',IDG) call IVOUT(1,IDUM,'('' DIMENSION OF IBASIS(*)='')',IDG) IDUM(1)=LPRG+1 call IVOUT(1,IDUM,'('' DIMENSION OF PRGOPT(*)='')',IDG) call IVOUT(0,IDUM, & '('' 1-NVARS=INDEPENDENT VARIABLE INDICES.''/ & & '' (NVARS+1)-(NVARS+MRELAS)=DEPENDENT VARIABLE INDICES.''/ & & '' CONSTRAINT INDICATORS ARE 1-4 AND MEAN'')',IDG) call IVOUT(0,IDUM, & '('' 1=VARIABLE HAS ONLY LOWER BOUND.''/ & & '' 2=VARIABLE HAS ONLY UPPER BOUND.''/ & & '' 3=VARIABLE HAS BOTH BOUNDS.''/ & & '' 4=VARIABLE HAS NO BOUNDS, IT IS FREE.'')',IDG) call DVOUT(NVARS,COSTS,'('' ARRAY OF COSTS'')',IDG) call IVOUT(NVARS+MRELAS,IND, & '('' CONSTRAINT INDICATORS'')',IDG) call DVOUT(NVARS+MRELAS,BL, & '('' LOWER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG) call DVOUT(NVARS+MRELAS,BU, & '('' UPPER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG) if (.NOT.(KPRINT >= 2)) go to 20302 call IVOUT(0,IDUM, & '(''0NON-BASIC INDICES THAT ARE NEGATIVE SHOW VARIABLES'' & & '' EXCHANGED AT A ZERO''/'' STEP LENGTH'')',IDG) call IVOUT(0,IDUM, & '('' WHEN COL. NO. LEAVING=COL. NO. ENTERING, THE ENTERING '' & & ''VARIABLE MOVED''/'' TO ITS BOUND. IT REMAINS NON-BASIC.''/ & & '' WHEN COL. NO. OF BASIS EXCHANGED IS NEGATIVE, THE LEAVING''/ & & '' VARIABLE IS AT ITS UPPER BOUND.'')',IDG) 20302 CONTINUE go to 20011 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (PRINT SUMMARY) 30012 IDUM(1)=INFO call IVOUT(1,IDUM,'('' THE OUTPUT VALUE OF INFO IS'')',IDG) if (.NOT.(MINPRB)) go to 20305 call IVOUT(0,IDUM,'('' THIS IS A MINIMIZATION PROBLEM.'')',IDG) go to 20306 20305 call IVOUT(0,IDUM,'('' THIS IS A MAXIMIZATION PROBLEM.'')',IDG) 20306 if (.NOT.(STPEDG)) go to 20308 call IVOUT(0,IDUM,'('' STEEPEST EDGE PRICING WAS USED.'')',IDG) go to 20309 20308 call IVOUT(0,IDUM,'('' MINIMUM REDUCED COST PRICING WAS USED.'')', & IDG) 20309 RDUM(1)=DDOT(NVARS,COSTS,1,PRIMAL,1) call DVOUT(1,RDUM, & '('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',IDG) call DVOUT(NVARS+MRELAS,PRIMAL, & '('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',IDG) call DVOUT(MRELAS+NVARS,DUALS, & '('' THE OUTPUT DUAL VARIABLES'')',IDG) call IVOUT(NVARS+MRELAS,IBASIS, & '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG) IDUM(1)=ITLP call IVOUT(1,IDUM,'('' NO. OF ITERATIONS'')',IDG) IDUM(1)=NREDC call IVOUT(1,IDUM,'('' NO. OF FULL REDECOMPS'')',IDG) go to NPR012, (20096,20237) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (PRINT ITERATION SUMMARY) 30021 IDUM(1)=ITLP+1 call IVOUT(1,IDUM,'(''0ITERATION NUMBER'')',IDG) IDUM(1)=IBASIS(ABS(ILEAVE)) call IVOUT(1,IDUM, & '('' INDEX OF VARIABLE ENTERING THE BASIS'')',IDG) IDUM(1)=ILEAVE call IVOUT(1,IDUM,'('' COLUMN OF THE BASIS EXCHANGED'')',IDG) IDUM(1)=IBASIS(IENTER) call IVOUT(1,IDUM, & '('' INDEX OF VARIABLE LEAVING THE BASIS'')',IDG) RDUM(1)=THETA call DVOUT(1,RDUM,'('' LENGTH OF THE EXCHANGE STEP'')',IDG) if (.NOT.(KPRINT >= 3)) go to 20311 call DVOUT(MRELAS,RPRIM,'('' BASIC (INTERNAL) PRIMAL SOLN.'')', & IDG) call IVOUT(NVARS+MRELAS,IBASIS, & '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG) call IVOUT(NVARS+MRELAS,IBB,'('' IBB ARRAY'')',IDG) call DVOUT(MRELAS,RHS,'('' TRANSLATED RHS'')',IDG) call DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG) 20311 CONTINUE go to 20266 !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (RETURN TO USER) 30001 if (.NOT.(SAVEDT)) go to 20314 go to 30020 20317 CONTINUE 20314 if ( IMAT(LMX-1) /= (-1)) call SCLOSM(IPAGEF) ! ! THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN ! COMPILERS. return end subroutine DPLPMU (MRELAS, NVARS, LMX, LBM, NREDC, INFO, IENTER, & ILEAVE, IOPT, NPP, JSTRT, IBASIS, IMAT, IBRC, IPR, IWR, IND, & IBB, ANORM, EPS, UU, GG, RPRNRM, ERDNRM, DULNRM, THETA, COSTSC, & XLAMDA, RHSNRM, AMAT, BASMAT, CSC, WR, RPRIM, WW, BU, BL, RHS, & ERD, ERP, RZ, RG, COLNRM, COSTS, PRIMAL, DUALS, SINGLR, REDBAS, & ZEROLV, STPEDG) ! !! DPLPMU is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPLPMU-S, DPLPMU-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/, ! /SASUM/DASUM/,/SCOPY/DCOPY/,/SDOT/DDOT/, ! /.E0/.D0/ ! ! THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE. IT PERFORMS THE ! TASKS OF UPDATING THE PRIMAL SOLUTION, EDGE WEIGHTS, REDUCED ! COSTS, AND MATRIX DECOMPOSITION. ! IT IS THE MAIN PART OF THE PROCEDURE (MAKE MOVE AND UPDATE). ! ! REVISED 821122-1100 ! REVISED YYMMDD ! !***SEE ALSO DSPLP !***ROUTINES CALLED DASUM, DCOPY, DDOT, DPLPDM, DPNNZR, DPRWPG, IDLOC, ! LA05BD, LA05CD, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 890606 Changed references from IPLOC to IDLOC. (WRB) ! 890606 Removed unused COMMON block LA05DD. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DPLPMU INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) DOUBLE PRECISION AIJ,ALPHA,ANORM,COSTSC,ERDNRM,DULNRM,EPS,GAMMA, & GG,GQ,ONE,RPRNRM,RZJ,SCALR,THETA,TWO,UU,WP,XLAMDA,RHSNRM, & ZERO,AMAT(*),BASMAT(*),CSC(*),WR(*),RPRIM(*),WW(*),BU(*),BL(*), & RHS(*),ERD(*),ERP(*),RZ(*),RG(*),COSTS(*),PRIMAL(*),DUALS(*), & COLNRM(*),RCOST,DASUM,DDOT,CNORM LOGICAL SINGLR,REDBAS,PAGEPL,TRANS,ZEROLV,STPEDG ! !***FIRST EXECUTABLE STATEMENT DPLPMU ZERO=0.D0 ONE=1.D0 TWO=2.D0 LPG=LMX-(NVARS+4) ! ! UPDATE THE PRIMAL SOLUTION WITH A MULTIPLE OF THE SEARCH ! DIRECTION. I=1 N20002=MRELAS go to 20003 20002 I=I+1 20003 if ((N20002-I) < 0) go to 20004 RPRIM(I)=RPRIM(I)-THETA*WW(I) go to 20002 ! ! if EJECTED VARIABLE IS LEAVING AT AN UPPER BOUND, THEN ! TRANSLATE RIGHT HAND SIDE. 20004 if (.NOT.(ILEAVE < 0)) go to 20006 IBAS=IBASIS(ABS(ILEAVE)) SCALR=RPRIM(ABS(ILEAVE)) ASSIGN 20009 TO NPR001 go to 30001 20009 IBB(IBAS)=ABS(IBB(IBAS))+1 ! ! if ENTERING VARIABLE IS RESTRICTED TO ITS UPPER BOUND, TRANSLATE ! RIGHT HAND SIDE. if THE VARIABLE DECREASED FROM ITS UPPER ! BOUND, A SIGN CHANGE IS REQUIRED IN THE TRANSLATION. 20006 if (.NOT.(IENTER == ILEAVE)) go to 20010 IBAS=IBASIS(IENTER) SCALR=THETA if (MOD(IBB(IBAS),2) == 0) SCALR=-SCALR ASSIGN 20013 TO NPR001 go to 30001 20013 IBB(IBAS)=IBB(IBAS)+1 go to 20011 20010 IBAS=IBASIS(IENTER) ! ! if ENTERING VARIABLE IS DECREASING FROM ITS UPPER BOUND, ! COMPLEMENT ITS PRIMAL VALUE. if (.NOT.(IND(IBAS) == 3.AND.MOD(IBB(IBAS),2) == 0)) go to 20014 SCALR=-(BU(IBAS)-BL(IBAS)) if (IBAS <= NVARS) SCALR=SCALR/CSC(IBAS) ASSIGN 20017 TO NPR001 go to 30001 20017 THETA=-SCALR-THETA IBB(IBAS)=IBB(IBAS)+1 20014 CONTINUE RPRIM(ABS(ILEAVE))=THETA IBB(IBAS)=-ABS(IBB(IBAS)) I=IBASIS(ABS(ILEAVE)) IBB(I)=ABS(IBB(I)) if ( PRIMAL(ABS(ILEAVE)+NVARS) > ZERO) IBB(I)=IBB(I)+1 ! ! INTERCHANGE COLUMN POINTERS TO NOTE EXCHANGE OF COLUMNS. 20011 IBAS=IBASIS(IENTER) IBASIS(IENTER)=IBASIS(ABS(ILEAVE)) IBASIS(ABS(ILEAVE))=IBAS ! ! if VARIABLE WAS EXCHANGED AT A ZERO LEVEL, MARK IT SO THAT ! IT CAN'T BE BROUGHT BACK IN. THIS IS TO HELP PREVENT CYCLING. if ( ZEROLV) IBASIS(IENTER)=-ABS(IBASIS(IENTER)) RPRNRM=MAX(RPRNRM,DASUM(MRELAS,RPRIM,1)) K=1 N20018=MRELAS go to 20019 20018 K=K+1 20019 if ((N20018-K) < 0) go to 20020 ! ! SEE if VARIABLES THAT WERE CLASSIFIED AS INFEASIBLE HAVE NOW ! BECOME FEASIBLE. THIS MAY REQUIRED TRANSLATING UPPER BOUNDED ! VARIABLES. if (.NOT.(PRIMAL(K+NVARS) /= ZERO .AND. & ABS(RPRIM(K)) <= RPRNRM*ERP(K))) go to 20022 if (.NOT.(PRIMAL(K+NVARS) > ZERO)) go to 20025 IBAS=IBASIS(K) SCALR=-(BU(IBAS)-BL(IBAS)) if ( IBAS <= NVARS)SCALR=SCALR/CSC(IBAS) ASSIGN 20028 TO NPR001 go to 30001 20028 RPRIM(K)=-SCALR RPRNRM=RPRNRM-SCALR 20025 PRIMAL(K+NVARS)=ZERO 20022 CONTINUE go to 20018 ! ! UPDATE REDUCED COSTS, EDGE WEIGHTS, AND MATRIX DECOMPOSITION. 20020 if (.NOT.(IENTER /= ILEAVE)) go to 20029 ! ! THE INCOMING VARIABLE IS ALWAYS CLASSIFIED AS FEASIBLE. PRIMAL(ABS(ILEAVE)+NVARS)=ZERO ! WP=WW(ABS(ILEAVE)) GQ=DDOT(MRELAS,WW,1,WW,1)+ONE ! ! COMPUTE INVERSE (TRANSPOSE) TIMES SEARCH DIRECTION. TRANS=.TRUE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) ! ! UPDATE THE MATRIX DECOMPOSITION. COL. ABS(ILEAVE) IS LEAVING. ! THE ARRAY DUALS(*) CONTAINS INTERMEDIATE RESULTS FOR THE ! INCOMING COLUMN. call LA05CD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,DUALS,GG,UU, & ABS(ILEAVE)) REDBAS=.FALSE. if (.NOT.(GG < ZERO)) go to 20032 ! ! REDECOMPOSE BASIS MATRIX WHEN AN ERROR RETURN FROM ! LA05CD( ) IS NOTED. THIS WILL PROBABLY BE DUE TO ! SPACE BEING EXHAUSTED, GG=-7. call DPLPDM( & MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & ANORM,EPS,UU,GG, & AMAT,BASMAT,CSC,WR, & SINGLR,REDBAS) if (.NOT.(SINGLR)) go to 20035 NERR=26 call XERMSG ('SLATEC', 'DPLPMU', & 'IN DSPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.', & NERR, IOPT) INFO=-NERR return 20035 CONTINUE go to 30002 20038 CONTINUE 20032 CONTINUE ! ! if STEEPEST EDGE PRICING IS USED, UPDATE REDUCED COSTS ! AND EDGE WEIGHTS. if (.NOT.(STPEDG)) go to 20039 ! ! COMPUTE COL. ABS(ILEAVE) OF THE NEW INVERSE (TRANSPOSE) MATRIX ! HERE ABS(ILEAVE) POINTS TO THE EJECTED COLUMN. ! USE ERD(*) FOR TEMP. STORAGE. call dinit ( MRELAS,ZERO,ERD,1) ERD(ABS(ILEAVE))=ONE TRANS=.TRUE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,ERD,TRANS) ! ! COMPUTE UPDATED DUAL VARIABLES IN DUALS(*). ASSIGN 20042 TO NPR003 go to 30003 ! ! COMPUTE THE DOT PRODUCT OF COL. J OF THE NEW INVERSE (TRANSPOSE) ! WITH EACH NON-BASIC COLUMN. ALSO COMPUTE THE DOT PRODUCT OF THE ! INVERSE (TRANSPOSE) OF NON-UPDATED MATRIX (TIMES) THE ! SEARCH DIRECTION WITH EACH NON-BASIC COLUMN. ! RECOMPUTE REDUCED COSTS. 20042 PAGEPL=.TRUE. call dinit ( NVARS+MRELAS,ZERO,RZ,1) NNEGRC=0 J=JSTRT 20043 if (.NOT.(IBB(J) <= 0)) go to 20045 PAGEPL=.TRUE. RG(J)=ONE go to 20046 ! ! NONBASIC INDEPENDENT VARIABLES (COLUMN IN SPARSE MATRIX STORAGE) 20045 if (.NOT.(J <= NVARS)) go to 20048 RZJ=COSTS(J)*COSTSC ALPHA=ZERO GAMMA=ZERO ! ! COMPUTE THE DOT PRODUCT OF THE SPARSE MATRIX NONBASIC COLUMNS ! WITH THREE VECTORS INVOLVED IN THE UPDATING STEP. if (.NOT.(J == 1)) go to 20051 ILOW=NVARS+5 go to 20052 20051 ILOW=IMAT(J+3)+1 20052 if (.NOT.(PAGEPL)) go to 20054 IL1=IDLOC(ILOW,AMAT,IMAT) if (.NOT.(IL1 >= LMX-1)) go to 20057 ILOW=ILOW+2 IL1=IDLOC(ILOW,AMAT,IMAT) 20057 CONTINUE IPAGE=ABS(IMAT(LMX-1)) go to 20055 20054 IL1=IHI+1 20055 IHI=IMAT(J+4)-(ILOW-IL1) 20060 IU1=MIN(LMX-2,IHI) if (.NOT.(IL1 > IU1)) go to 20062 go to 20061 20062 CONTINUE DO 10 I=IL1,IU1 RZJ=RZJ-AMAT(I)*DUALS(IMAT(I)) ALPHA=ALPHA+AMAT(I)*ERD(IMAT(I)) GAMMA=GAMMA+AMAT(I)*WW(IMAT(I)) 10 CONTINUE if (.NOT.(IHI <= LMX-2)) go to 20065 go to 20061 20065 CONTINUE IPAGE=IPAGE+1 KEY=1 call DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG go to 20060 20061 PAGEPL=IHI == (LMX-2) RZ(J)=RZJ*CSC(J) ALPHA=ALPHA*CSC(J) GAMMA=GAMMA*CSC(J) RG(J)=MAX(RG(J)-TWO*ALPHA*GAMMA+ALPHA**2*GQ,ONE+ALPHA**2) ! ! NONBASIC DEPENDENT VARIABLES (COLUMNS DEFINED IMPLICITLY) go to 20049 20048 PAGEPL=.TRUE. SCALR=-ONE if ( IND(J) == 2) SCALR=ONE I=J-NVARS ALPHA=SCALR*ERD(I) RZ(J)=-SCALR*DUALS(I) GAMMA=SCALR*WW(I) RG(J)=MAX(RG(J)-TWO*ALPHA*GAMMA+ALPHA**2*GQ,ONE+ALPHA**2) 20049 CONTINUE 20046 CONTINUE ! RCOST=RZ(J) if (MOD(IBB(J),2) == 0) RCOST=-RCOST if (.NOT.(IND(J) == 3)) go to 20068 if ( BU(J) == BL(J)) RCOST=ZERO 20068 CONTINUE if (IND(J) == 4) RCOST=-ABS(RCOST) CNORM=ONE if (J <= NVARS) CNORM=COLNRM(J) if (RCOST+ERDNRM*DULNRM*CNORM < ZERO) NNEGRC=NNEGRC+1 J=MOD(J,MRELAS+NVARS)+1 if (.NOT.(NNEGRC >= NPP .OR. J == JSTRT)) go to 20071 go to 20044 20071 CONTINUE go to 20043 20044 JSTRT=J ! ! UPDATE THE EDGE WEIGHT FOR THE EJECTED VARIABLE. RG(ABS(IBASIS(IENTER)))= GQ/WP**2 ! ! if MINIMUM REDUCED COST (DANTZIG) PRICING IS USED, ! CALCULATE THE NEW REDUCED COSTS. go to 20040 ! ! COMPUTE THE UPDATED DUALS IN DUALS(*). 20039 ASSIGN 20074 TO NPR003 go to 30003 20074 call dinit ( NVARS+MRELAS,ZERO,RZ,1) NNEGRC=0 J=JSTRT PAGEPL=.TRUE. ! 20075 if (.NOT.(IBB(J) <= 0)) go to 20077 PAGEPL=.TRUE. go to 20078 ! ! NONBASIC INDEPENDENT VARIABLE (COLUMN IN SPARSE MATRIX STORAGE) 20077 if (.NOT.(J <= NVARS)) go to 20080 RZ(J)=COSTS(J)*COSTSC if (.NOT.(J == 1)) go to 20083 ILOW=NVARS+5 go to 20084 20083 ILOW=IMAT(J+3)+1 20084 CONTINUE if (.NOT.(PAGEPL)) go to 20086 IL1=IDLOC(ILOW,AMAT,IMAT) if (.NOT.(IL1 >= LMX-1)) go to 20089 ILOW=ILOW+2 IL1=IDLOC(ILOW,AMAT,IMAT) 20089 CONTINUE IPAGE=ABS(IMAT(LMX-1)) go to 20087 20086 IL1=IHI+1 20087 CONTINUE IHI=IMAT(J+4)-(ILOW-IL1) 20092 IU1=MIN(LMX-2,IHI) if (.NOT.(IU1 >= IL1 .AND.MOD(IU1-IL1,2) == 0)) go to 20094 RZ(J)=RZ(J)-AMAT(IL1)*DUALS(IMAT(IL1)) IL1=IL1+1 20094 CONTINUE if (.NOT.(IL1 > IU1)) go to 20097 go to 20093 20097 CONTINUE ! ! UNROLL THE DOT PRODUCT LOOP TO A DEPTH OF TWO. (THIS IS DONE ! FOR INCREASED EFFICIENCY). DO 40 I=IL1,IU1,2 RZ(J)=RZ(J)-AMAT(I)*DUALS(IMAT(I))-AMAT(I+1)*DUALS(IMAT(I+1)) 40 CONTINUE if (.NOT.(IHI <= LMX-2)) go to 20100 go to 20093 20100 CONTINUE IPAGE=IPAGE+1 KEY=1 call DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG go to 20092 20093 PAGEPL=IHI == (LMX-2) RZ(J)=RZ(J)*CSC(J) ! ! NONBASIC DEPENDENT VARIABLES (COLUMNS DEFINED IMPLICITLY) go to 20081 20080 PAGEPL=.TRUE. SCALR=-ONE if ( IND(J) == 2) SCALR=ONE I=J-NVARS RZ(J)=-SCALR*DUALS(I) 20081 CONTINUE 20078 CONTINUE ! RCOST=RZ(J) if (MOD(IBB(J),2) == 0) RCOST=-RCOST if (.NOT.(IND(J) == 3)) go to 20103 if ( BU(J) == BL(J)) RCOST=ZERO 20103 CONTINUE if (IND(J) == 4) RCOST=-ABS(RCOST) CNORM=ONE if (J <= NVARS) CNORM=COLNRM(J) if (RCOST+ERDNRM*DULNRM*CNORM < ZERO) NNEGRC=NNEGRC+1 J=MOD(J,MRELAS+NVARS)+1 if (.NOT.(NNEGRC >= NPP .OR. J == JSTRT)) go to 20106 go to 20076 20106 CONTINUE go to 20075 20076 JSTRT=J 20040 CONTINUE go to 20030 ! ! THIS IS NECESSARY ONLY FOR PRINTING OF INTERMEDIATE RESULTS. 20029 ASSIGN 20109 TO NPR003 go to 30003 20109 CONTINUE 20030 RETURN ! PROCEDURE (TRANSLATE RIGHT HAND SIDE) ! ! PERFORM THE TRANSLATION ON THE RIGHT-HAND SIDE. 30001 if (.NOT.(IBAS <= NVARS)) go to 20110 I=0 20113 call DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,IBAS) if (.NOT.(I <= 0)) go to 20115 go to 20114 20115 CONTINUE RHS(I)=RHS(I)-SCALR*AIJ*CSC(IBAS) go to 20113 20114 go to 20111 20110 I=IBAS-NVARS if (.NOT.(IND(IBAS) == 2)) go to 20118 RHS(I)=RHS(I)-SCALR go to 20119 20118 RHS(I)=RHS(I)+SCALR 20119 CONTINUE 20111 CONTINUE RHSNRM=MAX(RHSNRM,DASUM(MRELAS,RHS,1)) go to NPR001, (20009,20013,20017,20028) ! PROCEDURE (COMPUTE NEW PRIMAL) ! ! COPY RHS INTO WW(*), SOLVE SYSTEM. 30002 call DCOPY(MRELAS,RHS,1,WW,1) TRANS = .FALSE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) call DCOPY(MRELAS,WW,1,RPRIM,1) RPRNRM=DASUM(MRELAS,RPRIM,1) go to 20038 ! PROCEDURE (COMPUTE NEW DUALS) ! ! SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*). 30003 I=1 N20121=MRELAS go to 20122 20121 I=I+1 20122 if ((N20121-I) < 0) go to 20123 J=IBASIS(I) if (.NOT.(J <= NVARS)) go to 20125 DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS) go to 20126 20125 DUALS(I)=XLAMDA*PRIMAL(I+NVARS) 20126 CONTINUE go to 20121 ! 20123 TRANS=.TRUE. call LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS) DULNRM=DASUM(MRELAS,DUALS,1) go to NPR003, (20042,20074,20109) end subroutine DPLPUP (DUSRMT, MRELAS, NVARS, PRGOPT, DATTRV, BL, BU, & IND, INFO, AMAT, IMAT, SIZEUP, ASMALL, ABIG) ! !! DPLPUP is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPLPUP-S, DPLPUP-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/. ! ! REVISED 810613-1130 ! REVISED YYMMDD-HHMM ! ! THIS SUBROUTINE COLLECTS INFORMATION ABOUT THE BOUNDS AND MATRIX ! FROM THE USER. IT IS PART OF THE DSPLP( ) PACKAGE. ! !***SEE ALSO DSPLP !***ROUTINES CALLED DPCHNG, DPNNZR, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Corrected references to XERRWV. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891009 Removed unreferenced variables. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls, changed do-it-yourself ! DO loops to DO loops. (RWC) ! 900602 Get rid of ASSIGNed GOTOs. (RWC) !***END PROLOGUE DPLPUP DOUBLE PRECISION ABIG,AIJ,AMAT(*),AMN,AMX,ASMALL,BL(*), & BU(*),DATTRV(*),PRGOPT(*),XVAL,ZERO INTEGER IFLAG(10),IMAT(*),IND(*) LOGICAL SIZEUP,FIRST CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 ! !***FIRST EXECUTABLE STATEMENT DPLPUP ZERO = 0.D0 ! ! CHECK USER-SUPPLIED BOUNDS ! ! CHECK THAT IND(*) VALUES ARE 1,2,3 OR 4. ! ALSO CHECK CONSISTENCY OF UPPER AND LOWER BOUNDS. ! DO 10 J=1,NVARS if (IND(J) < 1 .OR. IND(J) > 4) THEN WRITE (XERN1, '(I8)') J call XERMSG ('SLATEC', 'DPLPUP', & 'IN DSPLP, INDEPENDENT VARIABLE = ' // XERN1 // & ' IS NOT DEFINED.', 10, 1) INFO = -10 return ENDIF ! if (IND(J) == 3) THEN if (BL(J) > BU(J)) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') BL(J) WRITE (XERN4, '(1PE15.6)') BU(J) call XERMSG ('SLATEC', 'DPLPUP', & 'IN DSPLP, LOWER BOUND = ' // XERN3 // & ' AND UPPER BOUND = ' // XERN4 // & ' FOR INDEPENDENT VARIABLE = ' // XERN1 // & ' ARE NOT CONSISTENT.', 11, 1) return ENDIF ENDIF 10 CONTINUE ! DO 20 I=NVARS+1,NVARS+MRELAS if (IND(I) < 1 .OR. IND(I) > 4) THEN WRITE (XERN1, '(I8)') I-NVARS call XERMSG ('SLATEC', 'DPLPUP', & 'IN DSPLP, DEPENDENT VARIABLE = ' // XERN1 // & ' IS NOT DEFINED.', 12, 1) INFO = -12 return ENDIF ! if (IND(I) == 3) THEN if (BL(I) > BU(I)) THEN WRITE (XERN1, '(I8)') I WRITE (XERN3, '(1PE15.6)') BL(I) WRITE (XERN4, '(1PE15.6)') BU(I) call XERMSG ('SLATEC', 'DPLPUP', & 'IN DSPLP, LOWER BOUND = ' // XERN3 // & ' AND UPPER BOUND = ' // XERN4 // & ' FOR DEPENDANT VARIABLE = ' // XERN1 // & ' ARE NOT CONSISTENT.',13,1) INFO = -13 return ENDIF ENDIF 20 CONTINUE ! ! GET UPDATES OR DATA FOR MATRIX FROM THE USER ! ! GET THE ELEMENTS OF THE MATRIX FROM THE USER. IT WILL BE STORED ! BY COLUMNS USING THE SPARSE STORAGE CODES OF RJ HANSON AND ! JA WISNIEWSKI. ! IFLAG(1) = 1 ! ! KEEP ACCEPTING ELEMENTS UNTIL THE USER IS FINISHED GIVING THEM. ! LIMIT THIS LOOP TO 2*NVARS*MRELAS ITERATIONS. ! ITMAX = 2*NVARS*MRELAS+1 ITCNT = 0 FIRST = .TRUE. ! ! CHECK ON THE ITERATION COUNT. ! 30 ITCNT = ITCNT+1 if (ITCNT > ITMAX) THEN call XERMSG ('SLATEC', 'DPLPUP', & 'IN DSPLP, MORE THAN 2*NVARS*MRELAS ITERATIONS DEFINING ' // & 'OR UPDATING MATRIX DATA.', 7, 1) INFO = -7 return end if ! AIJ = ZERO call DUSRMT(I,J,AIJ,INDCAT,PRGOPT,DATTRV,IFLAG) if (IFLAG(1) == 1) THEN IFLAG(1) = 2 go to 30 end if ! ! CHECK TO SEE THAT THE SUBSCRIPTS I AND J ARE VALID. ! if (I < 1 .OR. I > MRELAS .OR. J < 1 .OR. J > NVARS) THEN ! ! CHECK ON SIZE OF MATRIX DATA ! RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS. ! if (IFLAG(1) == 3) THEN if (SIZEUP .AND. ABS(AIJ) /= ZERO) THEN if (FIRST) THEN AMX = ABS(AIJ) AMN = ABS(AIJ) FIRST = .FALSE. ELSEIF (ABS(AIJ) > AMX) THEN AMX = ABS(AIJ) ELSEIF (ABS(AIJ) < AMN) THEN AMN = ABS(AIJ) ENDIF ENDIF go to 40 ENDIF ! WRITE (XERN1, '(I8)') I WRITE (XERN2, '(I8)') J call XERMSG ('SLATEC', 'DPLPUP', & 'IN DSPLP, ROW INDEX = ' // XERN1 // ' OR COLUMN INDEX = ' & // XERN2 // ' IS OUT OF RANGE.', 8, 1) INFO = -8 return end if ! ! if INDCAT=0 THEN SET A(I,J)=AIJ. ! if INDCAT=1 THEN ACCUMULATE ELEMENT, A(I,J)=A(I,J)+AIJ. ! if (INDCAT == 0) THEN call DPCHNG(I,AIJ,IPLACE,AMAT,IMAT,J) ELSEIF (INDCAT == 1) THEN INDEX = -(I-1) call DPNNZR(INDEX,XVAL,IPLACE,AMAT,IMAT,J) if (INDEX == I) AIJ=AIJ+XVAL call DPCHNG(I,AIJ,IPLACE,AMAT,IMAT,J) ELSE WRITE (XERN1, '(I8)') INDCAT call XERMSG ('SLATEC', 'DPLPUP', & 'IN DSPLP, INDICATION FLAG = ' // XERN1 // & ' FOR MATRIX DATA MUST BE EITHER 0 OR 1.', 9, 1) INFO = -9 return end if ! ! CHECK ON SIZE OF MATRIX DATA ! RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS. ! if (SIZEUP .AND. ABS(AIJ) /= ZERO) THEN if (FIRST) THEN AMX = ABS(AIJ) AMN = ABS(AIJ) FIRST = .FALSE. ELSEIF (ABS(AIJ) > AMX) THEN AMX = ABS(AIJ) ELSEIF (ABS(AIJ) < AMN) THEN AMN = ABS(AIJ) ENDIF end if if (IFLAG(1) /= 3) go to 30 ! 40 if (SIZEUP .AND. .NOT. FIRST) THEN if (AMN < ASMALL .OR. AMX > ABIG) THEN call XERMSG ('SLATEC', 'DPLPUP', & 'IN DSPLP, A MATRIX ELEMENT''S SIZE IS OUT OF THE ' // & 'SPECIFIED RANGE.', 22, 1) INFO = -22 return ENDIF end if return end subroutine DPNNZR (I, XVAL, IPLACE, SX, IX, IRCX) ! !! DPNNZR is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PNNZRS-S, DPNNZR-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! DPNNZR LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. ! SPARSE MATRIX NON ZERO RETRIEVAL SUBROUTINE. ! ! SUBROUTINE DPNNZR() GETS THE NEXT NONZERO VALUE IN ROW OR COLUMN ! +/- IRCX WITH AN INDEX GREATER THAN THE VALUE OF I. ! ! I ABSOLUTE VALUE OF THIS SUBSCRIPT IS TO BE EXCEEDED ! IN THE SEARCH FOR THE NEXT NONZERO VALUE. A NEGATIVE ! OR ZERO VALUE OF I CAUSES THE SEARCH TO START AT ! THE BEGINNING OF THE VECTOR. A POSITIVE VALUE ! OF I CAUSES THE SEARCH TO CONTINUE FROM THE LAST PLACE ! ACCESSED. ON OUTPUT, THE ARGUMENT I ! CONTAINS THE VALUE OF THE SUBSCRIPT FOUND. AN OUTPUT ! VALUE OF I EQUAL TO ZERO INDICATES THAT ALL COMPONENTS ! WITH AN INDEX GREATER THAN THE INPUT VALUE OF I ARE ! ZERO. ! XVAL VALUE OF THE NONZERO ELEMENT FOUND. ON OUTPUT, ! XVAL=0. WHENEVER I=0. ! IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE. ! SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE ! MATRIX. THESE ARRAY CONTENTS ARE AUTOMATICALLY ! MAINTAINED BY THE PACKAGE FOR THE USER. ! IRCX POINTS TO THE VECTOR OF THE MATRIX BEING SCANNED. A ! NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS TO BE ! SCANNED. A POSITIVE VALUE OF IRCX INDICATES THAT ! COLUMN IRCX IS TO BE SCANNED. A ZERO VALUE OF IRCX IS ! AN ERROR. ! ! THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LNNZRS, ! SANDIA LABS. REPT. SAND78-0785. ! MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON ! REVISED 811130-1000 ! REVISED YYMMDD-HHMM ! !***SEE ALSO DSPLP !***ROUTINES CALLED IDLOC, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 890606 Changed references from IPLOC to IDLOC. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) !***END PROLOGUE DPNNZR DIMENSION IX(*) DOUBLE PRECISION XVAL,SX(*),ZERO SAVE ZERO DATA ZERO /0.D0/ !***FIRST EXECUTABLE STATEMENT DPNNZR IOPT=1 ! ! CHECK VALIDITY OF ROW/COL. INDEX. ! if (.NOT.(IRCX == 0)) go to 20002 NERR=55 call XERMSG ('SLATEC', 'DPNNZR', 'IRCX=0', NERR, IOPT) ! ! LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA. ! 20002 LMX = IX(1) if (.NOT.(IRCX < 0)) go to 20005 ! ! CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE <= M AND ! THE INDEX MUST BE <= N. ! if (.NOT.(IX(2) < -IRCX .OR. IX(3) < ABS(I))) go to 20008 NERR=55 call XERMSG ('SLATEC', 'DPNNZR', & 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // & 'BOUNDS.', NERR, IOPT) 20008 L=IX(3) go to 20006 ! ! CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE <= N AND ! THE INDEX MUST BE <= M. ! 20005 if (.NOT.(IRCX > IX(3) .OR. ABS(I) > IX(2))) go to 20011 NERR=55 call XERMSG ('SLATEC', 'DPNNZR', & 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // & 'BOUNDS', NERR, IOPT) 20011 L=IX(2) ! ! HERE L IS THE LARGEST POSSIBLE SUBSCRIPT WITHIN THE VECTOR. ! 20006 J=ABS(IRCX) LL=IX(3)+4 LPG = LMX - LL if (.NOT.(IRCX > 0)) go to 20014 ! ! SEARCHING FOR THE NEXT NONZERO IN A COLUMN. ! ! INITIALIZE STARTING LOCATIONS.. if (.NOT.(I <= 0)) go to 20017 if (.NOT.(J == 1)) go to 20020 IPLACE=LL+1 go to 20021 20020 IPLACE=IX(J+3)+1 20021 CONTINUE ! ! THE CASE I <= 0 SIGNALS THAT THE SCAN FOR THE ENTRY ! IS TO BEGIN AT THE START OF THE VECTOR. ! 20017 I = ABS(I) if (.NOT.(J == 1)) go to 20023 ISTART = LL+1 go to 20024 20023 ISTART=IX(J+3)+1 20024 IEND = IX(J+4) ! ! VALIDATE IPLACE. SET TO START OF VECTOR if OUT OF RANGE. ! if (.NOT.(ISTART > IPLACE .OR. IPLACE > IEND)) go to 20026 if (.NOT.(J == 1)) go to 20029 IPLACE=LL+1 go to 20030 20029 IPLACE=IX(J+3)+1 20030 CONTINUE ! ! SCAN THROUGH SEVERAL PAGES, if NECESSARY, TO FIND MATRIX ENTRY. ! 20026 IPL = IDLOC(IPLACE,SX,IX) ! ! FIX UP IPLACE AND IPL if THEY POINT TO PAGING DATA. ! THIS IS NECESSARY BECAUSE THERE IS CONTROL INFORMATION AT THE ! END OF EACH PAGE. ! IDIFF = LMX - IPL if (.NOT.(IDIFF <= 1.AND.IX(LMX-1) > 0)) go to 20032 ! ! UPDATE THE RELATIVE ADDRESS IN A NEW PAGE. ! IPLACE = IPLACE + IDIFF + 1 IPL = IDLOC(IPLACE,SX,IX) 20032 NP = ABS(IX(LMX-1)) go to 20036 20035 if (ILAST == IEND) go to 20037 20036 ILAST = MIN(IEND,NP*LPG+LL-2) ! ! THE VIRTUAL END OF THE DATA FOR THIS PAGE IS ILAST. ! IL = IDLOC(ILAST,SX,IX) IL = MIN(IL,LMX-2) ! ! THE RELATIVE END OF DATA FOR THIS PAGE IS IL. ! SEARCH FOR A NONZERO VALUE WITH AN INDEX > I ON THE PRESENT ! PAGE. ! 20038 if (.NOT.(.NOT.(IPL >= IL.OR.(IX(IPL) > I.AND.SX(IPL) /= ZERO)))) & go to 20039 IPL=IPL+1 go to 20038 ! ! TEST if WE HAVE FOUND THE NEXT NONZERO. ! 20039 if (.NOT.(IX(IPL) > I .AND. SX(IPL) /= ZERO .AND. IPL <= IL)) GO & TO 20040 I = IX(IPL) XVAL = SX(IPL) IPLACE = (NP-1)*LPG + IPL return ! ! UPDATE TO SCAN THE NEXT PAGE. 20040 IPL = LL + 1 NP = NP + 1 go to 20035 ! ! NO DATA WAS FOUND. END OF VECTOR ENCOUNTERED. ! 20037 I = 0 XVAL = ZERO IL = IL + 1 if ( IL == LMX-1) IL = IL + 2 ! ! if A NEW ITEM WOULD BE INSERTED, IPLACE POINTS TO THE PLACE ! TO PUT IT. ! IPLACE = (NP-1)*LPG + IL return ! ! SEARCH A ROW FOR THE NEXT NONZERO. ! FIND ELEMENT J=ABS(IRCX) IN ROWS ABS(I)+1,...,L. ! 20014 I=ABS(I) ! ! CHECK FOR END OF VECTOR. ! if (.NOT.(I == L)) go to 20043 I=0 XVAL=ZERO return 20043 I1 = I+1 II=I1 N20046=L go to 20047 20046 II=II+1 20047 if ((N20046-II) < 0) go to 20048 ! ! INITIALIZE IPPLOC FOR ORTHOGONAL SCAN. ! LOOK FOR J AS A SUBSCRIPT IN ROWS II, II=I+1,...,L. ! if (.NOT.(II == 1)) go to 20050 IPPLOC = LL + 1 go to 20051 20050 IPPLOC = IX(II+3) + 1 20051 IEND = IX(II+4) ! ! SCAN THROUGH SEVERAL PAGES, if NECESSARY, TO FIND MATRIX ENTRY. ! IPL = IDLOC(IPPLOC,SX,IX) ! ! FIX UP IPPLOC AND IPL TO POINT TO MATRIX DATA. ! IDIFF = LMX - IPL if (.NOT.(IDIFF <= 1.AND.IX(LMX-1) > 0)) go to 20053 IPPLOC = IPPLOC + IDIFF + 1 IPL = IDLOC(IPPLOC,SX,IX) 20053 NP = ABS(IX(LMX-1)) go to 20057 20056 if (ILAST == IEND) go to 20058 20057 ILAST = MIN(IEND,NP*LPG+LL-2) IL = IDLOC(ILAST,SX,IX) IL = MIN(IL,LMX-2) 20059 if (.NOT.(.NOT.(IPL >= IL .OR. IX(IPL) >= J))) go to 20060 IPL=IPL+1 go to 20059 ! ! TEST if WE HAVE FOUND THE NEXT NONZERO. ! 20060 if (.NOT.(IX(IPL) == J .AND. SX(IPL) /= ZERO .AND. IPL <= IL)) GO & TO 20061 I = II XVAL = SX(IPL) return 20061 if ( IX(IPL) >= J) ILAST = IEND IPL = LL + 1 NP = NP + 1 go to 20056 20058 go to 20046 ! ! ORTHOGONAL SCAN FAILED. THE VALUE J WAS NOT A SUBSCRIPT ! IN ANY ROW. ! 20048 I=0 XVAL=ZERO return end DOUBLE PRECISION FUNCTION DPOCH1 (A, X) ! !! DPOCH1 calculates a generalization of Pochhammer's symbol starting ... ! from first order. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C1, C7A !***TYPE DOUBLE PRECISION (POCH1-S, DPOCH1-D) !***KEYWORDS FIRST ORDER, FNLIB, POCHHAMMER, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate a double precision generalization of Pochhammer's symbol ! for double precision A and X for special situations that require ! especially accurate values when X is small in ! POCH1(A,X) = (POCH(A,X)-1)/X ! = (GAMMA(A+X)/GAMMA(A) - 1.0)/X . ! This specification is particularly suited for stably computing ! expressions such as ! (GAMMA(A+X)/GAMMA(A) - GAMMA(B+X)/GAMMA(B))/X ! = POCH1(A,X) - POCH1(B,X) ! Note that POCH1(A,0.0) = PSI(A) ! ! When ABS(X) is so small that substantial cancellation will occur if ! the straightforward formula is used, we use an expansion due ! to Fields and discussed by Y. L. Luke, The Special Functions and Their ! Approximations, Vol. 1, Academic Press, 1969, page 34. ! ! The ratio POCH(A,X) = GAMMA(A+X)/GAMMA(A) is written by Luke as ! (A+(X-1)/2)**X * polynomial in (A+(X-1)/2)**(-2) . ! In order to maintain significance in POCH1, we write for positive a ! (A+(X-1)/2)**X = EXP(X*LOG(A+(X-1)/2)) = EXP(Q) ! = 1.0 + Q*EXPREL(Q) . ! Likewise the polynomial is written ! POLY = 1.0 + X*POLY1(A,X) . ! Thus, ! POCH1(A,X) = (POCH(A,X) - 1) / X ! = EXPREL(Q)*(Q/X + Q*POLY1(A,X)) + POLY1(A,X) ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCOT, DEXPRL, DPOCH, DPSI, XERMSG !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE DPOCH1 DOUBLE PRECISION A, X, ABSA, ABSX, ALNEPS, ALNVAR, B, BERN(20), & BINV, BP, GBERN(21), GBK, PI, POLY1, Q, RHO, SINPXX, SINPX2, & SQTBIG, TERM, TRIG, VAR, VAR2, D1MACH, DPSI, DEXPRL, DCOT, DPOCH LOGICAL FIRST EXTERNAL DCOT SAVE BERN, PI, SQTBIG, ALNEPS, FIRST DATA BERN ( 1) / +.833333333333333333333333333333333D-1 / DATA BERN ( 2) / -.138888888888888888888888888888888D-2 / DATA BERN ( 3) / +.330687830687830687830687830687830D-4 / DATA BERN ( 4) / -.826719576719576719576719576719576D-6 / DATA BERN ( 5) / +.208767569878680989792100903212014D-7 / DATA BERN ( 6) / -.528419013868749318484768220217955D-9 / DATA BERN ( 7) / +.133825365306846788328269809751291D-10 / DATA BERN ( 8) / -.338968029632258286683019539124944D-12 / DATA BERN ( 9) / +.858606205627784456413590545042562D-14 / DATA BERN ( 10) / -.217486869855806187304151642386591D-15 / DATA BERN ( 11) / +.550900282836022951520265260890225D-17 / DATA BERN ( 12) / -.139544646858125233407076862640635D-18 / DATA BERN ( 13) / +.353470703962946747169322997780379D-20 / DATA BERN ( 14) / -.895351742703754685040261131811274D-22 / DATA BERN ( 15) / +.226795245233768306031095073886816D-23 / DATA BERN ( 16) / -.574472439520264523834847971943400D-24 / DATA BERN ( 17) / +.145517247561486490186626486727132D-26 / DATA BERN ( 18) / -.368599494066531017818178247990866D-28 / DATA BERN ( 19) / +.933673425709504467203255515278562D-30 / DATA BERN ( 20) / -.236502241570062993455963519636983D-31 / DATA PI / 3.141592653589793238462643383279503D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DPOCH1 if (FIRST) THEN SQTBIG = 1.0D0/SQRT(24.0D0*D1MACH(1)) ALNEPS = LOG(D1MACH(3)) end if FIRST = .FALSE. ! if (X == 0.0D0) DPOCH1 = DPSI(A) if (X == 0.0D0) RETURN ! ABSX = ABS(X) ABSA = ABS(A) if (ABSX > 0.1D0*ABSA) go to 70 if (ABSX*LOG(MAX(ABSA,2.0D0)) > 0.1D0) go to 70 ! BP = A if (A < (-0.5D0)) BP = 1.0D0 - A - X INCR = 0 if (BP < 10.0D0) INCR = 11.0D0 - BP B = BP + INCR ! VAR = B + 0.5D0*(X-1.0D0) ALNVAR = LOG(VAR) Q = X*ALNVAR ! POLY1 = 0.0D0 if (VAR >= SQTBIG) go to 40 VAR2 = (1.0D0/VAR)**2 ! RHO = 0.5D0*(X+1.0D0) GBERN(1) = 1.0D0 GBERN(2) = -RHO/12.0D0 TERM = VAR2 POLY1 = GBERN(2)*TERM ! NTERMS = -0.5D0*ALNEPS/ALNVAR + 1.0D0 if (NTERMS > 20) call XERMSG ('SLATEC', 'DPOCH1', & 'NTERMS IS TOO BIG, MAYBE D1MACH(3) IS BAD', 1, 2) if (NTERMS < 2) go to 40 ! DO 30 K=2,NTERMS GBK = 0.0D0 DO 20 J=1,K NDX = K - J + 1 GBK = GBK + BERN(NDX)*GBERN(J) 20 CONTINUE GBERN(K+1) = -RHO*GBK/K ! TERM = TERM * (2*K-2-X)*(2*K-1-X)*VAR2 POLY1 = POLY1 + GBERN(K+1)*TERM 30 CONTINUE ! 40 POLY1 = (X-1.0D0)*POLY1 DPOCH1 = DEXPRL(Q)*(ALNVAR+Q*POLY1) + POLY1 ! if (INCR == 0) go to 60 ! ! WE HAVE DPOCH1(B,X), BUT BP IS SMALL, SO WE USE BACKWARDS RECURSION ! TO OBTAIN DPOCH1(BP,X). ! DO 50 II=1,INCR I = INCR - II BINV = 1.0D0/(BP+I) DPOCH1 = (DPOCH1 - BINV) / (1.0D0 + X*BINV) 50 CONTINUE ! 60 if (BP == A) RETURN ! ! WE HAVE DPOCH1(BP,X), BUT A IS LT -0.5. WE THEREFORE USE A REFLECTION ! FORMULA TO OBTAIN DPOCH1(A,X). ! SINPXX = SIN(PI*X)/X SINPX2 = SIN(0.5D0*PI*X) TRIG = SINPXX*DCOT(PI*B) - 2.0D0*SINPX2*(SINPX2/X) ! DPOCH1 = TRIG + (1.0D0 + X*TRIG)*DPOCH1 return ! 70 DPOCH1 = (DPOCH(A,X) - 1.0D0) / X return ! end DOUBLE PRECISION FUNCTION DPOCH (A, X) ! !! DPOCH evaluates a generalization of Pochhammer's symbol. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C1, C7A !***TYPE DOUBLE PRECISION (POCH-S, DPOCH-D) !***KEYWORDS FNLIB, POCHHAMMER, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate a double precision generalization of Pochhammer's symbol ! (A)-sub-X = GAMMA(A+X)/GAMMA(A) for double precision A and X. ! For X a non-negative integer, POCH(A,X) is just Pochhammer's symbol. ! This is a preliminary version that does not handle wrong arguments ! properly and may not properly handle the case when the result is ! computed to less than half of double precision. ! !***REFERENCES (NONE) !***ROUTINES CALLED D9LGMC, DFAC, DGAMMA, DGAMR, DLGAMS, DLNREL, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE DPOCH DOUBLE PRECISION A, X, ABSA, ABSAX, ALNGA, ALNGAX, AX, B, PI, & SGNGA, SGNGAX, DFAC, DLNREL, D9LGMC, DGAMMA, DGAMR, DCOT EXTERNAL DGAMMA SAVE PI DATA PI / 3.141592653589793238462643383279503D0 / !***FIRST EXECUTABLE STATEMENT DPOCH AX = A + X if (AX > 0.0D0) go to 30 if (AINT(AX) /= AX) go to 30 ! if (A > 0.0D0 .OR. AINT(A) /= A) call XERMSG ('SLATEC', & 'DPOCH', 'A+X IS NON-POSITIVE INTEGER BUT A IS NOT', 2, 2) ! ! WE KNOW HERE THAT BOTH A+X AND A ARE NON-POSITIVE INTEGERS. ! DPOCH = 1.0D0 if (X == 0.D0) RETURN ! N = X if (MIN(A+X,A) < (-20.0D0)) go to 20 ! IA = A DPOCH = (-1.0D0)**N * DFAC(-IA)/DFAC(-IA-N) return ! 20 DPOCH = (-1.0D0)**N * EXP ((A-0.5D0)*DLNREL(X/(A-1.0D0)) & + X*LOG(-A+1.0D0-X) - X + D9LGMC(-A+1.0D0) - D9LGMC(-A-X+1.D0)) return ! ! A+X IS NOT ZERO OR A NEGATIVE INTEGER. ! 30 DPOCH = 0.0D0 if (A <= 0.0D0 .AND. AINT(A) == A) RETURN ! N = ABS(X) if (DBLE(N) /= X .OR. N > 20) go to 50 ! ! X IS A SMALL NON-POSITIVE INTEGER, PRESUMMABLY A COMMON CASE. ! DPOCH = 1.0D0 if (N == 0) RETURN DO 40 I=1,N DPOCH = DPOCH * (A+I-1) 40 CONTINUE return ! 50 ABSAX = ABS(A+X) ABSA = ABS(A) if (MAX(ABSAX,ABSA) > 20.0D0) go to 60 DPOCH = DGAMMA(A+X) * DGAMR(A) return ! 60 if (ABS(X) > 0.5D0*ABSA) go to 70 ! ! ABS(X) IS SMALL AND BOTH ABS(A+X) AND ABS(A) ARE LARGE. THUS, ! A+X AND A MUST HAVE THE SAME SIGN. FOR NEGATIVE A, WE USE ! GAMMA(A+X)/GAMMA(A) = GAMMA(-A+1)/GAMMA(-A-X+1) * ! SIN(PI*A)/SIN(PI*(A+X)) ! B = A if (B < 0.0D0) B = -A - X + 1.0D0 DPOCH = EXP ((B-0.5D0)*DLNREL(X/B) + X*LOG(B+X) - X & + D9LGMC(B+X) - D9LGMC(B) ) if (A < 0.0D0 .AND. DPOCH /= 0.0D0) DPOCH = & DPOCH/(COS(PI*X) + DCOT(PI*A)*SIN(PI*X) ) return ! 70 call DLGAMS (A+X, ALNGAX, SGNGAX) call DLGAMS (A, ALNGA, SGNGA) DPOCH = SGNGAX * SGNGA * EXP(ALNGAX-ALNGA) ! return end subroutine DPOCO (A, LDA, N, RCOND, Z, INFO) ! !! DPOCO factors a real symmetric positive definite matrix ! and estimates the condition of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE DOUBLE PRECISION (SPOCO-S, DPOCO-D, CPOCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPOCO factors a double precision symmetric positive definite ! matrix and estimates the condition of the matrix. ! ! If RCOND is not needed, DPOFA is slightly faster. ! To solve A*X = B , follow DPOCO by DPOSL. ! To compute INVERSE(A)*C , follow DPOCO by DPOSL. ! To compute DETERMINANT(A) , follow DPOCO by DPODI. ! To compute INVERSE(A) , follow DPOCO by DPODI. ! ! On Entry ! ! A DOUBLE PRECISION(LDA, N) ! the symmetric matrix to be factored. Only the ! diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix R so that A = TRANS(R)*R ! where TRANS(R) is the transpose. ! The strict lower triangle is unaltered. ! If INFO /= 0 , the factorization is not complete. ! ! RCOND DOUBLE PRECISION ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. If INFO /= 0 , RCOND is unchanged. ! ! Z DOUBLE PRECISION(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! If INFO /= 0 , Z is unchanged. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DASUM, DAXPY, DDOT, DPOFA, DSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPOCO INTEGER LDA,N,INFO DOUBLE PRECISION A(LDA,*),Z(*) DOUBLE PRECISION RCOND ! DOUBLE PRECISION DDOT,EK,T,WK,WKM DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM INTEGER I,J,JM1,K,KB,KP1 ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT DPOCO DO 30 J = 1, N Z(J) = DASUM(J,A(1,J),1) JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 Z(I) = Z(I) + ABS(A(I,J)) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0D0 DO 40 J = 1, N ANORM = MAX(ANORM,Z(J)) 40 CONTINUE ! ! FACTOR ! call DPOFA(A,LDA,N,INFO) if (INFO /= 0) go to 180 ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE TRANS(R)*W = E ! EK = 1.0D0 DO 50 J = 1, N Z(J) = 0.0D0 50 CONTINUE DO 110 K = 1, N if (Z(K) /= 0.0D0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= A(K,K)) go to 60 S = A(K,K)/ABS(EK-Z(K)) call DSCAL(N,S,Z,1) EK = S*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) WK = WK/A(K,K) WKM = WKM/A(K,K) KP1 = K + 1 if (KP1 > N) go to 100 DO 70 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)) 70 CONTINUE if (S >= SM) go to 90 T = WKM - WK WK = WKM DO 80 J = KP1, N Z(J) = Z(J) + T*A(K,J) 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) ! ! SOLVE R*Y = W ! DO 130 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= A(K,K)) go to 120 S = A(K,K)/ABS(Z(K)) call DSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) call DAXPY(K-1,T,A(1,K),1,Z(1),1) 130 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) ! YNORM = 1.0D0 ! ! SOLVE TRANS(R)*V = Y ! DO 150 K = 1, N Z(K) = Z(K) - DDOT(K-1,A(1,K),1,Z(1),1) if (ABS(Z(K)) <= A(K,K)) go to 140 S = A(K,K)/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/A(K,K) 150 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE R*Z = V ! DO 170 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= A(K,K)) go to 160 S = A(K,K)/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) call DAXPY(K-1,T,A(1,K),1,Z(1),1) 170 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0D0) RCOND = YNORM/ANORM if (ANORM == 0.0D0) RCOND = 0.0D0 180 CONTINUE return end subroutine DPODI (A, LDA, N, DET, JOB) ! !! DPODI computes the determinant and inverse of a certain real symmetric ... ! positive definite matrix using the factors ! computed by DPOCO, DPOFA or DQRDC. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B, D3B1B !***TYPE DOUBLE PRECISION (SPODI-S, DPODI-D, CPODI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPODI computes the determinant and inverse of a certain ! double precision symmetric positive definite matrix (see below) ! using the factors computed by DPOCO, DPOFA or DQRDC. ! ! On Entry ! ! A DOUBLE PRECISION(LDA, N) ! the output A from DPOCO or DPOFA ! or the output X from DQRDC. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! JOB INTEGER ! = 11 both determinant and inverse. ! = 01 inverse only. ! = 10 determinant only. ! ! On Return ! ! A If DPOCO or DPOFA was used to factor A , then ! DPODI produces the upper half of INVERSE(A) . ! If DQRDC was used to decompose X , then ! DPODI produces the upper half of inverse(TRANS(X)*X) ! where TRANS(X) is the transpose. ! Elements of A below the diagonal are unchanged. ! If the units digit of JOB is zero, A is unchanged. ! ! DET DOUBLE PRECISION(2) ! determinant of A or of TRANS(X)*X if requested. ! Otherwise not referenced. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= DET(1) < 10.0 ! or DET(1) == 0.0 . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal and the inverse is requested. ! It will not occur if the subroutines are called correctly ! and if DPOCO or DPOFA has set INFO == 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPODI INTEGER LDA,N,JOB DOUBLE PRECISION A(LDA,*) DOUBLE PRECISION DET(2) ! DOUBLE PRECISION T DOUBLE PRECISION S INTEGER I,J,JM1,K,KP1 !***FIRST EXECUTABLE STATEMENT DPODI ! ! COMPUTE DETERMINANT ! if (JOB/10 == 0) go to 70 DET(1) = 1.0D0 DET(2) = 0.0D0 S = 10.0D0 DO 50 I = 1, N DET(1) = A(I,I)**2*DET(1) if (DET(1) == 0.0D0) go to 60 10 if (DET(1) >= 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) < 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 ! ! COMPUTE INVERSE(R) ! if (MOD(JOB,10) == 0) go to 140 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 < 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 ! ! FORM INVERSE(R) * TRANS(INVERSE(R)) ! DO 130 J = 1, N JM1 = J - 1 if (JM1 < 1) go to 120 DO 110 K = 1, JM1 T = A(K,J) call DAXPY(K,T,A(1,J),1,A(1,K),1) 110 CONTINUE 120 CONTINUE T = A(J,J) call DSCAL(J,T,A(1,J),1) 130 CONTINUE 140 CONTINUE return end subroutine DPOFA (A, LDA, N, INFO) ! !! DPOFA factors a real symmetric positive definite matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE DOUBLE PRECISION (SPOFA-S, DPOFA-D, CPOFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPOFA factors a double precision symmetric positive definite ! matrix. ! ! DPOFA is usually called by DPOCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! (time for DPOCO) = (1 + 18/N)*(time for DPOFA) . ! ! On Entry ! ! A DOUBLE PRECISION(LDA, N) ! the symmetric matrix to be factored. Only the ! diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix R so that A = TRANS(R)*R ! where TRANS(R) is the transpose. ! The strict lower triangle is unaltered. ! If INFO /= 0 , the factorization is not complete. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPOFA INTEGER LDA,N,INFO DOUBLE PRECISION A(LDA,*) ! DOUBLE PRECISION DDOT,T DOUBLE PRECISION S INTEGER J,JM1,K !***FIRST EXECUTABLE STATEMENT DPOFA DO 30 J = 1, N INFO = J S = 0.0D0 JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 K = 1, JM1 T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1) T = T/A(K,K) A(K,J) = T S = S + T*T 10 CONTINUE 20 CONTINUE S = A(J,J) - S if (S <= 0.0D0) go to 40 A(J,J) = SQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE return end subroutine DPOFS (A, LDA, N, V, ITASK, IND, WORK) ! !! DPOFS solves a positive definite symmetric system of linear equations. ! !***LIBRARY SLATEC !***CATEGORY D2B1B !***TYPE DOUBLE PRECISION (SPOFS-S, DPOFS-D, CPOFS-C) !***KEYWORDS HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine DPOFS solves a positive definite symmetric ! NxN system of double precision linear equations using ! LINPACK subroutines DPOCO and DPOSL. That is, if A is an ! NxN double precision positive definite symmetric matrix and if ! X and B are double precision N-vectors, then DPOFS solves ! the equation ! ! A*X=B. ! ! The matrix A is first factored into upper and lower tri- ! angular matrices R and R-TRANPOSE. These factors are used to ! find the solution vector X. An approximate condition number is ! calculated to provide a rough estimate of the number of ! digits of accuracy in the computed solution. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option only to solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, and N must not have been altered by the user following ! factorization (ITASK=1). IND will not be changed by DPOFS ! in this case. ! ! Argument Description *** ! ! A DOUBLE PRECISION(LDA,N) ! on entry, the doubly subscripted array with dimension ! (LDA,N) which contains the coefficient matrix. Only ! the upper triangle, including the diagonal, of the ! coefficient matrix need be entered and will subse- ! quently be referenced and changed by the routine. ! on return, A contains in its upper triangle an upper ! triangular matrix R such that A = (R-TRANPOSE) * R . ! LDA INTEGER ! the leading dimension of the array A. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. N must be greater ! than or equal to 1. (terminal error message IND=-2) ! V DOUBLE PRECISION(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! If ITASK = 1, the matrix A is factored and then the ! linear equation is solved. ! If ITASK > 1, the equation is solved using the existing ! factored matrix A. ! If ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. ! LT. 0 See error message corresponding to IND below. ! WORK DOUBLE PRECISION(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 Terminal N is greater than LDA. ! IND=-2 Terminal N is less than 1. ! IND=-3 Terminal ITASK is less than 1. ! IND=-4 Terminal The matrix A is computationally singular or ! is not positive definite. A solution ! has not been computed. ! IND=-10 Warning The solution has no apparent significance. ! The solution may be inaccurate or the ! matrix A may be poorly scaled. ! ! Note- The above Terminal(*fatal*) Error Messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED D1MACH, DPOCO, DPOSL, XERMSG !***REVISION HISTORY (YYMMDD) ! 800514 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPOFS ! INTEGER LDA,N,ITASK,IND,INFO DOUBLE PRECISION A(LDA,*),V(*),WORK(*),D1MACH DOUBLE PRECISION RCOND CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT DPOFS if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'DPOFS', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'DPOFS', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'DPOFS', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ITASK == 1) THEN ! ! FACTOR MATRIX A INTO R ! call DPOCO(A,LDA,N,RCOND,WORK,INFO) ! ! CHECK FOR POSITIVE DEFINITE MATRIX ! if (INFO /= 0) THEN IND = -4 call XERMSG ('SLATEC', 'DPOFS', & 'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1) return ENDIF ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(D1MACH(4)/RCOND) if (IND == 0) THEN IND = -10 call XERMSG ('SLATEC', 'DPOFS', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) ENDIF end if ! ! SOLVE AFTER FACTORING ! call DPOSL(A,LDA,N,V) return end subroutine DPOLCF (XX, N, X, C, D, WORK) ! !! DPOLCF computes the coefficients of the polynomial fit (including ... ! Hermite polynomial fits) produced by a previous call to POLINT. ! !***LIBRARY SLATEC !***CATEGORY E1B !***TYPE DOUBLE PRECISION (POLCOF-S, DPOLCF-D) !***KEYWORDS COEFFICIENTS, POLYNOMIAL !***AUTHOR Huddleston, R. E., (SNLL) !***DESCRIPTION ! ! Abstract ! Subroutine DPOLCF computes the coefficients of the polynomial ! fit (including Hermite polynomial fits ) produced by a previous ! call to DPLINT. The coefficients of the polynomial, expanded ! about XX, are stored in the array D. The expansion is of the form ! P(Z) = D(1) + D(2)*(Z-XX) +D(3)*((Z-XX)**2) + ... + ! D(N)*((Z-XX)**(N-1)). ! Between the call to DPLINT and the call to DPOLCF the variable N ! and the arrays X and C must not be altered. ! ! ***** INPUT PARAMETERS ! *** All TYPE REAL variables are DOUBLE PRECISION *** ! ! XX - The point about which the Taylor expansion is to be made. ! ! N - **** ! * N, X, and C must remain unchanged between the ! X - * call to DPLINT and the call to DPOLCF. ! C - **** ! ! ***** OUTPUT PARAMETER ! *** All TYPE REAL variables are DOUBLE PRECISION *** ! ! D - The array of coefficients for the Taylor expansion as ! explained in the abstract ! ! ***** STORAGE PARAMETER ! ! WORK - This is an array to provide internal working storage. It ! must be dimensioned by at least 2*N in the calling program. ! ! ! **** Note - There are two methods for evaluating the fit produced ! by DPLINT. You may call DPOLVL to perform the task, or you may ! call DPOLCF to obtain the coefficients of the Taylor expansion and ! then write your own evaluation scheme. Due to the inherent errors ! in the computations of the Taylor expansion from the Newton ! coefficients produced by DPLINT, much more accuracy may be ! expected by calling DPOLVL as opposed to writing your own scheme. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890213 DATE WRITTEN ! 891006 Cosmetic changes to prologue. (WRB) ! 891024 Corrected KEYWORD section. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DPOLCF ! INTEGER I,IM1,K,KM1,KM1PI,KM2N,KM2NPI,N,NM1,NMKP1,NPKM1 DOUBLE PRECISION C(*),D(*),PONE,PTWO,X(*),XX,WORK(*) !***FIRST EXECUTABLE STATEMENT DPOLCF DO 10010 K=1,N D(K)=C(K) 10010 CONTINUE if (N == 1) RETURN WORK(1)=1.0D0 PONE=C(1) NM1=N-1 DO 10020 K=2,N KM1=K-1 NPKM1=N+K-1 WORK(NPKM1)=XX-X(KM1) WORK(K)=WORK(NPKM1)*WORK(KM1) PTWO=PONE+WORK(K)*C(K) PONE=PTWO 10020 CONTINUE D(1)=PTWO if (N == 2) RETURN DO 10030 K=2,NM1 KM1=K-1 KM2N=K-2+N NMKP1=N-K+1 DO 10030 I=2,NMKP1 KM2NPI=KM2N+I IM1=I-1 KM1PI=KM1+I WORK(I)=WORK(KM2NPI)*WORK(IM1)+WORK(I) D(K)=D(K)+WORK(I)*D(KM1PI) 10030 CONTINUE return end subroutine DPOLFT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A) ! !! DPOLFT fits discrete data in a least squares sense by polynomials ... ! in one variable. ! !***LIBRARY SLATEC !***CATEGORY K1A1A2 !***TYPE DOUBLE PRECISION (POLFIT-S, DPOLFT-D) !***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT !***AUTHOR Shampine, L. F., (SNLA) ! Davenport, S. M., (SNLA) ! Huddleston, R. E., (SNLL) !***DESCRIPTION ! ! Abstract ! ! Given a collection of points X(I) and a set of values Y(I) which ! correspond to some function or measurement at each of the X(I), ! subroutine DPOLFT computes the weighted least-squares polynomial ! fits of all degrees up to some degree either specified by the user ! or determined by the routine. The fits thus obtained are in ! orthogonal polynomial form. Subroutine DP1VLU may then be ! called to evaluate the fitted polynomials and any of their ! derivatives at any point. The subroutine DPCOEF may be used to ! express the polynomial fits as powers of (X-C) for any specified ! point C. ! ! The parameters for DPOLFT are ! ! Input -- All TYPE REAL variables are DOUBLE PRECISION ! N - the number of data points. The arrays X, Y and W ! must be dimensioned at least N (N >= 1). ! X - array of values of the independent variable. These ! values may appear in any order and need not all be ! distinct. ! Y - array of corresponding function values. ! W - array of positive values to be used as weights. If ! W(1) is negative, DPOLFT will set all the weights ! to 1.0, which means unweighted least squares error ! will be minimized. To minimize relative error, the ! user should set the weights to: W(I) = 1.0/Y(I)**2, ! I = 1,...,N . ! MAXDEG - maximum degree to be allowed for polynomial fit. ! MAXDEG may be any non-negative integer less than N. ! Note -- MAXDEG cannot be equal to N-1 when a ! statistical test is to be used for degree selection, ! i.e., when input value of EPS is negative. ! EPS - specifies the criterion to be used in determining ! the degree of fit to be computed. ! (1) If EPS is input negative, DPOLFT chooses the ! degree based on a statistical F test of ! significance. One of three possible ! significance levels will be used: .01, .05 or ! .10. If EPS=-1.0 , the routine will ! automatically select one of these levels based ! on the number of data points and the maximum ! degree to be considered. If EPS is input as ! -.01, -.05, or -.10, a significance level of ! .01, .05, or .10, respectively, will be used. ! (2) If EPS is set to 0., DPOLFT computes the ! polynomials of degrees 0 through MAXDEG . ! (3) If EPS is input positive, EPS is the RMS ! error tolerance which must be satisfied by the ! fitted polynomial. DPOLFT will increase the ! degree of fit until this criterion is met or ! until the maximum degree is reached. ! ! Output -- All TYPE REAL variables are DOUBLE PRECISION ! NDEG - degree of the highest degree fit computed. ! EPS - RMS error of the polynomial of degree NDEG . ! R - vector of dimension at least NDEG containing values ! of the fit of degree NDEG at each of the X(I) . ! Except when the statistical test is used, these ! values are more accurate than results from subroutine ! DP1VLU normally are. ! IERR - error flag with the following possible values. ! 1 -- indicates normal execution, i.e., either ! (1) the input value of EPS was negative, and the ! computed polynomial fit of degree NDEG ! satisfies the specified F test, or ! (2) the input value of EPS was 0., and the fits of ! all degrees up to MAXDEG are complete, or ! (3) the input value of EPS was positive, and the ! polynomial of degree NDEG satisfies the RMS ! error requirement. ! 2 -- invalid input parameter. At least one of the input ! parameters has an illegal value and must be corrected ! before DPOLFT can proceed. Valid input results ! when the following restrictions are observed ! N >= 1 ! 0 <= MAXDEG <= N-1 for EPS >= 0. ! 0 <= MAXDEG <= N-2 for EPS < 0. ! W(1)=-1.0 or W(I) > 0., I=1,...,N . ! 3 -- cannot satisfy the RMS error requirement with a ! polynomial of degree no greater than MAXDEG . Best ! fit found is of degree MAXDEG . ! 4 -- cannot satisfy the test for significance using ! current value of MAXDEG . Statistically, the ! best fit found is of order NORD . (In this case, ! NDEG will have one of the values: MAXDEG-2, ! MAXDEG-1, or MAXDEG). Using a higher value of ! MAXDEG may result in passing the test. ! A - work and output array having at least 3N+3MAXDEG+3 ! locations ! ! Note - DPOLFT calculates all fits of degrees up to and including ! NDEG . Any or all of these fits can be evaluated or ! expressed as powers of (X-C) using DP1VLU and DPCOEF ! after just one call to DPOLFT . ! !***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, ! Curve fitting by polynomials in one variable, Report ! SLA-74-0270, Sandia Laboratories, June 1974. !***ROUTINES CALLED DP1VLU, XERMSG !***REVISION HISTORY (YYMMDD) ! 740601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900911 Added variable YP to DOUBLE PRECISION declaration. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 920527 Corrected erroneous statements in DESCRIPTION. (WRB) !***END PROLOGUE DPOLFT INTEGER I,IDEGF,IERR,J,JP1,JPAS,K1,K1PJ,K2,K2PJ,K3,K3PI,K4, & K4PI,K5,K5PI,KSIG,M,MAXDEG,MOP1,NDEG,NDER,NFAIL DOUBLE PRECISION TEMD1,TEMD2 DOUBLE PRECISION A(*),DEGF,DEN,EPS,ETST,F,FCRIT,R(*),SIG,SIGJ, & SIGJM1,SIGPAS,TEMP,X(*),XM,Y(*),YP,W(*),W1,W11 DOUBLE PRECISION CO(4,3) SAVE CO DATA CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2), & CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3), & CO(4,3)/-13.086850D0,-2.4648165D0,-3.3846535D0,-1.2973162D0, & -3.3381146D0,-1.7812271D0,-3.2578406D0,-1.6589279D0, & -1.6282703D0,-1.3152745D0,-3.2640179D0,-1.9829776D0/ !***FIRST EXECUTABLE STATEMENT DPOLFT M = ABS(N) if (M == 0) go to 30 if (MAXDEG < 0) go to 30 A(1) = MAXDEG MOP1 = MAXDEG + 1 if (M < MOP1) go to 30 if (EPS < 0.0D0 .AND. M == MOP1) go to 30 XM = M ETST = EPS*EPS*XM if (W(1) < 0.0D0) go to 2 DO 1 I = 1,M if (W(I) <= 0.0D0) go to 30 1 CONTINUE go to 4 2 DO 3 I = 1,M 3 W(I) = 1.0D0 4 if (EPS >= 0.0D0) go to 8 ! ! DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR ! CHOOSING DEGREE OF POLYNOMIAL FIT ! if (EPS > (-.55D0)) go to 5 IDEGF = M - MAXDEG - 1 KSIG = 1 if (IDEGF < 10) KSIG = 2 if (IDEGF < 5) KSIG = 3 go to 8 5 KSIG = 1 if (EPS < (-.03D0)) KSIG = 2 if (EPS < (-.07D0)) KSIG = 3 ! ! INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING ! 8 K1 = MAXDEG + 1 K2 = K1 + MAXDEG K3 = K2 + MAXDEG + 2 K4 = K3 + M K5 = K4 + M DO 9 I = 2,K4 9 A(I) = 0.0D0 W11 = 0.0D0 if (N < 0) go to 11 ! ! UNCONSTRAINED CASE ! DO 10 I = 1,M K4PI = K4 + I A(K4PI) = 1.0D0 10 W11 = W11 + W(I) go to 13 ! ! CONSTRAINED CASE ! 11 DO 12 I = 1,M K4PI = K4 + I 12 W11 = W11 + W(I)*A(K4PI)**2 ! ! COMPUTE FIT OF DEGREE ZERO ! 13 TEMD1 = 0.0D0 DO 14 I = 1,M K4PI = K4 + I TEMD1 = TEMD1 + W(I)*Y(I)*A(K4PI) 14 CONTINUE TEMD1 = TEMD1/W11 A(K2+1) = TEMD1 SIGJ = 0.0D0 DO 15 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = TEMD1*A(K4PI) R(I) = TEMD2 A(K5PI) = TEMD2 - R(I) 15 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 J = 0 ! ! SEE if POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION ! if (EPS) 24,26,27 ! ! INCREMENT DEGREE ! 16 J = J + 1 JP1 = J + 1 K1PJ = K1 + J K2PJ = K2 + J SIGJM1 = SIGJ ! ! COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 ! if (J > 1) A(K1PJ) = W11/W1 ! ! COMPUTE NEW A COEFFICIENT ! TEMD1 = 0.0D0 DO 18 I = 1,M K4PI = K4 + I TEMD2 = A(K4PI) TEMD1 = TEMD1 + X(I)*W(I)*TEMD2*TEMD2 18 CONTINUE A(JP1) = TEMD1/W11 ! ! EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS ! W1 = W11 W11 = 0.0D0 DO 19 I = 1,M K3PI = K3 + I K4PI = K4 + I TEMP = A(K3PI) A(K3PI) = A(K4PI) A(K4PI) = (X(I)-A(JP1))*A(K3PI) - A(K1PJ)*TEMP 19 W11 = W11 + W(I)*A(K4PI)**2 ! ! GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE ! PRECISION ! TEMD1 = 0.0D0 DO 20 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = W(I)*((Y(I)-R(I))-A(K5PI))*A(K4PI) 20 TEMD1 = TEMD1 + TEMD2 TEMD1 = TEMD1/W11 A(K2PJ+1) = TEMD1 ! ! UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND ! ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE ! COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, ! THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST ! SIGNIFICANT BITS ARE IN A(K5PI) . ! SIGJ = 0.0D0 DO 21 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = R(I) + A(K5PI) + TEMD1*A(K4PI) R(I) = TEMD2 A(K5PI) = TEMD2 - R(I) 21 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 ! ! SEE if DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE ! MAXDEG HAS BEEN REACHED ! if (EPS) 23,26,27 ! ! COMPUTE F STATISTICS (INPUT EPS < 0.) ! 23 if (SIGJ == 0.0D0) go to 29 DEGF = M - J - 1 DEN = (CO(4,KSIG)*DEGF + 1.0D0)*DEGF FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN FCRIT = FCRIT*FCRIT F = (SIGJM1 - SIGJ)*DEGF/SIGJ if (F < FCRIT) go to 25 ! ! POLYNOMIAL OF DEGREE J SATISFIES F TEST ! 24 SIGPAS = SIGJ JPAS = J NFAIL = 0 if (MAXDEG == J) go to 32 go to 16 ! ! POLYNOMIAL OF DEGREE J FAILS F TEST. if THERE HAVE BEEN THREE ! SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. ! 25 NFAIL = NFAIL + 1 if (NFAIL >= 3) go to 29 if (MAXDEG == J) go to 32 go to 16 ! ! RAISE THE DEGREE if DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT ! EPS = 0.) ! 26 if (MAXDEG == J) go to 28 go to 16 ! ! SEE if RMS ERROR CRITERION IS SATISFIED (INPUT EPS > 0.) ! 27 if (SIGJ <= ETST) go to 28 if (MAXDEG == J) go to 31 go to 16 ! ! RETURNS ! 28 IERR = 1 NDEG = J SIG = SIGJ go to 33 29 IERR = 1 NDEG = JPAS SIG = SIGPAS go to 33 30 IERR = 2 call XERMSG ('SLATEC', 'DPOLFT', 'INVALID INPUT PARAMETER.', 2, & 1) go to 37 31 IERR = 3 NDEG = MAXDEG SIG = SIGJ go to 33 32 IERR = 4 NDEG = JPAS SIG = SIGPAS ! 33 A(K3) = NDEG ! ! WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT ! ALL THE DATA POINTS if R DOES NOT ALREADY CONTAIN THESE VALUES ! if ( EPS >= 0.0 .OR. NDEG == MAXDEG) go to 36 NDER = 0 DO 35 I = 1,M call DP1VLU (NDEG,NDER,X(I),R(I),YP,A) 35 CONTINUE 36 EPS = SQRT(SIG/XM) 37 return end subroutine DPOLVL (NDER, XX, YFIT, YP, N, X, C, WORK, IERR) ! !! DPOLVL evaluates a polynomial and its first NDER derivatives where ... ! the polynomial was produced by a previous call to DPLINT. ! !***LIBRARY SLATEC !***CATEGORY E3 !***TYPE DOUBLE PRECISION (POLYVL-S, DPOLVL-D) !***KEYWORDS POLYNOMIAL EVALUATION !***AUTHOR Huddleston, R. E., (SNLL) !***DESCRIPTION ! ! Abstract - ! Subroutine DPOLVL calculates the value of the polynomial and ! its first NDER derivatives where the polynomial was produced by ! a previous call to DPLINT. ! The variable N and the arrays X and C must not be altered ! between the call to DPLINT and the call to DPOLVL. ! ! ****** Dimensioning Information ******* ! ! YP must be dimensioned by at least NDER ! X must be dimensioned by at least N (see the abstract ) ! C must be dimensioned by at least N (see the abstract ) ! WORK must be dimensioned by at least 2*N if NDER is > 0. ! ! *** Note *** ! If NDER=0, neither YP nor WORK need to be dimensioned variables. ! If NDER=1, YP does not need to be a dimensioned variable. ! ! ! ***** Input parameters ! *** All TYPE REAL variables are DOUBLE PRECISION *** ! ! NDER - the number of derivatives to be evaluated ! ! XX - the argument at which the polynomial and its derivatives ! are to be evaluated. ! ! N - ***** ! * N, X, and C must not be altered between the call ! X - * to DPLINT and the call to DPOLVL. ! C - ***** ! ! ! ***** Output Parameters ! *** All TYPE REAL variables are DOUBLE PRECISION *** ! ! YFIT - the value of the polynomial at XX ! ! YP - the derivatives of the polynomial at XX. The derivative of ! order J at XX is stored in YP(J) , J = 1,...,NDER. ! ! IERR - Output error flag with the following possible values. ! = 1 indicates normal execution ! ! ***** Storage Parameters ! ! WORK = this is an array to provide internal working storage for ! DPOLVL. It must be dimensioned by at least 2*N if NDER is ! > 0. If NDER=0, WORK does not need to be a dimensioned ! variable. ! !***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, ! Curve fitting by polynomials in one variable, Report ! SLA-74-0270, Sandia Laboratories, June 1974. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 740601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPOLVL INTEGER I,IERR,IM1,IZERO,K,KM1,KM1PI,KM2PN,KM2PNI,M,MM,N,NDR,NDER, & NMKP1,NPKM1 DOUBLE PRECISION C(*),FAC,PIONE,PITWO,PONE,PTWO,X(*),XK,XX, & YFIT,YP(*),WORK(*) !***FIRST EXECUTABLE STATEMENT DPOLVL IERR=1 if (NDER > 0) go to 10020 ! ! ***** CODING FOR THE CASE NDER = 0 ! PIONE=1.0D0 PONE=C(1) YFIT=PONE if (N == 1) RETURN DO 10010 K=2,N PITWO=(XX-X(K-1))*PIONE PIONE=PITWO PTWO=PONE+PITWO*C(K) PONE=PTWO 10010 CONTINUE YFIT=PTWO return ! ! ***** END OF NDER = 0 CASE ! 10020 CONTINUE if (N > 1) go to 10040 YFIT=C(1) ! ! ***** CODING FOR THE CASE N=1 AND NDER > 0 ! DO 10030 K=1,NDER YP(K)=0.0D0 10030 CONTINUE return ! ! ***** END OF THE CASE N = 1 AND NDER > 0 ! 10040 CONTINUE if (NDER < N) go to 10050 ! ! ***** SET FLAGS FOR NUMBER OF DERIVATIVES AND FOR DERIVATIVES ! IN EXCESS OF THE DEGREE (N-1) OF THE POLYNOMIAL. ! IZERO=1 NDR=N-1 go to 10060 10050 CONTINUE IZERO=0 NDR=NDER 10060 CONTINUE M=NDR+1 MM=M ! ! ***** START OF THE CASE NDER > 0 AND N > 1 ! ***** THE POLYNOMIAL AND ITS DERIVATIVES WILL BE EVALUATED AT XX ! DO 10070 K=1,NDR YP(K)=C(K+1) 10070 CONTINUE ! ! ***** THE FOLLOWING SECTION OF CODE IS EASIER TO READ if ONE ! BREAKS WORK INTO TWO ARRAYS W AND V. THE CODE WOULD THEN ! READ ! W(1) = 1. ! PONE = C(1) ! *DO K = 2,N ! * V(K-1) = XX - X(K-1) ! * W(K) = V(K-1)*W(K-1) ! * PTWO = PONE + W(K)*C(K) ! * PONE = PWO ! ! YFIT = PTWO ! WORK(1)=1.0D0 PONE=C(1) DO 10080 K=2,N KM1=K-1 NPKM1=N+K-1 WORK(NPKM1)=XX-X(KM1) WORK(K)=WORK(NPKM1)*WORK(KM1) PTWO=PONE+WORK(K)*C(K) PONE=PTWO 10080 CONTINUE YFIT=PTWO ! ! ** AT THIS POINT THE POLYNOMIAL HAS BEEN EVALUATED AND INFORMATION ! FOR THE DERIVATIVE EVALUATIONS HAVE BEEN STORED IN THE ARRAY ! WORK if (N == 2) go to 10110 if (M == N) MM=NDR ! ! ***** EVALUATE THE DERIVATIVES AT XX ! ! ****** DO K=2,MM (FOR MOST CASES, MM = NDER + 1) ! * ****** DO I=2,N-K+1 ! * * W(I) = V(K-2+I)*W(I-1) + W(I) ! * * YP(K-1) = YP(K-1) + W(I)*C(K-1+I) ! ****** CONTINUE ! DO 10090 K=2,MM NMKP1=N-K+1 KM1=K-1 KM2PN=K-2+N DO 10090 I=2,NMKP1 KM2PNI=KM2PN+I IM1=I-1 KM1PI=KM1+I WORK(I)=WORK(KM2PNI)*WORK(IM1)+WORK(I) YP(KM1)=YP(KM1)+WORK(I)*C(KM1PI) 10090 CONTINUE if (NDR == 1) go to 10110 FAC=1.0D0 DO 10100 K=2,NDR XK=K FAC=XK*FAC YP(K)=FAC*YP(K) 10100 CONTINUE ! ! ***** END OF DERIVATIVE EVALUATIONS ! 10110 CONTINUE if (IZERO == 0) RETURN ! ! ***** SET EXCESS DERIVATIVES TO ZERO. ! DO 10120 K=N,NDER YP(K)=0.0D0 10120 CONTINUE return end subroutine DPOPT (PRGOPT, MRELAS, NVARS, INFO, CSC, IBASIS, ROPT, & INTOPT, LOPT) ! !! DPOPT is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPOPT-S, DPOPT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/,/R1MACH/D1MACH/,/E0/D0/ ! ! REVISED 821122-1045 ! REVISED YYMMDD-HHMM ! ! THIS SUBROUTINE PROCESSES THE OPTION VECTOR, PRGOPT(*), ! AND VALIDATES ANY MODIFIED DATA. ! !***SEE ALSO DSPLP !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Fixed an error message. (RWC) !***END PROLOGUE DPOPT DOUBLE PRECISION ABIG,ASMALL,COSTSC,CSC(*),EPS,ONE,PRGOPT(*), & ROPT(07),TOLLS,TUNE,ZERO,D1MACH,TOLABS INTEGER IBASIS(*),INTOPT(08) LOGICAL CONTIN,USRBAS,SIZEUP,SAVEDT,COLSCP,CSTSCP,MINPRB, & STPEDG,LOPT(8) ! !***FIRST EXECUTABLE STATEMENT DPOPT IOPT=1 ZERO=0.D0 ONE=1.D0 go to 30001 20002 CONTINUE go to 30002 ! 20003 LOPT(1)=CONTIN LOPT(2)=USRBAS LOPT(3)=SIZEUP LOPT(4)=SAVEDT LOPT(5)=COLSCP LOPT(6)=CSTSCP LOPT(7)=MINPRB LOPT(8)=STPEDG ! INTOPT(1)=IDG INTOPT(2)=IPAGEF INTOPT(3)=ISAVE INTOPT(4)=MXITLP INTOPT(5)=KPRINT INTOPT(6)=ITBRC INTOPT(7)=NPP INTOPT(8)=LPRG ! ROPT(1)=EPS ROPT(2)=ASMALL ROPT(3)=ABIG ROPT(4)=COSTSC ROPT(5)=TOLLS ROPT(6)=TUNE ROPT(7)=TOLABS return ! ! ! PROCEDURE (INITIALIZE PARAMETERS AND PROCESS USER OPTIONS) 30001 CONTIN = .FALSE. USRBAS = .FALSE. SIZEUP = .FALSE. SAVEDT = .FALSE. COLSCP = .FALSE. CSTSCP = .FALSE. MINPRB = .TRUE. STPEDG = .TRUE. ! ! GET THE MACHINE REL. FLOATING POINT ACCURACY VALUE FROM THE ! LIBRARY SUBPROGRAM, D1MACH( ). EPS=D1MACH(4) TOLLS=D1MACH(4) TUNE=ONE TOLABS=ZERO ! ! DEFINE NOMINAL FILE NUMBERS FOR MATRIX PAGES AND DATA SAVING. IPAGEF=1 ISAVE=2 ITBRC=10 MXITLP=3*(NVARS+MRELAS) KPRINT=0 IDG=-4 NPP=NVARS LPRG=0 ! LAST = 1 IADBIG=10000 ICTMAX=1000 ICTOPT= 0 20004 NEXT=PRGOPT(LAST) if (.NOT.(NEXT <= 0 .OR. NEXT > IADBIG)) go to 20006 ! ! THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT ! WORKING WITH UNDEFINED DATA. NERR=14 call XERMSG ('SLATEC', 'DPOPT', & 'IN DSPLP, THE USER OPTION ARRAY HAS UNDEFINED DATA.', NERR, & IOPT) INFO=-NERR return 20006 if (.NOT.(NEXT == 1)) go to 10001 go to 20005 10001 if (.NOT.(ICTOPT > ICTMAX)) go to 10002 NERR=15 call XERMSG ('SLATEC', 'DPOPT', & 'IN DSPLP, OPTION ARRAY PROCESSING IS CYCLING.', NERR, IOPT) INFO=-NERR return 10002 CONTINUE KEY = PRGOPT(LAST+1) ! ! if KEY = 50, THIS IS TO BE A MAXIMIZATION PROBLEM ! INSTEAD OF A MINIMIZATION PROBLEM. if (.NOT.(KEY == 50)) go to 20010 MINPRB = PRGOPT(LAST+2) == ZERO LDS=3 go to 20009 20010 CONTINUE ! ! if KEY = 51, THE LEVEL OF OUTPUT IS BEING MODIFIED. ! KPRINT = 0, NO OUTPUT ! = 1, SUMMARY OUTPUT ! = 2, LOTS OF OUTPUT ! = 3, EVEN MORE OUTPUT if (.NOT.(KEY == 51)) go to 20013 KPRINT=PRGOPT(LAST+2) LDS=3 go to 20009 20013 CONTINUE ! ! if KEY = 52, REDEFINE THE FORMAT AND PRECISION USED ! IN THE OUTPUT. if (.NOT.(KEY == 52)) go to 20016 if (PRGOPT(LAST+2) /= ZERO) IDG=PRGOPT(LAST+3) LDS=4 go to 20009 20016 CONTINUE ! ! if KEY = 53, THE ALLOTTED SPACE FOR THE SPARSE MATRIX ! STORAGE AND/OR SPARSE EQUATION SOLVING HAS BEEN CHANGED. ! (PROCESSED IN DSPLP(). THIS IS TO COMPUTE THE LENGTH OF PRGOPT(*).) if (.NOT.(KEY == 53)) go to 20019 LDS=5 go to 20009 20019 CONTINUE ! ! if KEY = 54, REDEFINE THE FILE NUMBER WHERE THE PAGES ! FOR THE SPARSE MATRIX ARE STORED. if (.NOT.(KEY == 54)) go to 20022 if ( PRGOPT(LAST+2) /= ZERO) IPAGEF = PRGOPT(LAST+3) LDS=4 go to 20009 20022 CONTINUE ! ! if KEY = 55, A CONTINUATION FOR A PROBLEM MAY BE REQUESTED. if (.NOT.(KEY == 55)) go to 20025 CONTIN = PRGOPT(LAST+2) /= ZERO LDS=3 go to 20009 20025 CONTINUE ! ! if KEY = 56, REDEFINE THE FILE NUMBER WHERE THE SAVED DATA ! WILL BE STORED. if (.NOT.(KEY == 56)) go to 20028 if ( PRGOPT(LAST+2) /= ZERO) ISAVE = PRGOPT(LAST+3) LDS=4 go to 20009 20028 CONTINUE ! ! if KEY = 57, SAVE DATA (ON EXTERNAL FILE) AT MXITLP ITERATIONS OR ! THE OPTIMUM, WHICHEVER COMES FIRST. if (.NOT.(KEY == 57)) go to 20031 SAVEDT=PRGOPT(LAST+2) /= ZERO LDS=3 go to 20009 20031 CONTINUE ! ! if KEY = 58, SEE IF PROBLEM IS TO RUN ONLY A GIVEN ! NUMBER OF ITERATIONS. if (.NOT.(KEY == 58)) go to 20034 if (PRGOPT(LAST+2) /= ZERO) MXITLP = PRGOPT(LAST+3) LDS=4 go to 20009 20034 CONTINUE ! ! if KEY = 59, SEE IF USER PROVIDES THE BASIS INDICES. if (.NOT.(KEY == 59)) go to 20037 USRBAS = PRGOPT(LAST+2) /= ZERO if (.NOT.(USRBAS)) go to 20040 I=1 N20043=MRELAS go to 20044 20043 I=I+1 20044 if ((N20043-I) < 0) go to 20045 IBASIS(I) = PRGOPT(LAST+2+I) go to 20043 20045 CONTINUE 20040 CONTINUE LDS=MRELAS+3 go to 20009 20037 CONTINUE ! ! if KEY = 60, SEE IF USER HAS PROVIDED SCALING OF COLUMNS. if (.NOT.(KEY == 60)) go to 20047 COLSCP = PRGOPT(LAST+2) /= ZERO if (.NOT.(COLSCP)) go to 20050 J=1 N20053=NVARS go to 20054 20053 J=J+1 20054 if ((N20053-J) < 0) go to 20055 CSC(J)=ABS(PRGOPT(LAST+2+J)) go to 20053 20055 CONTINUE 20050 CONTINUE LDS=NVARS+3 go to 20009 20047 CONTINUE ! ! if KEY = 61, SEE IF USER HAS PROVIDED SCALING OF COSTS. if (.NOT.(KEY == 61)) go to 20057 CSTSCP = PRGOPT(LAST+2) /= ZERO if (CSTSCP) COSTSC = PRGOPT(LAST+3) LDS=4 go to 20009 20057 CONTINUE ! ! if KEY = 62, SEE IF SIZE PARAMETERS ARE PROVIDED WITH THE DATA. ! THESE WILL BE CHECKED AGAINST THE MATRIX ELEMENT SIZES LATER. if (.NOT.(KEY == 62)) go to 20060 SIZEUP = PRGOPT(LAST+2) /= ZERO if (.NOT.(SIZEUP)) go to 20063 ASMALL = PRGOPT(LAST+3) ABIG = PRGOPT(LAST+4) 20063 CONTINUE LDS=5 go to 20009 20060 CONTINUE ! ! if KEY = 63, SEE IF TOLERANCE FOR LINEAR SYSTEM RESIDUAL ERROR IS ! PROVIDED. if (.NOT.(KEY == 63)) go to 20066 if (PRGOPT(LAST+2) /= ZERO) TOLLS = MAX(EPS,PRGOPT(LAST+3)) LDS=4 go to 20009 20066 CONTINUE ! ! if KEY = 64, SEE IF MINIMUM REDUCED COST OR STEEPEST EDGE ! DESCENT IS TO BE USED FOR SELECTING VARIABLES TO ENTER BASIS. if (.NOT.(KEY == 64)) go to 20069 STPEDG = PRGOPT(LAST+2) == ZERO LDS=3 go to 20009 20069 CONTINUE ! ! if KEY = 65, SET THE NUMBER OF ITERATIONS BETWEEN RECALCULATING ! THE ERROR IN THE PRIMAL SOLUTION. if (.NOT.(KEY == 65)) go to 20072 if (PRGOPT(LAST+2) /= ZERO) ITBRC=MAX(ONE,PRGOPT(LAST+3)) LDS=4 go to 20009 20072 CONTINUE ! ! if KEY = 66, SET THE NUMBER OF NEGATIVE REDUCED COSTS TO BE FOUND ! IN THE PARTIAL PRICING STRATEGY. if (.NOT.(KEY == 66)) go to 20075 if (.NOT.(PRGOPT(LAST+2) /= ZERO)) go to 20078 NPP=MAX(PRGOPT(LAST+3),ONE) NPP=MIN(NPP,NVARS) 20078 CONTINUE LDS=4 go to 20009 20075 CONTINUE ! if KEY = 67, CHANGE THE TUNING PARAMETER TO APPLY TO THE ERROR ! ESTIMATES FOR THE PRIMAL AND DUAL SYSTEMS. if (.NOT.(KEY == 67)) go to 20081 if (.NOT.(PRGOPT(LAST+2) /= ZERO)) go to 20084 TUNE=ABS(PRGOPT(LAST+3)) 20084 CONTINUE LDS=4 go to 20009 20081 CONTINUE if (.NOT.(KEY == 68)) go to 20087 LDS=6 go to 20009 20087 CONTINUE ! ! RESET THE ABSOLUTE TOLERANCE TO BE USED ON THE FEASIBILITY ! DECISION PROVIDED THE RELATIVE ERROR TEST FAILED. if (.NOT.(KEY == 69)) go to 20090 if ( PRGOPT(LAST+2) /= ZERO)TOLABS=PRGOPT(LAST+3) LDS=4 go to 20009 20090 CONTINUE CONTINUE ! 20009 ICTOPT = ICTOPT+1 LAST = NEXT LPRG=LPRG+LDS go to 20004 20005 CONTINUE go to 20002 ! ! PROCEDURE (VALIDATE OPTIONALLY MODIFIED DATA) ! ! if USER HAS DEFINED THE BASIS, CHECK FOR VALIDITY OF INDICES. 30002 if (.NOT.(USRBAS)) go to 20093 I=1 N20096=MRELAS go to 20097 20096 I=I+1 20097 if ((N20096-I) < 0) go to 20098 ITEST=IBASIS(I) if (.NOT.(ITEST <= 0 .OR.ITEST > (NVARS+MRELAS))) go to 20100 NERR=16 call XERMSG ('SLATEC', 'DPOPT', & 'IN DSPLP, AN INDEX OF USER-SUPPLIED BASIS IS OUT OF RANGE.', & NERR, IOPT) INFO=-NERR return 20100 CONTINUE go to 20096 20098 CONTINUE 20093 CONTINUE ! ! if USER HAS PROVIDED SIZE PARAMETERS, MAKE SURE THEY ARE ORDERED ! AND POSITIVE. if (.NOT.(SIZEUP)) go to 20103 if (.NOT.(ASMALL <= ZERO .OR. ABIG < ASMALL)) go to 20106 NERR=17 call XERMSG ('SLATEC', 'DPOPT', & 'IN DSPLP, SIZE PARAMETERS FOR MATRIX MUST BE SMALLEST AND ' // & 'LARGEST MAGNITUDES OF NONZERO ENTRIES.', NERR, IOPT) INFO=-NERR return 20106 CONTINUE 20103 CONTINUE ! ! THE NUMBER OF ITERATIONS OF REV. SIMPLEX STEPS MUST BE POSITIVE. if (.NOT.(MXITLP <= 0)) go to 20109 NERR=18 call XERMSG ('SLATEC', 'DPOPT', & 'IN DSPLP, THE NUMBER OF REVISED SIMPLEX STEPS BETWEEN ' // & 'CHECK-POINTS MUST BE POSITIVE.', NERR, IOPT) INFO=-NERR return 20109 CONTINUE ! ! CHECK THAT SAVE AND PAGE FILE NUMBERS ARE DEFINED AND NOT EQUAL. ! if (.NOT.(ISAVE <= 0.OR.IPAGEF <= 0.OR.(ISAVE == IPAGEF))) go to 20112 NERR=19 call XERMSG ('SLATEC', 'DPOPT', & 'IN DSPLP, FILE NUMBERS FOR SAVED DATA AND MATRIX PAGES ' // & 'MUST BE POSITIVE AND NOT EQUAL.', NERR, IOPT) INFO=-NERR return 20112 CONTINUE CONTINUE go to 20003 end subroutine DPOSL (A, LDA, N, B) ! !! DPOSL solves the real symmetric positive definite linear system ... ! using the factors computed by DPOCO or DPOFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE DOUBLE PRECISION (SPOSL-S, DPOSL-D, CPOSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPOSL solves the double precision symmetric positive definite ! system A * X = B ! using the factors computed by DPOCO or DPOFA. ! ! On Entry ! ! A DOUBLE PRECISION(LDA, N) ! the output from DPOCO or DPOFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! B DOUBLE PRECISION(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal. Technically this indicates ! singularity, but it is usually caused by improper subroutine ! arguments. It will not occur if the subroutines are called ! correctly and INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call DPOCO(A,LDA,N,RCOND,Z,INFO) ! if (RCOND is too small .OR. INFO /= 0) go to ... ! DO 10 J = 1, P ! call DPOSL(A,LDA,N,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPOSL INTEGER LDA,N DOUBLE PRECISION A(LDA,*),B(*) ! DOUBLE PRECISION DDOT,T INTEGER K,KB ! ! SOLVE TRANS(R)*Y = B ! !***FIRST EXECUTABLE STATEMENT DPOSL ! DO K = 1, N T = DDOT(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) end do ! ! SOLVE R*X = Y ! DO 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) end do return end subroutine DPPCO (AP, N, RCOND, Z, INFO) ! !! DPPCO factors a symmetric positive definite matrix stored in ! packed form and estimate the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE DOUBLE PRECISION (SPPCO-S, DPPCO-D, CPPCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, PACKED, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPPCO factors a double precision symmetric positive definite ! matrix stored in packed form ! and estimates the condition of the matrix. ! ! If RCOND is not needed, DPPFA is slightly faster. ! To solve A*X = B , follow DPPCO by DPPSL. ! To compute INVERSE(A)*C , follow DPPCO by DPPSL. ! To compute DETERMINANT(A) , follow DPPCO by DPPDI. ! To compute INVERSE(A) , follow DPPCO by DPPDI. ! ! On Entry ! ! AP DOUBLE PRECISION (N*(N+1)/2) ! the packed form of a symmetric matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! AP an upper triangular matrix R , stored in packed ! form, so that A = TRANS(R)*R . ! If INFO /= 0 , the factorization is not complete. ! ! RCOND DOUBLE PRECISION ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. If INFO /= 0 , RCOND is unchanged. ! ! Z DOUBLE PRECISION(N) ! a work vector whose contents are usually unimportant. ! If A is singular to working precision, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! If INFO /= 0 , Z is unchanged. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a symmetric matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DASUM, DAXPY, DDOT, DPPFA, DSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPPCO INTEGER N,INFO DOUBLE PRECISION AP(*),Z(*) DOUBLE PRECISION RCOND ! DOUBLE PRECISION DDOT,EK,T,WK,WKM DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM INTEGER I,IJ,J,JM1,J1,K,KB,KJ,KK,KP1 ! ! FIND NORM OF A ! !***FIRST EXECUTABLE STATEMENT DPPCO J1 = 1 DO 30 J = 1, N Z(J) = DASUM(J,AP(J1),1) IJ = J1 J1 = J1 + J JM1 = J - 1 if (JM1 < 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.0D0 DO 40 J = 1, N ANORM = MAX(ANORM,Z(J)) 40 CONTINUE ! ! FACTOR ! call DPPFA(AP,N,INFO) if (INFO /= 0) go to 180 ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE TRANS(R)*W = E ! EK = 1.0D0 DO 50 J = 1, N Z(J) = 0.0D0 50 CONTINUE KK = 0 DO 110 K = 1, N KK = KK + K if (Z(K) /= 0.0D0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= AP(KK)) go to 60 S = AP(KK)/ABS(EK-Z(K)) call DSCAL(N,S,Z,1) EK = S*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) WK = WK/AP(KK) WKM = WKM/AP(KK) KP1 = K + 1 KJ = KK + K if (KP1 > N) go to 100 DO 70 J = KP1, N SM = SM + ABS(Z(J)+WKM*AP(KJ)) Z(J) = Z(J) + WK*AP(KJ) S = S + ABS(Z(J)) KJ = KJ + J 70 CONTINUE if (S >= SM) go to 90 T = WKM - WK WK = WKM KJ = KK + K DO 80 J = KP1, N Z(J) = Z(J) + T*AP(KJ) KJ = KJ + J 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) ! ! SOLVE R*Y = W ! DO 130 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= AP(KK)) go to 120 S = AP(KK)/ABS(Z(K)) call DSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/AP(KK) KK = KK - K T = -Z(K) call DAXPY(K-1,T,AP(KK+1),1,Z(1),1) 130 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) ! YNORM = 1.0D0 ! ! SOLVE TRANS(R)*V = Y ! DO 150 K = 1, N Z(K) = Z(K) - DDOT(K-1,AP(KK+1),1,Z(1),1) KK = KK + K if (ABS(Z(K)) <= AP(KK)) go to 140 S = AP(KK)/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/AP(KK) 150 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE R*Z = V ! DO 170 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= AP(KK)) go to 160 S = AP(KK)/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/AP(KK) KK = KK - K T = -Z(K) call DAXPY(K-1,T,AP(KK+1),1,Z(1),1) 170 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0D0) RCOND = YNORM/ANORM if (ANORM == 0.0D0) RCOND = 0.0D0 180 CONTINUE return end subroutine DPPDI (AP, N, DET, JOB) ! !! DPPDI computes the determinant and inverse of a real symmetric ... ! positive definite matrix using factors from DPPCO or DPPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B, D3B1B !***TYPE DOUBLE PRECISION (SPPDI-S, DPPDI-D, CPPDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! PACKED, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPPDI computes the determinant and inverse ! of a double precision symmetric positive definite matrix ! using the factors computed by DPPCO or DPPFA . ! ! On Entry ! ! AP DOUBLE PRECISION (N*(N+1)/2) ! the output from DPPCO or DPPFA. ! ! N INTEGER ! the order of the matrix A . ! ! JOB INTEGER ! = 11 both determinant and inverse. ! = 01 inverse only. ! = 10 determinant only. ! ! On Return ! ! AP the upper triangular half of the inverse . ! The strict lower triangle is unaltered. ! ! DET DOUBLE PRECISION(2) ! determinant of original matrix if requested. ! Otherwise not referenced. ! DETERMINANT = DET(1) * 10.0**DET(2) ! with 1.0 <= DET(1) < 10.0 ! or DET(1) == 0.0 . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal and the inverse is requested. ! It will not occur if the subroutines are called correctly ! and if DPOCO or DPOFA has set INFO == 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPPDI INTEGER N,JOB DOUBLE PRECISION AP(*) DOUBLE PRECISION DET(2) ! DOUBLE PRECISION T DOUBLE PRECISION S INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1 !***FIRST EXECUTABLE STATEMENT DPPDI ! ! COMPUTE DETERMINANT ! if (JOB/10 == 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) if (DET(1) == 0.0D0) go to 60 10 if (DET(1) >= 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) < 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 ! ! COMPUTE INVERSE(R) ! if (MOD(JOB,10) == 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 < 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 ! ! FORM INVERSE(R) * TRANS(INVERSE(R)) ! JJ = 0 DO 130 J = 1, N J1 = JJ + 1 JJ = JJ + J JM1 = J - 1 K1 = 1 KJ = J1 if (JM1 < 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 DPPERM (DX, N, IPERM, IER) ! !! DPPERM rearranges an array according to a prescribed permutation. ! !***LIBRARY SLATEC !***CATEGORY N8 !***TYPE DOUBLE PRECISION (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H) !***KEYWORDS PERMUTATION, REARRANGEMENT !***AUTHOR McClain, M. A., (NIST) ! Rhoads, G. S., (NBS) !***DESCRIPTION ! ! DPPERM rearranges the data vector DX according to the ! permutation IPERM: DX(I) <--- DX(IPERM(I)). IPERM could come ! from one of the sorting routines IPSORT, SPSORT, DPSORT or ! HPSORT. ! ! Description of Parameters ! DX - input/output -- double precision array of values to be ! rearranged. ! N - input -- number of values in double precision array DX. ! IPERM - input -- permutation vector. ! IER - output -- error indicator: ! = 0 if no error, ! = 1 if N is zero or negative, ! = 2 if IPERM is not a valid permutation. ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 901004 DATE WRITTEN ! 920507 Modified by M. McClain to revise prologue text. !***END PROLOGUE DPPERM INTEGER N, IPERM(*), I, IER, INDX, INDX0, ISTRT DOUBLE PRECISION DX(*), DTEMP !***FIRST EXECUTABLE STATEMENT DPPERM IER=0 if ( N < 1)THEN IER=1 call XERMSG ('SLATEC', 'DPPERM', & 'The number of values to be rearranged, N, is not positive.', & IER, 1) return end if ! ! CHECK WHETHER IPERM IS A VALID PERMUTATION ! DO 100 I=1,N INDX=ABS(IPERM(I)) if ( (INDX >= 1).AND.(INDX <= N))THEN if ( IPERM(INDX) > 0)THEN IPERM(INDX)=-IPERM(INDX) GOTO 100 ENDIF ENDIF IER=2 call XERMSG ('SLATEC', 'DPPERM', & 'The permutation vector, IPERM, is not valid.', IER, 1) return 100 CONTINUE ! ! REARRANGE THE VALUES OF DX ! ! USE THE IPERM VECTOR AS A FLAG. ! if IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION ! DO 330 ISTRT = 1 , N if (IPERM(ISTRT) > 0) GOTO 330 INDX = ISTRT INDX0 = INDX DTEMP = DX(ISTRT) 320 CONTINUE if (IPERM(INDX) >= 0) GOTO 325 DX(INDX) = DX(-IPERM(INDX)) INDX0 = INDX IPERM(INDX) = -IPERM(INDX) INDX = IPERM(INDX) GOTO 320 325 CONTINUE DX(INDX0) = DTEMP 330 CONTINUE ! return end subroutine DPPFA (AP, N, INFO) ! !! DPPFA factors a real symmetric positive definite matrix in packed form. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE DOUBLE PRECISION (SPPFA-S, DPPFA-D, CPPFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPPFA factors a double precision symmetric positive definite ! matrix stored in packed form. ! ! DPPFA is usually called by DPPCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! (time for DPPCO) = (1 + 18/N)*(time for DPPFA) . ! ! On Entry ! ! AP DOUBLE PRECISION (N*(N+1)/2) ! the packed form of a symmetric matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! AP an upper triangular matrix R , stored in packed ! form, so that A = TRANS(R)*R . ! ! INFO INTEGER ! = 0 for normal return. ! = K if the leading minor of order K is not ! positive definite. ! ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a symmetric matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPPFA INTEGER N,INFO DOUBLE PRECISION AP(*) ! DOUBLE PRECISION DDOT,T DOUBLE PRECISION S INTEGER J,JJ,JM1,K,KJ,KK !***FIRST EXECUTABLE STATEMENT DPPFA JJ = 0 DO 30 J = 1, N INFO = J S = 0.0D0 JM1 = J - 1 KJ = JJ KK = 0 if (JM1 < 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 if (S <= 0.0D0) go to 40 AP(JJ) = SQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE return end subroutine DPPGQ8 (FUN, LDC, C, XI, LXI, KK, ID, A, B, INPPV, ERR, & ANS, IERR) ! !! DPPGQ8 is subsidiary to DPFQAD. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PPGQ8-S, DPPGQ8-D) !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract **** A DOUBLE PRECISION routine **** ! ! DPPGQ8, a modification of GAUS8, integrates the ! product of FUN(X) by the ID-th derivative of a spline ! DPPVAL(LDC,C,XI,LXI,KK,ID,X,INPPV) between limits A and B. ! ! Description of Arguments ! ! Input-- FUN,C,XI,A,B,ERR are DOUBLE PRECISION ! FUN - Name of external function of one argument which ! multiplies DPPVAL. ! LDC - Leading dimension of matrix C, LDC >= KK ! C - Matrix of Taylor derivatives of dimension at least ! (K,LXI) ! XI - Breakpoint vector of length LXI+1 ! LXI - Number of polynomial pieces ! KK - Order of the spline, KK >= 1 ! ID - Order of the spline derivative, 0 <= ID <= KK-1 ! A - Lower limit of integral ! B - Upper limit of integral (may be less than A) ! INPPV- Initialization parameter for DPPVAL ! ERR - Is a requested pseudorelative error tolerance. Normally ! pick a value of ABS(ERR) < 1D-3. ANS will normally ! have no more error than ABS(ERR) times the integral of ! the absolute value of FUN(X)*DPPVAL(LDC,C,XI,LXI,KK,ID,X, ! INPPV). ! ! ! Output-- ERR,ANS are DOUBLE PRECISION ! ERR - Will be an estimate of the absolute error in ANS if the ! input value of ERR was negative. (ERR Is unchanged if ! the input value of ERR was nonnegative.) The estimated ! error is solely for information to the user and should ! not be used as a correction to the computed integral. ! ANS - Computed value of integral ! IERR- A status code ! --Normal Codes ! 1 ANS most likely meets requested error tolerance, ! or A=B. ! -1 A and B are too nearly equal to allow normal ! integration. ANS is set to zero. ! --Abnormal Code ! 2 ANS probably does not meet requested error tolerance. ! !***SEE ALSO DPFQAD !***ROUTINES CALLED D1MACH, DPPVAL, I1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE DPPGQ8 ! INTEGER ID,IERR,INPPV,K,KK,KML,KMX,L,LDC,LMN,LMX,LR,LXI,MXL, & NBITS, NIB, NLMN, NLMX INTEGER I1MACH DOUBLE PRECISION A,AA,AE,ANIB,ANS,AREA,B,BE,C,CC,EE,EF,EPS,ERR, & EST,GL,GLR,GR,HH,SQ2,TOL,VL,VR,W1, W2, W3, W4, XI, X1, & X2, X3, X4, X, H DOUBLE PRECISION D1MACH, DPPVAL, G8, FUN DIMENSION XI(*), C(LDC,*) DIMENSION AA(60), HH(60), LR(60), VL(60), GR(60) SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, NLMN, KMX, KML DATA X1, X2, X3, X4/ & 1.83434642495649805D-01, 5.25532409916328986D-01, & 7.96666477413626740D-01, 9.60289856497536232D-01/ DATA W1, W2, W3, W4/ & 3.62683783378361983D-01, 3.13706645877887287D-01, & 2.22381034453374471D-01, 1.01228536290376259D-01/ DATA SQ2/1.41421356D0/ DATA NLMN/1/,KMX/5000/,KML/6/ G8(X,H)= & H*((W1*(FUN(X-X1*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X1*H,INPPV) & +FUN(X+X1*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X1*H,INPPV)) & +W2*(FUN(X-X2*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X2*H,INPPV) & +FUN(X+X2*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X2*H,INPPV))) & +(W3*(FUN(X-X3*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X3*H,INPPV) & +FUN(X+X3*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X3*H,INPPV)) & +W4*(FUN(X-X4*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X4*H,INPPV) & +FUN(X+X4*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X4*H,INPPV)))) ! ! INITIALIZE ! !***FIRST EXECUTABLE STATEMENT DPPGQ8 K = I1MACH(14) ANIB = D1MACH(5)*K/0.30102000D0 NBITS = INT(ANIB) NLMX = MIN((NBITS*5)/8,60) ANS = 0.0D0 IERR = 1 BE = 0.0D0 if (A == B) go to 140 LMX = NLMX LMN = NLMN if (B == 0.0D0) go to 10 if (SIGN(1.0D0,B)*A <= 0.0D0) go to 10 CC = ABS(1.0D0-A/B) if (CC > 0.1D0) go to 10 if (CC <= 0.0D0) go to 140 ANIB = 0.5D0 - LOG(CC)/0.69314718D0 NIB = INT(ANIB) LMX = MIN(NLMX,NBITS-NIB-7) if (LMX < 1) go to 130 LMN = MIN(LMN,LMX) 10 TOL = MAX(ABS(ERR),2.0D0**(5-NBITS))/2.0D0 if (ERR == 0.0D0) TOL = SQRT(D1MACH(4)) EPS = TOL HH(1) = (B-A)/4.0D0 AA(1) = A LR(1) = 1 L = 1 EST = G8(AA(L)+2.0D0*HH(L),2.0D0*HH(L)) K = 8 AREA = ABS(EST) EF = 0.5D0 MXL = 0 ! ! COMPUTE REFINED ESTIMATES, ESTIMATE THE ERROR, ETC. ! 20 GL = G8(AA(L)+HH(L),HH(L)) GR(L) = G8(AA(L)+3.0D0*HH(L),HH(L)) K = K + 16 AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) GLR = GL + GR(L) EE = ABS(EST-GLR)*EF AE = MAX(EPS*AREA,TOL*ABS(GLR)) if (EE-AE) 40, 40, 50 30 MXL = 1 40 BE = BE + (EST-GLR) if (LR(L)) 60, 60, 80 ! ! CONSIDER THE LEFT HALF OF THIS LEVEL ! 50 if (K > KMX) LMX = KML if (L >= LMX) go to 30 L = L + 1 EPS = EPS*0.5D0 EF = EF/SQ2 HH(L) = HH(L-1)*0.5D0 LR(L) = -1 AA(L) = AA(L-1) EST = GL go to 20 ! ! PROCEED TO RIGHT HALF AT THIS LEVEL ! 60 VL(L) = GLR 70 EST = GR(L-1) LR(L) = 1 AA(L) = AA(L) + 4.0D0*HH(L) go to 20 ! ! return ONE LEVEL ! 80 VR = GLR 90 if (L <= 1) go to 120 L = L - 1 EPS = EPS*2.0D0 EF = EF*SQ2 if (LR(L)) 100, 100, 110 100 VL(L) = VL(L+1) + VR go to 70 110 VR = VL(L+1) + VR go to 90 ! ! EXIT ! 120 ANS = VR if ((MXL == 0) .OR. (ABS(BE) <= 2.0D0*TOL*AREA)) go to 140 IERR = 2 call XERMSG ('SLATEC', 'DPPGQ8', & 'ANS IS PROBABLY INSUFFICIENTLY ACCURATE.', 3, 1) go to 140 130 IERR = -1 call XERMSG ('SLATEC', 'DPPGQ8', & 'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL ' // & 'INTEGRATION. ANSWER IS SET TO ZERO, AND IERR=-1.', 1, -1) 140 CONTINUE if (ERR < 0.0D0) ERR = BE return end subroutine DPPQAD (LDC, C, XI, LXI, K, X1, X2, PQUAD) ! !! DPPQAD computes the integral on (X1,X2) of a K-th order B-spline ... ! using the piecewise polynomial (PP) representation. ! !***LIBRARY SLATEC !***CATEGORY H2A2A1, E3, K6 !***TYPE DOUBLE PRECISION (PPQAD-S, DPPQAD-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract **** a double precision routine **** ! DPPQAD computes the integral on (X1,X2) of a K-th order ! B-spline using the piecewise polynomial representation ! (C,XI,LXI,K). Here the Taylor expansion about the left ! end point XI(J) of the J-th interval is integrated and ! evaluated on subintervals of (X1,X2) which are formed by ! included break points. Integration outside (XI(1),XI(LXI+1)) ! is permitted. ! ! Description of Arguments ! Input C,XI,X1,X2 are double precision ! LDC - leading dimension of matrix C, LDC >= K ! C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI ! XI(*) - break point array of length LXI+1 ! LXI - number of polynomial pieces ! K - order of B-spline, K >= 1 ! X1,X2 - end points of quadrature interval, normally in ! XI(1) <= X <= XI(LXI+1) ! ! Output PQUAD is double precision ! PQUAD - integral of the PP representation over (X1,X2) ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES D. E. Amos, Quadrature subroutines for splines and ! B-splines, Report SAND79-1825, Sandia Laboratories, ! December 1979. !***ROUTINES CALLED DINTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPPQAD ! INTEGER I, II, IL, ILO, IL1, IL2, IM, K, LDC, LEFT, LXI, MF1, MF2 DOUBLE PRECISION A,AA,BB,C,DX,FLK,PQUAD,Q,S,SS,TA,TB,X,XI,X1,X2 DIMENSION XI(*), C(LDC,*), SS(2) ! !***FIRST EXECUTABLE STATEMENT DPPQAD PQUAD = 0.0D0 if ( K < 1) go to 100 if ( LXI < 1) go to 105 if ( LDC < K) go to 110 AA = MIN(X1,X2) BB = MAX(X1,X2) if (AA == BB) RETURN ILO = 1 call DINTRV(XI, LXI, AA, ILO, IL1, MF1) call DINTRV(XI, LXI, BB, ILO, IL2, MF2) Q = 0.0D0 DO 40 LEFT=IL1,IL2 TA = XI(LEFT) A = MAX(AA,TA) if (LEFT == 1) A = AA TB = BB if (LEFT < LXI) TB = XI(LEFT+1) X = MIN(BB,TB) DO 30 II=1,2 SS(II) = 0.0D0 DX = X - XI(LEFT) if (DX == 0.0D0) go to 20 S = C(K,LEFT) FLK = K IM = K - 1 IL = IM DO 10 I=1,IL S = S*DX/FLK + C(IM,LEFT) IM = IM - 1 FLK = FLK - 1.0D0 10 CONTINUE SS(II) = S*DX 20 CONTINUE X = A 30 CONTINUE Q = Q + (SS(1)-SS(2)) 40 CONTINUE if (X1 > X2) Q = -Q PQUAD = Q return ! ! 100 CONTINUE call XERMSG ('SLATEC', 'DPPQAD', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'DPPQAD', 'LXI DOES NOT SATISFY LXI >= 1', & 2, 1) return 110 CONTINUE call XERMSG ('SLATEC', 'DPPQAD', 'LDC DOES NOT SATISFY LDC >= K', & 2, 1) return end subroutine DPPSL (AP, N, B) ! !! DPPSL solves the real symmetric positive definite system using ... ! the factors computed by DPPCO or DPPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE DOUBLE PRECISION (SPPSL-S, DPPSL-D, CPPSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, ! POSITIVE DEFINITE, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DPPSL solves the double precision symmetric positive definite ! system A * X = B ! using the factors computed by DPPCO or DPPFA. ! ! On Entry ! ! AP DOUBLE PRECISION (N*(N+1)/2) ! the output from DPPCO or DPPFA. ! ! N INTEGER ! the order of the matrix A . ! ! B DOUBLE PRECISION(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal. Technically this indicates ! singularity, but it is usually caused by improper subroutine ! arguments. It will not occur if the subroutines are called ! correctly and INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call DPPCO(AP,N,RCOND,Z,INFO) ! if (RCOND is too small .OR. INFO /= 0) go to ... ! DO 10 J = 1, P ! call DPPSL(AP,N,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPPSL INTEGER N DOUBLE PRECISION AP(*),B(*) ! DOUBLE PRECISION DDOT,T INTEGER K,KB,KK !***FIRST EXECUTABLE STATEMENT DPPSL 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 DOUBLE PRECISION FUNCTION DPPVAL (LDC, C, XI, LXI, K, IDERIV, X, & INPPV) ! !! DPPVAL calculates the value of the IDERIV-th derivative of the ! B-spline from the PP-representation. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE DOUBLE PRECISION (PPVAL-S, DPPVAL-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract **** a double precision routine **** ! DPPVAL is the PPVALU function of the reference. ! ! DPPVAL calculates (at X) the value of the IDERIV-th ! derivative of the B-spline from the PP-representation ! (C,XI,LXI,K). The Taylor expansion about XI(J) for X in ! the interval XI(J) <= X < XI(J+1) is evaluated, J=1,LXI. ! Right limiting values at X=XI(J) are obtained. DPPVAL will ! extrapolate beyond XI(1) and XI(LXI+1). ! ! To obtain left limiting values (left derivatives) at XI(J) ! replace LXI by J-1 and set X=XI(J),J=2,LXI+1. ! ! Description of Arguments ! ! Input C,XI,X are double precision ! LDC - leading dimension of C matrix, LDC >= K ! C - matrix of dimension at least (K,LXI) containing ! right derivatives at break points XI(*). ! XI - break point vector of length LXI+1 ! LXI - number of polynomial pieces ! K - order of B-spline, K >= 1 ! IDERIV - order of the derivative, 0 <= IDERIV <= K-1 ! IDERIV=0 gives the B-spline value ! X - argument, XI(1) <= X <= XI(LXI+1) ! INPPV - an initialization parameter which must be set ! to 1 the first time DPPVAL is called. ! ! Output DPPVAL is double precision ! INPPV - INPPV contains information for efficient process- ! ing after the initial call and INPPV must not ! be changed by the user. Distinct splines require ! distinct INPPV parameters. ! DPPVAL - value of the IDERIV-th derivative at X ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED DINTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPPVAL ! INTEGER I, IDERIV, INPPV, J, K, LDC, LXI, NDUMMY, KK DOUBLE PRECISION C, DX, X, XI DIMENSION XI(*), C(LDC,*) !***FIRST EXECUTABLE STATEMENT DPPVAL DPPVAL = 0.0D0 if ( K < 1) go to 90 if ( LDC < K) go to 80 if ( LXI < 1) go to 85 if ( IDERIV < 0 .OR. IDERIV >= K) go to 95 I = K - IDERIV KK = I call DINTRV(XI, LXI, X, INPPV, I, NDUMMY) DX = X - XI(I) J = K 10 DPPVAL = (DPPVAL/KK)*DX + C(J,I) J = J - 1 KK = KK - 1 if (KK > 0) go to 10 return ! ! 80 CONTINUE call XERMSG ('SLATEC', 'DPPVAL', 'LDC DOES NOT SATISFY LDC >= K', & 2, 1) return 85 CONTINUE call XERMSG ('SLATEC', 'DPPVAL', 'LXI DOES NOT SATISFY LXI >= 1', & 2, 1) return 90 CONTINUE call XERMSG ('SLATEC', 'DPPVAL', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 95 CONTINUE call XERMSG ('SLATEC', 'DPPVAL', & 'IDERIV DOES NOT SATISFY 0 <= IDERIV < K', 2, 1) return end DOUBLE PRECISION FUNCTION DPRVEC (M, U, V) ! !! DPRVEC is subsidiary to DBVSUP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PRVEC-S, DPRVEC-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This subroutine computes the inner product of a vector U ! with the imaginary product or mate vector corresponding to V. ! !***SEE ALSO DBVSUP !***ROUTINES CALLED DDOT !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DPRVEC ! DOUBLE PRECISION DDOT INTEGER M, N, NP DOUBLE PRECISION U(*), V(*), VP !***FIRST EXECUTABLE STATEMENT DPRVEC N = M/2 NP = N + 1 VP = DDOT(N,U(1),1,V(NP),1) DPRVEC = DDOT(N,U(NP),1,V(1),1) - VP return end subroutine DPRWPG (KEY, IPAGE, LPG, SX, IX) ! !! DPRWPG is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PRWPGE-S, DPRWPG-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! DPRWPG LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. ! VIRTUAL MEMORY PAGE READ/WRITE SUBROUTINE. ! ! DEPENDING ON THE VALUE OF KEY, SUBROUTINE DPRWPG() PERFORMS A PAGE ! READ OR WRITE OF PAGE IPAGE. THE PAGE HAS LENGTH LPG. ! ! KEY IS A FLAG INDICATING WHETHER A PAGE READ OR WRITE IS ! TO BE PERFORMED. ! if KEY = 1 DATA IS READ. ! if KEY = 2 DATA IS WRITTEN. ! IPAGE IS THE PAGE NUMBER OF THE MATRIX TO BE ACCESSED. ! LPG IS THE LENGTH OF THE PAGE OF THE MATRIX TO BE ACCESSED. ! SX(*),IX(*) IS THE MATRIX TO BE ACCESSED. ! ! THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWPGE, ! SANDIA LABS. REPT. SAND78-0785. ! MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON ! REVISED 811130-1000 ! REVISED YYMMDD-HHMM ! !***SEE ALSO DSPLP !***ROUTINES CALLED DPRWVR, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Fixed error messages and replaced GOTOs with ! IF-THEN-ELSE. (RWC) ! 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) !***END PROLOGUE DPRWPG DOUBLE PRECISION SX(*) DIMENSION IX(*) !***FIRST EXECUTABLE STATEMENT DPRWPG ! ! CHECK if IPAGE IS IN RANGE. ! if (IPAGE < 1) THEN call XERMSG ('SLATEC', 'DPRWPG', & 'THE VALUE OF IPAGE (PAGE NUMBER) WAS NOT IN THE RANGE' // & '1 <= IPAGE <= MAXPGE.', 55, 1) end if ! ! CHECK if LPG IS POSITIVE. ! if (LPG <= 0) THEN call XERMSG ('SLATEC', 'DPRWPG', & 'THE VALUE OF LPG (PAGE LENGTH) WAS NONPOSITIVE.', 55, 1) end if ! ! DECIDE if WE ARE READING OR WRITING. ! if (KEY == 1) THEN ! ! CODE TO DO A PAGE READ. ! call DPRWVR(KEY,IPAGE,LPG,SX,IX) ELSE if (KEY == 2) THEN ! ! CODE TO DO A PAGE WRITE. ! call DPRWVR(KEY,IPAGE,LPG,SX,IX) ELSE call XERMSG ('SLATEC', 'DPRWPG', & 'THE VALUE OF KEY (READ-WRITE FLAG) WAS NOT 1 OR 2.', 55, 1) end if return end subroutine DPRWVR (KEY, IPAGE, LPG, SX, IX) ! !! DPRWVR is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PRWVIR-S, DPRWVR-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! DPRWVR LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SPARSE MATRIX ! STORAGE SCHEME. THE PAGE STORAGE IS ON RANDOM ACCESS DISK. ! DPRWVR IS PART OF THE SPARSE LP PACKAGE, DSPLP. ! ! KEY IS A FLAG WHICH INDICATES WHETHER A READ OR WRITE ! OPERATION IS TO BE PERFORMED. A VALUE OF KEY=1 INDICATES ! A READ. A VALUE OF KEY=2 INDICATES A WRITE. ! IPAGE IS THE PAGE OF MATRIX MN WE ARE ACCESSING. ! LPG IS THE LENGTH OF THE PAGE. ! SX(*),IX(*) IS THE MATRIX DATA. ! ! THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWVIR, ! SANDIA LABS. REPT. SAND78-0785. ! MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON ! !***SEE ALSO DSPLP !***ROUTINES CALLED DREADP, DWRITP, SOPENM !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 891009 Removed unreferenced variables. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) !***END PROLOGUE DPRWVR DIMENSION IX(*) DOUBLE PRECISION SX(*),ZERO,ONE LOGICAL FIRST SAVE ZERO, ONE DATA ZERO,ONE/0.D0,1.D0/ !***FIRST EXECUTABLE STATEMENT DPRWVR ! ! COMPUTE STARTING ADDRESS OF PAGE. ! IPAGEF=SX(3) ISTART = IX(3) + 5 ! ! OPEN RANDOM ACCESS FILE NUMBER IPAGEF, if FIRST PAGE WRITE. ! FIRST=SX(4) == ZERO if (.NOT.(FIRST)) go to 20002 call SOPENM(IPAGEF,LPG) SX(4)=ONE ! ! PERFORM EITHER A READ OR A WRITE. ! 20002 IADDR = 2*IPAGE - 1 if (.NOT.(KEY == 1)) go to 20005 call DREADP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR) go to 20006 20005 if (.NOT.(KEY == 2)) go to 10001 call DWRITP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR) 10001 CONTINUE 20006 RETURN end DOUBLE PRECISION FUNCTION DPSI (X) ! !! DPSI computes the Psi (or Digamma) function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7C !***TYPE DOUBLE PRECISION (PSI-S, DPSI-D, CPSI-C) !***KEYWORDS DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DPSI calculates the double precision Psi (or Digamma) function for ! double precision argument X. PSI(X) is the logarithmic derivative ! of the Gamma function of X. ! ! Series for PSI on the interval 0. to 1.00000E+00 ! with weighted error 5.79E-32 ! log weighted error 31.24 ! significant figures required 30.93 ! decimal places required 32.05 ! ! ! Series for APSI on the interval 0. to 1.00000E-02 ! with weighted error 7.75E-33 ! log weighted error 32.11 ! significant figures required 28.88 ! decimal places required 32.71 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCOT, DCSEVL, INITDS, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) ! 920618 Removed space from variable name. (RWC, WRB) !***END PROLOGUE DPSI DOUBLE PRECISION X, PSICS(42), APSICS(16), AUX, DXREL, PI, XBIG, & Y, DCOT, DCSEVL, D1MACH LOGICAL FIRST EXTERNAL DCOT SAVE PSICS, APSICS, PI, NTPSI, NTAPSI, XBIG, DXREL, FIRST DATA PSICS( 1) / -.38057080835217921520437677667039D-1 / DATA PSICS( 2) / +.49141539302938712748204699654277D+0 / DATA PSICS( 3) / -.56815747821244730242892064734081D-1 / DATA PSICS( 4) / +.83578212259143131362775650747862D-2 / DATA PSICS( 5) / -.13332328579943425998079274172393D-2 / DATA PSICS( 6) / +.22031328706930824892872397979521D-3 / DATA PSICS( 7) / -.37040238178456883592889086949229D-4 / DATA PSICS( 8) / +.62837936548549898933651418717690D-5 / DATA PSICS( 9) / -.10712639085061849855283541747074D-5 / DATA PSICS( 10) / +.18312839465484165805731589810378D-6 / DATA PSICS( 11) / -.31353509361808509869005779796885D-7 / DATA PSICS( 12) / +.53728087762007766260471919143615D-8 / DATA PSICS( 13) / -.92116814159784275717880632624730D-9 / DATA PSICS( 14) / +.15798126521481822782252884032823D-9 / DATA PSICS( 15) / -.27098646132380443065440589409707D-10 / DATA PSICS( 16) / +.46487228599096834872947319529549D-11 / DATA PSICS( 17) / -.79752725638303689726504797772737D-12 / DATA PSICS( 18) / +.13682723857476992249251053892838D-12 / DATA PSICS( 19) / -.23475156060658972717320677980719D-13 / DATA PSICS( 20) / +.40276307155603541107907925006281D-14 / DATA PSICS( 21) / -.69102518531179037846547422974771D-15 / DATA PSICS( 22) / +.11856047138863349552929139525768D-15 / DATA PSICS( 23) / -.20341689616261559308154210484223D-16 / DATA PSICS( 24) / +.34900749686463043850374232932351D-17 / DATA PSICS( 25) / -.59880146934976711003011081393493D-18 / DATA PSICS( 26) / +.10273801628080588258398005712213D-18 / DATA PSICS( 27) / -.17627049424561071368359260105386D-19 / DATA PSICS( 28) / +.30243228018156920457454035490133D-20 / DATA PSICS( 29) / -.51889168302092313774286088874666D-21 / DATA PSICS( 30) / +.89027730345845713905005887487999D-22 / DATA PSICS( 31) / -.15274742899426728392894971904000D-22 / DATA PSICS( 32) / +.26207314798962083136358318079999D-23 / DATA PSICS( 33) / -.44964642738220696772598388053333D-24 / DATA PSICS( 34) / +.77147129596345107028919364266666D-25 / DATA PSICS( 35) / -.13236354761887702968102638933333D-25 / DATA PSICS( 36) / +.22709994362408300091277311999999D-26 / DATA PSICS( 37) / -.38964190215374115954491391999999D-27 / DATA PSICS( 38) / +.66851981388855302310679893333333D-28 / DATA PSICS( 39) / -.11469986654920864872529919999999D-28 / DATA PSICS( 40) / +.19679385886541405920515413333333D-29 / DATA PSICS( 41) / -.33764488189750979801907200000000D-30 / DATA PSICS( 42) / +.57930703193214159246677333333333D-31 / DATA APSICS( 1) / -.832710791069290760174456932269D-3 / DATA APSICS( 2) / -.416251842192739352821627121990D-3 / DATA APSICS( 3) / +.103431560978741291174463193961D-6 / DATA APSICS( 4) / -.121468184135904152987299556365D-9 / DATA APSICS( 5) / +.311369431998356155521240278178D-12 / DATA APSICS( 6) / -.136461337193177041776516100945D-14 / DATA APSICS( 7) / +.902051751315416565130837974000D-17 / DATA APSICS( 8) / -.831542997421591464829933635466D-19 / DATA APSICS( 9) / +.101224257073907254188479482666D-20 / DATA APSICS( 10) / -.156270249435622507620478933333D-22 / DATA APSICS( 11) / +.296542716808903896133226666666D-24 / DATA APSICS( 12) / -.674686886765702163741866666666D-26 / DATA APSICS( 13) / +.180345311697189904213333333333D-27 / DATA APSICS( 14) / -.556901618245983607466666666666D-29 / DATA APSICS( 15) / +.195867922607736251733333333333D-30 / DATA APSICS( 16) / -.775195892523335680000000000000D-32 / DATA PI / 3.14159265358979323846264338327950D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DPSI if (FIRST) THEN NTPSI = INITDS (PSICS, 42, 0.1*REAL(D1MACH(3)) ) NTAPSI = INITDS (APSICS, 16, 0.1*REAL(D1MACH(3)) ) ! XBIG = 1.0D0/SQRT(D1MACH(3)) DXREL = SQRT(D1MACH(4)) end if FIRST = .FALSE. ! Y = ABS(X) ! if (Y > 10.0D0) go to 50 ! ! DPSI(X) FOR ABS(X) <= 2 ! N = X if (X < 0.D0) N = N - 1 Y = X - N N = N - 1 DPSI = DCSEVL (2.D0*Y-1.D0, PSICS, NTPSI) if (N == 0) RETURN ! if (N > 0) go to 30 ! N = -N if (X == 0.D0) call XERMSG ('SLATEC', 'DPSI', 'X IS 0', 2, 2) if (X < 0.D0 .AND. X+N-2 == 0.D0) call XERMSG ('SLATEC', & 'DPSI', 'X IS A NEGATIVE INTEGER', 3, 2) if (X < (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) < DXREL) & call XERMSG ('SLATEC', 'DPSI', & 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', & 1, 1) ! DO 20 I=1,N DPSI = DPSI - 1.D0/(X+I-1) 20 CONTINUE return ! ! DPSI(X) FOR X >= 2.0 AND X <= 10.0 ! 30 DO 40 I=1,N DPSI = DPSI + 1.0D0/(Y+I) 40 CONTINUE return ! ! DPSI(X) FOR ABS(X) > 10.0 ! 50 AUX = 0.D0 if (Y < XBIG) AUX = DCSEVL (2.D0*(10.D0/Y)**2-1.D0, APSICS, & NTAPSI) ! if (X < 0.D0) DPSI = LOG(ABS(X)) - 0.5D0/X + AUX & - PI*DCOT(PI*X) if (X > 0.D0) DPSI = LOG(X) - 0.5D0/X + AUX return ! end subroutine DPSIFN (X, N, KODE, M, ANS, NZ, IERR) ! !! DPSIFN computes derivatives of the Psi function. ! !***LIBRARY SLATEC !***CATEGORY C7C !***TYPE DOUBLE PRECISION (PSIFN-S, DPSIFN-D) !***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, ! PSI FUNCTION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! The following definitions are used in DPSIFN: ! ! Definition 1 ! PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of ! the log GAMMA function. ! Definition 2 ! K K ! PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). ! ___________________________________________________________________ ! DPSIFN computes a sequence of SCALED derivatives of ! the PSI function; i.e. for fixed X and M it computes ! the M-member sequence ! ! ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) ! for K = N,...,N+M-1 ! ! where PSI(K,X) is as defined above. For KODE=1, DPSIFN returns ! the scaled derivatives as described. KODE=2 is operative only ! when K=0 and in that case DPSIFN returns -PSI(X) + LN(X). That ! is, the logarithmic behavior for large X is removed when KODE=2 ! and K=0. When sums or differences of PSI functions are computed ! the logarithmic terms can be combined analytically and computed ! separately to help retain significant digits. ! ! Note that call DPSIFN(X,0,1,1,ANS) results in ! ANS = -PSI(X) ! ! Input X is DOUBLE PRECISION ! X - Argument, X .gt. 0.0D0 ! N - First member of the sequence, 0 .le. N .le. 100 ! N=0 gives ANS(1) = -PSI(X) for KODE=1 ! -PSI(X)+LN(X) for KODE=2 ! KODE - Selection parameter ! KODE=1 returns scaled derivatives of the PSI ! function. ! KODE=2 returns scaled derivatives of the PSI ! function EXCEPT when N=0. In this case, ! ANS(1) = -PSI(X) + LN(X) is returned. ! M - Number of members of the sequence, M.ge.1 ! ! Output ANS is DOUBLE PRECISION ! ANS - A vector of length at least M whose first M ! components contain the sequence of derivatives ! scaled according to KODE. ! NZ - Underflow flag ! NZ.eq.0, A normal return ! NZ.ne.0, Underflow, last NZ components of ANS are ! set to zero, ANS(M-K+1)=0.0, K=1,...,NZ ! IERR - Error flag ! IERR=0, A normal return, computation completed ! IERR=1, Input error, no computation ! IERR=2, Overflow, X too small or N+M-1 too ! large or both ! IERR=3, Error, N too large. Dimensioned ! array TRMR(NMAX) is not large enough for N ! ! The nominal computational accuracy is the maximum of unit ! roundoff (=D1MACH(4)) and 1.0D-18 since critical constants ! are given to only 18 digits. ! ! PSIFN is the single precision version of DPSIFN. ! ! *Long Description: ! ! The basic method of evaluation is the asymptotic expansion ! for large X.ge.XMIN followed by backward recursion on a two ! term recursion relation ! ! W(X+1) + X**(-N-1) = W(X). ! ! This is supplemented by a series ! ! SUM( (X+K)**(-N-1) , K=0,1,2,... ) ! ! which converges rapidly for large N. Both XMIN and the ! number of terms of the series are calculated from the unit ! roundoff of the machine environment. ! !***REFERENCES Handbook of Mathematical Functions, National Bureau ! of Standards Applied Mathematics Series 55, edited ! by M. Abramowitz and I. A. Stegun, equations 6.3.5, ! 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. ! D. E. Amos, A portable Fortran subroutine for ! derivatives of the Psi function, Algorithm 610, ACM ! Transactions on Mathematical Software 9, 4 (1983), ! pp. 494-502. !***ROUTINES CALLED D1MACH, I1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPSIFN INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ, & FN INTEGER I1MACH DOUBLE PRECISION ANS, ARG, B, DEN, ELIM, EPS, FLN, & FX, RLN, RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM, & TRMR, TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, & XM, XMIN, XQ, YINT DOUBLE PRECISION D1MACH DIMENSION B(22), TRM(22), TRMR(100), ANS(*) SAVE NMAX, B DATA NMAX /100/ !----------------------------------------------------------------------- ! BERNOULLI NUMBERS !----------------------------------------------------------------------- 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.00000000000000000D+00, & -5.00000000000000000D-01,1.66666666666666667D-01, & -3.33333333333333333D-02,2.38095238095238095D-02, & -3.33333333333333333D-02,7.57575757575757576D-02, & -2.53113553113553114D-01,1.16666666666666667D+00, & -7.09215686274509804D+00,5.49711779448621554D+01, & -5.29124242424242424D+02,6.19212318840579710D+03, & -8.65802531135531136D+04,1.42551716666666667D+06, & -2.72982310678160920D+07,6.01580873900642368D+08, & -1.51163157670921569D+10,4.29614643061166667D+11, & -1.37116552050883328D+13,4.88332318973593167D+14, & -1.92965793419400681D+16/ ! !***FIRST EXECUTABLE STATEMENT DPSIFN IERR = 0 NZ=0 if (X <= 0.0D0) IERR=1 if (N < 0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (M < 1) IERR=1 if (IERR /= 0) RETURN MM=M NX = MIN(-I1MACH(15),I1MACH(16)) R1M5 = D1MACH(5) R1M4 = D1MACH(4)*0.5D0 WDTOL = MAX(R1M4,0.5D-18) !----------------------------------------------------------------------- ! ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT !----------------------------------------------------------------------- ELIM = 2.302D0*(NX*R1M5-3.0D0) XLN = LOG(X) 41 CONTINUE NN = N + MM - 1 FN = NN T = (FN+1)*XLN !----------------------------------------------------------------------- ! OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X !----------------------------------------------------------------------- if (ABS(T) > ELIM) go to 290 if (X < WDTOL) go to 260 !----------------------------------------------------------------------- ! COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 !----------------------------------------------------------------------- RLN = R1M5*I1MACH(14) RLN = MIN(RLN,18.06D0) FLN = MAX(RLN,3.0D0) - 3.0D0 YINT = 3.50D0 + 0.40D0*FLN SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0) XM = YINT + SLOPE*FN MX = INT(XM) + 1 XMIN = MX if (N == 0) go to 50 XM = -2.302D0*RLN - MIN(0.0D0,XLN) ARG = XM/N ARG = MIN(0.0D0,ARG) EPS = EXP(ARG) XM = 1.0D0 - EPS if (ABS(ARG) < 1.0D-3) XM = -ARG FLN = X*XM/EPS XM = XMIN - X if (XM > 7.0D0 .AND. FLN < 15.0D0) go to 200 50 CONTINUE XDMY = X XDMLN = XLN XINC = 0.0D0 if (X >= XMIN) go to 60 NX = INT(X) XINC = XMIN - NX XDMY = X + XINC XDMLN = LOG(XDMY) 60 CONTINUE !----------------------------------------------------------------------- ! GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION !----------------------------------------------------------------------- T = FN*XDMLN T1 = XDMLN + XDMLN T2 = T + XDMLN TK = MAX(ABS(T),ABS(T1),ABS(T2)) if (TK > ELIM) go to 380 TSS = EXP(-T) TT = 0.5D0/XDMY T1 = TT TST = WDTOL*TT if (NN /= 0) T1 = TT + 1.0D0/FN RXSQ = 1.0D0/(XDMY*XDMY) TA = 0.5D0*RXSQ T = (FN+1)*TA S = T*B(3) if (ABS(S) < TST) go to 80 TK = 2.0D0 DO 70 K=4,22 T = T*((TK+FN+1)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ TRM(K) = T*B(K) if (ABS(TRM(K)) < TST) go to 80 S = S + TRM(K) TK = TK + 2.0D0 70 CONTINUE 80 CONTINUE S = (S+T1)*TSS if (XINC == 0.0D0) go to 100 !----------------------------------------------------------------------- ! BACKWARD RECUR FROM XDMY TO X !----------------------------------------------------------------------- NX = INT(XINC) NP = NN + 1 if (NX > NMAX) go to 390 if (NN == 0) go to 160 XM = XINC - 1.0D0 FX = X + XM !----------------------------------------------------------------------- ! THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL !----------------------------------------------------------------------- DO 90 I=1,NX TRMR(I) = FX**(-NP) S = S + TRMR(I) XM = XM - 1.0D0 FX = X + XM 90 CONTINUE 100 CONTINUE ANS(MM) = S if (FN == 0) go to 180 !----------------------------------------------------------------------- ! GENERATE LOWER DERIVATIVES, J < N+MM-1 !----------------------------------------------------------------------- if (MM == 1) RETURN DO 150 J=2,MM FN = FN - 1 TSS = TSS*XDMY T1 = TT if (FN /= 0) T1 = TT + 1.0D0/FN T = (FN+1)*TA S = T*B(3) if (ABS(S) < TST) go to 120 TK = 4 + FN DO 110 K=4,22 TRM(K) = TRM(K)*(FN+1)/TK if (ABS(TRM(K)) < TST) go to 120 S = S + TRM(K) TK = TK + 2.0D0 110 CONTINUE 120 CONTINUE S = (S+T1)*TSS if (XINC == 0.0D0) go to 140 if (FN == 0) go to 160 XM = XINC - 1.0D0 FX = X + XM DO 130 I=1,NX TRMR(I) = TRMR(I)*FX S = S + TRMR(I) XM = XM - 1.0D0 FX = X + XM 130 CONTINUE 140 CONTINUE MX = MM - J + 1 ANS(MX) = S if (FN == 0) go to 180 150 CONTINUE return !----------------------------------------------------------------------- ! RECURSION FOR N = 0 !----------------------------------------------------------------------- 160 CONTINUE DO 170 I=1,NX S = S + 1.0D0/(X+NX-I) 170 CONTINUE 180 CONTINUE if (KODE == 2) go to 190 ANS(1) = S - XDMLN return 190 CONTINUE if (XDMY == X) RETURN XQ = XDMY/X ANS(1) = S - LOG(XQ) return !----------------------------------------------------------------------- ! COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... !----------------------------------------------------------------------- 200 CONTINUE NN = INT(FLN) + 1 NP = N + 1 T1 = (N+1)*XLN T = EXP(-T1) S = T DEN = X DO 210 I=1,NN DEN = DEN + 1.0D0 TRM(I) = DEN**(-NP) S = S + TRM(I) 210 CONTINUE ANS(1) = S if (N /= 0) go to 220 if (KODE == 2) ANS(1) = S + XLN 220 CONTINUE if (MM == 1) RETURN !----------------------------------------------------------------------- ! GENERATE HIGHER DERIVATIVES, J > N !----------------------------------------------------------------------- TOL = WDTOL/5.0D0 DO 250 J=2,MM T = T/X S = T TOLS = T*TOL DEN = X DO 230 I=1,NN DEN = DEN + 1.0D0 TRM(I) = TRM(I)/DEN S = S + TRM(I) if (TRM(I) < TOLS) go to 240 230 CONTINUE 240 CONTINUE ANS(J) = S 250 CONTINUE return !----------------------------------------------------------------------- ! SMALL X < UNIT ROUND OFF !----------------------------------------------------------------------- 260 CONTINUE ANS(1) = X**(-N-1) if (MM == 1) go to 280 K = 1 DO 270 I=2,MM ANS(K+1) = ANS(K)/X K = K + 1 270 CONTINUE 280 CONTINUE if (N /= 0) RETURN if (KODE == 2) ANS(1) = ANS(1) + XLN return 290 CONTINUE if (T > 0.0D0) go to 380 NZ=0 IERR=2 return 380 CONTINUE NZ=NZ+1 ANS(MM)=0.0D0 MM=MM-1 if (MM == 0) RETURN go to 41 390 CONTINUE NZ=0 IERR=3 return end DOUBLE PRECISION FUNCTION DPSIXN (N) ! !! DPSIXN is subsidiary to DEXINT. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PSIXN-S, DPSIXN-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! This subroutine returns values of PSI(X)=derivative of log ! GAMMA(X), X > 0.0 at integer arguments. A table look-up is ! performed for N <= 100, and the asymptotic expansion is ! evaluated for N > 100. ! !***SEE ALSO DEXINT !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DPSIXN ! INTEGER N, K DOUBLE PRECISION AX, B, C, FN, RFN2, TRM, S, WDTOL DOUBLE PRECISION D1MACH DIMENSION B(6), C(100) ! ! DPSIXN(N), N = 1,100 DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), & C(19), C(20), C(21), C(22), C(23), C(24)/ & -5.77215664901532861D-01, 4.22784335098467139D-01, & 9.22784335098467139D-01, 1.25611766843180047D+00, & 1.50611766843180047D+00, 1.70611766843180047D+00, & 1.87278433509846714D+00, 2.01564147795561000D+00, & 2.14064147795561000D+00, 2.25175258906672111D+00, & 2.35175258906672111D+00, 2.44266167997581202D+00, & 2.52599501330914535D+00, 2.60291809023222227D+00, & 2.67434666166079370D+00, 2.74101332832746037D+00, & 2.80351332832746037D+00, 2.86233685773922507D+00, & 2.91789241329478063D+00, 2.97052399224214905D+00, & 3.02052399224214905D+00, 3.06814303986119667D+00, & 3.11359758531574212D+00, 3.15707584618530734D+00/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ & 3.19874251285197401D+00, 3.23874251285197401D+00, & 3.27720405131351247D+00, 3.31424108835054951D+00, & 3.34995537406483522D+00, 3.38443813268552488D+00, & 3.41777146601885821D+00, 3.45002953053498724D+00, & 3.48127953053498724D+00, 3.51158256083801755D+00, & 3.54099432554389990D+00, 3.56956575411532847D+00, & 3.59734353189310625D+00, 3.62437055892013327D+00, & 3.65068634839381748D+00, 3.67632737403484313D+00, & 3.70132737403484313D+00, 3.72571761793728215D+00, & 3.74952714174680596D+00, 3.77278295570029433D+00, & 3.79551022842756706D+00, 3.81773245064978928D+00, & 3.83947158108457189D+00, 3.86074817682925274D+00/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), & C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ & 3.88158151016258607D+00, 3.90198967342789220D+00, & 3.92198967342789220D+00, 3.94159751656514710D+00, & 3.96082828579591633D+00, 3.97969621032421822D+00, & 3.99821472884273674D+00, 4.01639654702455492D+00, & 4.03425368988169777D+00, 4.05179754953082058D+00, & 4.06903892884116541D+00, 4.08598808138353829D+00, & 4.10265474805020496D+00, 4.11904819067315578D+00, & 4.13517722293122029D+00, 4.15105023880423617D+00, & 4.16667523880423617D+00, 4.18205985418885155D+00, & 4.19721136934036670D+00, 4.21213674247469506D+00, & 4.22684262482763624D+00, 4.24133537845082464D+00, & 4.25562109273653893D+00, 4.26970559977879245D+00/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), & C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), & C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ & 4.28359448866768134D+00, 4.29729311880466764D+00, & 4.31080663231818115D+00, 4.32413996565151449D+00, & 4.33729786038835659D+00, 4.35028487337536958D+00, & 4.36310538619588240D+00, 4.37576361404398366D+00, & 4.38826361404398366D+00, 4.40060929305632934D+00, & 4.41280441500754886D+00, 4.42485260777863319D+00, & 4.43675736968339510D+00, 4.44852207556574804D+00, & 4.46014998254249223D+00, 4.47164423541605544D+00, & 4.48300787177969181D+00, 4.49424382683587158D+00, & 4.50535493794698269D+00, 4.51634394893599368D+00, & 4.52721351415338499D+00, 4.53796620232542800D+00, & 4.54860450019776842D+00, 4.55913081598724211D+00/ DATA C(97), C(98), C(99), C(100)/ & 4.56954748265390877D+00, 4.57985676100442424D+00, & 4.59006084263707730D+00, 4.60016185273808740D+00/ ! COEFFICIENTS OF ASYMPTOTIC EXPANSION DATA B(1), B(2), B(3), B(4), B(5), B(6)/ & 8.33333333333333333D-02, -8.33333333333333333D-03, & 3.96825396825396825D-03, -4.16666666666666666D-03, & 7.57575757575757576D-03, -2.10927960927960928D-02/ ! !***FIRST EXECUTABLE STATEMENT DPSIXN if (N > 100) go to 10 DPSIXN = C(N) return 10 CONTINUE WDTOL = MAX(D1MACH(4),1.0D-18) FN = N AX = 1.0D0 S = -0.5D0/FN if (ABS(S) <= WDTOL) go to 30 RFN2 = 1.0D0/(FN*FN) DO 20 K=1,6 AX = AX*RFN2 TRM = -B(K)*AX if (ABS(TRM) < WDTOL) go to 30 S = S + TRM 20 CONTINUE 30 CONTINUE DPSIXN = S + LOG(FN) return end subroutine DPSORT (DX, N, IPERM, KFLAG, IER) ! !! DPSORT sorts a double precision array. ! !***PURPOSE Return the permutation vector generated by sorting a given ! array and, optionally, rearrange the elements of the array. ! The array may be sorted in increasing or decreasing order. ! A slightly modified quicksort algorithm is used. !***LIBRARY SLATEC !***CATEGORY N6A1B, N6A2B !***TYPE DOUBLE PRECISION (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H) !***KEYWORDS NUMBER SORTING, PASSIVE SORTING, SINGLETON QUICKSORT, SORT !***AUTHOR Jones, R. E., (SNLA) ! Rhoads, G. S., (NBS) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! DPSORT returns the permutation vector IPERM generated by sorting ! the array DX and, optionally, rearranges the values in DX. DX may ! be sorted in increasing or decreasing order. A slightly modified ! quicksort algorithm is used. ! ! IPERM is such that DX(IPERM(I)) is the Ith value in the ! rearrangement of DX. IPERM may be applied to another array by ! calling IPPERM, SPPERM, DPPERM or HPPERM. ! ! The main difference between DPSORT and its active sorting equivalent ! DSORT is that the data are referenced indirectly rather than ! directly. Therefore, DPSORT should require approximately twice as ! long to execute as DSORT. However, DPSORT is more general. ! ! Description of Parameters ! DX - input/output -- double precision array of values to be ! sorted. If ABS(KFLAG) = 2, then the values in DX will be ! rearranged on output; otherwise, they are unchanged. ! N - input -- number of values in array DX to be sorted. ! IPERM - output -- permutation array such that IPERM(I) is the ! index of the value in the original order of the ! DX array that is in the Ith location in the sorted ! order. ! KFLAG - input -- control parameter: ! = 2 means return the permutation vector resulting from ! sorting DX in increasing order and sort DX also. ! = 1 means return the permutation vector resulting from ! sorting DX in increasing order and do not sort DX. ! = -1 means return the permutation vector resulting from ! sorting DX in decreasing order and do not sort DX. ! = -2 means return the permutation vector resulting from ! sorting DX in decreasing order and sort DX also. ! IER - output -- error indicator: ! = 0 if no error, ! = 1 if N is zero or negative, ! = 2 if KFLAG is not 2, 1, -1, or -2. !***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm ! for sorting with minimal storage, Communications of ! the ACM, 12, 3 (1969), pp. 185-187. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 761101 DATE WRITTEN ! 761118 Modified by John A. Wisniewski to use the Singleton ! quicksort algorithm. ! 870423 Modified by Gregory S. Rhoads for passive sorting with the ! option for the rearrangement of the original data. ! 890619 Double precision version of SPSORT created by D. W. Lozier. ! 890620 Algorithm for rearranging the data vector corrected by R. ! Boisvert. ! 890622 Prologue upgraded to Version 4.0 style by D. Lozier. ! 891128 Error when KFLAG < 0 and N=1 corrected by R. Boisvert. ! 920507 Modified by M. McClain to revise prologue text. ! 920818 Declarations section rebuilt and code restructured to use ! IF-THEN-ELSE-ENDIF. (SMR, WRB) !***END PROLOGUE DPSORT ! .. Scalar Arguments .. INTEGER IER, KFLAG, N ! .. Array Arguments .. DOUBLE PRECISION DX(*) INTEGER IPERM(*) ! .. Local Scalars .. DOUBLE PRECISION R, TEMP INTEGER I, IJ, INDX, INDX0, ISTRT, J, K, KK, L, LM, LMT, M, NN ! .. Local Arrays .. INTEGER IL(21), IU(21) ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, INT !***FIRST EXECUTABLE STATEMENT DPSORT IER = 0 NN = N if (NN < 1) THEN IER = 1 call XERMSG ('SLATEC', 'DPSORT', & 'The number of values to be sorted, N, is not positive.', & IER, 1) return end if ! KK = ABS(KFLAG) if (KK /= 1 .AND. KK /= 2) THEN IER = 2 call XERMSG ('SLATEC', 'DPSORT', & 'The sort control parameter, KFLAG, is not 2, 1, -1, or -2.', & IER, 1) return end if ! ! Initialize permutation vector ! DO 10 I=1,NN IPERM(I) = I 10 CONTINUE ! ! Return if only one value is to be sorted ! if (NN == 1) RETURN ! ! Alter array DX to get decreasing order if needed ! if (KFLAG <= -1) THEN DO 20 I=1,NN DX(I) = -DX(I) 20 CONTINUE end if ! ! Sort DX only ! M = 1 I = 1 J = NN R = .375D0 ! 30 if (I == J) go to 80 if (R <= 0.5898437D0) THEN R = R+3.90625D-2 ELSE R = R-0.21875D0 end if ! 40 K = I ! ! Select a central element of the array and save it in location L ! IJ = I + INT((J-I)*R) LM = IPERM(IJ) ! ! If first element of array is greater than LM, interchange with LM ! if (DX(IPERM(I)) > DX(LM)) THEN IPERM(IJ) = IPERM(I) IPERM(I) = LM LM = IPERM(IJ) end if L = J ! ! If last element of array is less than LM, interchange with LM ! if (DX(IPERM(J)) < DX(LM)) THEN IPERM(IJ) = IPERM(J) IPERM(J) = LM LM = IPERM(IJ) ! ! If first element of array is greater than LM, interchange ! with LM ! if (DX(IPERM(I)) > DX(LM)) THEN IPERM(IJ) = IPERM(I) IPERM(I) = LM LM = IPERM(IJ) ENDIF end if go to 60 50 LMT = IPERM(L) IPERM(L) = IPERM(K) IPERM(K) = LMT ! ! Find an element in the second half of the array which is smaller ! than LM ! 60 L = L-1 if (DX(IPERM(L)) > DX(LM)) go to 60 ! ! Find an element in the first half of the array which is greater ! than LM ! 70 K = K+1 if (DX(IPERM(K)) < DX(LM)) go to 70 ! ! Interchange these elements ! if (K <= L) go to 50 ! ! Save upper and lower subscripts of the array yet to be sorted ! if (L-I > J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 90 ! ! Begin again on another portion of the unsorted array ! 80 M = M-1 if (M == 0) go to 120 I = IL(M) J = IU(M) ! 90 if (J-I >= 1) go to 40 if (I == 1) go to 30 I = I-1 ! 100 I = I+1 if (I == J) go to 80 LM = IPERM(I+1) if (DX(IPERM(I)) <= DX(LM)) go to 100 K = I ! 110 IPERM(K+1) = IPERM(K) K = K-1 if (DX(LM) < DX(IPERM(K))) go to 110 IPERM(K+1) = LM go to 100 ! ! Clean up ! 120 if (KFLAG <= -1) THEN DO 130 I=1,NN DX(I) = -DX(I) 130 CONTINUE end if ! ! Rearrange the values of DX if desired ! if (KK == 2) THEN ! ! Use the IPERM vector as a flag. ! If IPERM(I) < 0, then the I-th value is in correct location ! DO 150 ISTRT=1,NN if (IPERM(ISTRT) >= 0) THEN INDX = ISTRT INDX0 = INDX TEMP = DX(ISTRT) 140 if (IPERM(INDX) > 0) THEN DX(INDX) = DX(IPERM(INDX)) INDX0 = INDX IPERM(INDX) = -IPERM(INDX) INDX = ABS(IPERM(INDX)) go to 140 ENDIF DX(INDX0) = TEMP ENDIF 150 CONTINUE ! ! Revert the signs of the IPERM values ! DO 160 I=1,NN IPERM(I) = -IPERM(I) 160 CONTINUE ! end if ! return end subroutine DPTSL (N, D, E, B) ! !! DPTSL solves a positive definite tridiagonal linear system. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B2A !***TYPE DOUBLE PRECISION (SPTSL-S, DPTSL-D, CPTSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE, ! TRIDIAGONAL !***AUTHOR Dongarra, J., (ANL) !***DESCRIPTION ! ! DPTSL, given a positive definite symmetric tridiagonal matrix and ! a right hand side, will find the solution. ! ! On Entry ! ! N INTEGER ! is the order of the tridiagonal matrix. ! ! D DOUBLE PRECISION(N) ! is the diagonal of the tridiagonal matrix. ! On output D is destroyed. ! ! E DOUBLE PRECISION(N) ! is the offdiagonal of the tridiagonal matrix. ! E(1) through E(N-1) should contain the ! offdiagonal. ! ! B DOUBLE PRECISION(N) ! is the right hand side vector. ! ! On Return ! ! B contains the solution. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890505 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DPTSL INTEGER N DOUBLE PRECISION D(*),E(*),B(*) ! INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2 DOUBLE PRECISION T1,T2 ! ! CHECK FOR 1 X 1 CASE ! !***FIRST EXECUTABLE STATEMENT DPTSL if (N /= 1) go to 10 B(1) = B(1)/D(1) go to 70 10 CONTINUE NM1 = N - 1 NM1D2 = NM1/2 if (N == 2) go to 30 KBM1 = N - 1 ! ! ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF ! SUPERDIAGONAL ! DO 20 K = 1, NM1D2 T1 = E(K)/D(K) D(K+1) = D(K+1) - T1*E(K) B(K+1) = B(K+1) - T1*B(K) T2 = E(KBM1)/D(KBM1+1) D(KBM1) = D(KBM1) - T2*E(KBM1) B(KBM1) = B(KBM1) - T2*B(KBM1+1) KBM1 = KBM1 - 1 20 CONTINUE 30 CONTINUE KP1 = NM1D2 + 1 ! ! CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER ! if (MOD(N,2) /= 0) go to 40 T1 = E(KP1)/D(KP1) D(KP1+1) = D(KP1+1) - T1*E(KP1) B(KP1+1) = B(KP1+1) - T1*B(KP1) KP1 = KP1 + 1 40 CONTINUE ! ! BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP ! AND BOTTOM ! B(KP1) = B(KP1)/D(KP1) if (N == 2) go to 60 K = KP1 - 1 KE = KP1 + NM1D2 - 1 DO 50 KF = KP1, KE B(K) = (B(K) - E(K)*B(K+1))/D(K) B(KF+1) = (B(KF+1) - E(KF)*B(KF))/D(KF+1) K = K - 1 50 CONTINUE 60 CONTINUE if (MOD(N,2) == 0) B(1) = (B(1) - E(1)*B(2))/D(1) 70 CONTINUE return end subroutine DQAGE (F, A, B, EPSABS, EPSREL, KEY, LIMIT, RESULT, & ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) ! !! DQAGE approximates the definite integral of F(X) over (A,B), ... ! hopefully satisfying following claim for accuracy ! ABS(I-RESLT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A1 !***TYPE DOUBLE PRECISION (QAGE-S, DQAGE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD RULES, ! GENERAL-PURPOSE, GLOBALLY ADAPTIVE, INTEGRAND EXAMINATOR, ! QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! KEY - Integer ! Key for choice of local integration rule ! A Gauss-Kronrod pair is used with ! 7 - 15 points if KEY < 2, ! 10 - 21 points if KEY = 2, ! 15 - 31 points if KEY = 3, ! 20 - 41 points if KEY = 4, ! 25 - 51 points if KEY = 5, ! 30 - 61 points if KEY > 5. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B), LIMIT >= 1. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! The estimates for result and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value ! of LIMIT. ! However, if this yields no improvement it ! is rather advised to analyze the integrand ! in order to determine the integration ! difficulties. If the position of a local ! difficulty can be determined(e.g. ! SINGULARITY, DISCONTINUITY within the ! interval) one will probably gain from ! splitting up the interval at this point ! and calling the integrator on the ! subranges. If possible, an appropriate ! special-purpose integrator should be used ! which is designed for handling the type of ! difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 6 The input is invalid, because ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! RESULT, ABSERR, NEVAL, LAST, RLIST(1) , ! ELIST(1) and IORD(1) are set to zero. ! ALIST(1) and BLIST(1) are set to A and B ! respectively. ! ! ALIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! BLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! RLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the ! integral approximations on the subintervals ! ! ELIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which are pointers to the ! error estimates over the subintervals, ! such that ELIST(IORD(1)), ..., ! ELIST(IORD(K)) form a decreasing sequence, ! with K = LAST if LAST <= (LIMIT/2+2), and ! K = LIMIT+1-LAST otherwise ! ! LAST - Integer ! Number of subintervals actually produced in the ! subdivision process ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DQK15, DQK21, DQK31, DQK41, DQK51, DQK61, ! DQPSRT !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQAGE ! DOUBLE PRECISION A,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,B, & BLIST,B1,B2,DEFABS,DEFAB1,DEFAB2,D1MACH,ELIST,EPMACH, & EPSABS,EPSREL,ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,F, & RESABS,RESULT,RLIST,UFLOW INTEGER IER,IORD,IROFF1,IROFF2,K,KEY,KEYF,LAST,LIMIT,MAXERR,NEVAL, & NRMAX ! DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), & RLIST(*) ! EXTERNAL F ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ! ERROR ESTIMATE ! ERRMAX - ELIST(MAXERR) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQAGE EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0D+00 ELIST(1) = 0.0D+00 IORD(1) = 0 if ( EPSABS <= 0.0D+00.AND. & EPSREL < MAX(0.5D+02*EPMACH,0.5D-28)) IER = 6 if ( IER == 6) go to 999 ! ! FIRST APPROXIMATION TO THE INTEGRAL ! ----------------------------------- ! KEYF = KEY if ( KEY <= 0) KEYF = 1 if ( KEY >= 7) KEYF = 6 NEVAL = 0 if ( KEYF == 1) call DQK15(F,A,B,RESULT,ABSERR,DEFABS,RESABS) if ( KEYF == 2) call DQK21(F,A,B,RESULT,ABSERR,DEFABS,RESABS) if ( KEYF == 3) call DQK31(F,A,B,RESULT,ABSERR,DEFABS,RESABS) if ( KEYF == 4) call DQK41(F,A,B,RESULT,ABSERR,DEFABS,RESABS) if ( KEYF == 5) call DQK51(F,A,B,RESULT,ABSERR,DEFABS,RESABS) if ( KEYF == 6) call DQK61(F,A,B,RESULT,ABSERR,DEFABS,RESABS) LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 ! ! TEST ON ACCURACY. ! ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) if ( ABSERR <= 0.5D+02*EPMACH*DEFABS.AND.ABSERR > ERRBND) IER = 2 if ( LIMIT == 1) IER = 1 if ( IER /= 0.OR.(ABSERR <= ERRBND.AND.ABSERR /= RESABS) & .OR.ABSERR == 0.0D+00) go to 60 ! ! INITIALIZATION ! -------------- ! ! ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR NRMAX = 1 IROFF1 = 0 IROFF2 = 0 ! ! MAIN DO-LOOP ! ------------ ! DO 30 LAST = 2,LIMIT ! ! BISECT THE SUBINTERVAL WITH THE LARGEST ERROR ESTIMATE. ! A1 = ALIST(MAXERR) B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) if ( KEYF == 1) call DQK15(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 2) call DQK21(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 3) call DQK31(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 4) call DQK41(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 5) call DQK51(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 6) call DQK61(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 1) call DQK15(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) if ( KEYF == 2) call DQK21(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) if ( KEYF == 3) call DQK31(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) if ( KEYF == 4) call DQK41(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) if ( KEYF == 5) call DQK51(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) if ( KEYF == 6) call DQK61(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! NEVAL = NEVAL+1 AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( DEFAB1 == ERROR1.OR.DEFAB2 == ERROR2) go to 5 if ( ABS(RLIST(MAXERR)-AREA12) <= 0.1D-04*ABS(AREA12) & .AND.ERRO12 >= 0.99D+00*ERRMAX) IROFF1 = IROFF1+1 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF2 = IROFF2+1 5 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) if ( ERRSUM <= ERRBND) go to 8 ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. ! if ( IROFF1 >= 6.OR.IROFF2 >= 20) IER = 2 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS ! EQUALS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT A POINT OF THE INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1D+01+0.1D+03* & EPMACH)*(ABS(A2)+0.1D+04*UFLOW)) IER = 3 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! 8 if ( ERROR2 > ERROR1) go to 10 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 go to 20 10 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 ! ! call SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL ! WITH THE LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). ! 20 call DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if ( IER /= 0.OR.ERRSUM <= ERRBND) go to 40 30 CONTINUE ! ! COMPUTE FINAL RESULT. ! --------------------- ! 40 RESULT = 0.0D+00 DO 50 K=1,LAST RESULT = RESULT+RLIST(K) 50 CONTINUE ABSERR = ERRSUM 60 if ( KEYF /= 1) NEVAL = (10*KEYF+1)*(2*NEVAL+1) if ( KEYF == 1) NEVAL = 30*NEVAL+15 999 RETURN end subroutine DQAG (F, A, B, EPSABS, EPSREL, KEY, RESULT, ABSERR, & NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) ! !! DQAG approximates the definite integral of F(X) over (A,B), ... ! hopefully satisfying following claim for accuracy ! ABS(I-RESULT)LE.MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A1 !***TYPE DOUBLE PRECISION (QAG-S, DQAG-D) !***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD RULES, ! GENERAL-PURPOSE, GLOBALLY ADAPTIVE, INTEGRAND EXAMINATOR, ! QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Double precision version ! ! F - Double precision ! Function subprogram defining the integrand ! Function F(X). The actual name for F needs to be ! Declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! And EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! The routine will end with IER = 6. ! ! KEY - Integer ! Key for choice of local integration rule ! A GAUSS-KRONROD PAIR is used with ! 7 - 15 POINTS If KEY < 2, ! 10 - 21 POINTS If KEY = 2, ! 15 - 31 POINTS If KEY = 3, ! 20 - 41 POINTS If KEY = 4, ! 25 - 51 POINTS If KEY = 5, ! 30 - 61 POINTS If KEY > 5. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! Which should EQUAL or EXCEED ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! The estimates for RESULT and ERROR are ! Less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). HOWEVER, If ! this yield no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. ! If the position of a local difficulty can ! be determined (I.E. SINGULARITY, ! DISCONTINUITY WITHIN THE INTERVAL) One ! will probably gain from splitting up the ! interval at this point and calling the ! INTEGRATOR on the SUBRANGES. If possible, ! AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR ! should be used which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 6 The input is invalid, because ! (EPSABS <= 0 AND ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! OR LIMIT < 1 OR LENW < LIMIT*4. ! RESULT, ABSERR, NEVAL, LAST are set ! to zero. ! EXCEPT when LENW is invalid, IWORK(1), ! WORK(LIMIT*2+1) and WORK(LIMIT*3+1) are ! set to zero, WORK(1) is set to A and ! WORK(LIMIT+1) to B. ! ! DIMENSIONING PARAMETERS ! LIMIT - Integer ! Dimensioning parameter for IWORK ! Limit determines the maximum number of subintervals ! in the partition of the given integration interval ! (A,B), LIMIT >= 1. ! If LIMIT < 1, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for work ! LENW must be at least LIMIT*4. ! if LENW < LIMIT*4, the routine will end with ! IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, which ! determines the number of significant elements ! actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least limit, the first K ! elements of which contain pointers to the error ! estimates over the subintervals, such that ! WORK(LIMIT*3+IWORK(1)),... , WORK(LIMIT*3+IWORK(K)) ! form a decreasing sequence with K = LAST If ! LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST otherwise ! ! WORK - Double precision ! Vector of dimension at least LENW ! on return ! WORK(1), ..., WORK(LAST) contain the left end ! points of the subintervals in the partition of ! (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain the ! right end points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain ! the integral approximations over the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) contain ! the error estimates. ! !***REFERENCES (NONE) !***ROUTINES CALLED DQAGE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DQAG DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK,KEY,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F !***FIRST EXECUTABLE STATEMENT DQAG IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 if (LIMIT >= 1 .AND. LENW >= LIMIT*4) THEN ! ! PREPARE call FOR DQAGE. ! L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 ! call DQAGE(F,A,B,EPSABS,EPSREL,KEY,LIMIT,RESULT,ABSERR,NEVAL, & IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 end if ! if (IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'DQAG', & 'ABNORMAL RETURN', IER, LVL) return end subroutine DQAGIE (F, BOUND, INF, EPSABS, EPSREL, LIMIT, RESULT, & ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) ! !! DQAGIE approximates the integral of F(X) over an infinite interval. ! ! The routine calculates an approximation result to a given ! integral I = Integral of F over (BOUND,+INFINITY) ! or I = Integral of F over (-INFINITY,BOUND) ! or I = Integral of F over (-INFINITY,+INFINITY), ! hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)) ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A3A1, H2A4A1 !***TYPE DOUBLE PRECISION (QAGIE-S, DQAGIE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, ! GLOBALLY ADAPTIVE, INFINITE INTERVALS, QUADPACK, ! QUADRATURE, TRANSFORMATION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration over infinite intervals ! Standard fortran subroutine ! ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! BOUND - Double precision ! Finite bound of integration range ! (has no meaning if interval is doubly-infinite) ! ! INF - Double precision ! Indicating the kind of integration range involved ! INF = 1 corresponds to (BOUND,+INFINITY), ! INF = -1 to (-INFINITY,BOUND), ! INF = 2 to (-INFINITY,+INFINITY). ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B), LIMIT >= 1 ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! - IER > 0 Abnormal termination of the routine. The ! estimates for result and error are less ! reliable. It is assumed that the requested ! accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. ! If the position of a local difficulty can ! be determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. If possible, ! an appropriate special-purpose integrator ! should be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. ! It is assumed that the requested tolerance ! cannot be achieved, and that the returned ! result is the best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER. ! = 6 The input is invalid, because ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! RESULT, ABSERR, NEVAL, LAST, RLIST(1), ! ELIST(1) and IORD(1) are set to zero. ! ALIST(1) and BLIST(1) are set to 0 ! and 1 respectively. ! ! ALIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left ! end points of the subintervals in the partition ! of the transformed integration range (0,1). ! ! BLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right ! end points of the subintervals in the partition ! of the transformed integration range (0,1). ! ! RLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension LIMIT, the first K ! elements of which are pointers to the ! error estimates over the subintervals, ! such that ELIST(IORD(1)), ..., ELIST(IORD(K)) ! form a decreasing sequence, with K = LAST ! If LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise ! ! LAST - Integer ! Number of subintervals actually produced ! in the subdivision process ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DQELG, DQK15I, DQPSRT !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQAGIE DOUBLE PRECISION ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, & A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2, & DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST, & ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS, & RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, & KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 LOGICAL EXTRAP,NOEXT ! DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), & RES3LA(3),RLIST(*),RLIST2(52) ! EXTERNAL F ! ! THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF ! LIMEXP IN SUBROUTINE DQELG. ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! RLIST2 - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), ! CONTAINING THE PART OF THE EPSILON TABLE ! WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR ! ESTIMATE ! ERRMAX - ELIST(MAXERR) ! ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED ! (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE ! NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. if AN ! APPROPRIATE APPROXIMATION TO THE COMPOUNDED ! INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN ! RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED ! BY ONE. ! SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP ! TO NOW, MULTIPLIED BY 1.5 ! ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER ! THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW ! EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE ! IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. ! BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE ! TRY TO DECREASE THE VALUE OF ERLARG. ! NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION ! IS NO LONGER ALLOWED (TRUE-VALUE) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQAGIE EPMACH = D1MACH(4) ! ! TEST ON VALIDITY OF PARAMETERS ! ----------------------------- ! IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 ALIST(1) = 0.0D+00 BLIST(1) = 0.1D+01 RLIST(1) = 0.0D+00 ELIST(1) = 0.0D+00 IORD(1) = 0 if ( EPSABS <= 0.0D+00.AND.EPSREL < MAX(0.5D+02*EPMACH,0.5D-28)) & IER = 6 if ( IER == 6) go to 999 ! ! ! FIRST APPROXIMATION TO THE INTEGRAL ! ----------------------------------- ! ! DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). ! if INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE ! I1 = INTEGRAL OF F OVER (-INFINITY,0), ! I2 = INTEGRAL OF F OVER (0,+INFINITY). ! BOUN = BOUND if ( INF == 2) BOUN = 0.0D+00 call DQK15I(F,BOUN,INF,0.0D+00,0.1D+01,RESULT,ABSERR, & DEFABS,RESABS) ! ! TEST ON ACCURACY ! LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 DRES = ABS(RESULT) ERRBND = MAX(EPSABS,EPSREL*DRES) if ( ABSERR <= 1.0D+02*EPMACH*DEFABS.AND.ABSERR > ERRBND) IER = 2 if ( LIMIT == 1) IER = 1 if ( IER /= 0.OR.(ABSERR <= ERRBND.AND.ABSERR /= RESABS).OR. & ABSERR == 0.0D+00) go to 130 ! ! INITIALIZATION ! -------------- ! UFLOW = D1MACH(1) OFLOW = D1MACH(2) RLIST2(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW NRMAX = 1 NRES = 0 KTMIN = 0 NUMRL2 = 2 EXTRAP = .FALSE. NOEXT = .FALSE. IERRO = 0 IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KSGN = -1 if ( DRES >= (0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1 ! ! MAIN DO-LOOP ! ------------ ! DO 90 LAST = 2,LIMIT ! ! BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE. ! A1 = ALIST(MAXERR) B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX call DQK15I(F,BOUN,INF,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) call DQK15I(F,BOUN,INF,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( DEFAB1 == ERROR1.OR.DEFAB2 == ERROR2)go to 15 if ( ABS(RLIST(MAXERR)-AREA12) > 0.1D-04*ABS(AREA12) & .OR.ERRO12 < 0.99D+00*ERRMAX) go to 10 if ( EXTRAP) IROFF2 = IROFF2+1 if ( .NOT.EXTRAP) IROFF1 = IROFF1+1 10 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF3 = IROFF3+1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. ! if ( IROFF1+IROFF2 >= 10.OR.IROFF3 >= 20) IER = 2 if ( IROFF2 >= 5) IERRO = 3 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF ! SUBINTERVALS EQUALS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT SOME POINTS OF THE INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1D+01+0.1D+03*EPMACH)* & (ABS(A2)+0.1D+04*UFLOW)) IER = 4 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! if ( ERROR2 > 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 ! ! call SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL ! WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). ! 30 call DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) if ( ERRSUM <= ERRBND) go to 115 if ( IER /= 0) go to 100 if ( LAST == 2) go to 80 if ( NOEXT) go to 90 ERLARG = ERLARG-ERLAST if ( ABS(B1-A1) > SMALL) ERLARG = ERLARG+ERRO12 if ( EXTRAP) go to 40 ! ! TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE ! SMALLEST INTERVAL. ! if ( ABS(BLIST(MAXERR)-ALIST(MAXERR)) > SMALL) go to 90 EXTRAP = .TRUE. NRMAX = 2 40 if ( IERRO == 3.OR.ERLARG <= ERTEST) go to 60 ! ! THE SMALLEST INTERVAL HAS THE LARGEST ERROR. ! BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE ! LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. ! ID = NRMAX JUPBND = LAST if ( LAST > (2+LIMIT/2)) JUPBND = LIMIT+3-LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) if ( ABS(BLIST(MAXERR)-ALIST(MAXERR)) > SMALL) go to 90 NRMAX = NRMAX+1 50 CONTINUE ! ! PERFORM EXTRAPOLATION. ! 60 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA call DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) KTMIN = KTMIN+1 if ( KTMIN > 5.AND.ABSERR < 0.1D-02*ERRSUM) IER = 5 if ( ABSEPS >= ABSERR) go to 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) if ( ABSERR <= ERTEST) go to 100 ! ! PREPARE BISECTION OF THE SMALLEST INTERVAL. ! 70 if ( NUMRL2 == 1) NOEXT = .TRUE. if ( IER == 5) go to 100 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5D+00 ERLARG = ERRSUM go to 90 80 SMALL = 0.375D+00 ERLARG = ERRSUM ERTEST = ERRBND RLIST2(2) = AREA 90 CONTINUE ! ! SET FINAL RESULT AND ERROR ESTIMATE. ! ------------------------------------ ! 100 if ( ABSERR == OFLOW) go to 115 if ( (IER+IERRO) == 0) go to 110 if ( IERRO == 3) ABSERR = ABSERR+CORREC if ( IER == 0) IER = 3 if ( RESULT /= 0.0D+00.AND.AREA /= 0.0D+00)go to 105 if ( ABSERR > ERRSUM)go to 115 if ( AREA == 0.0D+00) go to 130 go to 110 105 if ( ABSERR/ABS(RESULT) > ERRSUM/ABS(AREA))go to 115 ! ! TEST ON DIVERGENCE ! 110 if ( KSGN == (-1).AND.MAX(ABS(RESULT),ABS(AREA)) <= & DEFABS*0.1D-01) go to 130 if (0.1D-01 > (RESULT/AREA).OR.(RESULT/AREA) > 0.1D+03 & .OR.ERRSUM > ABS(AREA)) IER = 6 go to 130 ! ! COMPUTE GLOBAL INTEGRAL SUM. ! 115 RESULT = 0.0D+00 DO 120 K = 1,LAST RESULT = RESULT+RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 NEVAL = 30*LAST-15 if ( INF == 2) NEVAL = 2*NEVAL if ( IER > 2) IER=IER-1 999 RETURN end subroutine DQAGI (F, BOUND, INF, EPSABS, EPSREL, RESULT, ABSERR, & NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) ! !! DQAGI approximates the integral of F(X) over an infinite interval. ! ! The routine calculates an approximation result to a given ! INTEGRAL I = Integral of F over (BOUND,+INFINITY) ! OR I = Integral of F over (-INFINITY,BOUND) ! OR I = Integral of F over (-INFINITY,+INFINITY) ! Hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A3A1, H2A4A1 !***TYPE DOUBLE PRECISION (QAGI-S, DQAGI-D) !***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, ! GLOBALLY ADAPTIVE, INFINITE INTERVALS, QUADPACK, ! QUADRATURE, TRANSFORMATION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration over infinite intervals ! Standard fortran subroutine ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! BOUND - Double precision ! Finite bound of integration range ! (has no meaning if interval is doubly-infinite) ! ! INF - Integer ! indicating the kind of integration range involved ! INF = 1 corresponds to (BOUND,+INFINITY), ! INF = -1 to (-INFINITY,BOUND), ! INF = 2 to (-INFINITY,+INFINITY). ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! - IER > 0 abnormal termination of the routine. The ! estimates for result and error are less ! reliable. It is assumed that the requested ! accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. If ! the position of a local difficulty can be ! determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. If possible, ! an appropriate special-purpose integrator ! should be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. ! It is assumed that the requested tolerance ! cannot be achieved, and that the returned ! RESULT is the best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER. ! = 6 The input is invalid, because ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or LIMIT < 1 or LENIW < LIMIT*4. ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LIMIT or LENIW is ! invalid, IWORK(1), WORK(LIMIT*2+1) and ! WORK(LIMIT*3+1) are set to ZERO, WORK(1) ! is set to A and WORK(LIMIT+1) to B. ! ! DIMENSIONING PARAMETERS ! LIMIT - Integer ! Dimensioning parameter for IWORK ! LIMIT determines the maximum number of subintervals ! in the partition of the given integration interval ! (A,B), LIMIT >= 1. ! If LIMIT < 1, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LIMIT*4. ! If LENW < LIMIT*4, the routine will end ! with IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, which ! determines the number of significant elements ! actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LIMIT, the first ! K elements of which contain pointers ! to the error estimates over the subintervals, ! such that WORK(LIMIT*3+IWORK(1)),... , ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence, with K = LAST if LAST <= (LIMIT/2+2), and ! K = LIMIT+1-LAST otherwise ! ! WORK - Double precision ! Vector of dimension at least LENW ! on return ! WORK(1), ..., WORK(LAST) contain the left ! end points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) Contain ! the right end points, ! WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) contain the ! integral approximations over the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3) ! contain the error estimates. ! !***REFERENCES (NONE) !***ROUTINES CALLED DQAGIE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DQAGI ! DOUBLE PRECISION ABSERR,BOUND,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,INF,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMIT AND LENW. ! !***FIRST EXECUTABLE STATEMENT DQAGI IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 if ( LIMIT < 1.OR.LENW < LIMIT*4) go to 10 ! ! PREPARE call FOR DQAGIE. ! L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 ! call DQAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, & NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'DQAGI', & 'ABNORMAL RETURN', IER, LVL) return end subroutine DQAGPE (F, A, B, NPTS2, POINTS, EPSABS, EPSREL, LIMIT, & RESULT, ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, PTS, & IORD, LEVEL, NDIN, LAST) ! !! DQAGPE approximates the integral of a function with singularities. ! ! Approximate a given definite integral I = Integral of F ! over (A,B), hopefully satisfying the accuracy claim: ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! Break points of the integration interval, where local ! difficulties of the integrand may occur (e.g. singularities ! or discontinuities) are provided by the user. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE DOUBLE PRECISION (QAGPE-S, DQAGPE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, ! GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, ! SINGULARITIES AT USER SPECIFIED POINTS !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! NPTS2 - Integer ! Number equal to two more than the number of ! user-supplied break points within the integration ! range, NPTS2 >= 2. ! If NPTS2 < 2, the routine will end with IER = 6. ! ! POINTS - Double precision ! Vector of dimension NPTS2, the first (NPTS2-2) ! elements of which are the user provided break ! POINTS. If these POINTS do not constitute an ! ascending sequence there will be an automatic ! sorting. ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B), LIMIT >= NPTS2 ! If LIMIT < NPTS2, the routine will end with ! IER = 6. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine. ! The estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. If ! the position of a local difficulty can be ! determined (i.e. SINGULARITY, ! DISCONTINUITY within the interval), it ! should be supplied to the routine as an ! element of the vector points. If necessary ! an appropriate special-purpose integrator ! must be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! At some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. It is presumed that ! the requested tolerance cannot be ! achieved, and that the returned result is ! the best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER > 0. ! = 6 The input is invalid because ! NPTS2 < 2 or ! Break points are specified outside ! the integration range or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or LIMIT < NPTS2. ! RESULT, ABSERR, NEVAL, LAST, RLIST(1), ! and ELIST(1) are set to zero. ALIST(1) and ! BLIST(1) are set to A and B respectively. ! ! ALIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left end points ! of the subintervals in the partition of the given ! integration range (A,B) ! ! BLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right end points ! of the subintervals in the partition of the given ! integration range (A,B) ! ! RLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! PTS - Double precision ! Vector of dimension at least NPTS2, containing the ! integration limits and the break points of the ! interval in ascending sequence. ! ! LEVEL - Integer ! Vector of dimension at least LIMIT, containing the ! subdivision levels of the subinterval, i.e. if ! (AA,BB) is a subinterval of (P1,P2) where P1 as ! well as P2 is a user-provided break point or ! integration limit, then (AA,BB) has level L if ! ABS(BB-AA) = ABS(P2-P1)*2**(-L). ! ! NDIN - Integer ! Vector of dimension at least NPTS2, after first ! integration over the intervals (PTS(I)),PTS(I+1), ! I = 0,1, ..., NPTS2-2, the error estimates over ! some of the intervals may have been increased ! artificially, in order to put their subdivision ! forward. If this happens for the subinterval ! numbered K, NDIN(K) is put to 1, otherwise ! NDIN(K) = 0. ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which are pointers to the ! error estimates over the subintervals, ! such that ELIST(IORD(1)), ..., ELIST(IORD(K)) ! form a decreasing sequence, with K = LAST ! If LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise ! ! LAST - Integer ! Number of subintervals actually produced in the ! subdivisions process ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DQELG, DQK21, DQPSRT !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQAGPE DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, & A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2, & DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, & ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW,POINTS,PTS, & RESA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SIGN,TEMP,UFLOW INTEGER I,ID,IER,IERRO,IND1,IND2,IORD,IP1,IROFF1,IROFF2,IROFF3,J, & JLOW,JUPBND,K,KSGN,KTMIN,LAST,LEVCUR,LEVEL,LEVMAX,LIMIT,MAXERR, & NDIN,NEVAL,NINT,NINTP1,NPTS,NPTS2,NRES,NRMAX,NUMRL2 LOGICAL EXTRAP,NOEXT ! ! DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), & LEVEL(*),NDIN(*),POINTS(*),PTS(*),RES3LA(3), & RLIST(*),RLIST2(52) ! EXTERNAL F ! ! THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF ! LIMEXP IN SUBROUTINE EPSALG (RLIST2 SHOULD BE OF DIMENSION ! (LIMEXP+2) AT LEAST). ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 ! CONTAINING THE PART OF THE EPSILON TABLE WHICH ! IS STILL NEEDED FOR FURTHER COMPUTATIONS ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR ! ESTIMATE ! ERRMAX - ELIST(MAXERR) ! ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED ! (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE ! NUMRL2 - NUMBER OF ELEMENTS IN RLIST2. if AN APPROPRIATE ! APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS ! BEEN OBTAINED, IT IS PUT IN RLIST2(NUMRL2) AFTER ! NUMRL2 HAS BEEN INCREASED BY ONE. ! ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER ! THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW ! EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE ! IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. ! BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE ! TRY TO DECREASE THE VALUE OF ERLARG. ! NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION IS ! NO LONGER ALLOWED (TRUE-VALUE) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQAGPE EPMACH = D1MACH(4) ! ! TEST ON VALIDITY OF PARAMETERS ! ----------------------------- ! IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0D+00 ELIST(1) = 0.0D+00 IORD(1) = 0 LEVEL(1) = 0 NPTS = NPTS2-2 if ( NPTS2 < 2.OR.LIMIT <= NPTS.OR.(EPSABS <= 0.0D+00.AND. & EPSREL < MAX(0.5D+02*EPMACH,0.5D-28))) IER = 6 if ( IER == 6) go to 999 ! ! if ANY BREAK POINTS ARE PROVIDED, SORT THEM INTO AN ! ASCENDING SEQUENCE. ! SIGN = 1.0D+00 if ( A > B) SIGN = -1.0D+00 PTS(1) = MIN(A,B) if ( NPTS == 0) go to 15 DO 10 I = 1,NPTS PTS(I+1) = POINTS(I) 10 CONTINUE 15 PTS(NPTS+2) = MAX(A,B) NINT = NPTS+1 A1 = PTS(1) if ( NPTS == 0) go to 40 NINTP1 = NINT+1 DO 20 I = 1,NINT IP1 = I+1 DO 20 J = IP1,NINTP1 if ( PTS(I) <= PTS(J)) go to 20 TEMP = PTS(I) PTS(I) = PTS(J) PTS(J) = TEMP 20 CONTINUE if ( PTS(1) /= MIN(A,B).OR.PTS(NINTP1) /= MAX(A,B)) IER = 6 if ( IER == 6) go to 999 ! ! COMPUTE FIRST INTEGRAL AND ERROR APPROXIMATIONS. ! ------------------------------------------------ ! 40 RESABS = 0.0D+00 DO 50 I = 1,NINT B1 = PTS(I+1) call DQK21(F,A1,B1,AREA1,ERROR1,DEFABS,RESA) ABSERR = ABSERR+ERROR1 RESULT = RESULT+AREA1 NDIN(I) = 0 if ( ERROR1 == RESA.AND.ERROR1 /= 0.0D+00) NDIN(I) = 1 RESABS = RESABS+DEFABS LEVEL(I) = 0 ELIST(I) = ERROR1 ALIST(I) = A1 BLIST(I) = B1 RLIST(I) = AREA1 IORD(I) = I A1 = B1 50 CONTINUE ERRSUM = 0.0D+00 DO 55 I = 1,NINT if ( NDIN(I) == 1) ELIST(I) = ABSERR ERRSUM = ERRSUM+ELIST(I) 55 CONTINUE ! ! TEST ON ACCURACY. ! LAST = NINT NEVAL = 21*NINT DRES = ABS(RESULT) ERRBND = MAX(EPSABS,EPSREL*DRES) if ( ABSERR <= 0.1D+03*EPMACH*RESABS.AND.ABSERR > ERRBND) IER = 2 if ( NINT == 1) go to 80 DO 70 I = 1,NPTS JLOW = I+1 IND1 = IORD(I) DO 60 J = JLOW,NINT IND2 = IORD(J) if ( ELIST(IND1) > ELIST(IND2)) go to 60 IND1 = IND2 K = J 60 CONTINUE if ( IND1 == IORD(I)) go to 70 IORD(K) = IORD(I) IORD(I) = IND1 70 CONTINUE if ( LIMIT < NPTS2) IER = 1 80 if ( IER /= 0.OR.ABSERR <= ERRBND) go to 999 ! ! INITIALIZATION ! -------------- ! RLIST2(1) = RESULT MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) AREA = RESULT NRMAX = 1 NRES = 0 NUMRL2 = 1 KTMIN = 0 EXTRAP = .FALSE. NOEXT = .FALSE. ERLARG = ERRSUM ERTEST = ERRBND LEVMAX = 1 IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 IERRO = 0 UFLOW = D1MACH(1) OFLOW = D1MACH(2) ABSERR = OFLOW KSGN = -1 if ( DRES >= (0.1D+01-0.5D+02*EPMACH)*RESABS) KSGN = 1 ! ! MAIN DO-LOOP ! ------------ ! DO 160 LAST = NPTS2,LIMIT ! ! BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR ! ESTIMATE. ! LEVCUR = LEVEL(MAXERR)+1 A1 = ALIST(MAXERR) B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX call DQK21(F,A1,B1,AREA1,ERROR1,RESA,DEFAB1) call DQK21(F,A2,B2,AREA2,ERROR2,RESA,DEFAB2) ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! NEVAL = NEVAL+42 AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( DEFAB1 == ERROR1.OR.DEFAB2 == ERROR2) go to 95 if ( ABS(RLIST(MAXERR)-AREA12) > 0.1D-04*ABS(AREA12) & .OR.ERRO12 < 0.99D+00*ERRMAX) go to 90 if ( EXTRAP) IROFF2 = IROFF2+1 if ( .NOT.EXTRAP) IROFF1 = IROFF1+1 90 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF3 = IROFF3+1 95 LEVEL(MAXERR) = LEVCUR LEVEL(LAST) = LEVCUR RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. ! if ( IROFF1+IROFF2 >= 10.OR.IROFF3 >= 20) IER = 2 if ( IROFF2 >= 5) IERRO = 3 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF ! SUBINTERVALS EQUALS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT A POINT OF THE INTEGRATION RANGE ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1D+01+0.1D+03*EPMACH)* & (ABS(A2)+0.1D+04*UFLOW)) IER = 4 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! if ( ERROR2 > ERROR1) go to 100 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 go to 110 100 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 ! ! call SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL ! WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). ! 110 call DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if ( ERRSUM <= ERRBND) go to 190 ! ***JUMP OUT OF DO-LOOP if ( IER /= 0) go to 170 if ( NOEXT) go to 160 ERLARG = ERLARG-ERLAST if ( LEVCUR+1 <= LEVMAX) ERLARG = ERLARG+ERRO12 if ( EXTRAP) go to 120 ! ! TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE ! SMALLEST INTERVAL. ! if ( LEVEL(MAXERR)+1 <= LEVMAX) go to 160 EXTRAP = .TRUE. NRMAX = 2 120 if ( IERRO == 3.OR.ERLARG <= ERTEST) go to 140 ! ! THE SMALLEST INTERVAL HAS THE LARGEST ERROR. ! BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER ! THE LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. ! ID = NRMAX JUPBND = LAST if ( LAST > (2+LIMIT/2)) JUPBND = LIMIT+3-LAST DO 130 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) ! ***JUMP OUT OF DO-LOOP if ( LEVEL(MAXERR)+1 <= LEVMAX) go to 160 NRMAX = NRMAX+1 130 CONTINUE ! ! PERFORM EXTRAPOLATION. ! 140 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA if ( NUMRL2 <= 2) go to 155 call DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) KTMIN = KTMIN+1 if ( KTMIN > 5.AND.ABSERR < 0.1D-02*ERRSUM) IER = 5 if ( ABSEPS >= ABSERR) go to 150 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) ! ***JUMP OUT OF DO-LOOP if ( ABSERR < ERTEST) go to 170 ! ! PREPARE BISECTION OF THE SMALLEST INTERVAL. ! 150 if ( NUMRL2 == 1) NOEXT = .TRUE. if ( IER >= 5) go to 170 155 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. LEVMAX = LEVMAX+1 ERLARG = ERRSUM 160 CONTINUE ! ! SET THE FINAL RESULT. ! --------------------- ! ! 170 if ( ABSERR == OFLOW) go to 190 if ( (IER+IERRO) == 0) go to 180 if ( IERRO == 3) ABSERR = ABSERR+CORREC if ( IER == 0) IER = 3 if ( RESULT /= 0.0D+00.AND.AREA /= 0.0D+00)go to 175 if ( ABSERR > ERRSUM)go to 190 if ( AREA == 0.0D+00) go to 210 go to 180 175 if ( ABSERR/ABS(RESULT) > ERRSUM/ABS(AREA))go to 190 ! ! TEST ON DIVERGENCE. ! 180 if ( KSGN == (-1).AND.MAX(ABS(RESULT),ABS(AREA)) <= & DEFABS*0.1D-01) go to 210 if ( 0.1D-01 > (RESULT/AREA).OR.(RESULT/AREA) > 0.1D+03.OR. & ERRSUM > ABS(AREA)) IER = 6 go to 210 ! ! COMPUTE GLOBAL INTEGRAL SUM. ! 190 RESULT = 0.0D+00 DO 200 K = 1,LAST RESULT = RESULT+RLIST(K) 200 CONTINUE ABSERR = ERRSUM 210 if ( IER > 2) IER = IER-1 RESULT = RESULT*SIGN 999 RETURN end subroutine DQAGP (F, A, B, NPTS2, POINTS, EPSABS, EPSREL, RESULT, & ABSERR, NEVAL, IER, LENIW, LENW, LAST, IWORK, WORK) ! !! DQAGP approximates the integral of a function with singularities. ! ! The routine calculates an approximation result to a given ! definite integral I = Integral of F over (A,B), ! hopefully satisfying following claim for accuracy ! break points of the integration interval, where local ! difficulties of the integrand may occur (e.g. ! SINGULARITIES, DISCONTINUITIES), are provided by the user. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE DOUBLE PRECISION (QAGP-S, DQAGP-D) !***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, ! GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, ! SINGULARITIES AT USER SPECIFIED POINTS !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! Function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! NPTS2 - Integer ! Number equal to two more than the number of ! user-supplied break points within the integration ! range, NPTS >= 2. ! If NPTS2 < 2, The routine will end with IER = 6. ! ! POINTS - Double precision ! Vector of dimension NPTS2, the first (NPTS2-2) ! elements of which are the user provided break ! points. If these points do not constitute an ! ascending sequence there will be an automatic ! sorting. ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! And EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! The routine will end with IER = 6. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine. ! The estimates for integral and error are ! less reliable. it is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. one can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. If ! the position of a local difficulty can be ! determined (i.e. SINGULARITY, ! DISCONTINUITY within the interval), it ! should be supplied to the routine as an ! element of the vector points. If necessary ! an appropriate special-purpose integrator ! must be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! roundoff error is detected in the ! extrapolation table. ! It is presumed that the requested ! tolerance cannot be achieved, and that ! the returned RESULT is the best which ! can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. it must be noted that ! divergence can occur with any other value ! of IER > 0. ! = 6 The input is invalid because ! NPTS2 < 2 or ! break points are specified outside ! the integration range or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LENIW or LENW or NPTS2 ! is invalid, IWORK(1), IWORK(LIMIT+1), ! WORK(LIMIT*2+1) and WORK(LIMIT*3+1) ! are set to zero. ! WORK(1) is set to A and WORK(LIMIT+1) ! to B (where LIMIT = (LENIW-NPTS2)/2). ! ! DIMENSIONING PARAMETERS ! LENIW - Integer ! Dimensioning parameter for IWORK ! LENIW determines LIMIT = (LENIW-NPTS2)/2, ! which is the maximum number of subintervals in the ! partition of the given integration interval (A,B), ! LENIW >= (3*NPTS2-2). ! If LENIW < (3*NPTS2-2), the routine will end with ! IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LENIW*2-NPTS2. ! If LENW < LENIW*2-NPTS2, the routine will end ! with IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, which ! determines the number of significant elements ! actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LENIW. on return, ! the first K elements of which contain ! pointers to the error estimates over the ! subintervals, such that WORK(LIMIT*3+IWORK(1)),..., ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence, with K = LAST if LAST <= (LIMIT/2+2), and ! K = LIMIT+1-LAST otherwise ! IWORK(LIMIT+1), ...,IWORK(LIMIT+LAST) Contain the ! subdivision levels of the subintervals, i.e. ! if (AA,BB) is a subinterval of (P1,P2) ! where P1 as well as P2 is a user-provided ! break point or integration LIMIT, then (AA,BB) has ! level L if ABS(BB-AA) = ABS(P2-P1)*2**(-L), ! IWORK(LIMIT*2+1), ..., IWORK(LIMIT*2+NPTS2) have ! no significance for the user, ! note that LIMIT = (LENIW-NPTS2)/2. ! ! WORK - Double precision ! Vector of dimension at least LENW ! on return ! WORK(1), ..., WORK(LAST) contain the left ! end points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain ! the right end points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain ! the integral approximations over the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) ! contain the corresponding error estimates, ! WORK(LIMIT*4+1), ..., WORK(LIMIT*4+NPTS2) ! contain the integration limits and the ! break points sorted in an ascending sequence. ! note that LIMIT = (LENIW-NPTS2)/2. ! !***REFERENCES (NONE) !***ROUTINES CALLED DQAGPE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DQAGP ! DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,POINTS,RESULT,WORK INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,LVL,L1,L2,L3,L4,NEVAL, & NPTS2 ! DIMENSION IWORK(*),POINTS(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMIT AND LENW. ! !***FIRST EXECUTABLE STATEMENT DQAGP IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 if ( LENIW < (3*NPTS2-2).OR.LENW < (LENIW*2-NPTS2).OR.NPTS2 < 2) & go to 10 ! ! PREPARE call FOR DQAGPE. ! LIMIT = (LENIW-NPTS2)/2 L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 L4 = LIMIT+L3 ! call DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, & NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),WORK(L4), & IWORK(1),IWORK(L1),IWORK(L2),LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'DQAGP', & 'ABNORMAL RETURN', IER, LVL) return end subroutine DQAGSE (F, A, B, EPSABS, EPSREL, LIMIT, RESULT, ABSERR, & NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) ! !! DQAGSE approximates the integral of a function with singularities. ! ! The routine calculates an approximation result to a given ! definite integral I = Integral of F over (A,B), ! hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A1 !***TYPE DOUBLE PRECISION (QAGSE-S, DQAGSE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, END POINT SINGULARITIES, ! EXTRAPOLATION, GENERAL-PURPOSE, GLOBALLY ADAPTIVE, ! QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B) ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! the estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more sub- ! divisions by increasing the value of LIMIT ! (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. If ! the position of a local difficulty can be ! determined (e.g. singularity, ! discontinuity within the interval) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. If possible, ! an appropriate special-purpose integrator ! should be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is detec- ! ted, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour ! occurs at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. ! It is presumed that the requested ! tolerance cannot be achieved, and that the ! returned result is the best which can be ! obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER. ! = 6 The input is invalid, because ! EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28). ! RESULT, ABSERR, NEVAL, LAST, RLIST(1), ! IORD(1) and ELIST(1) are set to zero. ! ALIST(1) and BLIST(1) are set to A and B ! respectively. ! ! ALIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left end points ! of the subintervals in the partition of the ! given integration range (A,B) ! ! BLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right end points ! of the subintervals in the partition of the given ! integration range (A,B) ! ! RLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which are pointers to the ! error estimates over the subintervals, ! such that ELIST(IORD(1)), ..., ELIST(IORD(K)) ! form a decreasing sequence, with K = LAST ! If LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise ! ! LAST - Integer ! Number of subintervals actually produced in the ! subdivision process ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DQELG, DQK21, DQPSRT !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQAGSE ! DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, & A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,D1MACH, & DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX, & ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS,RESEPS,RESULT, & RES3LA,RLIST,RLIST2,SMALL,UFLOW INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, & KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 LOGICAL EXTRAP,NOEXT ! DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), & RES3LA(3),RLIST(*),RLIST2(52) ! EXTERNAL F ! ! THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF ! LIMEXP IN SUBROUTINE DQELG (RLIST2 SHOULD BE OF DIMENSION ! (LIMEXP+2) AT LEAST). ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 CONTAINING ! THE PART OF THE EPSILON TABLE WHICH IS STILL ! NEEDED FOR FURTHER COMPUTATIONS ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR ! ESTIMATE ! ERRMAX - ELIST(MAXERR) ! ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED ! (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT INTERVAL ! *****2 - VARIABLE FOR THE RIGHT INTERVAL ! LAST - INDEX FOR SUBDIVISION ! NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE ! NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. if AN ! APPROPRIATE APPROXIMATION TO THE COMPOUNDED ! INTEGRAL HAS BEEN OBTAINED IT IS PUT IN ! RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED ! BY ONE. ! SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP ! TO NOW, MULTIPLIED BY 1.5 ! ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER ! THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW ! EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE IS ! ATTEMPTING TO PERFORM EXTRAPOLATION I.E. BEFORE ! SUBDIVIDING THE SMALLEST INTERVAL WE TRY TO ! DECREASE THE VALUE OF ERLARG. ! NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION ! IS NO LONGER ALLOWED (TRUE VALUE) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQAGSE EPMACH = D1MACH(4) ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0D+00 ELIST(1) = 0.0D+00 if ( EPSABS <= 0.0D+00.AND.EPSREL < MAX(0.5D+02*EPMACH,0.5D-28)) & IER = 6 if ( IER == 6) go to 999 ! ! FIRST APPROXIMATION TO THE INTEGRAL ! ----------------------------------- ! UFLOW = D1MACH(1) OFLOW = D1MACH(2) IERRO = 0 call DQK21(F,A,B,RESULT,ABSERR,DEFABS,RESABS) ! ! TEST ON ACCURACY. ! DRES = ABS(RESULT) ERRBND = MAX(EPSABS,EPSREL*DRES) LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 if ( ABSERR <= 1.0D+02*EPMACH*DEFABS.AND.ABSERR > ERRBND) IER = 2 if ( LIMIT == 1) IER = 1 if ( IER /= 0.OR.(ABSERR <= ERRBND.AND.ABSERR /= RESABS).OR. & ABSERR == 0.0D+00) go to 140 ! ! INITIALIZATION ! -------------- ! 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 >= (0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1 ! ! MAIN DO-LOOP ! ------------ ! DO 90 LAST = 2,LIMIT ! ! BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR ! ESTIMATE. ! A1 = ALIST(MAXERR) B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX call DQK21(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) call DQK21(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( DEFAB1 == ERROR1.OR.DEFAB2 == ERROR2) go to 15 if ( ABS(RLIST(MAXERR)-AREA12) > 0.1D-04*ABS(AREA12) & .OR.ERRO12 < 0.99D+00*ERRMAX) go to 10 if ( EXTRAP) IROFF2 = IROFF2+1 if ( .NOT.EXTRAP) IROFF1 = IROFF1+1 10 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF3 = IROFF3+1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. ! if ( IROFF1+IROFF2 >= 10.OR.IROFF3 >= 20) IER = 2 if ( IROFF2 >= 5) IERRO = 3 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS ! EQUALS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT A POINT OF THE INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1D+01+0.1D+03*EPMACH)* & (ABS(A2)+0.1D+04*UFLOW)) IER = 4 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! if ( ERROR2 > 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 ! ! call SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL ! WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). ! 30 call DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if ( ERRSUM <= ERRBND) go to 115 ! ***JUMP OUT OF DO-LOOP if ( IER /= 0) go to 100 if ( LAST == 2) go to 80 if ( NOEXT) go to 90 ERLARG = ERLARG-ERLAST if ( ABS(B1-A1) > SMALL) ERLARG = ERLARG+ERRO12 if ( EXTRAP) go to 40 ! ! TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE ! SMALLEST INTERVAL. ! if ( ABS(BLIST(MAXERR)-ALIST(MAXERR)) > SMALL) go to 90 EXTRAP = .TRUE. NRMAX = 2 40 if ( IERRO == 3.OR.ERLARG <= ERTEST) go to 60 ! ! THE SMALLEST INTERVAL HAS THE LARGEST ERROR. ! BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE ! LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. ! ID = NRMAX JUPBND = LAST if ( LAST > (2+LIMIT/2)) JUPBND = LIMIT+3-LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) ! ***JUMP OUT OF DO-LOOP if ( ABS(BLIST(MAXERR)-ALIST(MAXERR)) > SMALL) go to 90 NRMAX = NRMAX+1 50 CONTINUE ! ! PERFORM EXTRAPOLATION. ! 60 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA call DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) KTMIN = KTMIN+1 if ( KTMIN > 5.AND.ABSERR < 0.1D-02*ERRSUM) IER = 5 if ( ABSEPS >= ABSERR) go to 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) ! ***JUMP OUT OF DO-LOOP if ( ABSERR <= ERTEST) go to 100 ! ! PREPARE BISECTION OF THE SMALLEST INTERVAL. ! 70 if ( NUMRL2 == 1) NOEXT = .TRUE. if ( IER == 5) go to 100 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5D+00 ERLARG = ERRSUM go to 90 80 SMALL = ABS(B-A)*0.375D+00 ERLARG = ERRSUM ERTEST = ERRBND RLIST2(2) = AREA 90 CONTINUE ! ! SET FINAL RESULT AND ERROR ESTIMATE. ! ------------------------------------ ! 100 if ( ABSERR == OFLOW) go to 115 if ( IER+IERRO == 0) go to 110 if ( IERRO == 3) ABSERR = ABSERR+CORREC if ( IER == 0) IER = 3 if ( RESULT /= 0.0D+00.AND.AREA /= 0.0D+00) go to 105 if ( ABSERR > ERRSUM) go to 115 if ( AREA == 0.0D+00) go to 130 go to 110 105 if ( ABSERR/ABS(RESULT) > ERRSUM/ABS(AREA)) go to 115 ! ! TEST ON DIVERGENCE. ! 110 if ( KSGN == (-1).AND.MAX(ABS(RESULT),ABS(AREA)) <= & DEFABS*0.1D-01) go to 130 if ( 0.1D-01 > (RESULT/AREA).OR.(RESULT/AREA) > 0.1D+03 & .OR.ERRSUM > ABS(AREA)) IER = 6 go to 130 ! ! COMPUTE GLOBAL INTEGRAL SUM. ! 115 RESULT = 0.0D+00 DO 120 K = 1,LAST RESULT = RESULT+RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 if ( IER > 2) IER = IER-1 140 NEVAL = 42*LAST-21 999 RETURN end subroutine DQAGS (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, NEVAL, & IER, LIMIT, LENW, LAST, IWORK, WORK) ! !! DQAGS approximates the integral of a function with singularities. ! ! The routine calculates an approximation result to a given ! Definite integral I = Integral of F over (A,B), ! Hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A1 !***TYPE DOUBLE PRECISION (QAGS-S, DQAGS-D) !***KEYWORDS AUTOMATIC INTEGRATOR, END POINT SINGULARITIES, ! EXTRAPOLATION, GENERAL-PURPOSE, GLOBALLY ADAPTIVE, ! QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Double precision version ! ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! Function F(X). The actual name for F needs to be ! Declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! And EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! The routine will end with IER = 6. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! The estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more sub- ! divisions by increasing the value of LIMIT ! (and taking the according dimension ! adjustments into account. However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. If ! the position of a local difficulty can be ! determined (E.G. SINGULARITY, ! DISCONTINUITY WITHIN THE INTERVAL) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. If possible, ! an appropriate special-purpose integrator ! should be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is detec- ! ted, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour ! occurs at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! Extrapolation table. It is presumed that ! the requested tolerance cannot be ! achieved, and that the returned result is ! the best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER. ! = 6 The input is invalid, because ! (EPSABS <= 0 AND ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28) ! OR LIMIT < 1 OR LENW < LIMIT*4. ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LIMIT or LENW is ! invalid, IWORK(1), WORK(LIMIT*2+1) and ! WORK(LIMIT*3+1) are set to zero, WORK(1) ! is set to A and WORK(LIMIT+1) TO B. ! ! DIMENSIONING PARAMETERS ! LIMIT - Integer ! DIMENSIONING PARAMETER FOR IWORK ! LIMIT determines the maximum number of subintervals ! in the partition of the given integration interval ! (A,B), LIMIT >= 1. ! if LIMIT < 1, the routine will end with IER = 6. ! ! LENW - Integer ! DIMENSIONING PARAMETER FOR WORK ! LENW must be at least LIMIT*4. ! If LENW < LIMIT*4, the routine will end ! with IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, determines the ! number of significant elements actually in the WORK ! Arrays. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which contain pointers ! to the error estimates over the subintervals ! such that WORK(LIMIT*3+IWORK(1)),... , ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence, with K = LAST if LAST <= (LIMIT/2+2), ! and K = LIMIT+1-LAST otherwise ! ! WORK - Double precision ! Vector of dimension at least LENW ! on return ! WORK(1), ..., WORK(LAST) contain the left ! end-points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain ! the right end-points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain ! the integral approximations over the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) ! contain the error estimates. ! !***REFERENCES (NONE) !***ROUTINES CALLED DQAGSE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DQAGS ! ! DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMIT AND LENW. ! !***FIRST EXECUTABLE STATEMENT DQAGS IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 if ( LIMIT < 1.OR.LENW < LIMIT*4) go to 10 ! ! PREPARE call FOR DQAGSE. ! L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 ! call DQAGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL, & IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'DQAGS', & 'ABNORMAL RETURN', IER, LVL) return end subroutine DQAWCE (F, A, B, C, EPSABS, EPSREL, LIMIT, RESULT, & ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) ! !! DQAWCE approximates the Cauchy principal value of the integral of F(X)/(X-C). ! ! The routine calculates an approximation result to a ! CAUCHY PRINCIPAL VALUE I = Integral of F*W over (A,B) ! (W(X) = 1/(X-C), (C /= A, C /= B), hopefully satisfying ! following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)) ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1, J4 !***TYPE DOUBLE PRECISION (QAWCE-S, DQAWCE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CAUCHY PRINCIPAL VALUE, ! CLENSHAW-CURTIS METHOD, QUADPACK, QUADRATURE, ! SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a CAUCHY PRINCIPAL VALUE ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! C - Double precision ! Parameter in the WEIGHT function, C /= A, C /= B ! If C = A OR C = B, the routine will end with ! IER = 6. ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B), LIMIT >= 1 ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! the estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more sub- ! divisions by increasing the value of ! LIMIT. However, if this yields no ! improvement it is advised to analyze the ! the integrand, in order to determine the ! the integration difficulties. If the ! position of a local difficulty can be ! determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling ! appropriate integrators on the subranges. ! = 2 The occurrence of roundoff error is detec- ! ted, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour ! occurs at some interior points of ! the integration interval. ! = 6 The input is invalid, because ! C = A or C = B or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or LIMIT < 1. ! RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1), ! IORD(1) and LAST are set to zero. ALIST(1) ! and BLIST(1) are set to A and B ! respectively. ! ! ALIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! BLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! RLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Double precision ! Vector of dimension LIMIT, the first LAST ! elements of which are the moduli of the absolute ! error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which are pointers to the error ! estimates over the subintervals, so that ! ELIST(IORD(1)), ..., ELIST(IORD(K)) with K = LAST ! If LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise, form a decreasing sequence ! ! LAST - Integer ! Number of subintervals actually produced in ! the subdivision process ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DQC25C, DQPSRT !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQAWCE ! DOUBLE PRECISION A,AA,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2, & B,BB,BLIST,B1,B2,C,D1MACH,ELIST,EPMACH,EPSABS,EPSREL, & ERRBND,ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,F,RESULT,RLIST,UFLOW INTEGER IER,IORD,IROFF1,IROFF2,K,KRULE,LAST,LIMIT,MAXERR,NEV, & NEVAL,NRMAX ! DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), & IORD(*) ! EXTERNAL F ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ! ERROR ESTIMATE ! ERRMAX - ELIST(MAXERR) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQAWCE EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! IER = 6 NEVAL = 0 LAST = 0 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0D+00 ELIST(1) = 0.0D+00 IORD(1) = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 if (C == A.OR.C == B.OR.(EPSABS <= 0.0D+00.AND. & EPSREL < MAX(0.5D+02*EPMACH,0.5D-28))) go to 999 ! ! FIRST APPROXIMATION TO THE INTEGRAL ! ----------------------------------- ! AA=A BB=B if (A <= B) go to 10 AA=B BB=A 10 IER=0 KRULE = 1 call DQC25C(F,AA,BB,C,RESULT,ABSERR,KRULE,NEVAL) LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 ALIST(1) = A BLIST(1) = B ! ! TEST ON ACCURACY ! ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) if ( LIMIT == 1) IER = 1 if ( ABSERR < MIN(0.1D-01*ABS(RESULT),ERRBND) & .OR.IER == 1) go to 70 ! ! INITIALIZATION ! -------------- ! ALIST(1) = AA BLIST(1) = BB RLIST(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR NRMAX = 1 IROFF1 = 0 IROFF2 = 0 ! ! MAIN DO-LOOP ! ------------ ! DO 40 LAST = 2,LIMIT ! ! BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ! ERROR ESTIMATE. ! A1 = ALIST(MAXERR) B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) B2 = BLIST(MAXERR) if ( C <= B1.AND.C > A1) B1 = 0.5D+00*(C+B2) if ( C > B1.AND.C < B2) B1 = 0.5D+00*(A1+C) A2 = B1 KRULE = 2 call DQC25C(F,A1,B1,C,AREA1,ERROR1,KRULE,NEV) NEVAL = NEVAL+NEV call DQC25C(F,A2,B2,C,AREA2,ERROR2,KRULE,NEV) NEVAL = NEVAL+NEV ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( ABS(RLIST(MAXERR)-AREA12) < 0.1D-04*ABS(AREA12) & .AND.ERRO12 >= 0.99D+00*ERRMAX.AND.KRULE == 0) & IROFF1 = IROFF1+1 if ( LAST > 10.AND.ERRO12 > ERRMAX.AND.KRULE == 0) & IROFF2 = IROFF2+1 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) if ( ERRSUM <= ERRBND) go to 15 ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. ! if ( IROFF1 >= 6.AND.IROFF2 > 20) IER = 2 ! ! SET ERROR FLAG IN THE CASE THAT NUMBER OF INTERVAL ! BISECTIONS EXCEEDS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT A POINT OF THE INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1D+01+0.1D+03*EPMACH) & *(ABS(A2)+0.1D+04*UFLOW)) IER = 3 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! 15 if ( ERROR2 > 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 ! ! call SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL ! WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). ! 30 call DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if ( IER /= 0.OR.ERRSUM <= ERRBND) go to 50 40 CONTINUE ! ! COMPUTE FINAL RESULT. ! --------------------- ! 50 RESULT = 0.0D+00 DO 60 K=1,LAST RESULT = RESULT+RLIST(K) 60 CONTINUE ABSERR = ERRSUM 70 if (AA == B) RESULT=-RESULT 999 RETURN end subroutine DQAWC (F, A, B, C, EPSABS, EPSREL, RESULT, ABSERR, & NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) ! !! DQAWC approximates the Cauchy principal value of the integral of F(X)/(X-C). ! ! The routine calculates an approximation result to a ! Cauchy principal value I = INTEGRAL of F*W over (A,B) ! (W(X) = 1/((X-C), C /= A, C /= B), hopefully satisfying ! following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABE,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1, J4 !***TYPE DOUBLE PRECISION (QAWC-S, DQAWC-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CAUCHY PRINCIPAL VALUE, ! CLENSHAW-CURTIS METHOD, GLOBALLY ADAPTIVE, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a Cauchy principal value ! Standard fortran subroutine ! Double precision version ! ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! Function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Under limit of integration ! ! B - Double precision ! Upper limit of integration ! ! C - Parameter in the weight function, C /= A, C /= B. ! If C = A or C = B, the routine will end with ! IER = 6 . ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate or the modulus of the absolute error, ! Which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! the estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more sub- ! divisions by increasing the value of LIMIT ! (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. ! If the position of a local difficulty ! can be determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling ! appropriate integrators on the subranges. ! = 2 The occurrence of roundoff error is detec- ! ted, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 6 The input is invalid, because ! C = A or C = B or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or LIMIT < 1 or LENW < LIMIT*4. ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LENW or LIMIT is ! invalid, IWORK(1), WORK(LIMIT*2+1) and ! WORK(LIMIT*3+1) are set to zero, WORK(1) ! is set to A and WORK(LIMIT+1) to B. ! ! DIMENSIONING PARAMETERS ! LIMIT - Integer ! Dimensioning parameter for IWORK ! LIMIT determines the maximum number of subintervals ! in the partition of the given integration interval ! (A,B), LIMIT >= 1. ! If LIMIT < 1, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LIMIT*4. ! If LENW < LIMIT*4, the routine will end with ! IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, which ! determines the number of significant elements ! actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which contain pointers ! to the error estimates over the subintervals, ! such that WORK(LIMIT*3+IWORK(1)), ... , ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence, with K = LAST if LAST <= (LIMIT/2+2), ! and K = LIMIT+1-LAST otherwise ! ! WORK - Double precision ! Vector of dimension at least LENW ! On return ! WORK(1), ..., WORK(LAST) contain the left ! end points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain ! the right end points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain ! the integral approximations over the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) ! contain the error estimates. ! !***REFERENCES (NONE) !***ROUTINES CALLED DQAWCE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DQAWC ! DOUBLE PRECISION A,ABSERR,B,C,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMIT AND LENW. ! !***FIRST EXECUTABLE STATEMENT DQAWC IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 if ( LIMIT < 1.OR.LENW < LIMIT*4) go to 10 ! ! PREPARE call FOR DQAWCE. ! L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 call DQAWCE(F,A,B,C,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL,IER, & WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'DQAWC', & 'ABNORMAL RETURN', IER, LVL) return end subroutine DQAWFE (F, A, OMEGA, INTEGR, EPSABS, LIMLST, LIMIT, & MAXP1, RESULT, ABSERR, NEVAL, IER, RSLST, ERLST, IERLST, LST, & ALIST, BLIST, RLIST, ELIST, IORD, NNLOG, CHEBMO) ! !! DQAWFE approximates a given Fourier integral. ! ! The routine calculates an approximation result to a ! given Fourier integral ! I = Integral of F(X)*W(X) over (A,INFINITY) ! where W(X)=COS(OMEGA*X) or W(X)=SIN(OMEGA*X), ! hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= EPSABS. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A3A1 !***TYPE DOUBLE PRECISION (QAWFE-S, DQAWFE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CONVERGENCE ACCELERATION, ! FOURIER INTEGRALS, INTEGRATION BETWEEN ZEROS, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE INTEGRAL !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of Fourier integrals ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! Function F(X). The actual name for F needs to ! be declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! OMEGA - Double precision ! Parameter in the WEIGHT function ! ! INTEGR - Integer ! Indicates which WEIGHT function is used ! INTEGR = 1 W(X) = COS(OMEGA*X) ! INTEGR = 2 W(X) = SIN(OMEGA*X) ! If INTEGR /= 1.AND.INTEGR /= 2, the routine will ! end with IER = 6. ! ! EPSABS - Double precision ! absolute accuracy requested, EPSABS > 0 ! If EPSABS <= 0, the routine will end with IER = 6. ! ! LIMLST - Integer ! LIMLST gives an upper bound on the number of ! cycles, LIMLST >= 1. ! If LIMLST < 3, the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! allowed in the partition of each cycle, LIMIT >= 1 ! each cycle, LIMIT >= 1. ! ! MAXP1 - Integer ! Gives an upper bound on the number of ! Chebyshev moments which can be stored, I.E. ! for the intervals of lengths ABS(B-A)*2**(-L), ! L=0,1, ..., MAXP1-2, MAXP1 >= 1 ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral X ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - IER = 0 Normal and reliable termination of ! the routine. It is assumed that the ! requested accuracy has been achieved. ! IER > 0 Abnormal termination of the routine. The ! estimates for integral and error are less ! reliable. It is assumed that the requested ! accuracy has not been achieved. ! ERROR MESSAGES ! If OMEGA /= 0 ! IER = 1 Maximum number of cycles allowed ! Has been achieved., i.e. of subintervals ! (A+(K-1)C,A+KC) where ! C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), ! for K = 1, 2, ..., LST. ! One can allow more cycles by increasing ! the value of LIMLST (and taking the ! according dimension adjustments into ! account). ! Examine the array IWORK which contains ! the error flags on the cycles, in order to ! look for eventual local integration ! difficulties. If the position of a local ! difficulty can be determined (e.g. ! SINGULARITY, DISCONTINUITY within the ! interval) one will probably gain from ! splitting up the interval at this point ! and calling appropriate integrators on ! the subranges. ! = 4 The extrapolation table constructed for ! convergence acceleration of the series ! formed by the integral contributions over ! the cycles, does not converge to within ! the requested accuracy. As in the case of ! IER = 1, it is advised to examine the ! array IWORK which contains the error ! flags on the cycles. ! = 6 The input is invalid because ! (INTEGR /= 1 AND INTEGR /= 2) or ! EPSABS <= 0 or LIMLST < 3. ! RESULT, ABSERR, NEVAL, LST are set ! to zero. ! = 7 Bad integrand behaviour occurs within one ! or more of the cycles. Location and type ! of the difficulty involved can be ! determined from the vector IERLST. Here ! LST is the number of cycles actually ! needed (see below). ! IERLST(K) = 1 The maximum number of ! subdivisions (= LIMIT) has ! been achieved on the K th ! cycle. ! = 2 Occurrence of roundoff error ! is detected and prevents the ! tolerance imposed on the ! K th cycle, from being ! achieved. ! = 3 Extremely bad integrand ! behaviour occurs at some ! points of the K th cycle. ! = 4 The integration procedure ! over the K th cycle does ! not converge (to within the ! required accuracy) due to ! roundoff in the ! extrapolation procedure ! invoked on this cycle. It ! is assumed that the result ! on this interval is the ! best which can be obtained. ! = 5 The integral over the K th ! cycle is probably divergent ! or slowly convergent. It ! must be noted that ! divergence can occur with ! any other value of ! IERLST(K). ! If OMEGA = 0 and INTEGR = 1, ! The integral is calculated by means of DQAGIE ! and IER = IERLST(1) (with meaning as described ! for IERLST(K), K = 1). ! ! RSLST - Double precision ! Vector of dimension at least LIMLST ! RSLST(K) contains the integral contribution ! over the interval (A+(K-1)C,A+KC) where ! C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), ! K = 1, 2, ..., LST. ! Note that, if OMEGA = 0, RSLST(1) contains ! the value of the integral over (A,INFINITY). ! ! ERLST - Double precision ! Vector of dimension at least LIMLST ! ERLST(K) contains the error estimate corresponding ! with RSLST(K). ! ! IERLST - Integer ! Vector of dimension at least LIMLST ! IERLST(K) contains the error flag corresponding ! with RSLST(K). For the meaning of the local error ! flags see description of output parameter IER. ! ! LST - Integer ! Number of subintervals needed for the integration ! If OMEGA = 0 then LST is set to 1. ! ! ALIST, BLIST, RLIST, ELIST - Double precision ! vector of dimension at least LIMIT, ! ! IORD, NNLOG - Integer ! Vector of dimension at least LIMIT, providing ! space for the quantities needed in the subdivision ! process of each cycle ! ! CHEBMO - Double precision ! Array of dimension at least (MAXP1,25), providing ! space for the Chebyshev moments needed within the ! cycles ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DQAGIE, DQAWOE, DQELG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQAWFE ! DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,BLIST,CHEBMO,CORREC,CYCLE, & C1,C2,DL,DRL,D1MACH,ELIST,ERLST,EP,EPS,EPSA, & EPSABS,ERRSUM,F,FACT,OMEGA,P,PI,P1,PSUM,RESEPS,RESULT,RES3LA, & RLIST,RSLST,UFLOW INTEGER IER,IERLST,INTEGR,IORD,KTMIN,L,LAST,LST,LIMIT,LIMLST,LL, & MAXP1,MOMCOM,NEV,NEVAL,NNLOG,NRES,NUMRL2 ! DIMENSION ALIST(*),BLIST(*),CHEBMO(MAXP1,25),ELIST(*), & ERLST(*),IERLST(*),IORD(*),NNLOG(*),PSUM(52), & RES3LA(3),RLIST(*),RSLST(*) ! EXTERNAL F ! ! ! THE DIMENSION OF PSUM IS DETERMINED BY THE VALUE OF ! LIMEXP IN SUBROUTINE DQELG (PSUM MUST BE OF DIMENSION ! (LIMEXP+2) AT LEAST). ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! C1, C2 - END POINTS OF SUBINTERVAL (OF LENGTH CYCLE) ! CYCLE - (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA) ! PSUM - VECTOR OF DIMENSION AT LEAST (LIMEXP+2) ! (SEE ROUTINE DQELG) ! PSUM CONTAINS THE PART OF THE EPSILON TABLE ! WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS. ! EACH ELEMENT OF PSUM IS A PARTIAL SUM OF THE ! SERIES WHICH SHOULD SUM TO THE VALUE OF THE ! INTEGRAL. ! ERRSUM - SUM OF ERROR ESTIMATES OVER THE SUBINTERVALS, ! CALCULATED CUMULATIVELY ! EPSA - ABSOLUTE TOLERANCE REQUESTED OVER CURRENT ! SUBINTERVAL ! CHEBMO - ARRAY CONTAINING THE MODIFIED CHEBYSHEV ! MOMENTS (SEE ALSO ROUTINE DQC25F) ! SAVE P, PI DATA P/0.9D+00/ DATA PI / 3.14159265358979323846264338327950D0 / ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! !***FIRST EXECUTABLE STATEMENT DQAWFE RESULT = 0.0D+00 ABSERR = 0.0D+00 NEVAL = 0 LST = 0 IER = 0 if ( (INTEGR /= 1.AND.INTEGR /= 2).OR.EPSABS <= 0.0D+00.OR. & LIMLST < 3) IER = 6 if ( IER == 6) go to 999 if ( OMEGA /= 0.0D+00) go to 10 ! ! INTEGRATION BY DQAGIE if OMEGA IS ZERO ! -------------------------------------- ! if ( INTEGR == 1) call DQAGIE(F,A,1,EPSABS,0.0D+00,LIMIT, & RESULT,ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) RSLST(1) = RESULT ERLST(1) = ABSERR IERLST(1) = IER LST = 1 go to 999 ! ! INITIALIZATIONS ! --------------- ! 10 L = ABS(OMEGA) DL = 2*L+1 CYCLE = DL*PI/ABS(OMEGA) IER = 0 KTMIN = 0 NEVAL = 0 NUMRL2 = 0 NRES = 0 C1 = A C2 = CYCLE+A P1 = 0.1D+01-P UFLOW = D1MACH(1) EPS = EPSABS if ( EPSABS > UFLOW/P1) EPS = EPSABS*P1 EP = EPS FACT = 0.1D+01 CORREC = 0.0D+00 ABSERR = 0.0D+00 ERRSUM = 0.0D+00 ! ! MAIN DO-LOOP ! ------------ ! DO 50 LST = 1,LIMLST ! ! INTEGRATE OVER CURRENT SUBINTERVAL. ! EPSA = EPS*FACT call DQAWOE(F,C1,C2,OMEGA,INTEGR,EPSA,0.0D+00,LIMIT,LST,MAXP1, & RSLST(LST),ERLST(LST),NEV,IERLST(LST),LAST,ALIST,BLIST,RLIST, & ELIST,IORD,NNLOG,MOMCOM,CHEBMO) NEVAL = NEVAL+NEV FACT = FACT*P ERRSUM = ERRSUM+ERLST(LST) DRL = 0.5D+02*ABS(RSLST(LST)) ! ! TEST ON ACCURACY WITH PARTIAL SUM ! if ( (ERRSUM+DRL) <= EPSABS.AND.LST >= 6) go to 80 CORREC = MAX(CORREC,ERLST(LST)) if ( IERLST(LST) /= 0) EPS = MAX(EP,CORREC*P1) if ( IERLST(LST) /= 0) IER = 7 if ( IER == 7.AND.(ERRSUM+DRL) <= CORREC*0.1D+02.AND. & LST > 5) go to 80 NUMRL2 = NUMRL2+1 if ( LST > 1) go to 20 PSUM(1) = RSLST(1) go to 40 20 PSUM(NUMRL2) = PSUM(LL)+RSLST(LST) if ( LST == 2) go to 40 ! ! TEST ON MAXIMUM NUMBER OF SUBINTERVALS ! if ( LST == LIMLST) IER = 1 ! ! PERFORM NEW EXTRAPOLATION ! call DQELG(NUMRL2,PSUM,RESEPS,ABSEPS,RES3LA,NRES) ! ! TEST WHETHER EXTRAPOLATED RESULT IS INFLUENCED BY ROUNDOFF ! KTMIN = KTMIN+1 if ( KTMIN >= 15.AND.ABSERR <= 0.1D-02*(ERRSUM+DRL)) IER = 4 if ( ABSEPS > ABSERR.AND.LST /= 3) go to 30 ABSERR = ABSEPS RESULT = RESEPS KTMIN = 0 ! ! if IER IS NOT 0, CHECK WHETHER DIRECT RESULT (PARTIAL SUM) ! OR EXTRAPOLATED RESULT YIELDS THE BEST INTEGRAL ! APPROXIMATION ! if ( (ABSERR+0.1D+02*CORREC) <= EPSABS.OR. & (ABSERR <= EPSABS.AND.0.1D+02*CORREC >= EPSABS)) go to 60 30 if ( IER /= 0.AND.IER /= 7) go to 60 40 LL = NUMRL2 C1 = C2 C2 = C2+CYCLE 50 CONTINUE ! ! SET FINAL RESULT AND ERROR ESTIMATE ! ----------------------------------- ! 60 ABSERR = ABSERR+0.1D+02*CORREC if ( IER == 0) go to 999 if ( RESULT /= 0.0D+00.AND.PSUM(NUMRL2) /= 0.0D+00) go to 70 if ( ABSERR > ERRSUM) go to 80 if ( PSUM(NUMRL2) == 0.0D+00) go to 999 70 if ( ABSERR/ABS(RESULT) > (ERRSUM+DRL)/ABS(PSUM(NUMRL2))) & go to 80 if ( IER >= 1.AND.IER /= 7) ABSERR = ABSERR+DRL go to 999 80 RESULT = PSUM(NUMRL2) ABSERR = ERRSUM+DRL 999 RETURN end subroutine DQAWF (F, A, OMEGA, INTEGR, EPSABS, RESULT, ABSERR, & NEVAL, IER, LIMLST, LST, LENIW, MAXP1, LENW, IWORK, WORK) ! !! DQAWF approximates a given Fourier integral. ! ! The routine calculates an approximation result to a given ! Fourier integral I=Integral of F(X)*W(X) over (A,INFINITY) ! where W(X) = COS(OMEGA*X) or W(X) = SIN(OMEGA*X). ! Hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= EPSABS. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A3A1 !***TYPE DOUBLE PRECISION (QAWF-S, DQAWF-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CONVERGENCE ACCELERATION, ! FOURIER INTEGRALS, INTEGRATION BETWEEN ZEROS, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE INTEGRAL !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of Fourier integrals ! Standard fortran subroutine ! Double precision version ! ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! OMEGA - Double precision ! Parameter in the integrand WEIGHT function ! ! INTEGR - Integer ! Indicates which of the WEIGHT functions is used ! INTEGR = 1 W(X) = COS(OMEGA*X) ! INTEGR = 2 W(X) = SIN(OMEGA*X) ! if INTEGR /= 1.AND.INTEGR /= 2, the routine ! will end with IER = 6. ! ! EPSABS - Double precision ! Absolute accuracy requested, EPSABS > 0. ! If EPSABS <= 0, the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! Which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine. ! The estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! If OMEGA /= 0 ! IER = 1 Maximum number of cycles allowed ! has been achieved, i.e. of subintervals ! (A+(K-1)C,A+KC) where ! C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), ! FOR K = 1, 2, ..., LST. ! One can allow more cycles by increasing ! the value of LIMLST (and taking the ! according dimension adjustments into ! account). Examine the array IWORK which ! contains the error flags on the cycles, in ! order to look for eventual local ! integration difficulties. ! If the position of a local difficulty ! can be determined (e.g. singularity, ! discontinuity within the interval) one ! will probably gain from splitting up the ! interval at this point and calling ! appropriate integrators on the subranges. ! = 4 The extrapolation table constructed for ! convergence acceleration of the series ! formed by the integral contributions over ! the cycles, does not converge to within ! the requested accuracy. ! As in the case of IER = 1, it is advised ! to examine the array IWORK which contains ! the error flags on the cycles. ! = 6 The input is invalid because ! (INTEGR /= 1 AND INTEGR /= 2) or ! EPSABS <= 0 or LIMLST < 1 or ! LENIW < (LIMLST+2) or MAXP1 < 1 or ! LENW < (LENIW*2+MAXP1*25). ! RESULT, ABSERR, NEVAL, LST are set to ! zero. ! = 7 Bad integrand behaviour occurs within ! one or more of the cycles. Location and ! type of the difficulty involved can be ! determined from the first LST elements of ! vector IWORK. Here LST is the number of ! cycles actually needed (see below). ! IWORK(K) = 1 The maximum number of ! subdivisions (=(LENIW-LIMLST) ! /2) has been achieved on the ! K th cycle. ! = 2 Occurrence of roundoff error ! is detected and prevents the ! tolerance imposed on the K th ! cycle, from being achieved ! on this cycle. ! = 3 Extremely bad integrand ! behaviour occurs at some ! points of the K th cycle. ! = 4 The integration procedure ! over the K th cycle does ! not converge (to within the ! required accuracy) due to ! roundoff in the extrapolation ! procedure invoked on this ! cycle. It is assumed that the ! result on this interval is ! the best which can be ! obtained. ! = 5 The integral over the K th ! cycle is probably divergent ! or slowly convergent. It must ! be noted that divergence can ! occur with any other value of ! IWORK(K). ! If OMEGA = 0 and INTEGR = 1, ! The integral is calculated by means of DQAGIE, ! and IER = IWORK(1) (with meaning as described ! for IWORK(K),K = 1). ! ! DIMENSIONING PARAMETERS ! LIMLST - Integer ! LIMLST gives an upper bound on the number of ! cycles, LIMLST >= 3. ! If LIMLST < 3, the routine will end with IER = 6. ! ! LST - Integer ! On return, LST indicates the number of cycles ! actually needed for the integration. ! If OMEGA = 0, then LST is set to 1. ! ! LENIW - Integer ! Dimensioning parameter for IWORK. On entry, ! (LENIW-LIMLST)/2 equals the maximum number of ! subintervals allowed in the partition of each ! cycle, LENIW >= (LIMLST+2). ! If LENIW < (LIMLST+2), the routine will end with ! IER = 6. ! ! MAXP1 - Integer ! MAXP1 gives an upper bound on the number of ! Chebyshev moments which can be stored, i.e. for ! the intervals of lengths ABS(B-A)*2**(-L), ! L = 0,1, ..., MAXP1-2, MAXP1 >= 1. ! If MAXP1 < 1, the routine will end with IER = 6. ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LENIW*2+MAXP1*25. ! If LENW < (LENIW*2+MAXP1*25), the routine will ! end with IER = 6. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LENIW ! On return, IWORK(K) FOR K = 1, 2, ..., LST ! contain the error flags on the cycles. ! ! WORK - Double precision ! Vector of dimension at least ! On return, ! WORK(1), ..., WORK(LST) contain the integral ! approximations over the cycles, ! WORK(LIMLST+1), ..., WORK(LIMLST+LST) contain ! the error estimates over the cycles. ! further elements of WORK have no specific ! meaning for the user. ! !***REFERENCES (NONE) !***ROUTINES CALLED DQAWFE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DQAWF ! DOUBLE PRECISION A,ABSERR,EPSABS,F,OMEGA,RESULT,WORK INTEGER IER,INTEGR,IWORK,LENIW,LENW,LIMIT,LIMLST,LL2,LVL, & LST,L1,L2,L3,L4,L5,L6,MAXP1,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMLST, LENIW, MAXP1 AND LENW. ! !***FIRST EXECUTABLE STATEMENT DQAWF IER = 6 NEVAL = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 if ( LIMLST < 3.OR.LENIW < (LIMLST+2).OR.MAXP1 < 1.OR.LENW < & (LENIW*2+MAXP1*25)) go to 10 ! ! PREPARE call FOR DQAWFE ! LIMIT = (LENIW-LIMLST)/2 L1 = LIMLST+1 L2 = LIMLST+L1 L3 = LIMIT+L2 L4 = LIMIT+L3 L5 = LIMIT+L4 L6 = LIMIT+L5 LL2 = LIMIT+L1 call DQAWFE(F,A,OMEGA,INTEGR,EPSABS,LIMLST,LIMIT,MAXP1,RESULT, & ABSERR,NEVAL,IER,WORK(1),WORK(L1),IWORK(1),LST,WORK(L2), & WORK(L3),WORK(L4),WORK(L5),IWORK(L1),IWORK(LL2),WORK(L6)) ! ! call ERROR HANDLER if NECESSARY ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'DQAWF', & 'ABNORMAL RETURN', IER, LVL) return end subroutine DQAWOE (F, A, B, OMEGA, INTEGR, EPSABS, EPSREL, LIMIT, & ICALL, MAXP1, RESULT, ABSERR, NEVAL, IER, LAST, ALIST, BLIST, & RLIST, ELIST, IORD, NNLOG, MOMCOM, CHEBMO) ! !! DQAWOE approximates a Fourier integral over a finite interval. ! ! Calculate an approximation to a given definite integral ! I = Integral of F(X)*W(X) over (A,B), where ! W(X) = COS(OMEGA*X) ! or W(X)=SIN(OMEGA*X), ! hopefully satisfying the following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE DOUBLE PRECISION (QAWOE-S, DQAWOE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, ! EXTRAPOLATION, GLOBALLY ADAPTIVE, ! INTEGRAND WITH OSCILLATORY COS OR SIN FACTOR, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of Oscillatory integrals ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! OMEGA - Double precision ! Parameter in the integrand weight function ! ! INTEGR - Integer ! Indicates which of the WEIGHT functions is to be ! used ! INTEGR = 1 W(X) = COS(OMEGA*X) ! INTEGR = 2 W(X) = SIN(OMEGA*X) ! If INTEGR /= 1 and INTEGR /= 2, the routine ! will end with IER = 6. ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subdivisions ! in the partition of (A,B), LIMIT >= 1. ! ! ICALL - Integer ! If DQAWOE is to be used only once, ICALL must ! be set to 1. Assume that during this call, the ! Chebyshev moments (for CLENSHAW-CURTIS integration ! of degree 24) have been computed for intervals of ! lengths (ABS(B-A))*2**(-L), L=0,1,2,...MOMCOM-1. ! If ICALL > 1 this means that DQAWOE has been ! called twice or more on intervals of the same ! length ABS(B-A). The Chebyshev moments already ! computed are then re-used in subsequent calls. ! If ICALL < 1, the routine will end with IER = 6. ! ! MAXP1 - Integer ! Gives an upper bound on the number of Chebyshev ! moments which can be stored, i.e. for the ! intervals of lengths ABS(B-A)*2**(-L), ! L=0,1, ..., MAXP1-2, MAXP1 >= 1. ! If MAXP1 < 1, the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the ! requested accuracy has been achieved. ! - IER > 0 Abnormal termination of the routine. ! The estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand, in order to ! determine the integration difficulties. ! If the position of a local difficulty can ! be determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. If possible, ! an appropriate special-purpose integrator ! should be used which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. ! It is presumed that the requested ! tolerance cannot be achieved due to ! roundoff in the extrapolation table, ! and that the returned result is the ! best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER > 0. ! = 6 The input is invalid, because ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or (INTEGR /= 1 and INTEGR /= 2) or ! ICALL < 1 or MAXP1 < 1. ! RESULT, ABSERR, NEVAL, LAST, RLIST(1), ! ELIST(1), IORD(1) and NNLOG(1) are set ! to ZERO. ALIST(1) and BLIST(1) are set ! to A and B respectively. ! ! LAST - Integer ! On return, LAST equals the number of ! subintervals produces in the subdivision ! process, which determines the number of ! significant elements actually in the ! WORK ARRAYS. ! ALIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! BLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! RLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which are pointers to the error ! estimates over the subintervals, ! such that ELIST(IORD(1)), ..., ! ELIST(IORD(K)) form a decreasing sequence, with ! K = LAST if LAST <= (LIMIT/2+2), and ! K = LIMIT+1-LAST otherwise. ! ! NNLOG - Integer ! Vector of dimension at least LIMIT, containing the ! subdivision levels of the subintervals, i.e. ! IWORK(I) = L means that the subinterval ! numbered I is of length ABS(B-A)*2**(1-L) ! ! ON ENTRY AND RETURN ! MOMCOM - Integer ! Indicating that the Chebyshev moments ! have been computed for intervals of lengths ! (ABS(B-A))*2**(-L), L=0,1,2, ..., MOMCOM-1, ! MOMCOM < MAXP1 ! ! CHEBMO - Double precision ! Array of dimension (MAXP1,25) containing the ! Chebyshev moments ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DQC25F, DQELG, DQPSRT !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQAWOE ! DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, & A2,B,BLIST,B1,B2,CHEBMO,CORREC,DEFAB1,DEFAB2,DEFABS, & DOMEGA,D1MACH,DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST, & ERRBND,ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW, & OMEGA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW,WIDTH INTEGER ICALL,ID,IER,IERRO,INTEGR,IORD,IROFF1,IROFF2,IROFF3, & JUPBND,K,KSGN,KTMIN,LAST,LIMIT,MAXERR,MAXP1,MOMCOM,NEV,NEVAL, & NNLOG,NRES,NRMAX,NRMOM,NUMRL2 LOGICAL EXTRAP,NOEXT,EXTALL ! DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), & IORD(*),RLIST2(52),RES3LA(3),CHEBMO(MAXP1,25),NNLOG(*) ! EXTERNAL F ! ! THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF ! LIMEXP IN SUBROUTINE DQELG (RLIST2 SHOULD BE OF ! DIMENSION (LIMEXP+2) AT LEAST). ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 ! CONTAINING THE PART OF THE EPSILON TABLE ! WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ! ERROR ESTIMATE ! ERRMAX - ELIST(MAXERR) ! ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE ! NUMRL2 - NUMBER OF ELEMENTS IN RLIST2. if AN APPROPRIATE ! APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS ! BEEN OBTAINED IT IS PUT IN RLIST2(NUMRL2) AFTER ! NUMRL2 HAS BEEN INCREASED BY ONE ! SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED ! UP TO NOW, MULTIPLIED BY 1.5 ! ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER ! THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW ! EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE IS ! ATTEMPTING TO PERFORM EXTRAPOLATION, I.E. BEFORE ! SUBDIVIDING THE SMALLEST INTERVAL WE TRY TO ! DECREASE THE VALUE OF ERLARG ! NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION ! IS NO LONGER ALLOWED (TRUE VALUE) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQAWOE EPMACH = D1MACH(4) ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0D+00 ELIST(1) = 0.0D+00 IORD(1) = 0 NNLOG(1) = 0 if ( (INTEGR /= 1.AND.INTEGR /= 2).OR.(EPSABS <= 0.0D+00.AND. & EPSREL < MAX(0.5D+02*EPMACH,0.5D-28)).OR.ICALL < 1.OR. & MAXP1 < 1) IER = 6 if ( IER == 6) go to 999 ! ! FIRST APPROXIMATION TO THE INTEGRAL ! ----------------------------------- ! DOMEGA = ABS(OMEGA) NRMOM = 0 if (ICALL > 1) go to 5 MOMCOM = 0 5 call DQC25F(F,A,B,DOMEGA,INTEGR,NRMOM,MAXP1,0,RESULT,ABSERR, & NEVAL,DEFABS,RESABS,MOMCOM,CHEBMO) ! ! TEST ON ACCURACY. ! DRES = ABS(RESULT) ERRBND = MAX(EPSABS,EPSREL*DRES) RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 if ( ABSERR <= 0.1D+03*EPMACH*DEFABS.AND.ABSERR > ERRBND) IER = 2 if ( LIMIT == 1) IER = 1 if ( IER /= 0.OR.ABSERR <= ERRBND) go to 200 ! ! INITIALIZATIONS ! --------------- ! UFLOW = D1MACH(1) OFLOW = D1MACH(2) ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW NRMAX = 1 EXTRAP = .FALSE. NOEXT = .FALSE. IERRO = 0 IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KTMIN = 0 SMALL = ABS(B-A)*0.75D+00 NRES = 0 NUMRL2 = 0 EXTALL = .FALSE. if ( 0.5D+00*ABS(B-A)*DOMEGA > 0.2D+01) go to 10 NUMRL2 = 1 EXTALL = .TRUE. RLIST2(1) = RESULT 10 if ( 0.25D+00*ABS(B-A)*DOMEGA <= 0.2D+01) EXTALL = .TRUE. KSGN = -1 if ( DRES >= (0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1 ! ! MAIN DO-LOOP ! ------------ ! DO 140 LAST = 2,LIMIT ! ! BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ! ERROR ESTIMATE. ! NRMOM = NNLOG(MAXERR)+1 A1 = ALIST(MAXERR) B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX call DQC25F(F,A1,B1,DOMEGA,INTEGR,NRMOM,MAXP1,0, & AREA1,ERROR1,NEV,RESABS,DEFAB1,MOMCOM,CHEBMO) NEVAL = NEVAL+NEV call DQC25F(F,A2,B2,DOMEGA,INTEGR,NRMOM,MAXP1,1, & AREA2,ERROR2,NEV,RESABS,DEFAB2,MOMCOM,CHEBMO) NEVAL = NEVAL+NEV ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( DEFAB1 == ERROR1.OR.DEFAB2 == ERROR2) go to 25 if ( ABS(RLIST(MAXERR)-AREA12) > 0.1D-04*ABS(AREA12) & .OR.ERRO12 < 0.99D+00*ERRMAX) go to 20 if ( EXTRAP) IROFF2 = IROFF2+1 if ( .NOT.EXTRAP) IROFF1 = IROFF1+1 20 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF3 = IROFF3+1 25 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 NNLOG(MAXERR) = NRMOM NNLOG(LAST) = NRMOM ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. ! if ( IROFF1+IROFF2 >= 10.OR.IROFF3 >= 20) IER = 2 if ( IROFF2 >= 5) IERRO = 3 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF ! SUBINTERVALS EQUALS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT A POINT OF THE INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1D+01+0.1D+03*EPMACH) & *(ABS(A2)+0.1D+04*UFLOW)) IER = 4 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! if ( ERROR2 > ERROR1) go to 30 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 go to 40 30 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 ! ! call SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL ! WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BISECTED NEXT). ! 40 call DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if ( ERRSUM <= ERRBND) go to 170 if ( IER /= 0) go to 150 if ( LAST == 2.AND.EXTALL) go to 120 if ( NOEXT) go to 140 if ( .NOT.EXTALL) go to 50 ERLARG = ERLARG-ERLAST if ( ABS(B1-A1) > SMALL) ERLARG = ERLARG+ERRO12 if ( EXTRAP) go to 70 ! ! TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE ! SMALLEST INTERVAL. ! 50 WIDTH = ABS(BLIST(MAXERR)-ALIST(MAXERR)) if ( WIDTH > SMALL) go to 140 if ( EXTALL) go to 60 ! ! TEST WHETHER WE CAN START WITH THE EXTRAPOLATION PROCEDURE ! (WE DO THIS if WE INTEGRATE OVER THE NEXT INTERVAL WITH ! USE OF A GAUSS-KRONROD RULE - SEE SUBROUTINE DQC25F). ! SMALL = SMALL*0.5D+00 if ( 0.25D+00*WIDTH*DOMEGA > 0.2D+01) go to 140 EXTALL = .TRUE. go to 130 60 EXTRAP = .TRUE. NRMAX = 2 70 if ( IERRO == 3.OR.ERLARG <= ERTEST) go to 90 ! ! THE SMALLEST INTERVAL HAS THE LARGEST ERROR. ! BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER ! THE LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. ! JUPBND = LAST if (LAST > (LIMIT/2+2)) JUPBND = LIMIT+3-LAST ID = NRMAX DO 80 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) if ( ABS(BLIST(MAXERR)-ALIST(MAXERR)) > SMALL) go to 140 NRMAX = NRMAX+1 80 CONTINUE ! ! PERFORM EXTRAPOLATION. ! 90 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA if ( NUMRL2 < 3) go to 110 call DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) KTMIN = KTMIN+1 if ( KTMIN > 5.AND.ABSERR < 0.1D-02*ERRSUM) IER = 5 if ( ABSEPS >= ABSERR) go to 100 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) ! ***JUMP OUT OF DO-LOOP if ( ABSERR <= ERTEST) go to 150 ! ! PREPARE BISECTION OF THE SMALLEST INTERVAL. ! 100 if ( NUMRL2 == 1) NOEXT = .TRUE. if ( IER == 5) go to 150 110 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5D+00 ERLARG = ERRSUM go to 140 120 SMALL = SMALL*0.5D+00 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA 130 ERTEST = ERRBND ERLARG = ERRSUM 140 CONTINUE ! ! SET THE FINAL RESULT. ! --------------------- ! 150 if ( ABSERR == OFLOW.OR.NRES == 0) go to 170 if ( IER+IERRO == 0) go to 165 if ( IERRO == 3) ABSERR = ABSERR+CORREC if ( IER == 0) IER = 3 if ( RESULT /= 0.0D+00.AND.AREA /= 0.0D+00) go to 160 if ( ABSERR > ERRSUM) go to 170 if ( AREA == 0.0D+00) go to 190 go to 165 160 if ( ABSERR/ABS(RESULT) > ERRSUM/ABS(AREA)) go to 170 ! ! TEST ON DIVERGENCE. ! 165 if ( KSGN == (-1).AND.MAX(ABS(RESULT),ABS(AREA)) <= & DEFABS*0.1D-01) go to 190 if ( 0.1D-01 > (RESULT/AREA).OR.(RESULT/AREA) > 0.1D+03 & .OR.ERRSUM >= ABS(AREA)) IER = 6 go to 190 ! ! COMPUTE GLOBAL INTEGRAL SUM. ! 170 RESULT = 0.0D+00 DO 180 K=1,LAST RESULT = RESULT+RLIST(K) 180 CONTINUE ABSERR = ERRSUM 190 if (IER > 2) IER=IER-1 200 if (INTEGR == 2.AND.OMEGA < 0.0D+00) RESULT=-RESULT 999 RETURN end subroutine DQAWO (F, A, B, OMEGA, INTEGR, EPSABS, EPSREL, RESULT, & ABSERR, NEVAL, IER, LENIW, MAXP1, LENW, LAST, IWORK, WORK) ! !! DQAWO approximates a Fourier integral over a finite interval. ! ! Calculate an approximation to a given definite integral ! I= Integral of F(X)*W(X) over (A,B), where ! W(X) = COS(OMEGA*X) ! or W(X) = SIN(OMEGA*X), ! hopefully satisfying the following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE DOUBLE PRECISION (QAWO-S, DQAWO-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, ! EXTRAPOLATION, GLOBALLY ADAPTIVE, ! INTEGRAND WITH OSCILLATORY COS OR SIN FACTOR, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of oscillatory integrals ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the function ! F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! OMEGA - Double precision ! Parameter in the integrand weight function ! ! INTEGR - Integer ! Indicates which of the weight functions is used ! INTEGR = 1 W(X) = COS(OMEGA*X) ! INTEGR = 2 W(X) = SIN(OMEGA*X) ! If INTEGR /= 1.AND.INTEGR /= 2, the routine will ! end with IER = 6. ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! - IER > 0 Abnormal termination of the routine. ! The estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved (= LENIW/2). One can ! allow more subdivisions by increasing the ! value of LENIW (and taking the according ! dimension adjustments into account). ! However, if this yields no improvement it ! is advised to analyze the integrand in ! order to determine the integration ! difficulties. If the position of a local ! difficulty can be determined (e.g. ! SINGULARITY, DISCONTINUITY within the ! interval) one will probably gain from ! splitting up the interval at this point ! and calling the integrator on the ! subranges. If possible, an appropriate ! special-purpose integrator should be used ! which is designed for handling the type of ! difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! at some interior points of the ! integration interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. It is presumed that ! the requested tolerance cannot be achieved ! due to roundoff in the extrapolation ! table, and that the returned result is ! the best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER. ! = 6 The input is invalid, because ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or (INTEGR /= 1 AND INTEGR /= 2), ! or LENIW < 2 OR MAXP1 < 1 or ! LENW < LENIW*2+MAXP1*25. ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LENIW, MAXP1 or LENW are ! invalid, WORK(LIMIT*2+1), WORK(LIMIT*3+1), ! IWORK(1), IWORK(LIMIT+1) are set to zero, ! WORK(1) is set to A and WORK(LIMIT+1) to ! B. ! ! DIMENSIONING PARAMETERS ! LENIW - Integer ! Dimensioning parameter for IWORK. ! LENIW/2 equals the maximum number of subintervals ! allowed in the partition of the given integration ! interval (A,B), LENIW >= 2. ! If LENIW < 2, the routine will end with IER = 6. ! ! MAXP1 - Integer ! Gives an upper bound on the number of Chebyshev ! moments which can be stored, i.e. for the ! intervals of lengths ABS(B-A)*2**(-L), ! L=0,1, ..., MAXP1-2, MAXP1 >= 1 ! If MAXP1 < 1, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LENIW*2+MAXP1*25. ! If LENW < (LENIW*2+MAXP1*25), the routine will ! end with IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, which ! determines the number of significant elements ! actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LENIW ! on return, the first K elements of which contain ! pointers to the error estimates over the ! subintervals, such that WORK(LIMIT*3+IWORK(1)), .. ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence, with LIMIT = LENW/2 , and K = LAST ! if LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise. ! Furthermore, IWORK(LIMIT+1), ..., IWORK(LIMIT+ ! LAST) indicate the subdivision levels of the ! subintervals, such that IWORK(LIMIT+I) = L means ! that the subinterval numbered I is of length ! ABS(B-A)*2**(1-L). ! ! WORK - Double precision ! Vector of dimension at least LENW ! On return ! WORK(1), ..., WORK(LAST) contain the left ! end points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain ! the right end points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain ! the integral approximations over the ! subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) ! contain the error estimates. ! WORK(LIMIT*4+1), ..., WORK(LIMIT*4+MAXP1*25) ! Provide space for storing the Chebyshev moments. ! Note that LIMIT = LENW/2. ! !***REFERENCES (NONE) !***ROUTINES CALLED DQAWOE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DQAWO ! DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,OMEGA,RESULT,WORK INTEGER IER,INTEGR,IWORK,LAST,LIMIT,LENW,LENIW,LVL,L1,L2,L3,L4, & MAXP1,MOMCOM,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LENIW, MAXP1 AND LENW. ! !***FIRST EXECUTABLE STATEMENT DQAWO IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 if ( LENIW < 2.OR.MAXP1 < 1.OR.LENW < (LENIW*2+MAXP1*25)) & go to 10 ! ! PREPARE call FOR DQAWOE ! LIMIT = LENIW/2 L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 L4 = LIMIT+L3 call DQAWOE(F,A,B,OMEGA,INTEGR,EPSABS,EPSREL,LIMIT,1,MAXP1,RESULT, & ABSERR,NEVAL,IER,LAST,WORK(1),WORK(L1),WORK(L2),WORK(L3), & IWORK(1),IWORK(L1),MOMCOM,WORK(L4)) ! ! call ERROR HANDLER if NECESSARY ! LVL = 0 10 if ( IER == 6) LVL = 0 if (IER /= 0) call XERMSG ('SLATEC', 'DQAWO', & 'ABNORMAL RETURN', IER, LVL) return end subroutine DQAWSE (F, A, B, ALFA, BETA, INTEGR, EPSABS, EPSREL, & LIMIT, RESULT, ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, & IORD, LAST) ! !! DQAWSE approimates the integral F(X)*W(X); W(X) has endpoint singularities. ! !***PURPOSE The routine calculates an approximation result to a given ! definite integral I = Integral of F*W over (A,B), ! (where W shows a singular behaviour at the end points, ! see parameter INTEGR). ! Hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE DOUBLE PRECISION (QAWSE-S, DQAWSE-D) !***KEYWORDS ALGEBRAIC-LOGARITHMIC END POINT SINGULARITIES, ! AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration of functions having algebraico-logarithmic ! end point singularities ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration, B > A ! If B <= A, the routine will end with IER = 6. ! ! ALFA - Double precision ! Parameter in the WEIGHT function, ALFA > (-1) ! If ALFA <= (-1), the routine will end with ! IER = 6. ! ! BETA - Double precision ! Parameter in the WEIGHT function, BETA > (-1) ! If BETA <= (-1), the routine will end with ! IER = 6. ! ! INTEGR - Integer ! Indicates which WEIGHT function is to be used ! = 1 (X-A)**ALFA*(B-X)**BETA ! = 2 (X-A)**ALFA*(B-X)**BETA*LOG(X-A) ! = 3 (X-A)**ALFA*(B-X)**BETA*LOG(B-X) ! = 4 (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X) ! If INTEGR < 1 or INTEGR > 4, the routine ! will end with IER = 6. ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B), LIMIT >= 2 ! If LIMIT < 2, the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! the estimates for the integral and error ! are less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT. However, if this yields no ! improvement, it is advised to analyze the ! integrand in order to determine the ! integration difficulties which prevent the ! requested tolerance from being achieved. ! In case of a jump DISCONTINUITY or a local ! SINGULARITY of algebraico-logarithmic type ! at one or more interior points of the ! integration range, one should proceed by ! splitting up the interval at these ! points and calling the integrator on the ! subranges. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 6 The input is invalid, because ! B <= A or ALFA <= (-1) or BETA <= (-1), or ! INTEGR < 1 or INTEGR > 4, or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! or LIMIT < 2. ! RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1), ! IORD(1) and LAST are set to zero. ALIST(1) ! and BLIST(1) are set to A and B ! respectively. ! ! ALIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! BLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! RLIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Double precision ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! of which are pointers to the error ! estimates over the subintervals, so that ! ELIST(IORD(1)), ..., ELIST(IORD(K)) with K = LAST ! If LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise form a decreasing sequence ! ! LAST - Integer ! Number of subintervals actually produced in ! the subdivision process ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DQC25S, DQMOMO, DQPSRT !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQAWSE ! DOUBLE PRECISION A,ABSERR,ALFA,ALIST,AREA,AREA1,AREA12,AREA2,A1, & A2,B,BETA,BLIST,B1,B2,CENTRE,D1MACH,ELIST,EPMACH, & EPSABS,EPSREL,ERRBND,ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,F, & RESAS1,RESAS2,RESULT,RG,RH,RI,RJ,RLIST,UFLOW INTEGER IER,INTEGR,IORD,IROFF1,IROFF2,K,LAST,LIMIT,MAXERR,NEV, & NEVAL,NRMAX ! EXTERNAL F ! DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), & IORD(*),RI(25),RJ(25),RH(25),RG(25) ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ! ERROR ESTIMATE ! ERRMAX - ELIST(MAXERR) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQAWSE EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! IER = 6 NEVAL = 0 LAST = 0 RLIST(1) = 0.0D+00 ELIST(1) = 0.0D+00 IORD(1) = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 if (B <= A.OR.(EPSABS == 0.0D+00.AND. & EPSREL < MAX(0.5D+02*EPMACH,0.5D-28)).OR.ALFA <= (-0.1D+01) & .OR.BETA <= (-0.1D+01).OR.INTEGR < 1.OR.INTEGR > 4.OR. & LIMIT < 2) go to 999 IER = 0 ! ! COMPUTE THE MODIFIED CHEBYSHEV MOMENTS. ! call DQMOMO(ALFA,BETA,RI,RJ,RG,RH,INTEGR) ! ! INTEGRATE OVER THE INTERVALS (A,(A+B)/2) AND ((A+B)/2,B). ! CENTRE = 0.5D+00*(B+A) call DQC25S(F,A,B,A,CENTRE,ALFA,BETA,RI,RJ,RG,RH,AREA1, & ERROR1,RESAS1,INTEGR,NEV) NEVAL = NEV call DQC25S(F,A,B,CENTRE,B,ALFA,BETA,RI,RJ,RG,RH,AREA2, & ERROR2,RESAS2,INTEGR,NEV) LAST = 2 NEVAL = NEVAL+NEV RESULT = AREA1+AREA2 ABSERR = ERROR1+ERROR2 ! ! TEST ON ACCURACY. ! ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) ! ! INITIALIZATION ! -------------- ! if ( ERROR2 > ERROR1) go to 10 ALIST(1) = A ALIST(2) = CENTRE BLIST(1) = CENTRE BLIST(2) = B RLIST(1) = AREA1 RLIST(2) = AREA2 ELIST(1) = ERROR1 ELIST(2) = ERROR2 go to 20 10 ALIST(1) = CENTRE ALIST(2) = A BLIST(1) = B BLIST(2) = CENTRE RLIST(1) = AREA2 RLIST(2) = AREA1 ELIST(1) = ERROR2 ELIST(2) = ERROR1 20 IORD(1) = 1 IORD(2) = 2 if ( LIMIT == 2) IER = 1 if ( ABSERR <= ERRBND.OR.IER == 1) go to 999 ERRMAX = ELIST(1) MAXERR = 1 NRMAX = 1 AREA = RESULT ERRSUM = ABSERR IROFF1 = 0 IROFF2 = 0 ! ! MAIN DO-LOOP ! ------------ ! DO 60 LAST = 3,LIMIT ! ! BISECT THE SUBINTERVAL WITH LARGEST ERROR ESTIMATE. ! A1 = ALIST(MAXERR) B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ! call DQC25S(F,A,B,A1,B1,ALFA,BETA,RI,RJ,RG,RH,AREA1, & ERROR1,RESAS1,INTEGR,NEV) NEVAL = NEVAL+NEV call DQC25S(F,A,B,A2,B2,ALFA,BETA,RI,RJ,RG,RH,AREA2, & ERROR2,RESAS2,INTEGR,NEV) NEVAL = NEVAL+NEV ! ! IMPROVE PREVIOUS APPROXIMATIONS INTEGRAL AND ERROR ! AND TEST FOR ACCURACY. ! AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( A == A1.OR.B == B2) go to 30 if ( RESAS1 == ERROR1.OR.RESAS2 == ERROR2) go to 30 ! ! TEST FOR ROUNDOFF ERROR. ! if ( ABS(RLIST(MAXERR)-AREA12) < 0.1D-04*ABS(AREA12) & .AND.ERRO12 >= 0.99D+00*ERRMAX) IROFF1 = IROFF1+1 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF2 = IROFF2+1 30 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ! ! TEST ON ACCURACY. ! ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) if ( ERRSUM <= ERRBND) go to 35 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF INTERVAL ! BISECTIONS EXCEEDS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! ! SET ERROR FLAG IN THE CASE OF ROUNDOFF ERROR. ! if ( IROFF1 >= 6.OR.IROFF2 >= 20) IER = 2 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT INTERIOR POINTS OF INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1D+01+0.1D+03*EPMACH)* & (ABS(A2)+0.1D+04*UFLOW)) IER = 3 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! 35 if ( ERROR2 > ERROR1) go to 40 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 go to 50 40 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 ! ! call SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL ! WITH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). ! 50 call DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if (IER /= 0.OR.ERRSUM <= ERRBND) go to 70 60 CONTINUE ! ! COMPUTE FINAL RESULT. ! --------------------- ! 70 RESULT = 0.0D+00 DO 80 K=1,LAST RESULT = RESULT+RLIST(K) 80 CONTINUE ABSERR = ERRSUM 999 RETURN end subroutine DQAWS (F, A, B, ALFA, BETA, INTEGR, EPSABS, EPSREL, & RESULT, ABSERR, NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) ! !! DQAWS approximates the integral of F(X)*W(X); W has endpoint singularities. ! !***PURPOSE The routine calculates an approximation result to a given ! definite integral I = Integral of F*W over (A,B), ! (where W shows a singular behaviour at the end points ! see parameter INTEGR). ! Hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE DOUBLE PRECISION (QAWS-S, DQAWS-D) !***KEYWORDS ALGEBRAIC-LOGARITHMIC END POINT SINGULARITIES, ! AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, ! GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration of functions having algebraico-logarithmic ! end point singularities ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration, B > A ! If B <= A, the routine will end with IER = 6. ! ! ALFA - Double precision ! Parameter in the integrand function, ALFA > (-1) ! If ALFA <= (-1), the routine will end with ! IER = 6. ! ! BETA - Double precision ! Parameter in the integrand function, BETA > (-1) ! If BETA <= (-1), the routine will end with ! IER = 6. ! ! INTEGR - Integer ! Indicates which WEIGHT function is to be used ! = 1 (X-A)**ALFA*(B-X)**BETA ! = 2 (X-A)**ALFA*(B-X)**BETA*LOG(X-A) ! = 3 (X-A)**ALFA*(B-X)**BETA*LOG(B-X) ! = 4 (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X) ! If INTEGR < 1 or INTEGR > 4, the routine ! will end with IER = 6. ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! Which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! The estimates for the integral and error ! are less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand, in order to ! determine the integration difficulties ! which prevent the requested tolerance from ! being achieved. In case of a jump ! discontinuity or a local singularity ! of algebraico-logarithmic type at one or ! more interior points of the integration ! range, one should proceed by splitting up ! the interval at these points and calling ! the integrator on the subranges. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 6 The input is invalid, because ! B <= A or ALFA <= (-1) or BETA <= (-1) or ! or INTEGR < 1 or INTEGR > 4 or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or LIMIT < 2 or LENW < LIMIT*4. ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LENW or LIMIT is invalid ! IWORK(1), WORK(LIMIT*2+1) and ! WORK(LIMIT*3+1) are set to zero, WORK(1) ! is set to A and WORK(LIMIT+1) to B. ! ! DIMENSIONING PARAMETERS ! LIMIT - Integer ! Dimensioning parameter for IWORK ! LIMIT determines the maximum number of ! subintervals in the partition of the given ! integration interval (A,B), LIMIT >= 2. ! If LIMIT < 2, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LIMIT*4. ! If LENW < LIMIT*4, the routine will end ! with IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of ! subintervals produced in the subdivision process, ! which determines the significant number of ! elements actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension LIMIT, the first K ! elements of which contain pointers ! to the error estimates over the subintervals, ! such that WORK(LIMIT*3+IWORK(1)), ..., ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence with K = LAST if LAST <= (LIMIT/2+2), ! and K = LIMIT+1-LAST otherwise ! ! WORK - Double precision ! Vector of dimension LENW ! On return ! WORK(1), ..., WORK(LAST) contain the left ! end points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain ! the right end points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) ! contain the integral approximations over ! the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) ! contain the error estimates. ! !***REFERENCES (NONE) !***ROUTINES CALLED DQAWSE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DQAWS ! DOUBLE PRECISION A,ABSERR,ALFA,B,BETA,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,INTEGR,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMIT AND LENW. ! !***FIRST EXECUTABLE STATEMENT DQAWS IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0D+00 ABSERR = 0.0D+00 if ( LIMIT < 2.OR.LENW < LIMIT*4) go to 10 ! ! PREPARE call FOR DQAWSE. ! L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 ! call DQAWSE(F,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,LIMIT,RESULT, & ABSERR,NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'DQAWS', & 'ABNORMAL RETURN', IER, LVL) return end subroutine DQC25C (F, A, B, C, RESULT, ABSERR, KRUL, NEVAL) ! !! DQC25C computes I = Integral of F/(X-C) over (A,B) with error estimate. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A2, J4 !***TYPE DOUBLE PRECISION (QC25C-S, DQC25C-D) !***KEYWORDS 25-POINT CLENSHAW-CURTIS INTEGRATION, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules for the computation of CAUCHY ! PRINCIPAL VALUE integrals ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! F - Double precision ! Function subprogram defining the integrand function ! F(X). The actual name for F needs to be declared ! E X T E R N A L in the driver program. ! ! A - Double precision ! Left end point of the integration interval ! ! B - Double precision ! Right end point of the integration interval, B > A ! ! C - Double precision ! Parameter in the WEIGHT function ! ! RESULT - Double precision ! Approximation to the integral ! result is computed by using a generalized ! Clenshaw-Curtis method if C lies within ten percent ! of the integration interval. In the other case the ! 15-point Kronrod rule obtained by optimal addition ! of abscissae to the 7-point Gauss rule, is applied. ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! KRUL - Integer ! Key which is decreased by 1 if the 15-point ! Gauss-Kronrod scheme has been used ! ! NEVAL - Integer ! Number of integrand evaluations ! ! ...................................................................... ! !***REFERENCES (NONE) !***ROUTINES CALLED DQCHEB, DQK15W, DQWGTC !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQC25C ! DOUBLE PRECISION A,ABSERR,AK22,AMOM0,AMOM1,AMOM2,B,C,CC,CENTR, & CHEB12,CHEB24,DQWGTC,F,FVAL,HLGTH,P2,P3,P4,RESABS, & RESASC,RESULT,RES12,RES24,U,X INTEGER I,ISYM,K,KP,KRUL,NEVAL ! DIMENSION X(11),FVAL(25),CHEB12(13),CHEB24(25) ! EXTERNAL F, DQWGTC ! ! THE VECTOR X CONTAINS THE VALUES COS(K*PI/24), ! K = 1, ..., 11, TO BE USED FOR THE CHEBYSHEV SERIES ! EXPANSION OF F ! SAVE X DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10),X(11)/ & 0.9914448613738104D+00, 0.9659258262890683D+00, & 0.9238795325112868D+00, 0.8660254037844386D+00, & 0.7933533402912352D+00, 0.7071067811865475D+00, & 0.6087614290087206D+00, 0.5000000000000000D+00, & 0.3826834323650898D+00, 0.2588190451025208D+00, & 0.1305261922200516D+00/ ! ! LIST OF MAJOR VARIABLES ! ---------------------- ! FVAL - VALUE OF THE FUNCTION F AT THE POINTS ! COS(K*PI/24), K = 0, ..., 24 ! CHEB12 - CHEBYSHEV SERIES EXPANSION COEFFICIENTS, ! FOR THE FUNCTION F, OF DEGREE 12 ! CHEB24 - CHEBYSHEV SERIES EXPANSION COEFFICIENTS, ! FOR THE FUNCTION F, OF DEGREE 24 ! RES12 - APPROXIMATION TO THE INTEGRAL CORRESPONDING ! TO THE USE OF CHEB12 ! RES24 - APPROXIMATION TO THE INTEGRAL CORRESPONDING ! TO THE USE OF CHEB24 ! DQWGTC - EXTERNAL FUNCTION SUBPROGRAM DEFINING ! THE WEIGHT FUNCTION ! HLGTH - HALF-LENGTH OF THE INTERVAL ! CENTR - MID POINT OF THE INTERVAL ! ! ! CHECK THE POSITION OF C. ! !***FIRST EXECUTABLE STATEMENT DQC25C CC = (0.2D+01*C-B-A)/(B-A) if ( ABS(CC) < 0.11D+01) go to 10 ! ! APPLY THE 15-POINT GAUSS-KRONROD SCHEME. ! KRUL = KRUL-1 call DQK15W(F,DQWGTC,C,P2,P3,P4,KP,A,B,RESULT,ABSERR, & RESABS,RESASC) NEVAL = 15 if (RESASC == ABSERR) KRUL = KRUL+1 go to 50 ! ! USE THE GENERALIZED CLENSHAW-CURTIS METHOD. ! 10 HLGTH = 0.5D+00*(B-A) CENTR = 0.5D+00*(B+A) NEVAL = 25 FVAL(1) = 0.5D+00*F(HLGTH+CENTR) FVAL(13) = F(CENTR) FVAL(25) = 0.5D+00*F(CENTR-HLGTH) DO 20 I=2,12 U = HLGTH*X(I-1) ISYM = 26-I FVAL(I) = F(U+CENTR) FVAL(ISYM) = F(CENTR-U) 20 CONTINUE ! ! COMPUTE THE CHEBYSHEV SERIES EXPANSION. ! call DQCHEB(X,FVAL,CHEB12,CHEB24) ! ! THE MODIFIED CHEBYSHEV MOMENTS ARE COMPUTED BY FORWARD ! RECURSION, USING AMOM0 AND AMOM1 AS STARTING VALUES. ! AMOM0 = LOG(ABS((0.1D+01-CC)/(0.1D+01+CC))) AMOM1 = 0.2D+01+CC*AMOM0 RES12 = CHEB12(1)*AMOM0+CHEB12(2)*AMOM1 RES24 = CHEB24(1)*AMOM0+CHEB24(2)*AMOM1 DO 30 K=3,13 AMOM2 = 0.2D+01*CC*AMOM1-AMOM0 AK22 = (K-2)*(K-2) if ( (K/2)*2 == K) AMOM2 = AMOM2-0.4D+01/(AK22-0.1D+01) RES12 = RES12+CHEB12(K)*AMOM2 RES24 = RES24+CHEB24(K)*AMOM2 AMOM0 = AMOM1 AMOM1 = AMOM2 30 CONTINUE DO 40 K=14,25 AMOM2 = 0.2D+01*CC*AMOM1-AMOM0 AK22 = (K-2)*(K-2) if ( (K/2)*2 == K) AMOM2 = AMOM2-0.4D+01/(AK22-0.1D+01) RES24 = RES24+CHEB24(K)*AMOM2 AMOM0 = AMOM1 AMOM1 = AMOM2 40 CONTINUE RESULT = RES24 ABSERR = ABS(RES24-RES12) 50 RETURN end subroutine DQC25F (F, A, B, OMEGA, INTEGR, NRMOM, MAXP1, KSAVE, & RESULT, ABSERR, NEVAL, RESABS, RESASC, MOMCOM, CHEBMO) ! !! DQC25F integrates F(X)*SIN(OMEGA*X) or F(X)*COS(OMEGA*X). ! !***PURPOSE To compute the integral I=Integral of F(X) over (A,B) ! Where W(X) = COS(OMEGA*X) or W(X)=SIN(OMEGA*X) and to ! compute J = Integral of ABS(F) over (A,B). For small value ! of OMEGA or small intervals (A,B) the 15-point GAUSS-KRONRO ! Rule is used. Otherwise a generalized CLENSHAW-CURTIS ! method is used. !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A2 !***TYPE DOUBLE PRECISION (QC25F-S, DQC25F-D) !***KEYWORDS CLENSHAW-CURTIS METHOD, GAUSS-KRONROD RULES, ! INTEGRATION RULES FOR FUNCTIONS WITH COS OR SIN FACTOR, ! QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules for functions with COS or SIN factor ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to ! be declared E X T E R N A L in the calling program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! OMEGA - Double precision ! Parameter in the WEIGHT function ! ! INTEGR - Integer ! Indicates which WEIGHT function is to be used ! INTEGR = 1 W(X) = COS(OMEGA*X) ! INTEGR = 2 W(X) = SIN(OMEGA*X) ! ! NRMOM - Integer ! The length of interval (A,B) is equal to the length ! of the original integration interval divided by ! 2**NRMOM (we suppose that the routine is used in an ! adaptive integration process, otherwise set ! NRMOM = 0). NRMOM must be zero at the first call. ! ! MAXP1 - Integer ! Gives an upper bound on the number of Chebyshev ! moments which can be stored, i.e. for the ! intervals of lengths ABS(BB-AA)*2**(-L), ! L = 0,1,2, ..., MAXP1-2. ! ! KSAVE - Integer ! Key which is one when the moments for the ! current interval have been computed ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral I ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute ! error, which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! RESABS - Double precision ! Approximation to the integral J ! ! RESASC - Double precision ! Approximation to the integral of ABS(F-I/(B-A)) ! ! ON ENTRY AND RETURN ! MOMCOM - Integer ! For each interval length we need to compute the ! Chebyshev moments. MOMCOM counts the number of ! intervals for which these moments have already been ! computed. If NRMOM < MOMCOM or KSAVE = 1, the ! Chebyshev moments for the interval (A,B) have ! already been computed and stored, otherwise we ! compute them and we increase MOMCOM. ! ! CHEBMO - Double precision ! Array of dimension at least (MAXP1,25) containing ! the modified Chebyshev moments for the first MOMCOM ! MOMCOM interval lengths ! ! ...................................................................... ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DGTSL, DQCHEB, DQK15W, DQWGTF !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQC25F ! DOUBLE PRECISION A,ABSERR,AC,AN,AN2,AS,ASAP,ASS,B,CENTR,CHEBMO, & CHEB12,CHEB24,CONC,CONS,COSPAR,D,DQWGTF,D1, & D1MACH,D2,ESTC,ESTS,F,FVAL,HLGTH,OFLOW,OMEGA,PARINT,PAR2,PAR22, & P2,P3,P4,RESABS,RESASC,RESC12,RESC24,RESS12,RESS24,RESULT, & SINPAR,V,X INTEGER I,IERS,INTEGR,ISYM,J,K,KSAVE,M,MOMCOM,NEVAL,MAXP1, & NOEQU,NOEQ1,NRMOM ! DIMENSION CHEBMO(MAXP1,25),CHEB12(13),CHEB24(25),D(25),D1(25), & D2(25),FVAL(25),V(28),X(11) ! EXTERNAL F, DQWGTF ! ! THE VECTOR X CONTAINS THE VALUES COS(K*PI/24) ! K = 1, ...,11, TO BE USED FOR THE CHEBYSHEV EXPANSION OF F ! SAVE X DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10),X(11)/ & 0.9914448613738104D+00, 0.9659258262890683D+00, & 0.9238795325112868D+00, 0.8660254037844386D+00, & 0.7933533402912352D+00, 0.7071067811865475D+00, & 0.6087614290087206D+00, 0.5000000000000000D+00, & 0.3826834323650898D+00, 0.2588190451025208D+00, & 0.1305261922200516D+00/ ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTEGRATION INTERVAL ! HLGTH - HALF-LENGTH OF THE INTEGRATION INTERVAL ! FVAL - VALUE OF THE FUNCTION F AT THE POINTS ! (B-A)*0.5*COS(K*PI/12) + (B+A)*0.5, K = 0, ..., 24 ! CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION ! OF DEGREE 12, FOR THE FUNCTION F, IN THE ! INTERVAL (A,B) ! CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION ! OF DEGREE 24, FOR THE FUNCTION F, IN THE ! INTERVAL (A,B) ! RESC12 - APPROXIMATION TO THE INTEGRAL OF ! COS(0.5*(B-A)*OMEGA*X)*F(0.5*(B-A)*X+0.5*(B+A)) ! OVER (-1,+1), USING THE CHEBYSHEV SERIES ! EXPANSION OF DEGREE 12 ! RESC24 - APPROXIMATION TO THE SAME INTEGRAL, USING THE ! CHEBYSHEV SERIES EXPANSION OF DEGREE 24 ! RESS12 - THE ANALOGUE OF RESC12 FOR THE SINE ! RESS24 - THE ANALOGUE OF RESC24 FOR THE SINE ! ! ! MACHINE DEPENDENT CONSTANT ! -------------------------- ! ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQC25F OFLOW = D1MACH(2) ! CENTR = 0.5D+00*(B+A) HLGTH = 0.5D+00*(B-A) PARINT = OMEGA*HLGTH ! ! COMPUTE THE INTEGRAL USING THE 15-POINT GAUSS-KRONROD ! FORMULA if THE VALUE OF THE PARAMETER IN THE INTEGRAND ! IS SMALL. ! if ( ABS(PARINT) > 0.2D+01) go to 10 call DQK15W(F,DQWGTF,OMEGA,P2,P3,P4,INTEGR,A,B,RESULT, & ABSERR,RESABS,RESASC) NEVAL = 15 go to 170 ! ! COMPUTE THE INTEGRAL USING THE GENERALIZED CLENSHAW- ! CURTIS METHOD. ! 10 CONC = HLGTH*COS(CENTR*OMEGA) CONS = HLGTH*SIN(CENTR*OMEGA) RESASC = OFLOW NEVAL = 25 ! ! CHECK WHETHER THE CHEBYSHEV MOMENTS FOR THIS INTERVAL ! HAVE ALREADY BEEN COMPUTED. ! if ( NRMOM < MOMCOM.OR.KSAVE == 1) go to 120 ! ! COMPUTE A NEW SET OF CHEBYSHEV MOMENTS. ! M = MOMCOM+1 PAR2 = PARINT*PARINT PAR22 = PAR2+0.2D+01 SINPAR = SIN(PARINT) COSPAR = COS(PARINT) ! ! COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO COSINE. ! V(1) = 0.2D+01*SINPAR/PARINT V(2) = (0.8D+01*COSPAR+(PAR2+PAR2-0.8D+01)*SINPAR/PARINT)/PAR2 V(3) = (0.32D+02*(PAR2-0.12D+02)*COSPAR+(0.2D+01* & ((PAR2-0.80D+02)*PAR2+0.192D+03)*SINPAR)/PARINT)/(PAR2*PAR2) AC = 0.8D+01*COSPAR AS = 0.24D+02*PARINT*SINPAR if ( ABS(PARINT) > 0.24D+02) go to 30 ! ! COMPUTE THE CHEBYSHEV MOMENTS AS THE SOLUTIONS OF A ! BOUNDARY VALUE PROBLEM WITH 1 INITIAL VALUE (V(3)) AND 1 ! END VALUE (COMPUTED USING AN ASYMPTOTIC FORMULA). ! NOEQU = 25 NOEQ1 = NOEQU-1 AN = 0.6D+01 DO 20 K = 1,NOEQ1 AN2 = AN*AN D(K) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2) D2(K) = (AN-0.1D+01)*(AN-0.2D+01)*PAR2 D1(K+1) = (AN+0.3D+01)*(AN+0.4D+01)*PAR2 V(K+3) = AS-(AN2-0.4D+01)*AC AN = AN+0.2D+01 20 CONTINUE AN2 = AN*AN D(NOEQU) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2) V(NOEQU+3) = AS-(AN2-0.4D+01)*AC V(4) = V(4)-0.56D+02*PAR2*V(3) ASS = PARINT*SINPAR ASAP = (((((0.210D+03*PAR2-0.1D+01)*COSPAR-(0.105D+03*PAR2 & -0.63D+02)*ASS)/AN2-(0.1D+01-0.15D+02*PAR2)*COSPAR & +0.15D+02*ASS)/AN2-COSPAR+0.3D+01*ASS)/AN2-COSPAR)/AN2 V(NOEQU+3) = V(NOEQU+3)-0.2D+01*ASAP*PAR2*(AN-0.1D+01)* & (AN-0.2D+01) ! ! SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN ! ELIMINATION WITH PARTIAL PIVOTING. ! ! *** call TO DGTSL MUST BE REPLACED BY CALL TO ! *** DOUBLE PRECISION VERSION OF LINPACK ROUTINE SGTSL ! call DGTSL(NOEQU,D1,D,D2,V(4),IERS) go to 50 ! ! COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF FORWARD ! RECURSION. ! 30 AN = 0.4D+01 DO 40 I = 4,13 AN2 = AN*AN V(I) = ((AN2-0.4D+01)*(0.2D+01*(PAR22-AN2-AN2)*V(I-1)-AC) & +AS-PAR2*(AN+0.1D+01)*(AN+0.2D+01)*V(I-2))/ & (PAR2*(AN-0.1D+01)*(AN-0.2D+01)) AN = AN+0.2D+01 40 CONTINUE 50 DO 60 J = 1,13 CHEBMO(M,2*J-1) = V(J) 60 CONTINUE ! ! COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO SINE. ! V(1) = 0.2D+01*(SINPAR-PARINT*COSPAR)/PAR2 V(2) = (0.18D+02-0.48D+02/PAR2)*SINPAR/PAR2 & +(-0.2D+01+0.48D+02/PAR2)*COSPAR/PARINT AC = -0.24D+02*PARINT*COSPAR AS = -0.8D+01*SINPAR if ( ABS(PARINT) > 0.24D+02) go to 80 ! ! COMPUTE THE CHEBYSHEV MOMENTS AS THE SOLUTIONS OF A BOUNDARY ! VALUE PROBLEM WITH 1 INITIAL VALUE (V(2)) AND 1 END VALUE ! (COMPUTED USING AN ASYMPTOTIC FORMULA). ! AN = 0.5D+01 DO 70 K = 1,NOEQ1 AN2 = AN*AN D(K) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2) D2(K) = (AN-0.1D+01)*(AN-0.2D+01)*PAR2 D1(K+1) = (AN+0.3D+01)*(AN+0.4D+01)*PAR2 V(K+2) = AC+(AN2-0.4D+01)*AS AN = AN+0.2D+01 70 CONTINUE AN2 = AN*AN D(NOEQU) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2) V(NOEQU+2) = AC+(AN2-0.4D+01)*AS V(3) = V(3)-0.42D+02*PAR2*V(2) ASS = PARINT*COSPAR ASAP = (((((0.105D+03*PAR2-0.63D+02)*ASS+(0.210D+03*PAR2 & -0.1D+01)*SINPAR)/AN2+(0.15D+02*PAR2-0.1D+01)*SINPAR- & 0.15D+02*ASS)/AN2-0.3D+01*ASS-SINPAR)/AN2-SINPAR)/AN2 V(NOEQU+2) = V(NOEQU+2)-0.2D+01*ASAP*PAR2*(AN-0.1D+01) & *(AN-0.2D+01) ! ! SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN ! ELIMINATION WITH PARTIAL PIVOTING. ! ! *** call TO DGTSL MUST BE REPLACED BY CALL TO ! *** DOUBLE PRECISION VERSION OF LINPACK ROUTINE SGTSL ! call DGTSL(NOEQU,D1,D,D2,V(3),IERS) go to 100 ! ! COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF FORWARD RECURSION. ! 80 AN = 0.3D+01 DO 90 I = 3,12 AN2 = AN*AN V(I) = ((AN2-0.4D+01)*(0.2D+01*(PAR22-AN2-AN2)*V(I-1)+AS) & +AC-PAR2*(AN+0.1D+01)*(AN+0.2D+01)*V(I-2)) & /(PAR2*(AN-0.1D+01)*(AN-0.2D+01)) AN = AN+0.2D+01 90 CONTINUE 100 DO 110 J = 1,12 CHEBMO(M,2*J) = V(J) 110 CONTINUE 120 if (NRMOM < MOMCOM) M = NRMOM+1 if (MOMCOM < (MAXP1-1).AND.NRMOM >= MOMCOM) MOMCOM = MOMCOM+1 ! ! COMPUTE THE COEFFICIENTS OF THE CHEBYSHEV EXPANSIONS ! OF DEGREES 12 AND 24 OF THE FUNCTION F. ! FVAL(1) = 0.5D+00*F(CENTR+HLGTH) FVAL(13) = F(CENTR) FVAL(25) = 0.5D+00*F(CENTR-HLGTH) DO 130 I = 2,12 ISYM = 26-I FVAL(I) = F(HLGTH*X(I-1)+CENTR) FVAL(ISYM) = F(CENTR-HLGTH*X(I-1)) 130 CONTINUE call DQCHEB(X,FVAL,CHEB12,CHEB24) ! ! COMPUTE THE INTEGRAL AND ERROR ESTIMATES. ! RESC12 = CHEB12(13)*CHEBMO(M,13) RESS12 = 0.0D+00 K = 11 DO 140 J = 1,6 RESC12 = RESC12+CHEB12(K)*CHEBMO(M,K) RESS12 = RESS12+CHEB12(K+1)*CHEBMO(M,K+1) K = K-2 140 CONTINUE RESC24 = CHEB24(25)*CHEBMO(M,25) RESS24 = 0.0D+00 RESABS = ABS(CHEB24(25)) K = 23 DO 150 J = 1,12 RESC24 = RESC24+CHEB24(K)*CHEBMO(M,K) RESS24 = RESS24+CHEB24(K+1)*CHEBMO(M,K+1) RESABS = ABS(CHEB24(K))+ABS(CHEB24(K+1)) K = K-2 150 CONTINUE ESTC = ABS(RESC24-RESC12) ESTS = ABS(RESS24-RESS12) RESABS = RESABS*ABS(HLGTH) if ( INTEGR == 2) go to 160 RESULT = CONC*RESC24-CONS*RESS24 ABSERR = ABS(CONC*ESTC)+ABS(CONS*ESTS) go to 170 160 RESULT = CONC*RESS24+CONS*RESC24 ABSERR = ABS(CONC*ESTS)+ABS(CONS*ESTC) 170 RETURN end subroutine DQC25S (F, A, B, BL, BR, ALFA, BETA, RI, RJ, RG, RH, & RESULT, ABSERR, RESASC, INTEGR, NEV) ! !! DQC25S estimates integral F(X)*W(X) for algebraic or logarithmic singularity. ! !***PURPOSE To compute I = Integral of F*W over (BL,BR), with error ! estimate, where the weight function W has a singular ! behaviour of ALGEBRAICO-LOGARITHMIC type at the points ! A and/or B. (BL,BR) is a part of (A,B). !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A2 !***TYPE DOUBLE PRECISION (QC25S-S, DQC25S-D) !***KEYWORDS 25-POINT CLENSHAW-CURTIS INTEGRATION, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules for integrands having ALGEBRAICO-LOGARITHMIC ! end point singularities ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! F - Double precision ! Function subprogram defining the integrand ! F(X). The actual name for F needs to be declared ! E X T E R N A L in the driver program. ! ! A - Double precision ! Left end point of the original interval ! ! B - Double precision ! Right end point of the original interval, B > A ! ! BL - Double precision ! Lower limit of integration, BL >= A ! ! BR - Double precision ! Upper limit of integration, BR <= B ! ! ALFA - Double precision ! PARAMETER IN THE WEIGHT FUNCTION ! ! BETA - Double precision ! Parameter in the weight function ! ! RI,RJ,RG,RH - Double precision ! Modified CHEBYSHEV moments for the application ! of the generalized CLENSHAW-CURTIS ! method (computed in subroutine DQMOMO) ! ! RESULT - Double precision ! Approximation to the integral ! RESULT is computed by using a generalized ! CLENSHAW-CURTIS method if B1 = A or BR = B. ! in all other cases the 15-POINT KRONROD ! RULE is applied, obtained by optimal addition of ! Abscissae to the 7-POINT GAUSS RULE. ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! RESASC - Double precision ! Approximation to the integral of ABS(F*W-I/(B-A)) ! ! INTEGR - Integer ! Which determines the weight function ! = 1 W(X) = (X-A)**ALFA*(B-X)**BETA ! = 2 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A) ! = 3 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(B-X) ! = 4 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A)* ! LOG(B-X) ! ! NEV - Integer ! Number of integrand evaluations ! !***REFERENCES (NONE) !***ROUTINES CALLED DQCHEB, DQK15W, DQWGTS !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQC25S ! DOUBLE PRECISION A,ABSERR,ALFA,B,BETA,BL,BR,CENTR,CHEB12,CHEB24, & DC,F,FACTOR,FIX,FVAL,HLGTH,RESABS,RESASC,RESULT,RES12, & RES24,RG,RH,RI,RJ,U,DQWGTS,X INTEGER I,INTEGR,ISYM,NEV ! DIMENSION CHEB12(13),CHEB24(25),FVAL(25),RG(25),RH(25),RI(25), & RJ(25),X(11) ! EXTERNAL F, DQWGTS ! ! THE VECTOR X CONTAINS THE VALUES COS(K*PI/24) ! K = 1, ..., 11, TO BE USED FOR THE COMPUTATION OF THE ! CHEBYSHEV SERIES EXPANSION OF F. ! SAVE X DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10),X(11)/ & 0.9914448613738104D+00, 0.9659258262890683D+00, & 0.9238795325112868D+00, 0.8660254037844386D+00, & 0.7933533402912352D+00, 0.7071067811865475D+00, & 0.6087614290087206D+00, 0.5000000000000000D+00, & 0.3826834323650898D+00, 0.2588190451025208D+00, & 0.1305261922200516D+00/ ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! FVAL - VALUE OF THE FUNCTION F AT THE POINTS ! (BR-BL)*0.5*COS(K*PI/24)+(BR+BL)*0.5 ! K = 0, ..., 24 ! CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION ! OF DEGREE 12, FOR THE FUNCTION F, IN THE ! INTERVAL (BL,BR) ! CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION ! OF DEGREE 24, FOR THE FUNCTION F, IN THE ! INTERVAL (BL,BR) ! RES12 - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB12 ! RES24 - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB24 ! DQWGTS - EXTERNAL FUNCTION SUBPROGRAM DEFINING ! THE FOUR POSSIBLE WEIGHT FUNCTIONS ! HLGTH - HALF-LENGTH OF THE INTERVAL (BL,BR) ! CENTR - MID POINT OF THE INTERVAL (BL,BR) ! !***FIRST EXECUTABLE STATEMENT DQC25S NEV = 25 if ( BL == A.AND.(ALFA /= 0.0D+00.OR.INTEGR == 2.OR.INTEGR == 4)) & go to 10 if ( BR == B.AND.(BETA /= 0.0D+00.OR.INTEGR == 3.OR.INTEGR == 4)) & go to 140 ! ! if A > BL AND B < BR, APPLY THE 15-POINT GAUSS-KRONROD ! SCHEME. ! ! call DQK15W(F,DQWGTS,A,B,ALFA,BETA,INTEGR,BL,BR, & RESULT,ABSERR,RESABS,RESASC) NEV = 15 go to 270 ! ! THIS PART OF THE PROGRAM IS EXECUTED ONLY if A = BL. ! ---------------------------------------------------- ! ! COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE ! FOLLOWING FUNCTION ! F1 = (0.5*(B+B-BR-A)-0.5*(BR-A)*X)**BETA ! *F(0.5*(BR-A)*X+0.5*(BR+A)) ! 10 HLGTH = 0.5D+00*(BR-BL) CENTR = 0.5D+00*(BR+BL) FIX = B-CENTR FVAL(1) = 0.5D+00*F(HLGTH+CENTR)*(FIX-HLGTH)**BETA FVAL(13) = F(CENTR)*(FIX**BETA) FVAL(25) = 0.5D+00*F(CENTR-HLGTH)*(FIX+HLGTH)**BETA DO 20 I=2,12 U = HLGTH*X(I-1) ISYM = 26-I FVAL(I) = F(U+CENTR)*(FIX-U)**BETA FVAL(ISYM) = F(CENTR-U)*(FIX+U)**BETA 20 CONTINUE FACTOR = HLGTH**(ALFA+0.1D+01) RESULT = 0.0D+00 ABSERR = 0.0D+00 RES12 = 0.0D+00 RES24 = 0.0D+00 if ( INTEGR > 2) go to 70 call DQCHEB(X,FVAL,CHEB12,CHEB24) ! ! INTEGR = 1 (OR 2) ! DO 30 I=1,13 RES12 = RES12+CHEB12(I)*RI(I) RES24 = RES24+CHEB24(I)*RI(I) 30 CONTINUE DO 40 I=14,25 RES24 = RES24+CHEB24(I)*RI(I) 40 CONTINUE if ( INTEGR == 1) go to 130 ! ! INTEGR = 2 ! DC = LOG(BR-BL) RESULT = RES24*DC ABSERR = ABS((RES24-RES12)*DC) RES12 = 0.0D+00 RES24 = 0.0D+00 DO 50 I=1,13 RES12 = RES12+CHEB12(I)*RG(I) RES24 = RES12+CHEB24(I)*RG(I) 50 CONTINUE DO 60 I=14,25 RES24 = RES24+CHEB24(I)*RG(I) 60 CONTINUE go to 130 ! ! COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE ! FOLLOWING FUNCTION ! F4 = F1*LOG(0.5*(B+B-BR-A)-0.5*(BR-A)*X) ! 70 FVAL(1) = FVAL(1)*LOG(FIX-HLGTH) FVAL(13) = FVAL(13)*LOG(FIX) FVAL(25) = FVAL(25)*LOG(FIX+HLGTH) DO 80 I=2,12 U = HLGTH*X(I-1) ISYM = 26-I FVAL(I) = FVAL(I)*LOG(FIX-U) FVAL(ISYM) = FVAL(ISYM)*LOG(FIX+U) 80 CONTINUE call DQCHEB(X,FVAL,CHEB12,CHEB24) ! ! INTEGR = 3 (OR 4) ! DO 90 I=1,13 RES12 = RES12+CHEB12(I)*RI(I) RES24 = RES24+CHEB24(I)*RI(I) 90 CONTINUE DO 100 I=14,25 RES24 = RES24+CHEB24(I)*RI(I) 100 CONTINUE if ( INTEGR == 3) go to 130 ! ! INTEGR = 4 ! DC = LOG(BR-BL) RESULT = RES24*DC ABSERR = ABS((RES24-RES12)*DC) RES12 = 0.0D+00 RES24 = 0.0D+00 DO 110 I=1,13 RES12 = RES12+CHEB12(I)*RG(I) RES24 = RES24+CHEB24(I)*RG(I) 110 CONTINUE DO 120 I=14,25 RES24 = RES24+CHEB24(I)*RG(I) 120 CONTINUE 130 RESULT = (RESULT+RES24)*FACTOR ABSERR = (ABSERR+ABS(RES24-RES12))*FACTOR go to 270 ! ! THIS PART OF THE PROGRAM IS EXECUTED ONLY if B = BR. ! ---------------------------------------------------- ! ! COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE ! FOLLOWING FUNCTION ! F2 = (0.5*(B+BL-A-A)+0.5*(B-BL)*X)**ALFA ! *F(0.5*(B-BL)*X+0.5*(B+BL)) ! 140 HLGTH = 0.5D+00*(BR-BL) CENTR = 0.5D+00*(BR+BL) FIX = CENTR-A FVAL(1) = 0.5D+00*F(HLGTH+CENTR)*(FIX+HLGTH)**ALFA FVAL(13) = F(CENTR)*(FIX**ALFA) FVAL(25) = 0.5D+00*F(CENTR-HLGTH)*(FIX-HLGTH)**ALFA DO 150 I=2,12 U = HLGTH*X(I-1) ISYM = 26-I FVAL(I) = F(U+CENTR)*(FIX+U)**ALFA FVAL(ISYM) = F(CENTR-U)*(FIX-U)**ALFA 150 CONTINUE FACTOR = HLGTH**(BETA+0.1D+01) RESULT = 0.0D+00 ABSERR = 0.0D+00 RES12 = 0.0D+00 RES24 = 0.0D+00 if ( INTEGR == 2.OR.INTEGR == 4) go to 200 ! ! INTEGR = 1 (OR 3) ! call DQCHEB(X,FVAL,CHEB12,CHEB24) DO 160 I=1,13 RES12 = RES12+CHEB12(I)*RJ(I) RES24 = RES24+CHEB24(I)*RJ(I) 160 CONTINUE DO 170 I=14,25 RES24 = RES24+CHEB24(I)*RJ(I) 170 CONTINUE if ( INTEGR == 1) go to 260 ! ! INTEGR = 3 ! DC = LOG(BR-BL) RESULT = RES24*DC ABSERR = ABS((RES24-RES12)*DC) RES12 = 0.0D+00 RES24 = 0.0D+00 DO 180 I=1,13 RES12 = RES12+CHEB12(I)*RH(I) RES24 = RES24+CHEB24(I)*RH(I) 180 CONTINUE DO 190 I=14,25 RES24 = RES24+CHEB24(I)*RH(I) 190 CONTINUE go to 260 ! ! COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE ! FOLLOWING FUNCTION ! F3 = F2*LOG(0.5*(B-BL)*X+0.5*(B+BL-A-A)) ! 200 FVAL(1) = FVAL(1)*LOG(FIX+HLGTH) FVAL(13) = FVAL(13)*LOG(FIX) FVAL(25) = FVAL(25)*LOG(FIX-HLGTH) DO 210 I=2,12 U = HLGTH*X(I-1) ISYM = 26-I FVAL(I) = FVAL(I)*LOG(U+FIX) FVAL(ISYM) = FVAL(ISYM)*LOG(FIX-U) 210 CONTINUE call DQCHEB(X,FVAL,CHEB12,CHEB24) ! ! INTEGR = 2 (OR 4) ! DO 220 I=1,13 RES12 = RES12+CHEB12(I)*RJ(I) RES24 = RES24+CHEB24(I)*RJ(I) 220 CONTINUE DO 230 I=14,25 RES24 = RES24+CHEB24(I)*RJ(I) 230 CONTINUE if ( INTEGR == 2) go to 260 DC = LOG(BR-BL) RESULT = RES24*DC ABSERR = ABS((RES24-RES12)*DC) RES12 = 0.0D+00 RES24 = 0.0D+00 ! ! INTEGR = 4 ! DO 240 I=1,13 RES12 = RES12+CHEB12(I)*RH(I) RES24 = RES24+CHEB24(I)*RH(I) 240 CONTINUE DO 250 I=14,25 RES24 = RES24+CHEB24(I)*RH(I) 250 CONTINUE 260 RESULT = (RESULT+RES24)*FACTOR ABSERR = (ABSERR+ABS(RES24-RES12))*FACTOR 270 RETURN end subroutine DQCHEB (X, FVAL, CHEB12, CHEB24) ! !! DQCHEB computes Chebyshev series expansions of a function. ! !***SUBSIDIARY !***PURPOSE This routine computes the CHEBYSHEV series expansion ! of degrees 12 and 24 of a function using A ! FAST FOURIER TRANSFORM METHOD ! F(X) = SUM(K=1,..,13) (CHEB12(K)*T(K-1,X)), ! F(X) = SUM(K=1,..,25) (CHEB24(K)*T(K-1,X)), ! Where T(K,X) is the CHEBYSHEV POLYNOMIAL OF DEGREE K. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QCHEB-S, DQCHEB-D) !***KEYWORDS CHEBYSHEV SERIES EXPANSION, FAST FOURIER TRANSFORM !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Chebyshev Series Expansion ! Standard Fortran Subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! X - Double precision ! Vector of dimension 11 containing the ! Values COS(K*PI/24), K = 1, ..., 11 ! ! FVAL - Double precision ! Vector of dimension 25 containing the ! function values at the points ! (B+A+(B-A)*COS(K*PI/24))/2, K = 0, ...,24, ! where (A,B) is the approximation interval. ! FVAL(1) and FVAL(25) are divided by two ! (these values are destroyed at output). ! ! ON RETURN ! CHEB12 - Double precision ! Vector of dimension 13 containing the ! CHEBYSHEV coefficients for degree 12 ! ! CHEB24 - Double precision ! Vector of dimension 25 containing the ! CHEBYSHEV Coefficients for degree 24 ! !***SEE ALSO DQC25C, DQC25F, DQC25S !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 830518 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DQCHEB ! DOUBLE PRECISION ALAM,ALAM1,ALAM2,CHEB12,CHEB24,FVAL,PART1,PART2, & PART3,V,X INTEGER I,J ! DIMENSION CHEB12(13),CHEB24(25),FVAL(25),V(12),X(11) ! !***FIRST EXECUTABLE STATEMENT DQCHEB DO 10 I=1,12 J = 26-I V(I) = FVAL(I)-FVAL(J) FVAL(I) = FVAL(I)+FVAL(J) 10 CONTINUE ALAM1 = V(1)-V(9) ALAM2 = X(6)*(V(3)-V(7)-V(11)) CHEB12(4) = ALAM1+ALAM2 CHEB12(10) = ALAM1-ALAM2 ALAM1 = V(2)-V(8)-V(10) ALAM2 = V(4)-V(6)-V(12) ALAM = X(3)*ALAM1+X(9)*ALAM2 CHEB24(4) = CHEB12(4)+ALAM CHEB24(22) = CHEB12(4)-ALAM ALAM = X(9)*ALAM1-X(3)*ALAM2 CHEB24(10) = CHEB12(10)+ALAM CHEB24(16) = CHEB12(10)-ALAM PART1 = X(4)*V(5) PART2 = X(8)*V(9) PART3 = X(6)*V(7) ALAM1 = V(1)+PART1+PART2 ALAM2 = X(2)*V(3)+PART3+X(10)*V(11) CHEB12(2) = ALAM1+ALAM2 CHEB12(12) = ALAM1-ALAM2 ALAM = X(1)*V(2)+X(3)*V(4)+X(5)*V(6)+X(7)*V(8) & +X(9)*V(10)+X(11)*V(12) CHEB24(2) = CHEB12(2)+ALAM CHEB24(24) = CHEB12(2)-ALAM ALAM = X(11)*V(2)-X(9)*V(4)+X(7)*V(6)-X(5)*V(8) & +X(3)*V(10)-X(1)*V(12) CHEB24(12) = CHEB12(12)+ALAM CHEB24(14) = CHEB12(12)-ALAM ALAM1 = V(1)-PART1+PART2 ALAM2 = X(10)*V(3)-PART3+X(2)*V(11) CHEB12(6) = ALAM1+ALAM2 CHEB12(8) = ALAM1-ALAM2 ALAM = X(5)*V(2)-X(9)*V(4)-X(1)*V(6) & -X(11)*V(8)+X(3)*V(10)+X(7)*V(12) CHEB24(6) = CHEB12(6)+ALAM CHEB24(20) = CHEB12(6)-ALAM ALAM = X(7)*V(2)-X(3)*V(4)-X(11)*V(6)+X(1)*V(8) & -X(9)*V(10)-X(5)*V(12) CHEB24(8) = CHEB12(8)+ALAM CHEB24(18) = CHEB12(8)-ALAM DO 20 I=1,6 J = 14-I V(I) = FVAL(I)-FVAL(J) FVAL(I) = FVAL(I)+FVAL(J) 20 CONTINUE ALAM1 = V(1)+X(8)*V(5) ALAM2 = X(4)*V(3) CHEB12(3) = ALAM1+ALAM2 CHEB12(11) = ALAM1-ALAM2 CHEB12(7) = V(1)-V(5) ALAM = X(2)*V(2)+X(6)*V(4)+X(10)*V(6) CHEB24(3) = CHEB12(3)+ALAM CHEB24(23) = CHEB12(3)-ALAM ALAM = X(6)*(V(2)-V(4)-V(6)) CHEB24(7) = CHEB12(7)+ALAM CHEB24(19) = CHEB12(7)-ALAM ALAM = X(10)*V(2)-X(6)*V(4)+X(2)*V(6) CHEB24(11) = CHEB12(11)+ALAM CHEB24(15) = CHEB12(11)-ALAM DO 30 I=1,3 J = 8-I V(I) = FVAL(I)-FVAL(J) FVAL(I) = FVAL(I)+FVAL(J) 30 CONTINUE CHEB12(5) = V(1)+X(8)*V(3) CHEB12(9) = FVAL(1)-X(8)*FVAL(3) ALAM = X(4)*V(2) CHEB24(5) = CHEB12(5)+ALAM CHEB24(21) = CHEB12(5)-ALAM ALAM = X(8)*FVAL(2)-FVAL(4) CHEB24(9) = CHEB12(9)+ALAM CHEB24(17) = CHEB12(9)-ALAM CHEB12(1) = FVAL(1)+FVAL(3) ALAM = FVAL(2)+FVAL(4) CHEB24(1) = CHEB12(1)+ALAM CHEB24(25) = CHEB12(1)-ALAM CHEB12(13) = V(1)-V(3) CHEB24(13) = CHEB12(13) ALAM = 0.1D+01/0.6D+01 DO 40 I=2,12 CHEB12(I) = CHEB12(I)*ALAM 40 CONTINUE ALAM = 0.5D+00*ALAM CHEB12(1) = CHEB12(1)*ALAM CHEB12(13) = CHEB12(13)*ALAM DO 50 I=2,24 CHEB24(I) = CHEB24(I)*ALAM 50 CONTINUE CHEB24(1) = 0.5D+00*ALAM*CHEB24(1) CHEB24(25) = 0.5D+00*ALAM*CHEB24(25) return end DOUBLE PRECISION FUNCTION DQDOTA (N, DB, QC, DX, INCX, DY, INCY) ! !! DQDOTA computes the inner product of two vectors with extended ... ! precision accumulation and result. ! !***LIBRARY SLATEC !***CATEGORY D1A4 !***TYPE DOUBLE PRECISION (DQDOTA-D) !***KEYWORDS DOT PRODUCT, INNER PRODUCT !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(S) ! DB double precision scalar to be added to inner product ! QC extended precision scalar to be added to inner product ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! DY double precision vector with N elements ! INCY storage spacing between elements of DY ! ! --Output-- ! DQDOTA double precision result ! QC extended precision result ! ! D.P. dot product with extended precision accumulation (and result) ! QC and DQDOTA are set = DB + QC + sum for I = 0 to N-1 of ! DX(LX+I*INCX) * DY(LY+I*INCY), where QC is an extended ! precision result previously computed by DQDOTI or DQDOTA ! and LX = 1 if INCX >= 0, else LX = (-INCX)*N, and LY is ! defined in a similar way using INCY. The MP package by ! Richard P. Brent is used for the extended precision arithmetic. ! ! Fred T. Krogh, JPL, 1977, June 1 ! ! The common block for the MP package is name MPCOM. If local ! variable I1 is zero, DQDOTA calls MPBLAS to initialize ! the MP package and reset I1 to 1. ! ! The argument QC(*) and the local variables QX and QY are INTEGER ! arrays of size 30. See the comments in the routine MPBLAS for the ! reason for this choice. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED MPADD, MPBLAS, MPCDM, MPCMD, MPMUL !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 930124 Increased Array sizes for SUN -r8. (RWC) !***END PROLOGUE DQDOTA DOUBLE PRECISION DX(*), DY(*), DB INTEGER QC(30), QX(30), QY(30) COMMON /MPCOM/ MPB, MPT, MPM, MPLUN, MPMXR, MPR(30) SAVE I1 DATA I1 / 0 / !***FIRST EXECUTABLE STATEMENT DQDOTA if (I1 == 0) call MPBLAS(I1) if (DB == 0.D0) go to 20 call MPCDM(DB, QX) call MPADD(QC, QX, QC) 20 if (N == 0) go to 40 IX = 1 IY = 1 if (INCX < 0) IX = (-N + 1) * INCX + 1 if (INCY < 0) IY = (-N + 1) * INCY + 1 DO 30 I = 1,N call MPCDM(DX(IX), QX) call MPCDM(DY(IY), QY) call MPMUL(QX, QY, QX) call MPADD(QC, QX, QC) IX = IX + INCX IY = IY + INCY 30 CONTINUE 40 call MPCMD(QC, DQDOTA) return end DOUBLE PRECISION FUNCTION DQDOTI (N, DB, QC, DX, INCX, DY, INCY) ! !! DQDOTI computes the inner product of two vectors with extended precision. ! !***LIBRARY SLATEC !***CATEGORY D1A4 !***TYPE DOUBLE PRECISION (DQDOTI-D) !***KEYWORDS DOT PRODUCT, INNER PRODUCT !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of parameters ! ! --Input-- ! N number of elements in input vector(s) ! DB double precision scalar to be added to inner product ! QC extended precision scalar to be added ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! DY double precision vector with N elements ! INCY storage spacing between elements of DY ! ! --Output-- ! DQDOTI double precision result ! QC extended precision result ! ! D.P. dot product with extended precision accumulation (and result) ! QC and DQDOTI are set = DB + sum for I = 0 to N-1 of ! DX(LX+I*INCX) * DY(LY+I*INCY), where QC is an extended ! precision result which can be used as input to DQDOTA, ! and LX = 1 if INCX >= 0, else LX = (-INCX)*N, and LY is ! defined in a similar way using INCY. The MP package by ! Richard P. Brent is used for the extended precision arithmetic. ! ! Fred T. Krogh, JPL, 1977, June 1 ! ! The common block for the MP package is named MPCOM. If local ! variable I1 is zero, DQDOTI calls MPBLAS to initialize the MP ! package and reset I1 to 1. ! ! The argument QC(*), and the local variables QX and QY are INTEGER ! arrays of size 30. See the comments in the routine MPBLAS for the ! reason for this choice. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED MPADD, MPBLAS, MPCDM, MPCMD, MPMUL !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 930124 Increased Array sizes for SUN -r8. (RWC) !***END PROLOGUE DQDOTI DOUBLE PRECISION DX(*), DY(*), DB INTEGER QC(30), QX(30), QY(30) COMMON /MPCOM/ MPB, MPT, MPM, MPLUN, MPMXR, MPR(30) SAVE I1 DATA I1 / 0 / !***FIRST EXECUTABLE STATEMENT DQDOTI if (I1 == 0) call MPBLAS(I1) QC(1) = 0 if (DB == 0.D0) go to 60 call MPCDM(DB, QX) call MPADD(QC, QX, QC) 60 if (N == 0) go to 80 IX = 1 IY = 1 if (INCX < 0) IX = (-N + 1) * INCX + 1 if (INCY < 0) IY = (-N + 1) * INCY + 1 DO 70 I = 1,N call MPCDM(DX(IX), QX) call MPCDM(DY(IY), QY) call MPMUL(QX, QY, QX) call MPADD(QC, QX, QC) IX = IX + INCX IY = IY + INCY 70 CONTINUE 80 call MPCMD(QC, DQDOTI) return end subroutine DQELG (N, EPSTAB, RESULT, ABSERR, RES3LA, NRES) ! !! DQELG applies the Epsilon algorithm. ! !***SUBSIDIARY !***PURPOSE The routine determines the limit of a given sequence of ! approximations, by means of the Epsilon algorithm of ! P.Wynn. An estimate of the absolute error is also given. ! The condensed Epsilon table is computed. Only those ! elements needed for the computation of the next diagonal ! are preserved. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QELG-S, DQELG-D) !***KEYWORDS CONVERGENCE ACCELERATION, EPSILON ALGORITHM, EXTRAPOLATION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Epsilon algorithm ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! N - Integer ! EPSTAB(N) contains the new element in the ! first column of the epsilon table. ! ! EPSTAB - Double precision ! Vector of dimension 52 containing the elements ! of the two lower diagonals of the triangular ! epsilon table. The elements are numbered ! starting at the right-hand corner of the ! triangle. ! ! RESULT - Double precision ! Resulting approximation to the integral ! ! ABSERR - Double precision ! Estimate of the absolute error computed from ! RESULT and the 3 previous results ! ! RES3LA - Double precision ! Vector of dimension 3 containing the last 3 ! results ! ! NRES - Integer ! Number of calls to the routine ! (should be zero at first call) ! !***SEE ALSO DQAGIE, DQAGOE, DQAGPE, DQAGSE !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DQELG ! DOUBLE PRECISION ABSERR,DELTA1,DELTA2,DELTA3,D1MACH, & 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) ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! E0 - THE 4 ELEMENTS ON WHICH THE COMPUTATION OF A NEW ! E1 ELEMENT IN THE EPSILON TABLE IS BASED ! E2 ! E3 E0 ! E3 E1 NEW ! E2 ! NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW ! DIAGONAL ! ERROR - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2) ! RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE ! OF ERROR ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON ! TABLE CAN CONTAIN. if THIS NUMBER IS REACHED, THE UPPER ! DIAGONAL OF THE EPSILON TABLE IS DELETED. ! !***FIRST EXECUTABLE STATEMENT DQELG EPMACH = D1MACH(4) OFLOW = D1MACH(2) NRES = NRES+1 ABSERR = OFLOW RESULT = EPSTAB(N) if ( N < 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 = MAX(ABS(E2),E1ABS)*EPMACH DELTA3 = E1-E0 ERR3 = ABS(DELTA3) TOL3 = MAX(E1ABS,ABS(E0))*EPMACH if ( ERR2 > TOL2.OR.ERR3 > TOL3) go to 10 ! ! if E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE ! ACCURACY, CONVERGENCE IS ASSUMED. ! RESULT = E2 ! ABSERR = ABS(E1-E0)+ABS(E2-E1) ! RESULT = RES ABSERR = ERR2+ERR3 ! ***JUMP OUT OF DO-LOOP go to 100 10 E3 = EPSTAB(K1) EPSTAB(K1) = E1 DELTA1 = E1-E3 ERR1 = ABS(DELTA1) TOL1 = MAX(E1ABS,ABS(E3))*EPMACH ! ! if TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT ! A PART OF THE TABLE BY ADJUSTING THE VALUE OF N ! if ( ERR1 <= TOL1.OR.ERR2 <= TOL2.OR.ERR3 <= TOL3) go to 20 SS = 0.1D+01/DELTA1+0.1D+01/DELTA2-0.1D+01/DELTA3 EPSINF = ABS(SS*E1) ! ! TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND ! EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE ! OF N. ! if ( EPSINF > 0.1D-03) go to 30 20 N = I+I-1 ! ***JUMP OUT OF DO-LOOP go to 50 ! ! COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST ! THE VALUE OF RESULT. ! 30 RES = E1+0.1D+01/SS EPSTAB(K1) = RES K1 = K1-2 ERROR = ERR2+ABS(RES-E2)+ERR3 if ( ERROR > ABSERR) go to 40 ABSERR = ERROR RESULT = RES 40 CONTINUE ! ! SHIFT THE TABLE. ! 50 if ( N == LIMEXP) N = 2*(LIMEXP/2)-1 IB = 1 if ( (NUM/2)*2 == NUM) IB = 2 IE = NEWELM+1 DO 60 I=1,IE IB2 = IB+2 EPSTAB(IB) = EPSTAB(IB2) IB = IB2 60 CONTINUE if ( NUM == 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 >= 4) go to 90 RES3LA(NRES) = RESULT ABSERR = OFLOW go to 100 ! ! COMPUTE ERROR ESTIMATE ! 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 = MAX(ABSERR,0.5D+01*EPMACH*ABS(RESULT)) return end subroutine DQFORM (M, N, Q, LDQ, WA) ! !! DQFORM explicitly forms the Q matrix of an implicit QR factorization. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DNSQ and DNSQE !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QFORM-S, DQFORM-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine proceeds from the computed QR factorization of ! an M by N matrix A to accumulate the M by M orthogonal matrix ! Q from its factored form. ! ! The subroutine statement is ! ! SUBROUTINE DQFORM(M,N,Q,LDQ,WA) ! ! where ! ! M is a positive integer input variable set to the number ! of rows of A and the order of Q. ! ! N is a positive integer input variable set to the number ! of columns of A. ! ! Q is an M by M array. On input the full lower trapezoid in ! the first MIN(M,N) columns of Q contains the factored form. ! On output Q has been accumulated into a square matrix. ! ! LDQ is a positive integer input variable not less than M ! which specifies the leading dimension of the array Q. ! ! WA is a work array of length M. ! !***SEE ALSO DNSQ, DNSQE !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DQFORM INTEGER I, J, JM1, K, L, LDQ, M, MINMN, N, NP1 DOUBLE PRECISION ONE, Q(LDQ,*), SUM, TEMP, WA(*), ZERO SAVE ONE, ZERO DATA ONE,ZERO /1.0D0,0.0D0/ ! ! ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS. ! !***FIRST EXECUTABLE STATEMENT DQFORM MINMN = MIN(M,N) if (MINMN < 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 ! ! INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX. ! NP1 = N + 1 if (M < 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 ! ! ACCUMULATE Q FROM ITS FACTORED FORM. ! 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) == 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 ! ! LAST CARD OF SUBROUTINE DQFORM. ! end subroutine DQK15 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! DQK15 computes Integral of F over (A,B), with error estimate. ! J = integral of ABS(F) over (A,B) ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE DOUBLE PRECISION (QK15-S, DQK15-D) !***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! FUNCTION F(X). The actual name for F needs to be ! Declared E X T E R N A L in the calling program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral I ! Result is computed by applying the 15-POINT ! KRONROD RULE (RESK) obtained by optimal addition ! of abscissae to the 7-POINT GAUSS RULE(RESG). ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should not exceed ABS(I-RESULT) ! ! RESABS - Double precision ! Approximation to the integral J ! ! RESASC - Double precision ! Approximation to the integral of ABS(F-I/(B-A)) ! over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQK15 ! DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, & D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, & RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(7),FV2(7),WG(4),WGK(8),XGK(8) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 7-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 15-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 7-POINT GAUSS RULE ! ! ! GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS ! AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, ! BELL LABS, NOV. 1981. ! SAVE WG, XGK, WGK DATA WG ( 1) / 0.129484966168869693270611432679082D0 / DATA WG ( 2) / 0.279705391489276667901467771423780D0 / DATA WG ( 3) / 0.381830050505118944950369775488975D0 / DATA WG ( 4) / 0.417959183673469387755102040816327D0 / ! DATA XGK ( 1) / 0.991455371120812639206854697526329D0 / DATA XGK ( 2) / 0.949107912342758524526189684047851D0 / DATA XGK ( 3) / 0.864864423359769072789712788640926D0 / DATA XGK ( 4) / 0.741531185599394439863864773280788D0 / DATA XGK ( 5) / 0.586087235467691130294144838258730D0 / DATA XGK ( 6) / 0.405845151377397166906606412076961D0 / DATA XGK ( 7) / 0.207784955007898467600689403773245D0 / DATA XGK ( 8) / 0.000000000000000000000000000000000D0 / ! DATA WGK ( 1) / 0.022935322010529224963732008058970D0 / DATA WGK ( 2) / 0.063092092629978553290700663189204D0 / DATA WGK ( 3) / 0.104790010322250183839876322541518D0 / DATA WGK ( 4) / 0.140653259715525918745189590510238D0 / DATA WGK ( 5) / 0.169004726639267902826583426598550D0 / DATA WGK ( 6) / 0.190350578064785409913256402421014D0 / DATA WGK ( 7) / 0.204432940075298892414161999234649D0 / DATA WGK ( 8) / 0.209482141084727828012999174891714D0 / ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 7-POINT GAUSS FORMULA ! RESK - RESULT OF THE 15-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), ! I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQK15 EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! CENTR = 0.5D+00*(A+B) HLGTH = 0.5D+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 15-POINT KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! FC = F(CENTR) RESG = FC*WG(4) RESK = FC*WGK(8) RESABS = ABS(RESK) DO 10 J=1,3 JTW = J*2 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,4 JTWM1 = J*2-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.5D+00 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 RESABS = RESABS*DHLGTH RESASC = RESASC*DHLGTH ABSERR = ABS((RESK-RESG)*HLGTH) if ( RESASC /= 0.0D+00.AND.ABSERR /= 0.0D+00) & ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) if ( RESABS > UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5D+02)*RESABS,ABSERR) return end subroutine DQK15I (F, BOUN, INF, A, B, RESULT, ABSERR, RESABS, & RESASC) ! !! DQK15I computes an integral over an infinite range. ! !***PURPOSE The original (infinite integration range is mapped ! onto the interval (0,1) and (A,B) is a part of (0,1). ! it is the purpose to compute ! I = Integral of transformed integrand over (A,B), ! J = Integral of ABS(Transformed Integrand) over (A,B). !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A3A2, H2A4A2 !***TYPE DOUBLE PRECISION (QK15I-S, DQK15I-D) !***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration Rule ! Standard Fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! FUNCTION F(X). The actual name for F needs to be ! Declared E X T E R N A L in the calling program. ! ! BOUN - Double precision ! Finite bound of original integration ! Range (SET TO ZERO if INF = +2) ! ! INF - Integer ! If INF = -1, the original interval is ! (-INFINITY,BOUND), ! If INF = +1, the original interval is ! (BOUND,+INFINITY), ! If INF = +2, the original interval is ! (-INFINITY,+INFINITY) AND ! The integral is computed as the sum of two ! integrals, one over (-INFINITY,0) and one over ! (0,+INFINITY). ! ! A - Double precision ! Lower limit for integration over subrange ! of (0,1) ! ! B - Double precision ! Upper limit for integration over subrange ! of (0,1) ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral I ! Result is computed by applying the 15-POINT ! KRONROD RULE(RESK) obtained by optimal addition ! of abscissae to the 7-POINT GAUSS RULE(RESG). ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! WHICH SHOULD EQUAL or EXCEED ABS(I-RESULT) ! ! RESABS - Double precision ! Approximation to the integral J ! ! RESASC - Double precision ! Approximation to the integral of ! ABS((TRANSFORMED INTEGRAND)-I/(B-A)) over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQK15I ! DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR,DINF, & D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH, & RESABS,RESASC,RESG,RESK,RESKH,RESULT,TABSC1,TABSC2,UFLOW,WG,WGK, & XGK INTEGER INF,J EXTERNAL F ! DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(8) ! ! THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL ! (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND ! THEIR CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 7-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 15-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING ! TO THE ABSCISSAE XGK(2), XGK(4), ... ! WG(1), WG(3), ... ARE SET TO ZERO. ! SAVE XGK, WGK, WG DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8)/ & 0.9914553711208126D+00, 0.9491079123427585D+00, & 0.8648644233597691D+00, 0.7415311855993944D+00, & 0.5860872354676911D+00, 0.4058451513773972D+00, & 0.2077849550078985D+00, 0.0000000000000000D+00/ ! DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8)/ & 0.2293532201052922D-01, 0.6309209262997855D-01, & 0.1047900103222502D+00, 0.1406532597155259D+00, & 0.1690047266392679D+00, 0.1903505780647854D+00, & 0.2044329400752989D+00, 0.2094821410847278D+00/ ! DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ & 0.0000000000000000D+00, 0.1294849661688697D+00, & 0.0000000000000000D+00, 0.2797053914892767D+00, & 0.0000000000000000D+00, 0.3818300505051189D+00, & 0.0000000000000000D+00, 0.4179591836734694D+00/ ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC* - ABSCISSA ! TABSC* - TRANSFORMED ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 7-POINT GAUSS FORMULA ! RESK - RESULT OF THE 15-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED ! INTEGRAND OVER (A,B), I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQK15I EPMACH = D1MACH(4) UFLOW = D1MACH(1) DINF = MIN(1,INF) ! CENTR = 0.5D+00*(A+B) HLGTH = 0.5D+00*(B-A) TABSC1 = BOUN+DINF*(0.1D+01-CENTR)/CENTR FVAL1 = F(TABSC1) if ( INF == 2) FVAL1 = FVAL1+F(-TABSC1) FC = (FVAL1/CENTR)/CENTR ! ! COMPUTE THE 15-POINT KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ERROR. ! 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*(0.1D+01-ABSC1)/ABSC1 TABSC2 = BOUN+DINF*(0.1D+01-ABSC2)/ABSC2 FVAL1 = F(TABSC1) FVAL2 = F(TABSC2) if ( INF == 2) FVAL1 = FVAL1+F(-TABSC1) if ( INF == 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.5D+00 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 /= 0.0D+00.AND.ABSERR /= 0.D0) ABSERR = RESASC* & MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) if ( RESABS > UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5D+02)*RESABS,ABSERR) return end subroutine DQK15W (F, W, P1, P2, P3, P4, KP, A, B, RESULT, ABSERR, & RESABS, RESASC) ! !! DQK15W computes Integral of F*W over (A,B), with error estimate. ! J = Integral of ABS(F*W) over (A,B) ! ! Discussion: ! ! Recently bug was discovered in subroutines QK15W, DQK15W, ! which are Quadpack routines included in SLATEC. In these ! routines, the DATA initialization of WG(3) should be changed from ! 0.3818300505051889E+0 and 0.3818300505051889D+00 ! to ! 0.3818300505051189E+0 and 0.3818300505051189D+00 ! respectively. ! ! DONE, JVB, 16 November 2023. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A2 !***TYPE DOUBLE PRECISION (QK15W-S, DQK15W-D) !***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! W - Double precision ! Function subprogram defining the integrand ! WEIGHT function W(X). The actual name for W ! needs to be declared E X T E R N A L in the ! calling program. ! ! P1, P2, P3, P4 - Double precision ! Parameters in the WEIGHT function ! ! KP - Integer ! Key for indicating the type of WEIGHT function ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral I ! RESULT is computed by applying the 15-point ! Kronrod rule (RESK) obtained by optimal addition ! of abscissae to the 7-point Gauss rule (RESG). ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! RESABS - Double precision ! Approximation to the integral of ABS(F) ! ! RESASC - Double precision ! Approximation to the integral of ABS(F-I/(B-A)) ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQK15W ! DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,CENTR,DHLGTH, & D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH, & P1,P2,P3,P4,RESABS,RESASC,RESG,RESK,RESKH,RESULT,UFLOW,W,WG,WGK, & XGK INTEGER J,JTW,JTWM1,KP EXTERNAL F, W ! DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(4) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 15-POINT GAUSS-KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 7-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 15-POINT GAUSS-KRONROD RULE ! ! WG - WEIGHTS OF THE 7-POINT GAUSS RULE ! SAVE XGK, WGK, WG DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8)/ & 0.9914553711208126D+00, 0.9491079123427585D+00, & 0.8648644233597691D+00, 0.7415311855993944D+00, & 0.5860872354676911D+00, 0.4058451513773972D+00, & 0.2077849550078985D+00, 0.0000000000000000D+00/ ! DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8)/ & 0.2293532201052922D-01, 0.6309209262997855D-01, & 0.1047900103222502D+00, 0.1406532597155259D+00, & 0.1690047266392679D+00, 0.1903505780647854D+00, & 0.2044329400752989D+00, 0.2094821410847278D+00/ ! DATA WG(1),WG(2),WG(3),WG(4)/ & 0.1294849661688697D+00, & 0.2797053914892767D+00, & 0.3818300505051189D+00, & 0.4179591836734694D+00/ ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC* - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 7-POINT GAUSS FORMULA ! RESK - RESULT OF THE 15-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F*W OVER (A,B), ! I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQK15W EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! CENTR = 0.5D+00*(A+B) HLGTH = 0.5D+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 15-POINT KRONROD APPROXIMATION TO THE ! INTEGRAL, AND ESTIMATE THE ERROR. ! FC = F(CENTR)*W(CENTR,P1,P2,P3,P4,KP) RESG = WG(4)*FC RESK = WGK(8)*FC RESABS = ABS(RESK) DO 10 J=1,3 JTW = J*2 ABSC = HLGTH*XGK(JTW) ABSC1 = CENTR-ABSC ABSC2 = CENTR+ABSC FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP) FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP) 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,4 JTWM1 = J*2-1 ABSC = HLGTH*XGK(JTWM1) ABSC1 = CENTR-ABSC ABSC2 = CENTR+ABSC FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP) FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP) 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.5D+00 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 RESABS = RESABS*DHLGTH RESASC = RESASC*DHLGTH ABSERR = ABS((RESK-RESG)*HLGTH) if ( RESASC /= 0.0D+00.AND.ABSERR /= 0.0D+00) & ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) if ( RESABS > UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX((EPMACH* & 0.5D+02)*RESABS,ABSERR) return end subroutine DQK21 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! DQK21 computes Integral of F over (A,B), with error estimate. ! J = Integral of ABS(F) over (A,B) ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE DOUBLE PRECISION (QK21-S, DQK21-D) !***KEYWORDS 21-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! FUNCTION F(X). The actual name for F needs to be ! Declared E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral I ! RESULT is computed by applying the 21-POINT ! KRONROD RULE (RESK) obtained by optimal addition ! of abscissae to the 10-POINT GAUSS RULE (RESG). ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should not exceed ABS(I-RESULT) ! ! RESABS - Double precision ! Approximation to the integral J ! ! RESASC - Double precision ! Approximation to the integral of ABS(F-I/(B-A)) ! over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQK21 ! DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, & D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, & RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(10),FV2(10),WG(5),WGK(11),XGK(11) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 21-POINT KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 10-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 10-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 21-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 10-POINT GAUSS RULE ! ! ! GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS ! AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, ! BELL LABS, NOV. 1981. ! SAVE WG, XGK, WGK DATA WG ( 1) / 0.066671344308688137593568809893332D0 / DATA WG ( 2) / 0.149451349150580593145776339657697D0 / DATA WG ( 3) / 0.219086362515982043995534934228163D0 / DATA WG ( 4) / 0.269266719309996355091226921569469D0 / DATA WG ( 5) / 0.295524224714752870173892994651338D0 / ! DATA XGK ( 1) / 0.995657163025808080735527280689003D0 / DATA XGK ( 2) / 0.973906528517171720077964012084452D0 / DATA XGK ( 3) / 0.930157491355708226001207180059508D0 / DATA XGK ( 4) / 0.865063366688984510732096688423493D0 / DATA XGK ( 5) / 0.780817726586416897063717578345042D0 / DATA XGK ( 6) / 0.679409568299024406234327365114874D0 / DATA XGK ( 7) / 0.562757134668604683339000099272694D0 / DATA XGK ( 8) / 0.433395394129247190799265943165784D0 / DATA XGK ( 9) / 0.294392862701460198131126603103866D0 / DATA XGK ( 10) / 0.148874338981631210884826001129720D0 / DATA XGK ( 11) / 0.000000000000000000000000000000000D0 / ! DATA WGK ( 1) / 0.011694638867371874278064396062192D0 / DATA WGK ( 2) / 0.032558162307964727478818972459390D0 / DATA WGK ( 3) / 0.054755896574351996031381300244580D0 / DATA WGK ( 4) / 0.075039674810919952767043140916190D0 / DATA WGK ( 5) / 0.093125454583697605535065465083366D0 / DATA WGK ( 6) / 0.109387158802297641899210590325805D0 / DATA WGK ( 7) / 0.123491976262065851077958109831074D0 / DATA WGK ( 8) / 0.134709217311473325928054001771707D0 / DATA WGK ( 9) / 0.142775938577060080797094273138717D0 / DATA WGK ( 10) / 0.147739104901338491374841515972068D0 / DATA WGK ( 11) / 0.149445554002916905664936468389821D0 / ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 10-POINT GAUSS FORMULA ! RESK - RESULT OF THE 21-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), ! I.E. TO I/(B-A) ! ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQK21 EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! CENTR = 0.5D+00*(A+B) HLGTH = 0.5D+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 21-POINT KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! RESG = 0.0D+00 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.5D+00 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 /= 0.0D+00.AND.ABSERR /= 0.0D+00) & ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) if ( RESABS > UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5D+02)*RESABS,ABSERR) return end subroutine DQK31 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! DQK31 computes Integral of F over (A,B) with error estimate. ! J = Integral of ABS(F) over (A,B) ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE DOUBLE PRECISION (QK31-S, DQK31-D) !***KEYWORDS 31-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! FUNCTION F(X). The actual name for F needs to be ! Declared E X T E R N A L in the calling program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral I ! RESULT is computed by applying the 31-POINT ! GAUSS-KRONROD RULE (RESK), obtained by optimal ! addition of abscissae to the 15-POINT GAUSS ! RULE (RESG). ! ! ABSERR - Double precision ! Estimate of the modulus of the modulus, ! which should not exceed ABS(I-RESULT) ! ! RESABS - Double precision ! Approximation to the integral J ! ! RESASC - Double precision ! Approximation to the integral of ABS(F-I/(B-A)) ! over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQK31 DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, & D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, & RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(15),FV2(15),XGK(16),WGK(16),WG(8) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 31-POINT KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 15-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 15-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 31-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 15-POINT GAUSS RULE ! ! ! GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS ! AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, ! BELL LABS, NOV. 1981. ! SAVE WG, XGK, WGK DATA WG ( 1) / 0.030753241996117268354628393577204D0 / DATA WG ( 2) / 0.070366047488108124709267416450667D0 / DATA WG ( 3) / 0.107159220467171935011869546685869D0 / DATA WG ( 4) / 0.139570677926154314447804794511028D0 / DATA WG ( 5) / 0.166269205816993933553200860481209D0 / DATA WG ( 6) / 0.186161000015562211026800561866423D0 / DATA WG ( 7) / 0.198431485327111576456118326443839D0 / DATA WG ( 8) / 0.202578241925561272880620199967519D0 / ! DATA XGK ( 1) / 0.998002298693397060285172840152271D0 / DATA XGK ( 2) / 0.987992518020485428489565718586613D0 / DATA XGK ( 3) / 0.967739075679139134257347978784337D0 / DATA XGK ( 4) / 0.937273392400705904307758947710209D0 / DATA XGK ( 5) / 0.897264532344081900882509656454496D0 / DATA XGK ( 6) / 0.848206583410427216200648320774217D0 / DATA XGK ( 7) / 0.790418501442465932967649294817947D0 / DATA XGK ( 8) / 0.724417731360170047416186054613938D0 / DATA XGK ( 9) / 0.650996741297416970533735895313275D0 / DATA XGK ( 10) / 0.570972172608538847537226737253911D0 / DATA XGK ( 11) / 0.485081863640239680693655740232351D0 / DATA XGK ( 12) / 0.394151347077563369897207370981045D0 / DATA XGK ( 13) / 0.299180007153168812166780024266389D0 / DATA XGK ( 14) / 0.201194093997434522300628303394596D0 / DATA XGK ( 15) / 0.101142066918717499027074231447392D0 / DATA XGK ( 16) / 0.000000000000000000000000000000000D0 / ! DATA WGK ( 1) / 0.005377479872923348987792051430128D0 / DATA WGK ( 2) / 0.015007947329316122538374763075807D0 / DATA WGK ( 3) / 0.025460847326715320186874001019653D0 / DATA WGK ( 4) / 0.035346360791375846222037948478360D0 / DATA WGK ( 5) / 0.044589751324764876608227299373280D0 / DATA WGK ( 6) / 0.053481524690928087265343147239430D0 / DATA WGK ( 7) / 0.062009567800670640285139230960803D0 / DATA WGK ( 8) / 0.069854121318728258709520077099147D0 / DATA WGK ( 9) / 0.076849680757720378894432777482659D0 / DATA WGK ( 10) / 0.083080502823133021038289247286104D0 / DATA WGK ( 11) / 0.088564443056211770647275443693774D0 / DATA WGK ( 12) / 0.093126598170825321225486872747346D0 / DATA WGK ( 13) / 0.096642726983623678505179907627589D0 / DATA WGK ( 14) / 0.099173598721791959332393173484603D0 / DATA WGK ( 15) / 0.100769845523875595044946662617570D0 / DATA WGK ( 16) / 0.101330007014791549017374792767493D0 / ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 15-POINT GAUSS FORMULA ! RESK - RESULT OF THE 31-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), ! I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. !***FIRST EXECUTABLE STATEMENT DQK31 EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! CENTR = 0.5D+00*(A+B) HLGTH = 0.5D+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 31-POINT KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! FC = F(CENTR) RESG = WG(8)*FC RESK = WGK(16)*FC RESABS = ABS(RESK) DO 10 J=1,7 JTW = J*2 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,8 JTWM1 = J*2-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.5D+00 RESASC = WGK(16)*ABS(FC-RESKH) DO 20 J=1,15 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 /= 0.0D+00.AND.ABSERR /= 0.0D+00) & ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) if ( RESABS > UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5D+02)*RESABS,ABSERR) return end subroutine DQK41 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! DQK41 computes Integral of F over (A,B), with error estimate. ! J = Integral of ABS(F) over (A,B) ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE DOUBLE PRECISION (QK41-S, DQK41-D) !***KEYWORDS 41-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! FUNCTION F(X). The actual name for F needs to be ! declared E X T E R N A L in the calling program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral I ! RESULT is computed by applying the 41-POINT ! GAUSS-KRONROD RULE (RESK) obtained by optimal ! addition of abscissae to the 20-POINT GAUSS ! RULE (RESG). ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should not exceed ABS(I-RESULT) ! ! RESABS - Double precision ! Approximation to the integral J ! ! RESASC - Double precision ! Approximation to the integral of ABS(F-I/(B-A)) ! over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQK41 ! DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, & D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, & RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(20),FV2(20),XGK(21),WGK(21),WG(10) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 41-POINT GAUSS-KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 20-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 20-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 41-POINT GAUSS-KRONROD RULE ! ! WG - WEIGHTS OF THE 20-POINT GAUSS RULE ! ! ! GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS ! AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, ! BELL LABS, NOV. 1981. ! SAVE WG, XGK, WGK DATA WG ( 1) / 0.017614007139152118311861962351853D0 / DATA WG ( 2) / 0.040601429800386941331039952274932D0 / DATA WG ( 3) / 0.062672048334109063569506535187042D0 / DATA WG ( 4) / 0.083276741576704748724758143222046D0 / DATA WG ( 5) / 0.101930119817240435036750135480350D0 / DATA WG ( 6) / 0.118194531961518417312377377711382D0 / DATA WG ( 7) / 0.131688638449176626898494499748163D0 / DATA WG ( 8) / 0.142096109318382051329298325067165D0 / DATA WG ( 9) / 0.149172986472603746787828737001969D0 / DATA WG ( 10) / 0.152753387130725850698084331955098D0 / ! DATA XGK ( 1) / 0.998859031588277663838315576545863D0 / DATA XGK ( 2) / 0.993128599185094924786122388471320D0 / DATA XGK ( 3) / 0.981507877450250259193342994720217D0 / DATA XGK ( 4) / 0.963971927277913791267666131197277D0 / DATA XGK ( 5) / 0.940822633831754753519982722212443D0 / DATA XGK ( 6) / 0.912234428251325905867752441203298D0 / DATA XGK ( 7) / 0.878276811252281976077442995113078D0 / DATA XGK ( 8) / 0.839116971822218823394529061701521D0 / DATA XGK ( 9) / 0.795041428837551198350638833272788D0 / DATA XGK ( 10) / 0.746331906460150792614305070355642D0 / DATA XGK ( 11) / 0.693237656334751384805490711845932D0 / DATA XGK ( 12) / 0.636053680726515025452836696226286D0 / DATA XGK ( 13) / 0.575140446819710315342946036586425D0 / DATA XGK ( 14) / 0.510867001950827098004364050955251D0 / DATA XGK ( 15) / 0.443593175238725103199992213492640D0 / DATA XGK ( 16) / 0.373706088715419560672548177024927D0 / DATA XGK ( 17) / 0.301627868114913004320555356858592D0 / DATA XGK ( 18) / 0.227785851141645078080496195368575D0 / DATA XGK ( 19) / 0.152605465240922675505220241022678D0 / DATA XGK ( 20) / 0.076526521133497333754640409398838D0 / DATA XGK ( 21) / 0.000000000000000000000000000000000D0 / ! DATA WGK ( 1) / 0.003073583718520531501218293246031D0 / DATA WGK ( 2) / 0.008600269855642942198661787950102D0 / DATA WGK ( 3) / 0.014626169256971252983787960308868D0 / DATA WGK ( 4) / 0.020388373461266523598010231432755D0 / DATA WGK ( 5) / 0.025882133604951158834505067096153D0 / DATA WGK ( 6) / 0.031287306777032798958543119323801D0 / DATA WGK ( 7) / 0.036600169758200798030557240707211D0 / DATA WGK ( 8) / 0.041668873327973686263788305936895D0 / DATA WGK ( 9) / 0.046434821867497674720231880926108D0 / DATA WGK ( 10) / 0.050944573923728691932707670050345D0 / DATA WGK ( 11) / 0.055195105348285994744832372419777D0 / DATA WGK ( 12) / 0.059111400880639572374967220648594D0 / DATA WGK ( 13) / 0.062653237554781168025870122174255D0 / DATA WGK ( 14) / 0.065834597133618422111563556969398D0 / DATA WGK ( 15) / 0.068648672928521619345623411885368D0 / DATA WGK ( 16) / 0.071054423553444068305790361723210D0 / DATA WGK ( 17) / 0.073030690332786667495189417658913D0 / DATA WGK ( 18) / 0.074582875400499188986581418362488D0 / DATA WGK ( 19) / 0.075704497684556674659542775376617D0 / DATA WGK ( 20) / 0.076377867672080736705502835038061D0 / DATA WGK ( 21) / 0.076600711917999656445049901530102D0 / ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 20-POINT GAUSS FORMULA ! RESK - RESULT OF THE 41-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO MEAN VALUE OF F OVER (A,B), I.E. ! TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQK41 EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! CENTR = 0.5D+00*(A+B) HLGTH = 0.5D+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 41-POINT GAUSS-KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! RESG = 0.0D+00 FC = F(CENTR) RESK = WGK(21)*FC RESABS = ABS(RESK) DO 10 J=1,10 JTW = J*2 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,10 JTWM1 = J*2-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.5D+00 RESASC = WGK(21)*ABS(FC-RESKH) DO 20 J=1,20 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 /= 0.0D+00.AND.ABSERR /= 0.D+00) & ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) if ( RESABS > UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5D+02)*RESABS,ABSERR) return end subroutine DQK51 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! DQK51 computes Integral of F over (A,B) with error estimate. ! J = Integral of ABS(F) over (A,B) ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE DOUBLE PRECISION (QK51-S, DQK51-D) !***KEYWORDS 51-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subroutine defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the calling program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral I ! RESULT is computed by applying the 51-point ! Kronrod rule (RESK) obtained by optimal addition ! of abscissae to the 25-point Gauss rule (RESG). ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should not exceed ABS(I-RESULT) ! ! RESABS - Double precision ! Approximation to the integral J ! ! RESASC - Double precision ! Approximation to the integral of ABS(F-I/(B-A)) ! over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910819 Added WGK(26) to code. (WRB) !***END PROLOGUE DQK51 ! DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, & D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, & RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(25),FV2(25),XGK(26),WGK(26),WG(13) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 51-POINT KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 25-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 25-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 51-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 25-POINT GAUSS RULE ! ! ! GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS ! AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, ! BELL LABS, NOV. 1981. ! SAVE WG, XGK, WGK DATA WG ( 1) / 0.011393798501026287947902964113235D0 / DATA WG ( 2) / 0.026354986615032137261901815295299D0 / DATA WG ( 3) / 0.040939156701306312655623487711646D0 / DATA WG ( 4) / 0.054904695975835191925936891540473D0 / DATA WG ( 5) / 0.068038333812356917207187185656708D0 / DATA WG ( 6) / 0.080140700335001018013234959669111D0 / DATA WG ( 7) / 0.091028261982963649811497220702892D0 / DATA WG ( 8) / 0.100535949067050644202206890392686D0 / DATA WG ( 9) / 0.108519624474263653116093957050117D0 / DATA WG ( 10) / 0.114858259145711648339325545869556D0 / DATA WG ( 11) / 0.119455763535784772228178126512901D0 / DATA WG ( 12) / 0.122242442990310041688959518945852D0 / DATA WG ( 13) / 0.123176053726715451203902873079050D0 / ! DATA XGK ( 1) / 0.999262104992609834193457486540341D0 / DATA XGK ( 2) / 0.995556969790498097908784946893902D0 / DATA XGK ( 3) / 0.988035794534077247637331014577406D0 / DATA XGK ( 4) / 0.976663921459517511498315386479594D0 / DATA XGK ( 5) / 0.961614986425842512418130033660167D0 / DATA XGK ( 6) / 0.942974571228974339414011169658471D0 / DATA XGK ( 7) / 0.920747115281701561746346084546331D0 / DATA XGK ( 8) / 0.894991997878275368851042006782805D0 / DATA XGK ( 9) / 0.865847065293275595448996969588340D0 / DATA XGK ( 10) / 0.833442628760834001421021108693570D0 / DATA XGK ( 11) / 0.797873797998500059410410904994307D0 / DATA XGK ( 12) / 0.759259263037357630577282865204361D0 / DATA XGK ( 13) / 0.717766406813084388186654079773298D0 / DATA XGK ( 14) / 0.673566368473468364485120633247622D0 / DATA XGK ( 15) / 0.626810099010317412788122681624518D0 / DATA XGK ( 16) / 0.577662930241222967723689841612654D0 / DATA XGK ( 17) / 0.526325284334719182599623778158010D0 / DATA XGK ( 18) / 0.473002731445714960522182115009192D0 / DATA XGK ( 19) / 0.417885382193037748851814394594572D0 / DATA XGK ( 20) / 0.361172305809387837735821730127641D0 / DATA XGK ( 21) / 0.303089538931107830167478909980339D0 / DATA XGK ( 22) / 0.243866883720988432045190362797452D0 / DATA XGK ( 23) / 0.183718939421048892015969888759528D0 / DATA XGK ( 24) / 0.122864692610710396387359818808037D0 / DATA XGK ( 25) / 0.061544483005685078886546392366797D0 / DATA XGK ( 26) / 0.000000000000000000000000000000000D0 / ! DATA WGK ( 1) / 0.001987383892330315926507851882843D0 / DATA WGK ( 2) / 0.005561932135356713758040236901066D0 / DATA WGK ( 3) / 0.009473973386174151607207710523655D0 / DATA WGK ( 4) / 0.013236229195571674813656405846976D0 / DATA WGK ( 5) / 0.016847817709128298231516667536336D0 / DATA WGK ( 6) / 0.020435371145882835456568292235939D0 / DATA WGK ( 7) / 0.024009945606953216220092489164881D0 / DATA WGK ( 8) / 0.027475317587851737802948455517811D0 / DATA WGK ( 9) / 0.030792300167387488891109020215229D0 / DATA WGK ( 10) / 0.034002130274329337836748795229551D0 / DATA WGK ( 11) / 0.037116271483415543560330625367620D0 / DATA WGK ( 12) / 0.040083825504032382074839284467076D0 / DATA WGK ( 13) / 0.042872845020170049476895792439495D0 / DATA WGK ( 14) / 0.045502913049921788909870584752660D0 / DATA WGK ( 15) / 0.047982537138836713906392255756915D0 / DATA WGK ( 16) / 0.050277679080715671963325259433440D0 / DATA WGK ( 17) / 0.052362885806407475864366712137873D0 / DATA WGK ( 18) / 0.054251129888545490144543370459876D0 / DATA WGK ( 19) / 0.055950811220412317308240686382747D0 / DATA WGK ( 20) / 0.057437116361567832853582693939506D0 / DATA WGK ( 21) / 0.058689680022394207961974175856788D0 / DATA WGK ( 22) / 0.059720340324174059979099291932562D0 / DATA WGK ( 23) / 0.060539455376045862945360267517565D0 / DATA WGK ( 24) / 0.061128509717053048305859030416293D0 / DATA WGK ( 25) / 0.061471189871425316661544131965264D0 / DATA WGK ( 26) / 0.061580818067832935078759824240055D0 / ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 25-POINT GAUSS FORMULA ! RESK - RESULT OF THE 51-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), ! I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQK51 EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! CENTR = 0.5D+00*(A+B) HLGTH = 0.5D+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 51-POINT KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! FC = F(CENTR) RESG = WG(13)*FC RESK = WGK(26)*FC RESABS = ABS(RESK) DO 10 J=1,12 JTW = J*2 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,13 JTWM1 = J*2-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.5D+00 RESASC = WGK(26)*ABS(FC-RESKH) DO 20 J=1,25 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 /= 0.0D+00.AND.ABSERR /= 0.0D+00) & ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) if ( RESABS > UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5D+02)*RESABS,ABSERR) return end subroutine DQK61 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! DQK61 computes Integral of F over (A,B) with error estimate. ! J = Integral of ABS(F) over (A,B) ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE DOUBLE PRECISION (QK61-S, DQK61-D) !***KEYWORDS 61-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rule ! Standard fortran subroutine ! Double precision version ! ! ! PARAMETERS ! ON ENTRY ! F - Double precision ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the calling program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral I ! RESULT is computed by applying the 61-point ! Kronrod rule (RESK) obtained by optimal addition of ! abscissae to the 30-point Gauss rule (RESG). ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! RESABS - Double precision ! Approximation to the integral J ! ! RESASC - Double precision ! Approximation to the integral of ABS(F-I/(B-A)) ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQK61 ! DOUBLE PRECISION A,DABSC,ABSERR,B,CENTR,DHLGTH, & D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, & RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(30),FV2(30),XGK(31),WGK(31),WG(15) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE ! INTERVAL (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ! ABSCISSAE AND THEIR CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 61-POINT KRONROD RULE ! XGK(2), XGK(4) ... ABSCISSAE OF THE 30-POINT ! GAUSS RULE ! XGK(1), XGK(3) ... OPTIMALLY ADDED ABSCISSAE ! TO THE 30-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 61-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 30-POINT GAUSS RULE ! ! ! GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS ! AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, ! BELL LABS, NOV. 1981. ! SAVE WG, XGK, WGK DATA WG ( 1) / 0.007968192496166605615465883474674D0 / DATA WG ( 2) / 0.018466468311090959142302131912047D0 / DATA WG ( 3) / 0.028784707883323369349719179611292D0 / DATA WG ( 4) / 0.038799192569627049596801936446348D0 / DATA WG ( 5) / 0.048402672830594052902938140422808D0 / DATA WG ( 6) / 0.057493156217619066481721689402056D0 / DATA WG ( 7) / 0.065974229882180495128128515115962D0 / DATA WG ( 8) / 0.073755974737705206268243850022191D0 / DATA WG ( 9) / 0.080755895229420215354694938460530D0 / DATA WG ( 10) / 0.086899787201082979802387530715126D0 / DATA WG ( 11) / 0.092122522237786128717632707087619D0 / DATA WG ( 12) / 0.096368737174644259639468626351810D0 / DATA WG ( 13) / 0.099593420586795267062780282103569D0 / DATA WG ( 14) / 0.101762389748405504596428952168554D0 / DATA WG ( 15) / 0.102852652893558840341285636705415D0 / ! DATA XGK ( 1) / 0.999484410050490637571325895705811D0 / DATA XGK ( 2) / 0.996893484074649540271630050918695D0 / DATA XGK ( 3) / 0.991630996870404594858628366109486D0 / DATA XGK ( 4) / 0.983668123279747209970032581605663D0 / DATA XGK ( 5) / 0.973116322501126268374693868423707D0 / DATA XGK ( 6) / 0.960021864968307512216871025581798D0 / DATA XGK ( 7) / 0.944374444748559979415831324037439D0 / DATA XGK ( 8) / 0.926200047429274325879324277080474D0 / DATA XGK ( 9) / 0.905573307699907798546522558925958D0 / DATA XGK ( 10) / 0.882560535792052681543116462530226D0 / DATA XGK ( 11) / 0.857205233546061098958658510658944D0 / DATA XGK ( 12) / 0.829565762382768397442898119732502D0 / DATA XGK ( 13) / 0.799727835821839083013668942322683D0 / DATA XGK ( 14) / 0.767777432104826194917977340974503D0 / DATA XGK ( 15) / 0.733790062453226804726171131369528D0 / DATA XGK ( 16) / 0.697850494793315796932292388026640D0 / DATA XGK ( 17) / 0.660061064126626961370053668149271D0 / DATA XGK ( 18) / 0.620526182989242861140477556431189D0 / DATA XGK ( 19) / 0.579345235826361691756024932172540D0 / DATA XGK ( 20) / 0.536624148142019899264169793311073D0 / DATA XGK ( 21) / 0.492480467861778574993693061207709D0 / DATA XGK ( 22) / 0.447033769538089176780609900322854D0 / DATA XGK ( 23) / 0.400401254830394392535476211542661D0 / DATA XGK ( 24) / 0.352704725530878113471037207089374D0 / DATA XGK ( 25) / 0.304073202273625077372677107199257D0 / DATA XGK ( 26) / 0.254636926167889846439805129817805D0 / DATA XGK ( 27) / 0.204525116682309891438957671002025D0 / DATA XGK ( 28) / 0.153869913608583546963794672743256D0 / DATA XGK ( 29) / 0.102806937966737030147096751318001D0 / DATA XGK ( 30) / 0.051471842555317695833025213166723D0 / DATA XGK ( 31) / 0.000000000000000000000000000000000D0 / ! DATA WGK ( 1) / 0.001389013698677007624551591226760D0 / DATA WGK ( 2) / 0.003890461127099884051267201844516D0 / DATA WGK ( 3) / 0.006630703915931292173319826369750D0 / DATA WGK ( 4) / 0.009273279659517763428441146892024D0 / DATA WGK ( 5) / 0.011823015253496341742232898853251D0 / DATA WGK ( 6) / 0.014369729507045804812451432443580D0 / DATA WGK ( 7) / 0.016920889189053272627572289420322D0 / DATA WGK ( 8) / 0.019414141193942381173408951050128D0 / DATA WGK ( 9) / 0.021828035821609192297167485738339D0 / DATA WGK ( 10) / 0.024191162078080601365686370725232D0 / DATA WGK ( 11) / 0.026509954882333101610601709335075D0 / DATA WGK ( 12) / 0.028754048765041292843978785354334D0 / DATA WGK ( 13) / 0.030907257562387762472884252943092D0 / DATA WGK ( 14) / 0.032981447057483726031814191016854D0 / DATA WGK ( 15) / 0.034979338028060024137499670731468D0 / DATA WGK ( 16) / 0.036882364651821229223911065617136D0 / DATA WGK ( 17) / 0.038678945624727592950348651532281D0 / DATA WGK ( 18) / 0.040374538951535959111995279752468D0 / DATA WGK ( 19) / 0.041969810215164246147147541285970D0 / DATA WGK ( 20) / 0.043452539701356069316831728117073D0 / DATA WGK ( 21) / 0.044814800133162663192355551616723D0 / DATA WGK ( 22) / 0.046059238271006988116271735559374D0 / DATA WGK ( 23) / 0.047185546569299153945261478181099D0 / DATA WGK ( 24) / 0.048185861757087129140779492298305D0 / DATA WGK ( 25) / 0.049055434555029778887528165367238D0 / DATA WGK ( 26) / 0.049795683427074206357811569379942D0 / DATA WGK ( 27) / 0.050405921402782346840893085653585D0 / DATA WGK ( 28) / 0.050881795898749606492297473049805D0 / DATA WGK ( 29) / 0.051221547849258772170656282604944D0 / DATA WGK ( 30) / 0.051426128537459025933862879215781D0 / DATA WGK ( 31) / 0.051494729429451567558340433647099D0 / ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! DABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 30-POINT GAUSS RULE ! RESK - RESULT OF THE 61-POINT KRONROD RULE ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F ! OVER (A,B), I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQK61 EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! CENTR = 0.5D+00*(B+A) HLGTH = 0.5D+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 61-POINT KRONROD APPROXIMATION TO THE ! INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! RESG = 0.0D+00 FC = F(CENTR) RESK = WGK(31)*FC RESABS = ABS(RESK) DO 10 J=1,15 JTW = J*2 DABSC = HLGTH*XGK(JTW) FVAL1 = F(CENTR-DABSC) FVAL2 = F(CENTR+DABSC) 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,15 JTWM1 = J*2-1 DABSC = HLGTH*XGK(JTWM1) FVAL1 = F(CENTR-DABSC) FVAL2 = F(CENTR+DABSC) 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.5D+00 RESASC = WGK(31)*ABS(FC-RESKH) DO 20 J=1,30 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 /= 0.0D+00.AND.ABSERR /= 0.0D+00) & ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) if ( RESABS > UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5D+02)*RESABS,ABSERR) return end subroutine DQMOMO (ALFA, BETA, RI, RJ, RG, RH, INTEGR) ! !! DQMOMO computes modified Chebyshev moments. ! The K-th ! modified Chebyshev moment is defined as the integral over ! (-1,1) of W(X)*T(K,X), where T(K,X) is the Chebyshev ! polynomial of degree K. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1, C3A2 !***TYPE DOUBLE PRECISION (QMOMO-S, DQMOMO-D) !***KEYWORDS MODIFIED CHEBYSHEV MOMENTS, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! MODIFIED CHEBYSHEV MOMENTS ! STANDARD FORTRAN SUBROUTINE ! DOUBLE PRECISION VERSION ! ! PARAMETERS ! ALFA - Double precision ! Parameter in the weight function W(X), ALFA > (-1) ! ! BETA - Double precision ! Parameter in the weight function W(X), BETA > (-1) ! ! RI - Double precision ! Vector of dimension 25 ! RI(K) is the integral over (-1,1) of ! (1+X)**ALFA*T(K-1,X), K = 1, ..., 25. ! ! RJ - Double precision ! Vector of dimension 25 ! RJ(K) is the integral over (-1,1) of ! (1-X)**BETA*T(K-1,X), K = 1, ..., 25. ! ! RG - Double precision ! Vector of dimension 25 ! RG(K) is the integral over (-1,1) of ! (1+X)**ALFA*LOG((1+X)/2)*T(K-1,X), K = 1, ..., 25. ! ! RH - Double precision ! Vector of dimension 25 ! RH(K) is the integral over (-1,1) of ! (1-X)**BETA*LOG((1-X)/2)*T(K-1,X), K = 1, ..., 25. ! ! INTEGR - Integer ! Input parameter indicating the modified ! Moments to be computed ! INTEGR = 1 compute RI, RJ ! = 2 compute RI, RJ, RG ! = 3 compute RI, RJ, RH ! = 4 compute RI, RJ, RG, RH ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820101 DATE WRITTEN ! 891009 Removed unreferenced statement label. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQMOMO ! DOUBLE PRECISION ALFA,ALFP1,ALFP2,AN,ANM1,BETA,BETP1,BETP2,RALF, & RBET,RG,RH,RI,RJ INTEGER I,IM1,INTEGR ! DIMENSION RG(25),RH(25),RI(25),RJ(25) ! ! !***FIRST EXECUTABLE STATEMENT DQMOMO ALFP1 = ALFA+0.1D+01 BETP1 = BETA+0.1D+01 ALFP2 = ALFA+0.2D+01 BETP2 = BETA+0.2D+01 RALF = 0.2D+01**ALFP1 RBET = 0.2D+01**BETP1 ! ! COMPUTE RI, RJ USING A FORWARD RECURRENCE RELATION. ! RI(1) = RALF/ALFP1 RJ(1) = RBET/BETP1 RI(2) = RI(1)*ALFA/ALFP2 RJ(2) = RJ(1)*BETA/BETP2 AN = 0.2D+01 ANM1 = 0.1D+01 DO 20 I=3,25 RI(I) = -(RALF+AN*(AN-ALFP2)*RI(I-1))/(ANM1*(AN+ALFP1)) RJ(I) = -(RBET+AN*(AN-BETP2)*RJ(I-1))/(ANM1*(AN+BETP1)) ANM1 = AN AN = AN+0.1D+01 20 CONTINUE if ( INTEGR == 1) go to 70 if ( INTEGR == 3) go to 40 ! ! COMPUTE RG USING A FORWARD RECURRENCE RELATION. ! RG(1) = -RI(1)/ALFP1 RG(2) = -(RALF+RALF)/(ALFP2*ALFP2)-RG(1) AN = 0.2D+01 ANM1 = 0.1D+01 IM1 = 2 DO 30 I=3,25 RG(I) = -(AN*(AN-ALFP2)*RG(IM1)-AN*RI(IM1)+ANM1*RI(I))/ & (ANM1*(AN+ALFP1)) ANM1 = AN AN = AN+0.1D+01 IM1 = I 30 CONTINUE if ( INTEGR == 2) go to 70 ! ! COMPUTE RH USING A FORWARD RECURRENCE RELATION. ! 40 RH(1) = -RJ(1)/BETP1 RH(2) = -(RBET+RBET)/(BETP2*BETP2)-RH(1) AN = 0.2D+01 ANM1 = 0.1D+01 IM1 = 2 DO 50 I=3,25 RH(I) = -(AN*(AN-BETP2)*RH(IM1)-AN*RJ(IM1)+ & ANM1*RJ(I))/(ANM1*(AN+BETP1)) ANM1 = AN AN = AN+0.1D+01 IM1 = I 50 CONTINUE DO 60 I=2,25,2 RH(I) = -RH(I) 60 CONTINUE 70 DO 80 I=2,25,2 RJ(I) = -RJ(I) 80 CONTINUE return end subroutine DQNC79 (FUN, A, B, ERR, ANS, IERR, K) ! !! DQNC79 integrates a function using a 7-point adaptive Newton-Cotes rule. ! !***LIBRARY SLATEC !***CATEGORY H2A1A1 !***TYPE DOUBLE PRECISION (QNC79-S, DQNC79-D) !***KEYWORDS ADAPTIVE QUADRATURE, INTEGRATION, NEWTON-COTES !***AUTHOR Kahaner, D. K., (NBS) ! Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract *** a DOUBLE PRECISION routine *** ! DQNC79 is a general purpose program for evaluation of ! one dimensional integrals of user defined functions. ! DQNC79 will pick its own points for evaluation of the ! integrand and these will vary from problem to problem. ! Thus, DQNC79 is not designed to integrate over data sets. ! Moderately smooth integrands will be integrated efficiently ! and reliably. For problems with strong singularities, ! oscillations etc., the user may wish to use more sophis- ! ticated routines such as those in QUADPACK. One measure ! of the reliability of DQNC79 is the output parameter K, ! giving the number of integrand evaluations that were needed. ! ! Description of Arguments ! ! --Input--* FUN, A, B, ERR are DOUBLE PRECISION * ! FUN - name of external function to be integrated. This name ! must be in an EXTERNAL statement in your calling ! program. You must write a Fortran function to evaluate ! FUN. This should be of the form ! DOUBLE PRECISION FUNCTION FUN (X) ! C ! C X can vary from A to B ! C FUN(X) should be finite for all X on interval. ! C ! FUN = ... ! return ! END ! A - lower limit of integration ! B - upper limit of integration (may be less than A) ! ERR - is a requested error tolerance. Normally, pick a value ! 0 < ERR < 1.0D-8. ! ! --Output-- ! ANS - computed value of the integral. Hopefully, ANS is ! accurate to within ERR * integral of ABS(FUN(X)). ! IERR - a status code ! - Normal codes ! 1 ANS most likely meets requested error tolerance. ! -1 A equals B, or A and B are too nearly equal to ! allow normal integration. ANS is set to zero. ! - Abnormal code ! 2 ANS probably does not meet requested error tolerance. ! K - the number of function evaluations actually used to do ! the integration. A value of K > 1000 indicates a ! difficult problem; other programs may be more efficient. ! DQNC79 will gracefully give up if K exceeds 2000. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, I1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920218 Code redone to parallel QNC79. (WRB) ! 930120 Increase array size 80->99, and KMX 2000->5000 for SUN -r8 ! wordlength. (RWC) !***END PROLOGUE DQNC79 ! .. Scalar Arguments .. DOUBLE PRECISION A, ANS, B, ERR INTEGER IERR, K ! .. Function Arguments .. DOUBLE PRECISION FUN EXTERNAL FUN ! .. Local Scalars .. DOUBLE PRECISION AE, AREA, BANK, BLOCAL, C, CE, EE, EF, EPS, Q13, & Q7, Q7L, SQ2, TEST, TOL, VR, W1, W2, W3, W4 INTEGER I, KML, KMX, L, LMN, LMX, NBITS, NIB, NLMN, NLMX LOGICAL FIRST ! .. Local Arrays .. DOUBLE PRECISION AA(99), F(13), F1(99), F2(99), F3(99), F4(99), & F5(99), F6(99), F7(99), HH(99), Q7R(99), VL(99) INTEGER LR(99) ! .. External Functions .. DOUBLE PRECISION D1MACH INTEGER I1MACH EXTERNAL D1MACH, I1MACH ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, LOG, MAX, MIN, SIGN, SQRT ! .. Save statement .. SAVE NBITS, NLMX, FIRST, SQ2, W1, W2, W3, W4 ! .. Data statements .. DATA KML /7/, KMX /5000/, NLMN /2/ DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DQNC79 if (FIRST) THEN W1 = 41.0D0/140.0D0 W2 = 216.0D0/140.0D0 W3 = 27.0D0/140.0D0 W4 = 272.0D0/140.0D0 NBITS = D1MACH(5)*I1MACH(14)/0.30102000D0 NLMX = MIN(99,(NBITS*4)/5) SQ2 = SQRT(2.0D0) end if FIRST = .FALSE. ANS = 0.0D0 IERR = 1 CE = 0.0D0 if (A == B) go to 260 LMX = NLMX LMN = NLMN if (B == 0.0D0) go to 100 if (SIGN(1.0D0,B)*A <= 0.0D0) go to 100 C = ABS(1.0D0-A/B) if (C > 0.1D0) go to 100 if (C <= 0.0D0) go to 260 NIB = 0.5D0 - LOG(C)/LOG(2.0D0) LMX = MIN(NLMX,NBITS-NIB-4) if (LMX < 2) go to 260 LMN = MIN(LMN,LMX) 100 TOL = MAX(ABS(ERR),2.0D0**(5-NBITS)) if (ERR == 0.0D0) TOL = SQRT(D1MACH(4)) EPS = TOL HH(1) = (B-A)/12.0D0 AA(1) = A LR(1) = 1 DO 110 I = 1,11,2 F(I) = FUN(A+(I-1)*HH(1)) 110 CONTINUE BLOCAL = B F(13) = FUN(BLOCAL) K = 7 L = 1 AREA = 0.0D0 Q7 = 0.0D0 EF = 256.0D0/255.0D0 BANK = 0.0D0 ! ! Compute refined estimates, estimate the error, etc. ! 120 DO 130 I = 2,12,2 F(I) = FUN(AA(L)+(I-1)*HH(L)) 130 CONTINUE K = K + 6 ! ! Compute left and right half estimates ! Q7L = HH(L)*((W1*(F(1)+F(7))+W2*(F(2)+F(6)))+ & (W3*(F(3)+F(5))+W4*F(4))) Q7R(L) = HH(L)*((W1*(F(7)+F(13))+W2*(F(8)+F(12)))+ & (W3*(F(9)+F(11))+W4*F(10))) ! ! Update estimate of integral of absolute value ! AREA = AREA + (ABS(Q7L)+ABS(Q7R(L))-ABS(Q7)) ! ! Do not bother to test convergence before minimum refinement level ! if (L < LMN) go to 180 ! ! Estimate the error in new value for whole interval, Q13 ! Q13 = Q7L + Q7R(L) EE = ABS(Q7-Q13)*EF ! ! Compute nominal allowed error ! AE = EPS*AREA ! ! Borrow from bank account, but not too much ! TEST = MIN(AE+0.8D0*BANK,10.0D0*AE) ! ! Don't ask for excessive accuracy ! TEST = MAX(TEST,TOL*ABS(Q13),0.00003D0*TOL*AREA) ! ! Now, did this interval pass or not? ! if (EE-TEST) 150,150,170 ! ! Have hit maximum refinement level -- penalize the cumulative error ! 140 CE = CE + (Q7-Q13) go to 160 ! ! On good intervals accumulate the theoretical estimate ! 150 CE = CE + (Q7-Q13)/255.0D0 ! ! Update the bank account. Don't go into debt. ! 160 BANK = BANK + (AE-EE) if (BANK < 0.0D0) BANK = 0.0D0 ! ! Did we just finish a left half or a right half? ! if (LR(L)) 190,190,210 ! ! Consider the left half of next deeper level ! 170 if (K > KMX) LMX = MIN(KML,LMX) if (L >= LMX) go to 140 180 L = L + 1 EPS = EPS*0.5D0 if (L <= 17) EF = EF/SQ2 HH(L) = HH(L-1)*0.5D0 LR(L) = -1 AA(L) = AA(L-1) Q7 = Q7L F1(L) = F(7) F2(L) = F(8) F3(L) = F(9) F4(L) = F(10) F5(L) = F(11) F6(L) = F(12) F7(L) = F(13) F(13) = F(7) F(11) = F(6) F(9) = F(5) F(7) = F(4) F(5) = F(3) F(3) = F(2) go to 120 ! ! Proceed to right half at this level ! 190 VL(L) = Q13 200 Q7 = Q7R(L-1) LR(L) = 1 AA(L) = AA(L) + 12.0D0*HH(L) F(1) = F1(L) F(3) = F2(L) F(5) = F3(L) F(7) = F4(L) F(9) = F5(L) F(11) = F6(L) F(13) = F7(L) go to 120 ! ! Left and right halves are done, so go back up a level ! 210 VR = Q13 220 if (L <= 1) go to 250 if (L <= 17) EF = EF*SQ2 EPS = EPS*2.0D0 L = L - 1 if (LR(L)) 230,230,240 230 VL(L) = VL(L+1) + VR go to 200 240 VR = VL(L+1) + VR go to 220 ! ! Exit ! 250 ANS = VR if (ABS(CE) <= 2.0D0*TOL*AREA) go to 270 IERR = 2 call XERMSG ('SLATEC', 'DQNC79', & 'ANS is probably insufficiently accurate.', 2, 1) go to 270 260 IERR = -1 call XERMSG ('SLATEC', 'DQNC79', & 'A and B are too nearly equal to allow normal integration. $$' & // 'ANS is set to zero and IERR to -1.', -1, -1) 270 RETURN end subroutine DQNG (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, NEVAL, IER) ! !! DQNG approximates the integral of a function over a finite interval. ! !***PURPOSE The routine calculates an approximation result to a ! given definite integral I = integral of F over (A,B), ! hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A1 !***TYPE DOUBLE PRECISION (QNG-S, DQNG-D) !***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD(PATTERSON) RULES, ! NONADAPTIVE, QUADPACK, QUADRATURE, SMOOTH INTEGRAND !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! NON-ADAPTIVE INTEGRATION ! STANDARD FORTRAN SUBROUTINE ! DOUBLE PRECISION VERSION ! ! F - Double precision ! Function subprogram defining the integrand function ! F(X). The actual name for F needs to be declared ! E X T E R N A L in the driver program. ! ! A - Double precision ! Lower limit of integration ! ! B - Double precision ! Upper limit of integration ! ! EPSABS - Double precision ! Absolute accuracy requested ! EPSREL - Double precision ! Relative accuracy requested ! If EPSABS <= 0 ! And EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! The routine will end with IER = 6. ! ! ON RETURN ! RESULT - Double precision ! Approximation to the integral I ! Result is obtained by applying the 21-POINT ! GAUSS-KRONROD RULE (RES21) obtained by optimal ! addition of abscissae to the 10-POINT GAUSS RULE ! (RES10), or by applying the 43-POINT RULE (RES43) ! obtained by optimal addition of abscissae to the ! 21-POINT GAUSS-KRONROD RULE, or by applying the ! 87-POINT RULE (RES87) obtained by optimal addition ! of abscissae to the 43-POINT RULE. ! ! ABSERR - Double precision ! Estimate of the modulus of the absolute error, ! which should EQUAL or EXCEED ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - IER = 0 normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine. It is ! assumed that the requested accuracy has ! not been achieved. ! ERROR MESSAGES ! IER = 1 The maximum number of steps has been ! executed. The integral is probably too ! difficult to be calculated by DQNG. ! = 6 The input is invalid, because ! EPSABS <= 0 AND ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28). ! RESULT, ABSERR and NEVAL are set to zero. ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE DQNG ! DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, & D1MACH,EPMACH,EPSABS,EPSREL,F,FCENTR,FVAL,FVAL1,FVAL2,FV1,FV2, & FV3,FV4,HLGTH,RESULT,RES10,RES21,RES43,RES87,RESABS,RESASC, & RESKH,SAVFUN,UFLOW,W10,W21A,W21B,W43A,W43B,W87A,W87B,X1,X2,X3,X4 INTEGER IER,IPX,K,L,NEVAL EXTERNAL F ! DIMENSION FV1(5),FV2(5),FV3(5),FV4(5),X1(5),X2(5),X3(11),X4(22), & W10(5),W21A(5),W21B(6),W43A(10),W43B(12),W87A(21),W87B(23), & SAVFUN(21) ! ! THE FOLLOWING DATA STATEMENTS CONTAIN THE ! ABSCISSAE AND WEIGHTS OF THE INTEGRATION RULES USED. ! ! X1 ABSCISSAE COMMON TO THE 10-, 21-, 43- AND 87- ! POINT RULE ! X2 ABSCISSAE COMMON TO THE 21-, 43- AND 87-POINT RULE ! X3 ABSCISSAE COMMON TO THE 43- AND 87-POINT RULE ! X4 ABSCISSAE OF THE 87-POINT RULE ! W10 WEIGHTS OF THE 10-POINT FORMULA ! W21A WEIGHTS OF THE 21-POINT FORMULA FOR ABSCISSAE X1 ! W21B WEIGHTS OF THE 21-POINT FORMULA FOR ABSCISSAE X2 ! W43A WEIGHTS OF THE 43-POINT FORMULA FOR ABSCISSAE X1, X3 ! W43B WEIGHTS OF THE 43-POINT FORMULA FOR ABSCISSAE X3 ! W87A WEIGHTS OF THE 87-POINT FORMULA FOR ABSCISSAE X1, ! X2, X3 ! W87B WEIGHTS OF THE 87-POINT FORMULA FOR ABSCISSAE X4 ! ! ! GAUSS-KRONROD-PATTERSON QUADRATURE COEFFICIENTS FOR USE IN ! QUADPACK ROUTINE QNG. THESE COEFFICIENTS WERE CALCULATED WITH ! 101 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, BELL LABS, NOV 1981. ! SAVE X1, W10, X2, W21A, W21B, X3, W43A, W43B, X4, W87A, W87B DATA X1 ( 1) / 0.973906528517171720077964012084452D0 / DATA X1 ( 2) / 0.865063366688984510732096688423493D0 / DATA X1 ( 3) / 0.679409568299024406234327365114874D0 / DATA X1 ( 4) / 0.433395394129247190799265943165784D0 / DATA X1 ( 5) / 0.148874338981631210884826001129720D0 / DATA W10 ( 1) / 0.066671344308688137593568809893332D0 / DATA W10 ( 2) / 0.149451349150580593145776339657697D0 / DATA W10 ( 3) / 0.219086362515982043995534934228163D0 / DATA W10 ( 4) / 0.269266719309996355091226921569469D0 / DATA W10 ( 5) / 0.295524224714752870173892994651338D0 / ! DATA X2 ( 1) / 0.995657163025808080735527280689003D0 / DATA X2 ( 2) / 0.930157491355708226001207180059508D0 / DATA X2 ( 3) / 0.780817726586416897063717578345042D0 / DATA X2 ( 4) / 0.562757134668604683339000099272694D0 / DATA X2 ( 5) / 0.294392862701460198131126603103866D0 / DATA W21A ( 1) / 0.032558162307964727478818972459390D0 / DATA W21A ( 2) / 0.075039674810919952767043140916190D0 / DATA W21A ( 3) / 0.109387158802297641899210590325805D0 / DATA W21A ( 4) / 0.134709217311473325928054001771707D0 / DATA W21A ( 5) / 0.147739104901338491374841515972068D0 / DATA W21B ( 1) / 0.011694638867371874278064396062192D0 / DATA W21B ( 2) / 0.054755896574351996031381300244580D0 / DATA W21B ( 3) / 0.093125454583697605535065465083366D0 / DATA W21B ( 4) / 0.123491976262065851077958109831074D0 / DATA W21B ( 5) / 0.142775938577060080797094273138717D0 / DATA W21B ( 6) / 0.149445554002916905664936468389821D0 / ! DATA X3 ( 1) / 0.999333360901932081394099323919911D0 / DATA X3 ( 2) / 0.987433402908088869795961478381209D0 / DATA X3 ( 3) / 0.954807934814266299257919200290473D0 / DATA X3 ( 4) / 0.900148695748328293625099494069092D0 / DATA X3 ( 5) / 0.825198314983114150847066732588520D0 / DATA X3 ( 6) / 0.732148388989304982612354848755461D0 / DATA X3 ( 7) / 0.622847970537725238641159120344323D0 / DATA X3 ( 8) / 0.499479574071056499952214885499755D0 / DATA X3 ( 9) / 0.364901661346580768043989548502644D0 / DATA X3 ( 10) / 0.222254919776601296498260928066212D0 / DATA X3 ( 11) / 0.074650617461383322043914435796506D0 / DATA W43A ( 1) / 0.016296734289666564924281974617663D0 / DATA W43A ( 2) / 0.037522876120869501461613795898115D0 / DATA W43A ( 3) / 0.054694902058255442147212685465005D0 / DATA W43A ( 4) / 0.067355414609478086075553166302174D0 / DATA W43A ( 5) / 0.073870199632393953432140695251367D0 / DATA W43A ( 6) / 0.005768556059769796184184327908655D0 / DATA W43A ( 7) / 0.027371890593248842081276069289151D0 / DATA W43A ( 8) / 0.046560826910428830743339154433824D0 / DATA W43A ( 9) / 0.061744995201442564496240336030883D0 / DATA W43A ( 10) / 0.071387267268693397768559114425516D0 / DATA W43B ( 1) / 0.001844477640212414100389106552965D0 / DATA W43B ( 2) / 0.010798689585891651740465406741293D0 / DATA W43B ( 3) / 0.021895363867795428102523123075149D0 / DATA W43B ( 4) / 0.032597463975345689443882222526137D0 / DATA W43B ( 5) / 0.042163137935191811847627924327955D0 / DATA W43B ( 6) / 0.050741939600184577780189020092084D0 / DATA W43B ( 7) / 0.058379395542619248375475369330206D0 / DATA W43B ( 8) / 0.064746404951445885544689259517511D0 / DATA W43B ( 9) / 0.069566197912356484528633315038405D0 / DATA W43B ( 10) / 0.072824441471833208150939535192842D0 / DATA W43B ( 11) / 0.074507751014175118273571813842889D0 / DATA W43B ( 12) / 0.074722147517403005594425168280423D0 / ! DATA X4 ( 1) / 0.999902977262729234490529830591582D0 / DATA X4 ( 2) / 0.997989895986678745427496322365960D0 / DATA X4 ( 3) / 0.992175497860687222808523352251425D0 / DATA X4 ( 4) / 0.981358163572712773571916941623894D0 / DATA X4 ( 5) / 0.965057623858384619128284110607926D0 / DATA X4 ( 6) / 0.943167613133670596816416634507426D0 / DATA X4 ( 7) / 0.915806414685507209591826430720050D0 / DATA X4 ( 8) / 0.883221657771316501372117548744163D0 / DATA X4 ( 9) / 0.845710748462415666605902011504855D0 / DATA X4 ( 10) / 0.803557658035230982788739474980964D0 / DATA X4 ( 11) / 0.757005730685495558328942793432020D0 / DATA X4 ( 12) / 0.706273209787321819824094274740840D0 / DATA X4 ( 13) / 0.651589466501177922534422205016736D0 / DATA X4 ( 14) / 0.593223374057961088875273770349144D0 / DATA X4 ( 15) / 0.531493605970831932285268948562671D0 / DATA X4 ( 16) / 0.466763623042022844871966781659270D0 / DATA X4 ( 17) / 0.399424847859218804732101665817923D0 / DATA X4 ( 18) / 0.329874877106188288265053371824597D0 / DATA X4 ( 19) / 0.258503559202161551802280975429025D0 / DATA X4 ( 20) / 0.185695396568346652015917141167606D0 / DATA X4 ( 21) / 0.111842213179907468172398359241362D0 / DATA X4 ( 22) / 0.037352123394619870814998165437704D0 / DATA W87A ( 1) / 0.008148377384149172900002878448190D0 / DATA W87A ( 2) / 0.018761438201562822243935059003794D0 / DATA W87A ( 3) / 0.027347451050052286161582829741283D0 / DATA W87A ( 4) / 0.033677707311637930046581056957588D0 / DATA W87A ( 5) / 0.036935099820427907614589586742499D0 / DATA W87A ( 6) / 0.002884872430211530501334156248695D0 / DATA W87A ( 7) / 0.013685946022712701888950035273128D0 / DATA W87A ( 8) / 0.023280413502888311123409291030404D0 / DATA W87A ( 9) / 0.030872497611713358675466394126442D0 / DATA W87A ( 10) / 0.035693633639418770719351355457044D0 / DATA W87A ( 11) / 0.000915283345202241360843392549948D0 / DATA W87A ( 12) / 0.005399280219300471367738743391053D0 / DATA W87A ( 13) / 0.010947679601118931134327826856808D0 / DATA W87A ( 14) / 0.016298731696787335262665703223280D0 / DATA W87A ( 15) / 0.021081568889203835112433060188190D0 / DATA W87A ( 16) / 0.025370969769253827243467999831710D0 / DATA W87A ( 17) / 0.029189697756475752501446154084920D0 / DATA W87A ( 18) / 0.032373202467202789685788194889595D0 / DATA W87A ( 19) / 0.034783098950365142750781997949596D0 / DATA W87A ( 20) / 0.036412220731351787562801163687577D0 / DATA W87A ( 21) / 0.037253875503047708539592001191226D0 / DATA W87B ( 1) / 0.000274145563762072350016527092881D0 / DATA W87B ( 2) / 0.001807124155057942948341311753254D0 / DATA W87B ( 3) / 0.004096869282759164864458070683480D0 / DATA W87B ( 4) / 0.006758290051847378699816577897424D0 / DATA W87B ( 5) / 0.009549957672201646536053581325377D0 / DATA W87B ( 6) / 0.012329447652244853694626639963780D0 / DATA W87B ( 7) / 0.015010447346388952376697286041943D0 / DATA W87B ( 8) / 0.017548967986243191099665352925900D0 / DATA W87B ( 9) / 0.019938037786440888202278192730714D0 / DATA W87B ( 10) / 0.022194935961012286796332102959499D0 / DATA W87B ( 11) / 0.024339147126000805470360647041454D0 / DATA W87B ( 12) / 0.026374505414839207241503786552615D0 / DATA W87B ( 13) / 0.028286910788771200659968002987960D0 / DATA W87B ( 14) / 0.030052581128092695322521110347341D0 / DATA W87B ( 15) / 0.031646751371439929404586051078883D0 / DATA W87B ( 16) / 0.033050413419978503290785944862689D0 / DATA W87B ( 17) / 0.034255099704226061787082821046821D0 / DATA W87B ( 18) / 0.035262412660156681033782717998428D0 / DATA W87B ( 19) / 0.036076989622888701185500318003895D0 / DATA W87B ( 20) / 0.036698604498456094498018047441094D0 / DATA W87B ( 21) / 0.037120549269832576114119958413599D0 / DATA W87B ( 22) / 0.037334228751935040321235449094698D0 / DATA W87B ( 23) / 0.037361073762679023410321241766599D0 / ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTEGRATION INTERVAL ! HLGTH - HALF-LENGTH OF THE INTEGRATION INTERVAL ! FCENTR - FUNCTION VALUE AT MID POINT ! ABSC - ABSCISSA ! FVAL - FUNCTION VALUE ! SAVFUN - ARRAY OF FUNCTION VALUES WHICH HAVE ALREADY BEEN ! COMPUTED ! RES10 - 10-POINT GAUSS RESULT ! RES21 - 21-POINT KRONROD RESULT ! RES43 - 43-POINT RESULT ! RES87 - 87-POINT RESULT ! RESABS - APPROXIMATION TO THE INTEGRAL OF ABS(F) ! RESASC - APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A)) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT DQNG EPMACH = D1MACH(4) UFLOW = D1MACH(1) ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! RESULT = 0.0D+00 ABSERR = 0.0D+00 NEVAL = 0 IER = 6 if ( EPSABS <= 0.0D+00.AND.EPSREL < MAX(0.5D+02*EPMACH,0.5D-28)) & go to 80 HLGTH = 0.5D+00*(B-A) DHLGTH = ABS(HLGTH) CENTR = 0.5D+00*(B+A) FCENTR = F(CENTR) NEVAL = 21 IER = 1 ! ! COMPUTE THE INTEGRAL USING THE 10- AND 21-POINT FORMULA. ! DO 70 L = 1,3 go to (5,25,45),L 5 RES10 = 0.0D+00 RES21 = W21B(6)*FCENTR RESABS = W21B(6)*ABS(FCENTR) DO 10 K=1,5 ABSC = HLGTH*X1(K) FVAL1 = F(CENTR+ABSC) FVAL2 = F(CENTR-ABSC) FVAL = FVAL1+FVAL2 RES10 = RES10+W10(K)*FVAL RES21 = RES21+W21A(K)*FVAL RESABS = RESABS+W21A(K)*(ABS(FVAL1)+ABS(FVAL2)) SAVFUN(K) = FVAL FV1(K) = FVAL1 FV2(K) = FVAL2 10 CONTINUE IPX = 5 DO 15 K=1,5 IPX = IPX+1 ABSC = HLGTH*X2(K) FVAL1 = F(CENTR+ABSC) FVAL2 = F(CENTR-ABSC) FVAL = FVAL1+FVAL2 RES21 = RES21+W21B(K)*FVAL RESABS = RESABS+W21B(K)*(ABS(FVAL1)+ABS(FVAL2)) SAVFUN(IPX) = FVAL FV3(K) = FVAL1 FV4(K) = FVAL2 15 CONTINUE ! ! TEST FOR CONVERGENCE. ! RESULT = RES21*HLGTH RESABS = RESABS*DHLGTH RESKH = 0.5D+00*RES21 RESASC = W21B(6)*ABS(FCENTR-RESKH) DO 20 K = 1,5 RESASC = RESASC+W21A(K)*(ABS(FV1(K)-RESKH)+ABS(FV2(K)-RESKH)) & +W21B(K)*(ABS(FV3(K)-RESKH)+ABS(FV4(K)-RESKH)) 20 CONTINUE ABSERR = ABS((RES21-RES10)*HLGTH) RESASC = RESASC*DHLGTH go to 65 ! ! COMPUTE THE INTEGRAL USING THE 43-POINT FORMULA. ! 25 RES43 = W43B(12)*FCENTR NEVAL = 43 DO 30 K=1,10 RES43 = RES43+SAVFUN(K)*W43A(K) 30 CONTINUE DO 40 K=1,11 IPX = IPX+1 ABSC = HLGTH*X3(K) FVAL = F(ABSC+CENTR)+F(CENTR-ABSC) RES43 = RES43+FVAL*W43B(K) SAVFUN(IPX) = FVAL 40 CONTINUE ! ! TEST FOR CONVERGENCE. ! RESULT = RES43*HLGTH ABSERR = ABS((RES43-RES21)*HLGTH) go to 65 ! ! COMPUTE THE INTEGRAL USING THE 87-POINT FORMULA. ! 45 RES87 = W87B(23)*FCENTR NEVAL = 87 DO 50 K=1,21 RES87 = RES87+SAVFUN(K)*W87A(K) 50 CONTINUE DO 60 K=1,22 ABSC = HLGTH*X4(K) RES87 = RES87+W87B(K)*(F(ABSC+CENTR)+F(CENTR-ABSC)) 60 CONTINUE RESULT = RES87*HLGTH ABSERR = ABS((RES87-RES43)*HLGTH) 65 if ( RESASC /= 0.0D+00.AND.ABSERR /= 0.0D+00) & ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) if (RESABS > UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5D+02)*RESABS,ABSERR) if (ABSERR <= MAX(EPSABS,EPSREL*ABS(RESULT))) IER = 0 ! ***JUMP OUT OF DO-LOOP if (IER == 0) go to 999 70 CONTINUE 80 call XERMSG ('SLATEC', 'DQNG', 'ABNORMAL RETURN', IER, 0) 999 RETURN end subroutine DQPSRT (LIMIT, LAST, MAXERR, ERMAX, ELIST, IORD, NRMAX) ! !! DQPSRT sorts the local error estimates for a quadrature routine. ! !***SUBSIDIARY !***PURPOSE This routine maintains the descending ordering in the ! list of the local error estimated resulting from the ! interval subdivision process. At each call two error ! estimates are inserted using the sequential search ! method, top-down for the largest error estimate and ! bottom-up for the smallest error estimate. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QPSRT-S, DQPSRT-D) !***KEYWORDS SEQUENTIAL SORTING !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Ordering routine ! Standard fortran subroutine ! Double precision version ! ! PARAMETERS (MEANING AT OUTPUT) ! LIMIT - Integer ! Maximum number of error estimates the list ! can contain ! ! LAST - Integer ! Number of error estimates currently in the list ! ! MAXERR - Integer ! MAXERR points to the NRMAX-th largest error ! estimate currently in the list ! ! ERMAX - Double precision ! NRMAX-th largest error estimate ! ERMAX = ELIST(MAXERR) ! ! ELIST - Double precision ! Vector of dimension LAST containing ! the error estimates ! ! IORD - Integer ! Vector of dimension LAST, the first K elements ! of which contain pointers to the error ! estimates, such that ! ELIST(IORD(1)),..., ELIST(IORD(K)) ! form a decreasing sequence, with ! K = LAST if LAST <= (LIMIT/2+2), and ! K = LIMIT+1-LAST otherwise ! ! NRMAX - Integer ! MAXERR = IORD(NRMAX) ! !***SEE ALSO DQAGE, DQAGIE, DQAGPE, DQAWSE !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DQPSRT ! DOUBLE PRECISION ELIST,ERMAX,ERRMAX,ERRMIN INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR, & NRMAX DIMENSION ELIST(*),IORD(*) ! ! CHECK WHETHER THE LIST CONTAINS MORE THAN ! TWO ERROR ESTIMATES. ! !***FIRST EXECUTABLE STATEMENT DQPSRT if ( LAST > 2) go to 10 IORD(1) = 1 IORD(2) = 2 go to 90 ! ! THIS PART OF THE ROUTINE IS ONLY EXECUTED IF, DUE TO A ! DIFFICULT INTEGRAND, SUBDIVISION INCREASED THE ERROR ! ESTIMATE. IN THE NORMAL CASE THE INSERT PROCEDURE SHOULD ! START AFTER THE NRMAX-TH LARGEST ERROR ESTIMATE. ! 10 ERRMAX = ELIST(MAXERR) if ( NRMAX == 1) go to 30 IDO = NRMAX-1 DO 20 I = 1,IDO ISUCC = IORD(NRMAX-1) ! ***JUMP OUT OF DO-LOOP if ( ERRMAX <= ELIST(ISUCC)) go to 30 IORD(NRMAX) = ISUCC NRMAX = NRMAX-1 20 CONTINUE ! ! COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO BE MAINTAINED ! IN DESCENDING ORDER. THIS NUMBER DEPENDS ON THE NUMBER OF ! SUBDIVISIONS STILL ALLOWED. ! 30 JUPBN = LAST if ( LAST > (LIMIT/2+2)) JUPBN = LIMIT+3-LAST ERRMIN = ELIST(LAST) ! ! INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN, ! STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)). ! JBND = JUPBN-1 IBEG = NRMAX+1 if ( IBEG > JBND) go to 50 DO 40 I=IBEG,JBND ISUCC = IORD(I) ! ***JUMP OUT OF DO-LOOP if ( ERRMAX >= ELIST(ISUCC)) go to 60 IORD(I-1) = ISUCC 40 CONTINUE 50 IORD(JBND) = MAXERR IORD(JUPBN) = LAST go to 90 ! ! INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP. ! 60 IORD(I-1) = MAXERR K = JBND DO 70 J=I,JBND ISUCC = IORD(K) ! ***JUMP OUT OF DO-LOOP if ( ERRMIN < 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 ! ! SET MAXERR AND ERMAX. ! 90 MAXERR = IORD(NRMAX) ERMAX = ELIST(MAXERR) return end subroutine DQRDC (X, LDX, N, P, QRAUX, JPVT, WORK, JOB) ! !! DQRDC computes the QR factorization of a rectangular matrix. ! Column pivoting is an option. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D5 !***TYPE DOUBLE PRECISION (SQRDC-S, DQRDC-D, CQRDC-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, ! QR DECOMPOSITION !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! DQRDC uses Householder transformations to compute the QR ! factorization of an N by P matrix X. Column pivoting ! based on the 2-norms of the reduced columns may be ! performed at the user's option. ! ! On Entry ! ! X DOUBLE PRECISION(LDX,P), where LDX >= N. ! X contains the matrix whose decomposition is to be ! computed. ! ! LDX INTEGER. ! LDX is the leading dimension of the array X. ! ! N INTEGER. ! N is the number of rows of the matrix X. ! ! P INTEGER. ! P is the number of columns of the matrix X. ! ! JPVT INTEGER(P). ! JPVT contains integers that control the selection ! of the pivot columns. The K-th column X(K) of X ! is placed in one of three classes according to the ! value of JPVT(K). ! ! If JPVT(K) > 0, then X(K) is an initial ! column. ! ! If JPVT(K) == 0, then X(K) is a free column. ! ! If JPVT(K) < 0, then X(K) is a final column. ! ! Before the decomposition is computed, initial columns ! are moved to the beginning of the array X and final ! columns to the end. Both initial and final columns ! are frozen in place during the computation and only ! free columns are moved. At the K-th stage of the ! reduction, if X(K) is occupied by a free column ! it is interchanged with the free column of largest ! reduced norm. JPVT is not referenced if ! JOB == 0. ! ! WORK DOUBLE PRECISION(P). ! WORK is a work array. WORK is not referenced if ! JOB == 0. ! ! JOB INTEGER. ! JOB is an integer that initiates column pivoting. ! If JOB == 0, no pivoting is done. ! If JOB /= 0, pivoting is done. ! ! On Return ! ! X X contains in its upper triangle the upper ! triangular matrix R of the QR factorization. ! Below its diagonal X contains information from ! which the orthogonal part of the decomposition ! can be recovered. Note that if pivoting has ! been requested, the decomposition is not that ! of the original matrix X but that of X ! with its columns permuted as described by JPVT. ! ! QRAUX DOUBLE PRECISION(P). ! QRAUX contains further information required to recover ! the orthogonal part of the decomposition. ! ! JPVT JPVT(K) contains the index of the column of the ! original matrix that has been interchanged into ! the K-th column, if pivoting was requested. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT, DNRM2, DSCAL, DSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DQRDC INTEGER LDX,N,P,JOB INTEGER JPVT(*) DOUBLE PRECISION X(LDX,*),QRAUX(*),WORK(*) ! INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU DOUBLE PRECISION MAXNRM,DNRM2,TT DOUBLE PRECISION DDOT,NRMXL,T LOGICAL NEGJ,SWAPJ ! !***FIRST EXECUTABLE STATEMENT DQRDC PL = 1 PU = 0 if (JOB == 0) go to 60 ! ! PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS ! ACCORDING TO JPVT. ! DO 20 J = 1, P SWAPJ = JPVT(J) > 0 NEGJ = JPVT(J) < 0 JPVT(J) = J if (NEGJ) JPVT(J) = -J if (.NOT.SWAPJ) go to 10 if (J /= PL) call DSWAP(N,X(1,PL),1,X(1,J),1) JPVT(J) = JPVT(PL) JPVT(PL) = J PL = PL + 1 10 CONTINUE 20 CONTINUE PU = P DO 50 JJ = 1, P J = P - JJ + 1 if (JPVT(J) >= 0) go to 40 JPVT(J) = -JPVT(J) if (J == PU) go to 30 call DSWAP(N,X(1,PU),1,X(1,J),1) JP = JPVT(PU) JPVT(PU) = JPVT(J) JPVT(J) = JP 30 CONTINUE PU = PU - 1 40 CONTINUE 50 CONTINUE 60 CONTINUE ! ! COMPUTE THE NORMS OF THE FREE COLUMNS. ! if (PU < PL) go to 80 DO 70 J = PL, PU QRAUX(J) = DNRM2(N,X(1,J),1) WORK(J) = QRAUX(J) 70 CONTINUE 80 CONTINUE ! ! PERFORM THE HOUSEHOLDER REDUCTION OF X. ! LUP = MIN(N,P) DO 200 L = 1, LUP if (L < PL .OR. L >= PU) go to 120 ! ! LOCATE THE COLUMN OF LARGEST NORM AND BRING IT ! INTO THE PIVOT POSITION. ! MAXNRM = 0.0D0 MAXJ = L DO 100 J = L, PU if (QRAUX(J) <= MAXNRM) go to 90 MAXNRM = QRAUX(J) MAXJ = J 90 CONTINUE 100 CONTINUE if (MAXJ == L) go to 110 call DSWAP(N,X(1,L),1,X(1,MAXJ),1) QRAUX(MAXJ) = QRAUX(L) WORK(MAXJ) = WORK(L) JP = JPVT(MAXJ) JPVT(MAXJ) = JPVT(L) JPVT(L) = JP 110 CONTINUE 120 CONTINUE QRAUX(L) = 0.0D0 if (L == N) go to 190 ! ! COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. ! NRMXL = DNRM2(N-L+1,X(L,L),1) if (NRMXL == 0.0D0) go to 180 if (X(L,L) /= 0.0D0) NRMXL = SIGN(NRMXL,X(L,L)) call DSCAL(N-L+1,1.0D0/NRMXL,X(L,L),1) X(L,L) = 1.0D0 + X(L,L) ! ! APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, ! UPDATING THE NORMS. ! LP1 = L + 1 if (P < LP1) go to 170 DO 160 J = LP1, P 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) if (J < PL .OR. J > PU) go to 150 if (QRAUX(J) == 0.0D0) go to 150 TT = 1.0D0 - (ABS(X(L,J))/QRAUX(J))**2 TT = MAX(TT,0.0D0) T = TT TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2 if (TT == 1.0D0) go to 130 QRAUX(J) = QRAUX(J)*SQRT(T) go to 140 130 CONTINUE QRAUX(J) = DNRM2(N-L,X(L+1,J),1) WORK(J) = QRAUX(J) 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE ! ! SAVE THE TRANSFORMATION. ! QRAUX(L) = X(L,L) X(L,L) = -NRMXL 180 CONTINUE 190 CONTINUE 200 CONTINUE return end subroutine DQRFAC (M, N, A, LDA, PIVOT, IPVT, LIPVT, SIGMA, & ACNORM, WA) ! !! DQRFAC computes the QR factorization of a rectangulr matrix. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DNLS1, DNLS1E, DNSQ and DNSQE !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QRFAC-S, DQRFAC-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! **** Double Precision version of QRFAC **** ! ! This subroutine uses Householder transformations with column ! pivoting (optional) to compute a QR factorization of the ! M by N matrix A. That is, DQRFAC determines an orthogonal ! matrix Q, a permutation matrix P, and an upper trapezoidal ! matrix R with diagonal elements of nonincreasing magnitude, ! such that A*P = Q*R. The Householder transformation for ! column K, K = 1,2,...,MIN(M,N), is of the form ! ! T ! I - (1/U(K))*U*U ! ! where U has zeros in the first K-1 positions. The form of ! this transformation and the method of pivoting first ! appeared in the corresponding LINPACK subroutine. ! ! The subroutine statement is ! ! SUBROUTINE DQRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,SIGMA,ACNORM,WA) ! ! where ! ! M is a positive integer input variable set to the number ! of rows of A. ! ! N is a positive integer input variable set to the number ! of columns of A. ! ! A is an M by N array. On input A contains the matrix for ! which the QR factorization is to be computed. On output ! the strict upper trapezoidal part of A contains the strict ! upper trapezoidal part of R, and the lower trapezoidal ! part of A contains a factored form of Q (the non-trivial ! elements of the U vectors described above). ! ! LDA is a positive integer input variable not less than M ! which specifies the leading dimension of the array A. ! ! PIVOT is a logical input variable. If pivot is set .TRUE., ! then column pivoting is enforced. If pivot is set .FALSE., ! then no column pivoting is done. ! ! IPVT is an integer output array of length LIPVT. IPVT ! defines the permutation matrix P such that A*P = Q*R. ! Column J of P is column IPVT(J) of the identity matrix. ! If pivot is .FALSE., IPVT is not referenced. ! ! LIPVT is a positive integer input variable. If PIVOT is ! .FALSE., then LIPVT may be as small as 1. If PIVOT is ! .TRUE., then LIPVT must be at least N. ! ! SIGMA is an output array of length N which contains the ! diagonal elements of R. ! ! ACNORM is an output array of length N which contains the ! norms of the corresponding columns of the input matrix A. ! If this information is not needed, then ACNORM can coincide ! with SIGMA. ! ! WA is a work array of length N. If pivot is .FALSE., then WA ! can coincide with SIGMA. ! !***SEE ALSO DNLS1, DNLS1E, DNSQ, DNSQE !***ROUTINES CALLED D1MACH, DENORM !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DQRFAC INTEGER M,N,LDA,LIPVT INTEGER IPVT(*) LOGICAL PIVOT SAVE ONE, P05, ZERO DOUBLE PRECISION A(LDA,*),SIGMA(*),ACNORM(*),WA(*) INTEGER I,J,JP1,K,KMAX,MINMN DOUBLE PRECISION AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO DOUBLE PRECISION D1MACH,DENORM DATA ONE,P05,ZERO /1.0D0,5.0D-2,0.0D0/ !***FIRST EXECUTABLE STATEMENT DQRFAC EPSMCH = D1MACH(4) ! ! COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. ! DO 10 J = 1, N ACNORM(J) = DENORM(M,A(1,J)) SIGMA(J) = ACNORM(J) WA(J) = SIGMA(J) if (PIVOT) IPVT(J) = J 10 CONTINUE ! ! REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. ! MINMN = MIN(M,N) DO 110 J = 1, MINMN if (.NOT.PIVOT) go to 40 ! ! BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. ! KMAX = J DO 20 K = J, N if (SIGMA(K) > SIGMA(KMAX)) KMAX = K 20 CONTINUE if (KMAX == 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 SIGMA(KMAX) = SIGMA(J) WA(KMAX) = WA(J) K = IPVT(J) IPVT(J) = IPVT(KMAX) IPVT(KMAX) = K 40 CONTINUE ! ! COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE ! J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. ! AJNORM = DENORM(M-J+1,A(J,J)) if (AJNORM == ZERO) go to 100 if (A(J,J) < ZERO) AJNORM = -AJNORM DO 50 I = J, M A(I,J) = A(I,J)/AJNORM 50 CONTINUE A(J,J) = A(J,J) + ONE ! ! APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS ! AND UPDATE THE NORMS. ! JP1 = J + 1 if (N < 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. SIGMA(K) == ZERO) go to 80 TEMP = A(J,K)/SIGMA(K) SIGMA(K) = SIGMA(K)*SQRT(MAX(ZERO,ONE-TEMP**2)) if (P05*(SIGMA(K)/WA(K))**2 > EPSMCH) go to 80 SIGMA(K) = DENORM(M-J,A(JP1,K)) WA(K) = SIGMA(K) 80 CONTINUE 90 CONTINUE 100 CONTINUE SIGMA(J) = -AJNORM 110 CONTINUE return ! ! LAST CARD OF SUBROUTINE DQRFAC. ! end subroutine DQRSL (X, LDX, N, K, QRAUX, Y, QY, QTY, B, RSD, XB, & JOB, INFO) ! !! DQRSL applies the output of DQRDC to compute coordinate transformations, ... ! projections, and least squares solutions. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D9, D2A1 !***TYPE DOUBLE PRECISION (SQRSL-S, DQRSL-D, CQRSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, ! SOLVE !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! DQRSL applies the output of DQRDC to compute coordinate ! transformations, projections, and least squares solutions. ! For K <= MIN(N,P), let XK be the matrix ! ! XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) ! ! formed from columns JPVT(1), ... ,JPVT(K) of the original ! N X P matrix X that was input to DQRDC (if no pivoting was ! done, XK consists of the first K columns of X in their ! original order). DQRDC produces a factored orthogonal matrix Q ! and an upper triangular matrix R such that ! ! XK = Q * (R) ! (0) ! ! This information is contained in coded form in the arrays ! X and QRAUX. ! ! On Entry ! ! X DOUBLE PRECISION(LDX,P). ! X contains the output of DQRDC. ! ! LDX INTEGER. ! LDX is the leading dimension of the array X. ! ! N INTEGER. ! N is the number of rows of the matrix XK. It must ! have the same value as N in DQRDC. ! ! K INTEGER. ! K is the number of columns of the matrix XK. K ! must not be greater than MIN(N,P), where P is the ! same as in the calling sequence to DQRDC. ! ! QRAUX DOUBLE PRECISION(P). ! QRAUX contains the auxiliary output from DQRDC. ! ! Y DOUBLE PRECISION(N) ! Y contains an N-vector that is to be manipulated ! by DQRSL. ! ! JOB INTEGER. ! JOB specifies what is to be computed. JOB has ! the decimal expansion ABCDE, with the following ! meaning. ! ! If A /= 0, compute QY. ! If B,C,D, or E /= 0, compute QTY. ! If C /= 0, compute B. ! If D /= 0, compute RSD. ! If E /= 0, compute XB. ! ! Note that a request to compute B, RSD, or XB ! automatically triggers the computation of QTY, for ! which an array must be provided in the calling ! sequence. ! ! On Return ! ! QY DOUBLE PRECISION(N). ! QY contains Q*Y, if its computation has been ! requested. ! ! QTY DOUBLE PRECISION(N). ! QTY contains TRANS(Q)*Y, if its computation has ! been requested. Here TRANS(Q) is the ! transpose of the matrix Q. ! ! B DOUBLE PRECISION(K) ! B contains the solution of the least squares problem ! ! minimize norm2(Y - XK*B), ! ! if its computation has been requested. (Note that ! if pivoting was requested in DQRDC, the J-th ! component of B will be associated with column JPVT(J) ! of the original matrix X that was input into DQRDC.) ! ! RSD DOUBLE PRECISION(N). ! RSD contains the least squares residual Y - XK*B, ! if its computation has been requested. RSD is ! also the orthogonal projection of Y onto the ! orthogonal complement of the column space of XK. ! ! XB DOUBLE PRECISION(N). ! XB contains the least squares approximation XK*B, ! if its computation has been requested. XB is also ! the orthogonal projection of Y onto the column space ! of X. ! ! INFO INTEGER. ! INFO is zero unless the computation of B has ! been requested and R is exactly singular. In ! this case, INFO is the index of the first zero ! diagonal element of R and B is left unaltered. ! ! The parameters QY, QTY, B, RSD, and XB are not referenced ! if their computation is not requested and in this case ! can be replaced by dummy variables in the calling program. ! To save storage, the user may in some cases use the same ! array for different parameters in the calling sequence. A ! frequently occurring example is when one wishes to compute ! any of B, RSD, or XB and does not need Y or QTY. In this ! case one may identify Y, QTY, and one of B, RSD, or XB, while ! providing separate arrays for anything else that is to be ! computed. Thus the calling sequence ! ! call DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) ! ! will result in the computation of B and RSD, with RSD ! overwriting Y. More generally, each item in the following ! list contains groups of permissible identifications for ! a single calling sequence. ! ! 1. (Y,QTY,B) (RSD) (XB) (QY) ! ! 2. (Y,QTY,RSD) (B) (XB) (QY) ! ! 3. (Y,QTY,XB) (B) (RSD) (QY) ! ! 4. (Y,QY) (QTY,B) (RSD) (XB) ! ! 5. (Y,QY) (QTY,RSD) (B) (XB) ! ! 6. (Y,QY) (QTY,XB) (B) (RSD) ! ! In any group the value returned in the array allocated to ! the group corresponds to the last member of the group. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DCOPY, DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DQRSL INTEGER LDX,N,K,JOB,INFO DOUBLE PRECISION X(LDX,*),QRAUX(*),Y(*),QY(*),QTY(*),B(*),RSD(*), & XB(*) ! INTEGER I,J,JJ,JU,KP1 DOUBLE PRECISION DDOT,T,TEMP LOGICAL CB,CQY,CQTY,CR,CXB !***FIRST EXECUTABLE STATEMENT DQRSL ! ! SET INFO FLAG. ! INFO = 0 ! ! DETERMINE WHAT IS TO BE COMPUTED. ! CQY = JOB/10000 /= 0 CQTY = MOD(JOB,10000) /= 0 CB = MOD(JOB,1000)/100 /= 0 CR = MOD(JOB,100)/10 /= 0 CXB = MOD(JOB,10) /= 0 JU = MIN(K,N-1) ! ! SPECIAL ACTION WHEN N=1. ! if (JU /= 0) go to 40 if (CQY) QY(1) = Y(1) if (CQTY) QTY(1) = Y(1) if (CXB) XB(1) = Y(1) if (.NOT.CB) go to 30 if (X(1,1) /= 0.0D0) go to 10 INFO = 1 go to 20 10 CONTINUE B(1) = Y(1)/X(1,1) 20 CONTINUE 30 CONTINUE if (CR) RSD(1) = 0.0D0 go to 250 40 CONTINUE ! ! SET UP TO COMPUTE QY OR QTY. ! if (CQY) call DCOPY(N,Y,1,QY,1) if (CQTY) call DCOPY(N,Y,1,QTY,1) if (.NOT.CQY) go to 70 ! ! COMPUTE QY. ! DO 60 JJ = 1, JU J = JU - JJ + 1 if (QRAUX(J) == 0.0D0) go to 50 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -DDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) call DAXPY(N-J+1,T,X(J,J),1,QY(J),1) X(J,J) = TEMP 50 CONTINUE 60 CONTINUE 70 CONTINUE if (.NOT.CQTY) go to 100 ! ! COMPUTE TRANS(Q)*Y. ! DO 90 J = 1, JU if (QRAUX(J) == 0.0D0) go to 80 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -DDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) call DAXPY(N-J+1,T,X(J,J),1,QTY(J),1) X(J,J) = TEMP 80 CONTINUE 90 CONTINUE 100 CONTINUE ! ! SET UP TO COMPUTE B, RSD, OR XB. ! if (CB) call DCOPY(K,QTY,1,B,1) KP1 = K + 1 if (CXB) call DCOPY(K,QTY,1,XB,1) if (CR .AND. K < N) call DCOPY(N-K,QTY(KP1),1,RSD(KP1),1) if (.NOT.CXB .OR. KP1 > N) go to 120 DO 110 I = KP1, N XB(I) = 0.0D0 110 CONTINUE 120 CONTINUE if (.NOT.CR) go to 140 DO 130 I = 1, K RSD(I) = 0.0D0 130 CONTINUE 140 CONTINUE if (.NOT.CB) go to 190 ! ! COMPUTE B. ! DO 170 JJ = 1, K J = K - JJ + 1 if (X(J,J) /= 0.0D0) go to 150 INFO = J go to 180 150 CONTINUE B(J) = B(J)/X(J,J) if (J == 1) go to 160 T = -B(J) call DAXPY(J-1,T,X(1,J),1,B,1) 160 CONTINUE 170 CONTINUE 180 CONTINUE 190 CONTINUE if (.NOT.CR .AND. .NOT.CXB) go to 240 ! ! COMPUTE RSD OR XB AS REQUIRED. ! DO 230 JJ = 1, JU J = JU - JJ + 1 if (QRAUX(J) == 0.0D0) go to 220 TEMP = X(J,J) X(J,J) = QRAUX(J) if (.NOT.CR) go to 200 T = -DDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) call DAXPY(N-J+1,T,X(J,J),1,RSD(J),1) 200 CONTINUE if (.NOT.CXB) go to 210 T = -DDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) call DAXPY(N-J+1,T,X(J,J),1,XB(J),1) 210 CONTINUE X(J,J) = TEMP 220 CONTINUE 230 CONTINUE 240 CONTINUE 250 CONTINUE return end subroutine DQRSLV (N, R, LDR, IPVT, DIAG, QTB, X, SIGMA, WA) ! !! DQRSLV solves a least squares problem. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DNLS1 and DNLS1E !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QRSOLV-S, DQRSLV-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! **** Double Precision version of QRSOLV **** ! ! Given an M by N matrix A, an N by N diagonal matrix D, ! and an M-vector B, the problem is to determine an X which ! solves the system ! ! A*X = B , D*X = 0 , ! ! in the least squares sense. ! ! This subroutine completes the solution of the problem ! if it is provided with the necessary information from the ! QR factorization, with column pivoting, of A. That is, if ! A*P = Q*R, where P is a permutation matrix, Q has orthogonal ! columns, and R is an upper triangular matrix with diagonal ! elements of nonincreasing magnitude, then DQRSLV expects ! the full upper triangle of R, the permutation matrix P, ! and the first N components of (Q TRANSPOSE)*B. The system ! A*X = B, D*X = 0, is then equivalent to ! ! T T ! R*Z = Q *B , P *D*P*Z = 0 , ! ! where X = P*Z. If this system does not have full rank, ! then a least squares solution is obtained. On output DQRSLV ! also provides an upper triangular matrix S such that ! ! T T T ! P *(A *A + D*D)*P = S *S . ! ! S is computed within DQRSLV and may be of separate interest. ! ! The subroutine statement is ! ! SUBROUTINE DQRSLV(N,R,LDR,IPVT,DIAG,QTB,X,SIGMA,WA) ! ! where ! ! N is a positive integer input variable set to the order of R. ! ! R is an N by N array. On input the full upper triangle ! must contain the full upper triangle of the matrix R. ! On output the full upper triangle is unaltered, and the ! strict lower triangle contains the strict upper triangle ! (transposed) of the upper triangular matrix S. ! ! LDR is a positive integer input variable not less than N ! which specifies the leading dimension of the array R. ! ! IPVT is an integer input array of length N which defines the ! permutation matrix P such that A*P = Q*R. Column J of P ! is column IPVT(J) of the identity matrix. ! ! DIAG is an input array of length N which must contain the ! diagonal elements of the matrix D. ! ! QTB is an input array of length N which must contain the first ! N elements of the vector (Q TRANSPOSE)*B. ! ! X is an output array of length N which contains the least ! squares solution of the system A*X = B, D*X = 0. ! ! SIGMA is an output array of length N which contains the ! diagonal elements of the upper triangular matrix S. ! ! WA is a work array of length N. ! !***SEE ALSO DNLS1, DNLS1E !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DQRSLV INTEGER N,LDR INTEGER IPVT(*) DOUBLE PRECISION R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA(*) INTEGER I,J,JP1,K,KP1,L,NSING DOUBLE PRECISION COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO SAVE P5, P25, ZERO DATA P5,P25,ZERO /5.0D-1,2.5D-1,0.0D0/ !***FIRST EXECUTABLE STATEMENT DQRSLV 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 ! ! ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. ! DO 100 J = 1, N ! ! PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE ! DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. ! L = IPVT(J) if (DIAG(L) == ZERO) go to 90 DO 30 K = J, N SIGMA(K) = ZERO 30 CONTINUE SIGMA(J) = DIAG(L) ! ! THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D ! MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B ! BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. ! QTBPJ = ZERO DO 80 K = J, N ! ! DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE ! APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. ! if (SIGMA(K) == ZERO) go to 70 if (ABS(R(K,K)) >= ABS(SIGMA(K))) go to 40 COTAN = R(K,K)/SIGMA(K) SIN = P5/SQRT(P25+P25*COTAN**2) COS = SIN*COTAN go to 50 40 CONTINUE TAN = SIGMA(K)/R(K,K) COS = P5/SQRT(P25+P25*TAN**2) SIN = COS*TAN 50 CONTINUE ! ! COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND ! THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). ! R(K,K) = COS*R(K,K) + SIN*SIGMA(K) TEMP = COS*WA(K) + SIN*QTBPJ QTBPJ = -SIN*WA(K) + COS*QTBPJ WA(K) = TEMP ! ! ACCUMULATE THE TRANSFORMATION IN THE ROW OF S. ! KP1 = K + 1 if (N < KP1) go to 70 DO 60 I = KP1, N TEMP = COS*R(I,K) + SIN*SIGMA(I) SIGMA(I) = -SIN*R(I,K) + COS*SIGMA(I) R(I,K) = TEMP 60 CONTINUE 70 CONTINUE 80 CONTINUE 90 CONTINUE ! ! STORE THE DIAGONAL ELEMENT OF S AND RESTORE ! THE CORRESPONDING DIAGONAL ELEMENT OF R. ! SIGMA(J) = R(J,J) R(J,J) = X(J) 100 CONTINUE ! ! SOLVE THE TRIANGULAR SYSTEM FOR Z. if THE SYSTEM IS ! SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. ! NSING = N DO 110 J = 1, N if (SIGMA(J) == ZERO .AND. NSING == N) NSING = J - 1 if (NSING < N) WA(J) = ZERO 110 CONTINUE if (NSING < 1) go to 150 DO 140 K = 1, NSING J = NSING - K + 1 SUM = ZERO JP1 = J + 1 if (NSING < 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)/SIGMA(J) 140 CONTINUE 150 CONTINUE ! ! PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. ! DO 160 J = 1, N L = IPVT(J) X(L) = WA(J) 160 CONTINUE return ! ! LAST CARD OF SUBROUTINE DQRSLV. ! end DOUBLE PRECISION FUNCTION DQWGTC (X, C, P2, P3, P4, KP) ! !! DQWGTC defines the weight function for DQAWC. ! !***SUBSIDIARY !***PURPOSE This function subprogram is used together with the ! routine DQAWC and defines the WEIGHT function. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QWGTC-S, DQWGTC-D) !***KEYWORDS CAUCHY PRINCIPAL VALUE, WEIGHT FUNCTION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***SEE ALSO DQK15W !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 830518 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DQWGTC ! DOUBLE PRECISION C,P2,P3,P4,X INTEGER KP !***FIRST EXECUTABLE STATEMENT DQWGTC DQWGTC = 0.1D+01/(X-C) return end DOUBLE PRECISION FUNCTION DQWGTF (X, OMEGA, P2, P3, P4, INTEGR) ! !! DQWGTF defines the weight function for DQAWF. ! !***SUBSIDIARY !***PURPOSE This function subprogram is used together with the ! routine DQAWF and defines the WEIGHT function. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QWGTF-S, DQWGTF-D) !***KEYWORDS COS OR SIN IN WEIGHT FUNCTION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***SEE ALSO DQK15W !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DQWGTF ! DOUBLE PRECISION OMEGA,OMX,P2,P3,P4,X INTEGER INTEGR !***FIRST EXECUTABLE STATEMENT DQWGTF OMX = OMEGA*X go to(10,20),INTEGR 10 DQWGTF = COS(OMX) go to 30 20 DQWGTF = SIN(OMX) 30 RETURN end DOUBLE PRECISION FUNCTION DQWGTS (X, A, B, ALFA, BETA, INTEGR) ! !! DQWGTS defines the weight function for DQAWS. ! !***SUBSIDIARY !***PURPOSE This function subprogram is used together with the ! routine DQAWS and defines the WEIGHT function. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QWGTS-S, DQWGTS-D) !***KEYWORDS ALGEBRAICO-LOGARITHMIC, END POINT SINGULARITIES, ! WEIGHT FUNCTION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***SEE ALSO DQK15W !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DQWGTS ! DOUBLE PRECISION A,ALFA,B,BETA,BMX,X,XMA INTEGER INTEGR !***FIRST EXECUTABLE STATEMENT DQWGTS XMA = X-A BMX = B-X DQWGTS = XMA**ALFA*BMX**BETA go to (40,10,20,30),INTEGR 10 DQWGTS = DQWGTS*LOG(XMA) go to 40 20 DQWGTS = DQWGTS*LOG(BMX) go to 40 30 DQWGTS = DQWGTS*LOG(XMA)*LOG(BMX) 40 RETURN end subroutine DRC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, & IER) ! !! DRC3JJ evaluates the 3J symbol f(L1) for all allowed values of L1. ! !***PURPOSE Evaluate the 3j symbol f(L1) = ( L1 L2 L3) ! (-M2-M3 M2 M3) ! for all allowed values of L1, the other parameters ! being held fixed. ! !***LIBRARY SLATEC !***CATEGORY C19 !***TYPE DOUBLE PRECISION (RC3JJ-S, DRC3JJ-D) !***KEYWORDS 3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, ! RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, ! WIGNER COEFFICIENTS !***AUTHOR Gordon, R. G., Harvard University ! Schulten, K., Max Planck Institute !***DESCRIPTION ! ! *Usage: ! ! DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM) ! INTEGER NDIM, IER ! ! call DRC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER) ! ! *Arguments: ! ! L2 :IN Parameter in 3j symbol. ! ! L3 :IN Parameter in 3j symbol. ! ! M2 :IN Parameter in 3j symbol. ! ! M3 :IN Parameter in 3j symbol. ! ! L1MIN :OUT Smallest allowable L1 in 3j symbol. ! ! L1MAX :OUT Largest allowable L1 in 3j symbol. ! ! THRCOF :OUT Set of 3j coefficients generated by evaluating the ! 3j symbol for all allowed values of L1. THRCOF(I) ! will contain f(L1MIN+I-1), I=1,2,...,L1MAX+L1MIN+1. ! ! NDIM :IN Declared length of THRCOF in calling program. ! ! IER :OUT Error flag. ! IER=0 No errors. ! IER=1 Either L2 < ABS(M2) or L3 < ABS(M3). ! IER=2 Either L2+ABS(M2) or L3+ABS(M3) non-integer. ! IER=3 L1MAX-L1MIN not an integer. ! IER=4 L1MAX less than L1MIN. ! IER=5 NDIM less than L1MAX-L1MIN+1. ! ! *Description: ! ! Although conventionally the parameters of the vector addition ! coefficients satisfy certain restrictions, such as being integers ! or integers plus 1/2, the restrictions imposed on input to this ! subroutine are somewhat weaker. See, for example, Section 27.9 of ! Abramowitz and Stegun or Appendix C of Volume II of A. Messiah. ! The restrictions imposed by this subroutine are ! 1. L2 >= ABS(M2) and L3 >= ABS(M3); ! 2. L2+ABS(M2) and L3+ABS(M3) must be integers; ! 3. L1MAX-L1MIN must be a non-negative integer, where ! L1MAX=L2+L3 and L1MIN=MAX(ABS(L2-L3),ABS(M2+M3)). ! If the conventional restrictions are satisfied, then these ! restrictions are met. ! ! The user should be cautious in using input parameters that do ! not satisfy the conventional restrictions. For example, the ! the subroutine produces values of ! f(L1) = ( L1 2.5 5.8) ! (-0.31.5 -1.2) ! for L1=3.3,4.3,...,8.3 but none of the symmetry properties of the 3j ! symbol, set forth on page 1056 of Messiah, is satisfied. ! ! The subroutine generates f(L1MIN), f(L1MIN+1), ..., f(L1MAX) ! where L1MIN and L1MAX are defined above. The sequence f(L1) is ! generated by a three-term recurrence algorithm with scaling to ! control overflow. Both backward and forward recurrence are used to ! maintain numerical stability. The two recurrence sequences are ! matched at an interior point and are normalized from the unitary ! property of 3j coefficients and Wigner's phase convention. ! ! The algorithm is suited to applications in which large quantum ! numbers arise, such as in molecular dynamics. ! !***REFERENCES 1. Abramowitz, M., and Stegun, I. A., Eds., Handbook ! of Mathematical Functions with Formulas, Graphs ! and Mathematical Tables, NBS Applied Mathematics ! Series 55, June 1964 and subsequent printings. ! 2. Messiah, Albert., Quantum Mechanics, Volume II, ! North-Holland Publishing Company, 1963. ! 3. Schulten, Klaus and Gordon, Roy G., Exact recursive ! evaluation of 3j and 6j coefficients for quantum- ! mechanical coupling of angular momenta, J Math ! Phys, v 16, no. 10, October 1975, pp. 1961-1970. ! 4. Schulten, Klaus and Gordon, Roy G., Semiclassical ! approximations to 3j and 6j coefficients for ! quantum-mechanical coupling of angular momenta, ! J Math Phys, v 16, no. 10, October 1975, ! pp. 1971-1988. ! 5. Schulten, Klaus and Gordon, Roy G., Recursive ! evaluation of 3j and 6j coefficients, Computer ! Phys Comm, v 11, 1976, pp. 269-278. !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters ! HUGE and TINY revised to depend on D1MACH. ! 891229 Prologue description rewritten; other prologue sections ! revised; LMATCH (location of match point for recurrences) ! removed from argument list; argument IER changed to serve ! only as an error flag (previously, in cases without error, ! it returned the number of scalings); number of error codes ! increased to provide more precise error information; ! program comments revised; SLATEC error handler calls ! introduced to enable printing of error messages to meet ! SLATEC standards. These changes were done by D. W. Lozier, ! M. A. McClain and J. M. Smith of the National Institute ! of Standards and Technology, formerly NBS. ! 910415 Mixed type expressions eliminated; variable C1 initialized; ! description of THRCOF expanded. These changes were done by ! D. W. Lozier. !***END PROLOGUE DRC3JJ ! INTEGER NDIM, IER DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM) ! INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, & NSTEP2 DOUBLE PRECISION A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, D1MACH, & DENOM, DV, EPS, HUGE, L1, M1, NEWFAC, OLDFAC, & ONE, RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, & SUM2, SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, & TINY, TWO, X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO ! DATA ZERO,EPS,ONE,TWO,THREE /0.0D0,0.01D0,1.0D0,2.0D0,3.0D0/ ! !***FIRST EXECUTABLE STATEMENT DRC3JJ IER=0 ! HUGE is the square root of one twentieth of the largest floating ! point number, approximately. HUGE = SQRT(D1MACH(2)/20.0D0) SRHUGE = SQRT(HUGE) TINY = 1.0D0/HUGE SRTINY = 1.0D0/SRHUGE ! ! LMATCH = ZERO M1 = - M2 - M3 ! ! Check error conditions 1 and 2. if ( (L2-ABS(M2)+EPS < ZERO).OR. & (L3-ABS(M3)+EPS < ZERO))THEN IER=1 call XERMSG('SLATEC','DRC3JJ','L2-ABS(M2) or L3-ABS(M3) '// & 'less than zero.',IER,1) return ELSEIF((MOD(L2+ABS(M2)+EPS,ONE) >= EPS+EPS).OR. & (MOD(L3+ABS(M3)+EPS,ONE) >= EPS+EPS))THEN IER=2 call XERMSG('SLATEC','DRC3JJ','L2+ABS(M2) or L3+ABS(M3) '// & 'not integer.',IER,1) return end if ! ! ! ! Limits for L1 ! L1MIN = MAX(ABS(L2-L3),ABS(M1)) L1MAX = L2 + L3 ! ! Check error condition 3. if ( MOD(L1MAX-L1MIN+EPS,ONE) >= EPS+EPS)THEN IER=3 call XERMSG('SLATEC','DRC3JJ','L1MAX-L1MIN not integer.',IER,1) return end if if ( L1MIN < L1MAX-EPS) go to 20 if ( L1MIN < L1MAX+EPS) go to 10 ! ! Check error condition 4. IER=4 call XERMSG('SLATEC','DRC3JJ','L1MIN greater than L1MAX.',IER,1) return ! ! This is reached in case that L1 can take only one value, ! i.e. L1MIN = L1MAX ! 10 CONTINUE ! LSCALE = 0 THRCOF(1) = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) / & SQRT(L1MIN + L2 + L3 + ONE) return ! ! This is reached in case that L1 takes more than one value, ! i.e. L1MIN < L1MAX. ! 20 CONTINUE ! LSCALE = 0 NFIN = INT(L1MAX-L1MIN+ONE+EPS) if ( NDIM-NFIN) 21, 23, 23 ! ! Check error condition 5. 21 IER = 5 call XERMSG('SLATEC','DRC3JJ','Dimension of result array for '// & '3j coefficients too small.',IER,1) return ! ! ! Starting forward recursion from L1MIN taking NSTEP1 steps ! 23 L1 = L1MIN NEWFAC = 0.0D0 C1 = 0.0D0 THRCOF(1) = SRTINY SUM1 = (L1+L1+ONE) * TINY ! ! LSTEP = 1 30 LSTEP = LSTEP + 1 L1 = L1 + ONE ! ! OLDFAC = NEWFAC A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE) A2 = (L1+M1) * (L1-M1) NEWFAC = SQRT(A1*A2) if ( L1 < ONE+EPS) go to 40 ! ! DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2) DENOM = (L1-ONE) * NEWFAC ! if ( LSTEP-2) 32, 32, 31 ! 31 C1OLD = ABS(C1) 32 C1 = - (L1+L1-ONE) * DV / DENOM go to 50 ! ! If L1 = 1, (L1-1) has to be factored out of DV, hence ! 40 C1 = - (L1+L1-ONE) * L1 * (M3-M2) / NEWFAC ! 50 if ( LSTEP > 2) go to 60 ! ! ! If L1 = L1MIN + 1, the third term in the recursion equation vanishes, ! hence X = SRTINY * C1 THRCOF(2) = X SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1*C1 if ( LSTEP == NFIN) go to 220 go to 30 ! ! 60 C2 = - L1 * OLDFAC / DENOM ! ! Recursion to the next 3j coefficient X ! X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2) THRCOF(LSTEP) = X SUMFOR = SUM1 SUM1 = SUM1 + (L1+L1+ONE) * X*X if ( LSTEP == NFIN) go to 100 ! ! See if last unnormalized 3j coefficient exceeds SRHUGE ! if ( ABS(X) < SRHUGE) go to 80 ! ! This is reached if last 3j coefficient larger than SRHUGE, ! so that the recursion series THRCOF(1), ... , THRCOF(LSTEP) ! has to be rescaled to prevent overflow ! ! LSCALE = LSCALE + 1 DO 70 I=1,LSTEP if ( ABS(THRCOF(I)) < SRTINY) THRCOF(I) = ZERO 70 THRCOF(I) = THRCOF(I) / SRHUGE SUM1 = SUM1 / HUGE SUMFOR = SUMFOR / HUGE X = X / SRHUGE ! ! As long as ABS(C1) is decreasing, the recursion proceeds towards ! increasing 3j values and, hence, is numerically stable. Once ! an increase of ABS(C1) is detected, the recursion direction is ! reversed. ! 80 if ( C1OLD-ABS(C1)) 100, 100, 30 ! ! ! Keep three 3j coefficients around LMATCH for comparison with ! backward recursion. ! 100 CONTINUE ! LMATCH = L1 - 1 X1 = X X2 = THRCOF(LSTEP-1) X3 = THRCOF(LSTEP-2) NSTEP2 = NFIN - LSTEP + 3 ! ! ! ! ! Starting backward recursion from L1MAX taking NSTEP2 steps, so ! that forward and backward recursion overlap at three points ! L1 = LMATCH+1, LMATCH, LMATCH-1. ! NFINP1 = NFIN + 1 NFINP2 = NFIN + 2 NFINP3 = NFIN + 3 L1 = L1MAX THRCOF(NFIN) = SRTINY SUM2 = TINY * (L1+L1+ONE) ! L1 = L1 + TWO LSTEP = 1 110 LSTEP = LSTEP + 1 L1 = L1 - ONE ! OLDFAC = NEWFAC A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO) A2S = (L1+M1-ONE) * (L1-M1-ONE) NEWFAC = SQRT(A1S*A2S) ! DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2) ! DENOM = L1 * NEWFAC C1 = - (L1+L1-ONE) * DV / DENOM if ( LSTEP > 2) go to 120 ! ! If L1 = L1MAX + 1, the third term in the recursion formula vanishes ! Y = SRTINY * C1 THRCOF(NFIN-1) = Y SUMBAC = SUM2 SUM2 = SUM2 + TINY * (L1+L1-THREE) * C1*C1 ! go to 110 ! ! 120 C2 = - (L1 - ONE) * OLDFAC / DENOM ! ! Recursion to the next 3j coefficient Y ! Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP) ! if ( LSTEP == NSTEP2) go to 200 ! THRCOF(NFINP1-LSTEP) = Y SUMBAC = SUM2 SUM2 = SUM2 + (L1+L1-THREE) * Y*Y ! ! See if last unnormalized 3j coefficient exceeds SRHUGE ! if ( ABS(Y) < SRHUGE) go to 110 ! ! This is reached if last 3j coefficient larger than SRHUGE, ! so that the recursion series THRCOF(NFIN), ... ,THRCOF(NFIN-LSTEP+1) ! has to be rescaled to prevent overflow ! ! LSCALE = LSCALE + 1 DO 130 I=1,LSTEP INDEX = NFIN - I + 1 if ( ABS(THRCOF(INDEX)) < SRTINY) THRCOF(INDEX) = ZERO 130 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE SUM2 = SUM2 / HUGE SUMBAC = SUMBAC / HUGE ! ! go to 110 ! ! ! The forward recursion 3j coefficients X1, X2, X3 are to be matched ! with the corresponding backward recursion values Y1, Y2, Y3. ! 200 Y3 = Y Y2 = THRCOF(NFINP2-LSTEP) Y1 = THRCOF(NFINP3-LSTEP) ! ! ! Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds ! with minimal error. ! RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) NLIM = NFIN - NSTEP2 + 1 ! if ( ABS(RATIO) < ONE) go to 211 ! DO 210 N=1,NLIM 210 THRCOF(N) = RATIO * THRCOF(N) SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC go to 230 ! 211 NLIM = NLIM + 1 RATIO = ONE / RATIO DO 212 N=NLIM,NFIN 212 THRCOF(N) = RATIO * THRCOF(N) SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC go to 230 ! 220 SUMUNI = SUM1 ! ! ! Normalize 3j coefficients ! 230 CNORM = ONE / SQRT(SUMUNI) ! ! Sign convention for last 3j coefficient determines overall phase ! SIGN1 = SIGN(ONE,THRCOF(NFIN)) SIGN2 = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) if ( SIGN1*SIGN2) 235,235,236 235 CNORM = - CNORM ! 236 if ( ABS(CNORM) < ONE) go to 250 ! DO 240 N=1,NFIN 240 THRCOF(N) = CNORM * THRCOF(N) return ! 250 THRESH = TINY / ABS(CNORM) DO 251 N=1,NFIN if ( ABS(THRCOF(N)) < THRESH) THRCOF(N) = ZERO 251 THRCOF(N) = CNORM * THRCOF(N) ! return end subroutine DRC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, & IER) ! !! DRC3JM evaluates the 3j symbol g(M2) for all allowed values of M2. ! !***PURPOSE Evaluate the 3j symbol g(M2) = (L1 L2 L3 ) ! (M1 M2 -M1-M2) ! for all allowed values of M2, the other parameters ! being held fixed. ! !***LIBRARY SLATEC !***CATEGORY C19 !***TYPE DOUBLE PRECISION (RC3JM-S, DRC3JM-D) !***KEYWORDS 3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, ! RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, ! WIGNER COEFFICIENTS !***AUTHOR Gordon, R. G., Harvard University ! Schulten, K., Max Planck Institute !***DESCRIPTION ! ! *Usage: ! ! DOUBLE PRECISION L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM) ! INTEGER NDIM, IER ! ! call DRC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, IER) ! ! *Arguments: ! ! L1 :IN Parameter in 3j symbol. ! ! L2 :IN Parameter in 3j symbol. ! ! L3 :IN Parameter in 3j symbol. ! ! M1 :IN Parameter in 3j symbol. ! ! M2MIN :OUT Smallest allowable M2 in 3j symbol. ! ! M2MAX :OUT Largest allowable M2 in 3j symbol. ! ! THRCOF :OUT Set of 3j coefficients generated by evaluating the ! 3j symbol for all allowed values of M2. THRCOF(I) ! will contain g(M2MIN+I-1), I=1,2,...,M2MAX-M2MIN+1. ! ! NDIM :IN Declared length of THRCOF in calling program. ! ! IER :OUT Error flag. ! IER=0 No errors. ! IER=1 Either L1 < ABS(M1) or L1+ABS(M1) non-integer. ! IER=2 ABS(L1-L2) <= L3 <= L1+L2 not satisfied. ! IER=3 L1+L2+L3 not an integer. ! IER=4 M2MAX-M2MIN not an integer. ! IER=5 M2MAX less than M2MIN. ! IER=6 NDIM less than M2MAX-M2MIN+1. ! ! *Description: ! ! Although conventionally the parameters of the vector addition ! coefficients satisfy certain restrictions, such as being integers ! or integers plus 1/2, the restrictions imposed on input to this ! subroutine are somewhat weaker. See, for example, Section 27.9 of ! Abramowitz and Stegun or Appendix C of Volume II of A. Messiah. ! The restrictions imposed by this subroutine are ! 1. L1 >= ABS(M1) and L1+ABS(M1) must be an integer; ! 2. ABS(L1-L2) <= L3 <= L1+L2; ! 3. L1+L2+L3 must be an integer; ! 4. M2MAX-M2MIN must be an integer, where ! M2MAX=MIN(L2,L3-M1) and M2MIN=MAX(-L2,-L3-M1). ! If the conventional restrictions are satisfied, then these ! restrictions are met. ! ! The user should be cautious in using input parameters that do ! not satisfy the conventional restrictions. For example, the ! the subroutine produces values of ! g(M2) = (0.751.50 1.75 ) ! (0.25 M2 -0.25-M2) ! for M2=-1.5,-0.5,0.5,1.5 but none of the symmetry properties of the ! 3j symbol, set forth on page 1056 of Messiah, is satisfied. ! ! The subroutine generates g(M2MIN), g(M2MIN+1), ..., g(M2MAX) ! where M2MIN and M2MAX are defined above. The sequence g(M2) is ! generated by a three-term recurrence algorithm with scaling to ! control overflow. Both backward and forward recurrence are used to ! maintain numerical stability. The two recurrence sequences are ! matched at an interior point and are normalized from the unitary ! property of 3j coefficients and Wigner's phase convention. ! ! The algorithm is suited to applications in which large quantum ! numbers arise, such as in molecular dynamics. ! !***REFERENCES 1. Abramowitz, M., and Stegun, I. A., Eds., Handbook ! of Mathematical Functions with Formulas, Graphs ! and Mathematical Tables, NBS Applied Mathematics ! Series 55, June 1964 and subsequent printings. ! 2. Messiah, Albert., Quantum Mechanics, Volume II, ! North-Holland Publishing Company, 1963. ! 3. Schulten, Klaus and Gordon, Roy G., Exact recursive ! evaluation of 3j and 6j coefficients for quantum- ! mechanical coupling of angular momenta, J Math ! Phys, v 16, no. 10, October 1975, pp. 1961-1970. ! 4. Schulten, Klaus and Gordon, Roy G., Semiclassical ! approximations to 3j and 6j coefficients for ! quantum-mechanical coupling of angular momenta, ! J Math Phys, v 16, no. 10, October 1975, ! pp. 1971-1988. ! 5. Schulten, Klaus and Gordon, Roy G., Recursive ! evaluation of 3j and 6j coefficients, Computer ! Phys Comm, v 11, 1976, pp. 269-278. !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters ! HUGE and TINY revised to depend on D1MACH. ! 891229 Prologue description rewritten; other prologue sections ! revised; MMATCH (location of match point for recurrences) ! removed from argument list; argument IER changed to serve ! only as an error flag (previously, in cases without error, ! it returned the number of scalings); number of error codes ! increased to provide more precise error information; ! program comments revised; SLATEC error handler calls ! introduced to enable printing of error messages to meet ! SLATEC standards. These changes were done by D. W. Lozier, ! M. A. McClain and J. M. Smith of the National Institute ! of Standards and Technology, formerly NBS. ! 910415 Mixed type expressions eliminated; variable C1 initialized; ! description of THRCOF expanded. These changes were done by ! D. W. Lozier. !***END PROLOGUE DRC3JM ! INTEGER NDIM, IER DOUBLE PRECISION L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM) ! INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, & NSTEP2 DOUBLE PRECISION A1, A1S, C1, C1OLD, C2, CNORM, D1MACH, DV, EPS, & HUGE, M2, M3, NEWFAC, OLDFAC, ONE, RATIO, SIGN1, & SIGN2, SRHUGE, SRTINY, SUM1, SUM2, SUMBAC, & SUMFOR, SUMUNI, THRESH, TINY, TWO, X, X1, X2, X3, & Y, Y1, Y2, Y3, ZERO ! DATA ZERO,EPS,ONE,TWO /0.0D0,0.01D0,1.0D0,2.0D0/ ! !***FIRST EXECUTABLE STATEMENT DRC3JM IER=0 ! HUGE is the square root of one twentieth of the largest floating ! point number, approximately. HUGE = SQRT(D1MACH(2)/20.0D0) SRHUGE = SQRT(HUGE) TINY = 1.0D0/HUGE SRTINY = 1.0D0/SRHUGE ! ! MMATCH = ZERO ! ! ! Check error conditions 1, 2, and 3. if ( (L1-ABS(M1)+EPS < ZERO).OR. & (MOD(L1+ABS(M1)+EPS,ONE) >= EPS+EPS))THEN IER=1 call XERMSG('SLATEC','DRC3JM','L1-ABS(M1) less than zero or '// & 'L1+ABS(M1) not integer.',IER,1) return ELSEIF((L1+L2-L3 < -EPS).OR.(L1-L2+L3 < -EPS).OR. & (-L1+L2+L3 < -EPS))THEN IER=2 call XERMSG('SLATEC','DRC3JM','L1, L2, L3 do not satisfy '// & 'triangular condition.',IER,1) return ELSEIF(MOD(L1+L2+L3+EPS,ONE) >= EPS+EPS)THEN IER=3 call XERMSG('SLATEC','DRC3JM','L1+L2+L3 not integer.',IER,1) return end if ! ! ! Limits for M2 M2MIN = MAX(-L2,-L3-M1) M2MAX = MIN(L2,L3-M1) ! ! Check error condition 4. if ( MOD(M2MAX-M2MIN+EPS,ONE) >= EPS+EPS)THEN IER=4 call XERMSG('SLATEC','DRC3JM','M2MAX-M2MIN not integer.',IER,1) return end if if ( M2MIN < M2MAX-EPS) go to 20 if ( M2MIN < M2MAX+EPS) go to 10 ! ! Check error condition 5. IER=5 call XERMSG('SLATEC','DRC3JM','M2MIN greater than M2MAX.',IER,1) return ! ! ! This is reached in case that M2 and M3 can take only one value. 10 CONTINUE ! MSCALE = 0 THRCOF(1) = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) / & SQRT(L1+L2+L3+ONE) return ! ! This is reached in case that M1 and M2 take more than one value. 20 CONTINUE ! MSCALE = 0 NFIN = INT(M2MAX-M2MIN+ONE+EPS) if ( NDIM-NFIN) 21, 23, 23 ! ! Check error condition 6. 21 IER = 6 call XERMSG('SLATEC','DRC3JM','Dimension of result array for '// & '3j coefficients too small.',IER,1) return ! ! ! ! Start of forward recursion from M2 = M2MIN ! 23 M2 = M2MIN THRCOF(1) = SRTINY NEWFAC = 0.0D0 C1 = 0.0D0 SUM1 = TINY ! ! LSTEP = 1 30 LSTEP = LSTEP + 1 M2 = M2 + ONE M3 = - M1 - M2 ! ! OLDFAC = NEWFAC A1 = (L2-M2+ONE) * (L2+M2) * (L3+M3+ONE) * (L3-M3) NEWFAC = SQRT(A1) ! ! DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE) & - (L2+M2-ONE)*(L3-M3-ONE) ! if ( LSTEP-2) 32, 32, 31 ! 31 C1OLD = ABS(C1) 32 C1 = - DV / NEWFAC ! if ( LSTEP > 2) go to 60 ! ! ! If M2 = M2MIN + 1, the third term in the recursion equation vanishes, ! hence ! X = SRTINY * C1 THRCOF(2) = X SUM1 = SUM1 + TINY * C1*C1 if ( LSTEP == NFIN) go to 220 go to 30 ! ! 60 C2 = - OLDFAC / NEWFAC ! ! Recursion to the next 3j coefficient X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2) THRCOF(LSTEP) = X SUMFOR = SUM1 SUM1 = SUM1 + X*X if ( LSTEP == NFIN) go to 100 ! ! See if last unnormalized 3j coefficient exceeds SRHUGE ! if ( ABS(X) < SRHUGE) go to 80 ! ! This is reached if last 3j coefficient larger than SRHUGE, ! so that the recursion series THRCOF(1), ... , THRCOF(LSTEP) ! has to be rescaled to prevent overflow ! ! MSCALE = MSCALE + 1 DO 70 I=1,LSTEP if ( ABS(THRCOF(I)) < SRTINY) THRCOF(I) = ZERO 70 THRCOF(I) = THRCOF(I) / SRHUGE SUM1 = SUM1 / HUGE SUMFOR = SUMFOR / HUGE X = X / SRHUGE ! ! ! As long as ABS(C1) is decreasing, the recursion proceeds towards ! increasing 3j values and, hence, is numerically stable. Once ! an increase of ABS(C1) is detected, the recursion direction is ! reversed. ! 80 if ( C1OLD-ABS(C1)) 100, 100, 30 ! ! ! Keep three 3j coefficients around MMATCH for comparison later ! with backward recursion values. ! 100 CONTINUE ! MMATCH = M2 - 1 NSTEP2 = NFIN - LSTEP + 3 X1 = X X2 = THRCOF(LSTEP-1) X3 = THRCOF(LSTEP-2) ! ! Starting backward recursion from M2MAX taking NSTEP2 steps, so ! that forwards and backwards recursion overlap at the three points ! M2 = MMATCH+1, MMATCH, MMATCH-1. ! NFINP1 = NFIN + 1 NFINP2 = NFIN + 2 NFINP3 = NFIN + 3 THRCOF(NFIN) = SRTINY SUM2 = TINY ! ! ! M2 = M2MAX + TWO LSTEP = 1 110 LSTEP = LSTEP + 1 M2 = M2 - ONE M3 = - M1 - M2 OLDFAC = NEWFAC A1S = (L2-M2+TWO) * (L2+M2-ONE) * (L3+M3+TWO) * (L3-M3-ONE) NEWFAC = SQRT(A1S) DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE) & - (L2+M2-ONE)*(L3-M3-ONE) C1 = - DV / NEWFAC if ( LSTEP > 2) go to 120 ! ! If M2 = M2MAX + 1 the third term in the recursion equation vanishes ! Y = SRTINY * C1 THRCOF(NFIN-1) = Y if ( LSTEP == NSTEP2) go to 200 SUMBAC = SUM2 SUM2 = SUM2 + Y*Y go to 110 ! 120 C2 = - OLDFAC / NEWFAC ! ! Recursion to the next 3j coefficient ! Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP) ! if ( LSTEP == NSTEP2) go to 200 ! THRCOF(NFINP1-LSTEP) = Y SUMBAC = SUM2 SUM2 = SUM2 + Y*Y ! ! ! See if last 3j coefficient exceeds SRHUGE ! if ( ABS(Y) < SRHUGE) go to 110 ! ! This is reached if last 3j coefficient larger than SRHUGE, ! so that the recursion series THRCOF(NFIN), ... , THRCOF(NFIN-LSTEP+1) ! has to be rescaled to prevent overflow. ! ! MSCALE = MSCALE + 1 DO 111 I=1,LSTEP INDEX = NFIN - I + 1 if ( ABS(THRCOF(INDEX)) < SRTINY) & THRCOF(INDEX) = ZERO 111 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE SUM2 = SUM2 / HUGE SUMBAC = SUMBAC / HUGE ! go to 110 ! ! ! ! The forward recursion 3j coefficients X1, X2, X3 are to be matched ! with the corresponding backward recursion values Y1, Y2, Y3. ! 200 Y3 = Y Y2 = THRCOF(NFINP2-LSTEP) Y1 = THRCOF(NFINP3-LSTEP) ! ! ! Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds ! with minimal error. ! RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) NLIM = NFIN - NSTEP2 + 1 ! if ( ABS(RATIO) < ONE) go to 211 ! DO 210 N=1,NLIM 210 THRCOF(N) = RATIO * THRCOF(N) SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC go to 230 ! 211 NLIM = NLIM + 1 RATIO = ONE / RATIO DO 212 N=NLIM,NFIN 212 THRCOF(N) = RATIO * THRCOF(N) SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC go to 230 ! 220 SUMUNI = SUM1 ! ! ! Normalize 3j coefficients ! 230 CNORM = ONE / SQRT((L1+L1+ONE) * SUMUNI) ! ! Sign convention for last 3j coefficient determines overall phase ! SIGN1 = SIGN(ONE,THRCOF(NFIN)) SIGN2 = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) if ( SIGN1*SIGN2) 235,235,236 235 CNORM = - CNORM ! 236 if ( ABS(CNORM) < ONE) go to 250 ! DO 240 N=1,NFIN 240 THRCOF(N) = CNORM * THRCOF(N) return ! 250 THRESH = TINY / ABS(CNORM) DO 251 N=1,NFIN if ( ABS(THRCOF(N)) < THRESH) THRCOF(N) = ZERO 251 THRCOF(N) = CNORM * THRCOF(N) ! ! ! return end subroutine DRC6J (L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, & IER) ! !! DRC6J evaluates the 6j symbol h(L1) for all allowed values of L1. ! !***PURPOSE Evaluate the 6j symbol h(L1) = {L1 L2 L3} ! {L4 L5 L6} ! for all allowed values of L1, the other parameters ! being held fixed. ! !***LIBRARY SLATEC !***CATEGORY C19 !***TYPE DOUBLE PRECISION (RC6J-S, DRC6J-D) !***KEYWORDS 6J COEFFICIENTS, 6J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, ! RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, ! WIGNER COEFFICIENTS !***AUTHOR Gordon, R. G., Harvard University ! Schulten, K., Max Planck Institute !***DESCRIPTION ! ! *Usage: ! ! DOUBLE PRECISION L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) ! INTEGER NDIM, IER ! ! call DRC6J(L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, IER) ! ! *Arguments: ! ! L2 :IN Parameter in 6j symbol. ! ! L3 :IN Parameter in 6j symbol. ! ! L4 :IN Parameter in 6j symbol. ! ! L5 :IN Parameter in 6j symbol. ! ! L6 :IN Parameter in 6j symbol. ! ! L1MIN :OUT Smallest allowable L1 in 6j symbol. ! ! L1MAX :OUT Largest allowable L1 in 6j symbol. ! ! SIXCOF :OUT Set of 6j coefficients generated by evaluating the ! 6j symbol for all allowed values of L1. SIXCOF(I) ! will contain h(L1MIN+I-1), I=1,2,...,L1MAX-L1MIN+1. ! ! NDIM :IN Declared length of SIXCOF in calling program. ! ! IER :OUT Error flag. ! IER=0 No errors. ! IER=1 L2+L3+L5+L6 or L4+L2+L6 not an integer. ! IER=2 L4, L2, L6 triangular condition not satisfied. ! IER=3 L4, L5, L3 triangular condition not satisfied. ! IER=4 L1MAX-L1MIN not an integer. ! IER=5 L1MAX less than L1MIN. ! IER=6 NDIM less than L1MAX-L1MIN+1. ! ! *Description: ! ! The definition and properties of 6j symbols can be found, for ! example, in Appendix C of Volume II of A. Messiah. Although the ! parameters of the vector addition coefficients satisfy certain ! conventional restrictions, the restriction that they be non-negative ! integers or non-negative integers plus 1/2 is not imposed on input ! to this subroutine. The restrictions imposed are ! 1. L2+L3+L5+L6 and L2+L4+L6 must be integers; ! 2. ABS(L2-L4) <= L6 <= L2+L4 must be satisfied; ! 3. ABS(L4-L5) <= L3 <= L4+L5 must be satisfied; ! 4. L1MAX-L1MIN must be a non-negative integer, where ! L1MAX=MIN(L2+L3,L5+L6) and L1MIN=MAX(ABS(L2-L3),ABS(L5-L6)). ! If all the conventional restrictions are satisfied, then these ! restrictions are met. Conversely, if input to this subroutine meets ! all of these restrictions and the conventional restriction stated ! above, then all the conventional restrictions are satisfied. ! ! The user should be cautious in using input parameters that do ! not satisfy the conventional restrictions. For example, the ! the subroutine produces values of ! h(L1) = { L12/3 1 } ! {2/32/32/3} ! for L1=1/3 and 4/3 but none of the symmetry properties of the 6j ! symbol, set forth on pages 1063 and 1064 of Messiah, is satisfied. ! ! The subroutine generates h(L1MIN), h(L1MIN+1), ..., h(L1MAX) ! where L1MIN and L1MAX are defined above. The sequence h(L1) is ! generated by a three-term recurrence algorithm with scaling to ! control overflow. Both backward and forward recurrence are used to ! maintain numerical stability. The two recurrence sequences are ! matched at an interior point and are normalized from the unitary ! property of 6j coefficients and Wigner's phase convention. ! ! The algorithm is suited to applications in which large quantum ! numbers arise, such as in molecular dynamics. ! !***REFERENCES 1. Messiah, Albert., Quantum Mechanics, Volume II, ! North-Holland Publishing Company, 1963. ! 2. Schulten, Klaus and Gordon, Roy G., Exact recursive ! evaluation of 3j and 6j coefficients for quantum- ! mechanical coupling of angular momenta, J Math ! Phys, v 16, no. 10, October 1975, pp. 1961-1970. ! 3. Schulten, Klaus and Gordon, Roy G., Semiclassical ! approximations to 3j and 6j coefficients for ! quantum-mechanical coupling of angular momenta, ! J Math Phys, v 16, no. 10, October 1975, ! pp. 1971-1988. ! 4. Schulten, Klaus and Gordon, Roy G., Recursive ! evaluation of 3j and 6j coefficients, Computer ! Phys Comm, v 11, 1976, pp. 269-278. !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters ! HUGE and TINY revised to depend on D1MACH. ! 891229 Prologue description rewritten; other prologue sections ! revised; LMATCH (location of match point for recurrences) ! removed from argument list; argument IER changed to serve ! only as an error flag (previously, in cases without error, ! it returned the number of scalings); number of error codes ! increased to provide more precise error information; ! program comments revised; SLATEC error handler calls ! introduced to enable printing of error messages to meet ! SLATEC standards. These changes were done by D. W. Lozier, ! M. A. McClain and J. M. Smith of the National Institute ! of Standards and Technology, formerly NBS. ! 910415 Mixed type expressions eliminated; variable C1 initialized; ! description of SIXCOF expanded. These changes were done by ! D. W. Lozier. !***END PROLOGUE DRC6J ! INTEGER NDIM, IER DOUBLE PRECISION L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) ! INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, & NSTEP2 DOUBLE PRECISION A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, D1MACH, & DENOM, DV, EPS, HUGE, L1, NEWFAC, OLDFAC, ONE, & RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, SUM2, & SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, TINY, TWO, & X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO ! DATA ZERO,EPS,ONE,TWO,THREE /0.0D0,0.01D0,1.0D0,2.0D0,3.0D0/ ! !***FIRST EXECUTABLE STATEMENT DRC6J IER=0 ! HUGE is the square root of one twentieth of the largest floating ! point number, approximately. HUGE = SQRT(D1MACH(2)/20.0D0) SRHUGE = SQRT(HUGE) TINY = 1.0D0/HUGE SRTINY = 1.0D0/SRHUGE ! ! LMATCH = ZERO ! ! Check error conditions 1, 2, and 3. if ( (MOD(L2+L3+L5+L6+EPS,ONE) >= EPS+EPS).OR. & (MOD(L4+L2+L6+EPS,ONE) >= EPS+EPS))THEN IER=1 call XERMSG('SLATEC','DRC6J','L2+L3+L5+L6 or L4+L2+L6 not '// & 'integer.',IER,1) return ELSEIF((L4+L2-L6 < ZERO).OR.(L4-L2+L6 < ZERO).OR. & (-L4+L2+L6 < ZERO))THEN IER=2 call XERMSG('SLATEC','DRC6J','L4, L2, L6 triangular '// & 'condition not satisfied.',IER,1) return ELSEIF((L4-L5+L3 < ZERO).OR.(L4+L5-L3 < ZERO).OR. & (-L4+L5+L3 < ZERO))THEN IER=3 call XERMSG('SLATEC','DRC6J','L4, L5, L3 triangular '// & 'condition not satisfied.',IER,1) return end if ! ! Limits for L1 ! L1MIN = MAX(ABS(L2-L3),ABS(L5-L6)) L1MAX = MIN(L2+L3,L5+L6) ! ! Check error condition 4. if ( MOD(L1MAX-L1MIN+EPS,ONE) >= EPS+EPS)THEN IER=4 call XERMSG('SLATEC','DRC6J','L1MAX-L1MIN not integer.',IER,1) return end if if ( L1MIN < L1MAX-EPS) go to 20 if ( L1MIN < L1MAX+EPS) go to 10 ! ! Check error condition 5. IER=5 call XERMSG('SLATEC','DRC6J','L1MIN greater than L1MAX.',IER,1) return ! ! ! This is reached in case that L1 can take only one value ! 10 CONTINUE ! LSCALE = 0 SIXCOF(1) = (-ONE) ** INT(L2+L3+L5+L6+EPS) / & SQRT((L1MIN+L1MIN+ONE)*(L4+L4+ONE)) return ! ! ! This is reached in case that L1 can take more than one value. ! 20 CONTINUE ! LSCALE = 0 NFIN = INT(L1MAX-L1MIN+ONE+EPS) if ( NDIM-NFIN) 21, 23, 23 ! ! Check error condition 6. 21 IER = 6 call XERMSG('SLATEC','DRC6J','Dimension of result array for 6j '// & 'coefficients too small.',IER,1) return ! ! ! Start of forward recursion ! 23 L1 = L1MIN NEWFAC = 0.0D0 C1 = 0.0D0 SIXCOF(1) = SRTINY SUM1 = (L1+L1+ONE) * TINY ! LSTEP = 1 30 LSTEP = LSTEP + 1 L1 = L1 + ONE ! OLDFAC = NEWFAC A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE) A2 = (L1+L5+L6+ONE) * (L1-L5+L6) * (L1+L5-L6) * (-L1+L5+L6+ONE) NEWFAC = SQRT(A1*A2) ! if ( L1 < ONE+EPS) go to 40 ! DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE) & - L1*(L1-ONE)*L4*(L4+ONE) ) & - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE)) & * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE)) ! DENOM = (L1-ONE) * NEWFAC ! if ( LSTEP-2) 32, 32, 31 ! 31 C1OLD = ABS(C1) 32 C1 = - (L1+L1-ONE) * DV / DENOM go to 50 ! ! If L1 = 1, (L1 - 1) has to be factored out of DV, hence ! 40 C1 = - TWO * ( L2*(L2+ONE) + L5*(L5+ONE) - L4*(L4+ONE) ) & / NEWFAC ! 50 if ( LSTEP > 2) go to 60 ! ! If L1 = L1MIN + 1, the third term in recursion equation vanishes ! X = SRTINY * C1 SIXCOF(2) = X SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1 * C1 ! if ( LSTEP == NFIN) go to 220 go to 30 ! ! 60 C2 = - L1 * OLDFAC / DENOM ! ! Recursion to the next 6j coefficient X ! X = C1 * SIXCOF(LSTEP-1) + C2 * SIXCOF(LSTEP-2) SIXCOF(LSTEP) = X ! SUMFOR = SUM1 SUM1 = SUM1 + (L1+L1+ONE) * X * X if ( LSTEP == NFIN) go to 100 ! ! See if last unnormalized 6j coefficient exceeds SRHUGE ! if ( ABS(X) < SRHUGE) go to 80 ! ! This is reached if last 6j coefficient larger than SRHUGE, ! so that the recursion series SIXCOF(1), ... ,SIXCOF(LSTEP) ! has to be rescaled to prevent overflow ! ! LSCALE = LSCALE + 1 DO 70 I=1,LSTEP if ( ABS(SIXCOF(I)) < SRTINY) SIXCOF(I) = ZERO 70 SIXCOF(I) = SIXCOF(I) / SRHUGE SUM1 = SUM1 / HUGE SUMFOR = SUMFOR / HUGE X = X / SRHUGE ! ! ! As long as the coefficient ABS(C1) is decreasing, the recursion ! proceeds towards increasing 6j values and, hence, is numerically ! stable. Once an increase of ABS(C1) is detected, the recursion ! direction is reversed. ! 80 if ( C1OLD-ABS(C1)) 100, 100, 30 ! ! ! Keep three 6j coefficients around LMATCH for comparison later ! with backward recursion. ! 100 CONTINUE ! LMATCH = L1 - 1 X1 = X X2 = SIXCOF(LSTEP-1) X3 = SIXCOF(LSTEP-2) ! ! ! ! Starting backward recursion from L1MAX taking NSTEP2 steps, so ! that forward and backward recursion overlap at the three points ! L1 = LMATCH+1, LMATCH, LMATCH-1. ! NFINP1 = NFIN + 1 NFINP2 = NFIN + 2 NFINP3 = NFIN + 3 NSTEP2 = NFIN - LSTEP + 3 L1 = L1MAX ! SIXCOF(NFIN) = SRTINY SUM2 = (L1+L1+ONE) * TINY ! ! L1 = L1 + TWO LSTEP = 1 110 LSTEP = LSTEP + 1 L1 = L1 - ONE ! OLDFAC = NEWFAC A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO) A2S = (L1+L5+L6)*(L1-L5+L6-ONE)*(L1+L5-L6-ONE)*(-L1+L5+L6+TWO) NEWFAC = SQRT(A1S*A2S) ! DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE) & - L1*(L1-ONE)*L4*(L4+ONE) ) & - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE)) & * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE)) ! DENOM = L1 * NEWFAC C1 = - (L1+L1-ONE) * DV / DENOM if ( LSTEP > 2) go to 120 ! ! If L1 = L1MAX + 1 the third term in the recursion equation vanishes ! Y = SRTINY * C1 SIXCOF(NFIN-1) = Y if ( LSTEP == NSTEP2) go to 200 SUMBAC = SUM2 SUM2 = SUM2 + (L1+L1-THREE) * C1 * C1 * TINY go to 110 ! ! 120 C2 = - (L1-ONE) * OLDFAC / DENOM ! ! Recursion to the next 6j coefficient Y ! Y = C1 * SIXCOF(NFINP2-LSTEP) + C2 * SIXCOF(NFINP3-LSTEP) if ( LSTEP == NSTEP2) go to 200 SIXCOF(NFINP1-LSTEP) = Y SUMBAC = SUM2 SUM2 = SUM2 + (L1+L1-THREE) * Y * Y ! ! See if last unnormalized 6j coefficient exceeds SRHUGE ! if ( ABS(Y) < SRHUGE) go to 110 ! ! This is reached if last 6j coefficient larger than SRHUGE, ! so that the recursion series SIXCOF(NFIN), ... ,SIXCOF(NFIN-LSTEP+1) ! has to be rescaled to prevent overflow ! ! LSCALE = LSCALE + 1 DO 130 I=1,LSTEP INDEX = NFIN-I+1 if ( ABS(SIXCOF(INDEX)) < SRTINY) SIXCOF(INDEX) = ZERO 130 SIXCOF(INDEX) = SIXCOF(INDEX) / SRHUGE SUMBAC = SUMBAC / HUGE SUM2 = SUM2 / HUGE ! go to 110 ! ! ! The forward recursion 6j coefficients X1, X2, X3 are to be matched ! with the corresponding backward recursion values Y1, Y2, Y3. ! 200 Y3 = Y Y2 = SIXCOF(NFINP2-LSTEP) Y1 = SIXCOF(NFINP3-LSTEP) ! ! ! Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds ! with minimal error. ! RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) NLIM = NFIN - NSTEP2 + 1 ! if ( ABS(RATIO) < ONE) go to 211 ! DO 210 N=1,NLIM 210 SIXCOF(N) = RATIO * SIXCOF(N) SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC go to 230 ! 211 NLIM = NLIM + 1 RATIO = ONE / RATIO DO 212 N=NLIM,NFIN 212 SIXCOF(N) = RATIO * SIXCOF(N) SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC go to 230 ! 220 SUMUNI = SUM1 ! ! ! Normalize 6j coefficients ! 230 CNORM = ONE / SQRT((L4+L4+ONE)*SUMUNI) ! ! Sign convention for last 6j coefficient determines overall phase ! SIGN1 = SIGN(ONE,SIXCOF(NFIN)) SIGN2 = (-ONE) ** INT(L2+L3+L5+L6+EPS) if ( SIGN1*SIGN2) 235,235,236 235 CNORM = - CNORM ! 236 if ( ABS(CNORM) < ONE) go to 250 ! DO 240 N=1,NFIN 240 SIXCOF(N) = CNORM * SIXCOF(N) return ! 250 THRESH = TINY / ABS(CNORM) DO 251 N=1,NFIN if ( ABS(SIXCOF(N)) < THRESH) SIXCOF(N) = ZERO 251 SIXCOF(N) = CNORM * SIXCOF(N) ! return end DOUBLE PRECISION FUNCTION DRC (X, Y, IER) ! !! DRC approximates the elliptic integral RC. ! !***PURPOSE Calculate a double precision approximation to ! DRC(X,Y) = Integral from zero to infinity of ! -1/2 -1 ! (1/2)(t+X) (t+Y) dt, ! where X is nonnegative and Y is positive. ! !***LIBRARY SLATEC !***CATEGORY C14 !***TYPE DOUBLE PRECISION (RC-S, DRC-D) !***KEYWORDS DUPLICATION THEOREM, ELEMENTARY FUNCTIONS, ! ELLIPTIC INTEGRAL, TAYLOR SERIES !***AUTHOR Carlson, B. C. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Notis, E. M. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Pexton, R. L. ! Lawrence Livermore National Laboratory ! Livermore, CA 94550 !***DESCRIPTION ! ! 1. DRC ! Standard FORTRAN function routine ! Double precision version ! The routine calculates an approximation result to ! DRC(X,Y) = integral from zero to infinity of ! ! -1/2 -1 ! (1/2)(t+X) (t+Y) dt, ! ! where X is nonnegative and Y is positive. The duplication ! theorem is iterated until the variables are nearly equal, ! and the function is then expanded in Taylor series to fifth ! order. Logarithmic, inverse circular, and inverse hyper- ! bolic functions can be expressed in terms of DRC. ! ! 2. Calling Sequence ! DRC( X, Y, IER ) ! ! Parameters On Entry ! Values assigned by the calling routine ! ! X - Double precision, nonnegative variable ! ! Y - Double precision, positive variable ! ! ! ! On Return (values assigned by the DRC routine) ! ! DRC - Double precision approximation to the integral ! ! IER - Integer to indicate normal or abnormal termination. ! ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! ! IER > 0 Abnormal termination of the routine ! ! X and Y are unaltered. ! ! 3. Error messages ! ! Value of IER assigned by the DRC routine ! ! Value assigned Error message printed ! IER = 1 X < 0.0D0.OR.Y <= 0.0D0 ! = 2 X+Y < LOLIM ! = 3 MAX(X,Y) > UPLIM ! ! 4. Control parameters ! ! Values of LOLIM, UPLIM, and ERRTOL are set by the ! routine. ! ! LOLIM and UPLIM determine the valid range of X and Y ! ! LOLIM - Lower limit of valid arguments ! ! Not less than 5 * (machine minimum) . ! ! UPLIM - Upper limit of valid arguments ! ! Not greater than (machine maximum) / 5 . ! ! ! Acceptable values for: LOLIM UPLIM ! IBM 360/370 SERIES : 3.0D-78 1.0D+75 ! CDC 6000/7000 SERIES : 1.0D-292 1.0D+321 ! UNIVAC 1100 SERIES : 1.0D-307 1.0D+307 ! CRAY : 2.3D-2466 1.0D+2465 ! VAX 11 SERIES : 1.5D-38 3.0D+37 ! ! ERRTOL determines the accuracy of the answer ! ! The value assigned by the routine will result ! in solution precision within 1-2 decimals of ! "machine precision". ! ! ! ERRTOL - relative error due to truncation is less than ! 16 * ERRTOL ** 6 / (1 - 2 * ERRTOL). ! ! ! The accuracy of the computed approximation to the inte- ! gral can be controlled by choosing the value of ERRTOL. ! Truncation of a Taylor series after terms of fifth order ! introduces an error less than the amount shown in the ! second column of the following table for each value of ! ERRTOL in the first column. In addition to the trunca- ! tion error there will be round-off error, but in prac- ! tice the total error from both sources is usually less ! than the amount given in the table. ! ! ! ! Sample choices: ERRTOL Relative truncation ! error less than ! 1.0D-3 2.0D-17 ! 3.0D-3 2.0D-14 ! 1.0D-2 2.0D-11 ! 3.0D-2 2.0D-8 ! 1.0D-1 2.0D-5 ! ! ! Decreasing ERRTOL by a factor of 10 yields six more ! decimal digits of accuracy at the expense of one or ! two more iterations of the duplication theorem. ! ! *Long Description: ! ! DRC special comments ! ! ! ! ! Check: DRC(X,X+Z) + DRC(Y,Y+Z) = DRC(0,Z) ! ! where X, Y, and Z are positive and X * Y = Z * Z ! ! ! On Input: ! ! X, and Y are the variables in the integral DRC(X,Y). ! ! On Output: ! ! X and Y are unaltered. ! ! ! ! DRC(0,1/4)=DRC(1/16,1/8)=PI=3.14159... ! ! DRC(9/4,2)=LN(2) ! ! ! ! ******************************************************** ! ! WARNING: Changes in the program may improve speed at the ! expense of robustness. ! ! ! -------------------------------------------------------------------- ! ! Special functions via DRC ! ! ! ! LN X X > 0 ! ! 2 ! LN(X) = (X-1) DRC(((1+X)/2) , X ) ! ! ! -------------------------------------------------------------------- ! ! ARCSIN X -1 <= X <= 1 ! ! 2 ! ARCSIN X = X DRC (1-X ,1 ) ! ! -------------------------------------------------------------------- ! ! ARCCOS X 0 <= X <= 1 ! ! ! 2 2 ! ARCCOS X = SQRT(1-X ) DRC(X ,1 ) ! ! -------------------------------------------------------------------- ! ! ARCTAN X -INF < X < +INF ! ! 2 ! ARCTAN X = X DRC(1,1+X ) ! ! -------------------------------------------------------------------- ! ! ARCCOT X 0 <= X < INF ! ! 2 2 ! ARCCOT X = DRC(X ,X +1 ) ! ! -------------------------------------------------------------------- ! ! ARCSINH X -INF < X < +INF ! ! 2 ! ARCSINH X = X DRC(1+X ,1 ) ! ! -------------------------------------------------------------------- ! ! ARCCOSH X X >= 1 ! ! 2 2 ! ARCCOSH X = SQRT(X -1) DRC(X ,1 ) ! ! -------------------------------------------------------------------- ! ! ARCTANH X -1 < X < 1 ! ! 2 ! ARCTANH X = X DRC(1,1-X ) ! ! -------------------------------------------------------------------- ! ! ARCCOTH X X > 1 ! ! 2 2 ! ARCCOTH X = DRC(X ,X -1 ) ! ! -------------------------------------------------------------------- ! !***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete ! elliptic integrals, ACM Transactions on Mathematical ! Software 7, 3 (September 1981), pp. 398-403. ! B. C. Carlson, Computing elliptic integrals by ! duplication, Numerische Mathematik 33, (1979), ! pp. 1-16. ! B. C. Carlson, Elliptic integrals of the first kind, ! SIAM Journal of Mathematical Analysis 8, (1977), ! pp. 231-242. !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced statement labels. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900510 Changed calls to XERMSG to standard form, and some ! editorial changes. (RWC)) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DRC CHARACTER*16 XERN3, XERN4, XERN5 INTEGER IER DOUBLE PRECISION C1, C2, ERRTOL, LAMDA, LOLIM, D1MACH DOUBLE PRECISION MU, S, SN, UPLIM, X, XN, Y, YN LOGICAL FIRST SAVE ERRTOL,LOLIM,UPLIM,C1,C2,FIRST DATA FIRST /.TRUE./ ! !***FIRST EXECUTABLE STATEMENT DRC if (FIRST) THEN ERRTOL = (D1MACH(3)/16.0D0)**(1.0D0/6.0D0) LOLIM = 5.0D0 * D1MACH(1) UPLIM = D1MACH(2) / 5.0D0 ! C1 = 1.0D0/7.0D0 C2 = 9.0D0/22.0D0 end if FIRST = .FALSE. ! ! call ERROR HANDLER if NECESSARY. ! DRC = 0.0D0 if (X < 0.0D0.OR.Y <= 0.0D0) THEN IER = 1 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y call XERMSG ('SLATEC', 'DRC', & 'X < 0 .OR. Y <= 0 WHERE X = ' // XERN3 // ' AND Y = ' // & XERN4, 1, 1) return end if ! if (MAX(X,Y) > UPLIM) THEN IER = 3 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') UPLIM call XERMSG ('SLATEC', 'DRC', & 'MAX(X,Y) > UPLIM WHERE X = ' // XERN3 // ' Y = ' // & XERN4 // ' AND UPLIM = ' // XERN5, 3, 1) return end if ! if (X+Y < LOLIM) THEN IER = 2 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') LOLIM call XERMSG ('SLATEC', 'DRC', & 'X+Y < LOLIM WHERE X = ' // XERN3 // ' Y = ' // XERN4 // & ' AND LOLIM = ' // XERN5, 2, 1) return end if ! IER = 0 XN = X YN = Y ! 30 MU = (XN+YN+YN)/3.0D0 SN = (YN+MU)/MU - 2.0D0 if (ABS(SN) < ERRTOL) go to 40 LAMDA = 2.0D0*SQRT(XN)*SQRT(YN) + YN XN = (XN+LAMDA)*0.250D0 YN = (YN+LAMDA)*0.250D0 go to 30 ! 40 S = SN*SN*(0.30D0+SN*(C1+SN*(0.3750D0+SN*C2))) DRC = (1.0D0+S)/SQRT(MU) return end DOUBLE PRECISION FUNCTION DRD (X, Y, Z, IER) ! !! DRD computes the incomplete or complete elliptic integral of 2nd kind. ! !***PURPOSE Compute the incomplete or complete elliptic integral of ! the 2nd kind. For X and Y nonnegative, X+Y and Z positive, ! DRD(X,Y,Z) = Integral from zero to infinity of ! -1/2 -1/2 -3/2 ! (3/2)(t+X) (t+Y) (t+Z) dt. ! If X or Y is zero, the integral is complete. ! !***LIBRARY SLATEC !***CATEGORY C14 !***TYPE DOUBLE PRECISION (RD-S, DRD-D) !***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, ! INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE SECOND KIND, ! TAYLOR SERIES !***AUTHOR Carlson, B. C. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Notis, E. M. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Pexton, R. L. ! Lawrence Livermore National Laboratory ! Livermore, CA 94550 !***DESCRIPTION ! ! 1. DRD ! Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL ! of the second kind ! Standard FORTRAN function routine ! Double precision version ! The routine calculates an approximation result to ! DRD(X,Y,Z) = Integral from zero to infinity of ! -1/2 -1/2 -3/2 ! (3/2)(t+X) (t+Y) (t+Z) dt, ! where X and Y are nonnegative, X + Y is positive, and Z is ! positive. If X or Y is zero, the integral is COMPLETE. ! The duplication theorem is iterated until the variables are ! nearly equal, and the function is then expanded in Taylor ! series to fifth order. ! ! 2. Calling Sequence ! ! DRD( X, Y, Z, IER ) ! ! Parameters On Entry ! Values assigned by the calling routine ! ! X - Double precision, nonnegative variable ! ! Y - Double precision, nonnegative variable ! ! X + Y is positive ! ! Z - Double precision, positive variable ! ! ! ! On Return (values assigned by the DRD routine) ! ! DRD - Double precision approximation to the integral ! ! ! IER - Integer ! ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! ! IER > 0 Abnormal termination of the routine ! ! ! X, Y, Z are unaltered. ! ! 3. Error Messages ! ! Value of IER assigned by the DRD routine ! ! Value assigned Error message printed ! IER = 1 MIN(X,Y) < 0.0D0 ! = 2 MIN(X + Y, Z ) < LOLIM ! = 3 MAX(X,Y,Z) > UPLIM ! ! ! 4. Control Parameters ! ! Values of LOLIM, UPLIM, and ERRTOL are set by the ! routine. ! ! LOLIM and UPLIM determine the valid range of X, Y, and Z ! ! LOLIM - Lower limit of valid arguments ! ! Not less than 2 / (machine maximum) ** (2/3). ! ! UPLIM - Upper limit of valid arguments ! ! Not greater than (0.1D0 * ERRTOL / machine ! minimum) ** (2/3), where ERRTOL is described below. ! In the following table it is assumed that ERRTOL will ! never be chosen smaller than 1.0D-5. ! ! ! Acceptable values for: LOLIM UPLIM ! IBM 360/370 SERIES : 6.0D-51 1.0D+48 ! CDC 6000/7000 SERIES : 5.0D-215 2.0D+191 ! UNIVAC 1100 SERIES : 1.0D-205 2.0D+201 ! CRAY : 3.0D-1644 1.69D+1640 ! VAX 11 SERIES : 1.0D-25 4.5D+21 ! ! ! ERRTOL determines the accuracy of the answer ! ! The value assigned by the routine will result ! in solution precision within 1-2 decimals of ! "machine precision". ! ! ERRTOL Relative error due to truncation is less than ! 3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2. ! ! ! ! The accuracy of the computed approximation to the integral ! can be controlled by choosing the value of ERRTOL. ! Truncation of a Taylor series after terms of fifth order ! introduces an error less than the amount shown in the ! second column of the following table for each value of ! ERRTOL in the first column. In addition to the truncation ! error there will be round-off error, but in practice the ! total error from both sources is usually less than the ! amount given in the table. ! ! ! ! ! Sample choices: ERRTOL Relative truncation ! error less than ! 1.0D-3 4.0D-18 ! 3.0D-3 3.0D-15 ! 1.0D-2 4.0D-12 ! 3.0D-2 3.0D-9 ! 1.0D-1 4.0D-6 ! ! ! Decreasing ERRTOL by a factor of 10 yields six more ! decimal digits of accuracy at the expense of one or ! two more iterations of the duplication theorem. ! ! *Long Description: ! ! DRD Special Comments ! ! ! ! Check: DRD(X,Y,Z) + DRD(Y,Z,X) + DRD(Z,X,Y) ! = 3 / SQRT(X * Y * Z), where X, Y, and Z are positive. ! ! ! On Input: ! ! X, Y, and Z are the variables in the integral DRD(X,Y,Z). ! ! ! On Output: ! ! ! X, Y, Z are unaltered. ! ! ! ! ******************************************************** ! ! WARNING: Changes in the program may improve speed at the ! expense of robustness. ! ! ! ! ------------------------------------------------------------------- ! ! ! Special double precision functions via DRD and DRF ! ! ! Legendre form of ELLIPTIC INTEGRAL of 2nd kind ! ! ----------------------------------------- ! ! ! 2 2 2 ! E(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1) - ! ! 2 3 2 2 2 ! -(K/3) SIN (PHI) DRD(COS (PHI),1-K SIN (PHI),1) ! ! ! 2 2 2 ! E(K) = DRF(0,1-K ,1) - (K/3) DRD(0,1-K ,1) ! ! PI/2 2 2 1/2 ! = INT (1-K SIN (PHI) ) D PHI ! 0 ! ! Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind ! ! ----------------------------------------- ! ! 22 2 ! EL2(X,KC,A,B) = AX DRF(1,1+KC X ,1+X ) + ! ! 3 22 2 ! +(1/3)(B-A) X DRD(1,1+KC X ,1+X ) ! ! ! ! ! Legendre form of alternative ELLIPTIC INTEGRAL ! of 2nd kind ! ! ----------------------------------------- ! ! ! ! Q 2 2 2 -1/2 ! D(Q,K) = INT SIN P (1-K SIN P) DP ! 0 ! ! ! ! 3 2 2 2 ! D(Q,K) = (1/3) (SIN Q) DRD(COS Q,1-K SIN Q,1) ! ! ! ! ! Lemniscate constant B ! ! ----------------------------------------- ! ! ! ! ! 1 2 4 -1/2 ! B = INT S (1-S ) DS ! 0 ! ! ! B = (1/3) DRD (0,2,1) ! ! ! Heuman's LAMBDA function ! ! ----------------------------------------- ! ! ! ! (PI/2) LAMBDA0(A,B) = ! ! 2 2 ! = SIN(B) (DRF(0,COS (A),1)-(1/3) SIN (A) * ! ! 2 2 2 2 ! *DRD(0,COS (A),1)) DRF(COS (B),1-COS (A) SIN (B),1) ! ! 2 3 2 ! -(1/3) COS (A) SIN (B) DRF(0,COS (A),1) * ! ! 2 2 2 ! *DRD(COS (B),1-COS (A) SIN (B),1) ! ! ! ! Jacobi ZETA function ! ! ----------------------------------------- ! ! 2 2 2 2 ! Z(B,K) = (K/3) SIN(B) DRF(COS (B),1-K SIN (B),1) ! ! ! 2 2 ! *DRD(0,1-K ,1)/DRF(0,1-K ,1) ! ! 2 3 2 2 2 ! -(K /3) SIN (B) DRD(COS (B),1-K SIN (B),1) ! ! ! --------------------------------------------------------------------- ! !***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete ! elliptic integrals, ACM Transactions on Mathematical ! Software 7, 3 (September 1981), pp. 398-403. ! B. C. Carlson, Computing elliptic integrals by ! duplication, Numerische Mathematik 33, (1979), ! pp. 1-16. ! B. C. Carlson, Elliptic integrals of the first kind, ! SIAM Journal of Mathematical Analysis 8, (1977), ! pp. 231-242. !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900510 Modify calls to XERMSG to put in standard form. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DRD CHARACTER*16 XERN3, XERN4, XERN5, XERN6 INTEGER IER DOUBLE PRECISION LOLIM, TUPLIM, UPLIM, EPSLON, ERRTOL, D1MACH DOUBLE PRECISION C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA DOUBLE PRECISION MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, & ZNROOT LOGICAL FIRST SAVE ERRTOL, LOLIM, UPLIM, C1, C2, C3, C4, FIRST DATA FIRST /.TRUE./ ! !***FIRST EXECUTABLE STATEMENT DRD if (FIRST) THEN ERRTOL = (D1MACH(3)/3.0D0)**(1.0D0/6.0D0) LOLIM = 2.0D0/(D1MACH(2))**(2.0D0/3.0D0) TUPLIM = D1MACH(1)**(1.0E0/3.0E0) TUPLIM = (0.10D0*ERRTOL)**(1.0E0/3.0E0)/TUPLIM UPLIM = TUPLIM**2.0D0 ! C1 = 3.0D0/14.0D0 C2 = 1.0D0/6.0D0 C3 = 9.0D0/22.0D0 C4 = 3.0D0/26.0D0 end if FIRST = .FALSE. ! ! call ERROR HANDLER if NECESSARY. ! DRD = 0.0D0 if ( MIN(X,Y) < 0.0D0) THEN IER = 1 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y call XERMSG ('SLATEC', 'DRD', & 'MIN(X,Y) < 0 WHERE X = ' // XERN3 // ' AND Y = ' // & XERN4, 1, 1) return end if ! if (MAX(X,Y,Z) > UPLIM) THEN IER = 3 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') UPLIM call XERMSG ('SLATEC', 'DRD', & 'MAX(X,Y,Z) > UPLIM WHERE X = ' // XERN3 // ' Y = ' // & XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, & 3, 1) return end if ! if (MIN(X+Y,Z) < LOLIM) THEN IER = 2 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') LOLIM call XERMSG ('SLATEC', 'DRD', & 'MIN(X+Y,Z) < LOLIM WHERE X = ' // XERN3 // ' Y = ' // & XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // XERN6, & 2, 1) return end if ! IER = 0 XN = X YN = Y ZN = Z SIGMA = 0.0D0 POWER4 = 1.0D0 ! 30 MU = (XN+YN+3.0D0*ZN)*0.20D0 XNDEV = (MU-XN)/MU YNDEV = (MU-YN)/MU ZNDEV = (MU-ZN)/MU EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV)) if (EPSLON < ERRTOL) go to 40 XNROOT = SQRT(XN) YNROOT = SQRT(YN) ZNROOT = SQRT(ZN) LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA)) POWER4 = POWER4*0.250D0 XN = (XN+LAMDA)*0.250D0 YN = (YN+LAMDA)*0.250D0 ZN = (ZN+LAMDA)*0.250D0 go to 30 ! 40 EA = XNDEV*YNDEV EB = ZNDEV*ZNDEV EC = EA - EB ED = EA - 6.0D0*EB EF = ED + EC + EC S1 = ED*(-C1+0.250D0*C3*ED-1.50D0*C4*ZNDEV*EF) S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA)) DRD = 3.0D0*SIGMA + POWER4*(1.0D0+S1+S2)/(MU*SQRT(MU)) ! return end subroutine DREADP (IPAGE, LIST, RLIST, LPAGE, IREC) ! !! DREADP reads a record from a file, for DSPLP. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DSPLP !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SREADP-S, DREADP-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! READ RECORD NUMBER IRECN, OF LENGTH LPG, FROM UNIT ! NUMBER IPAGEF INTO THE STORAGE ARRAY, LIST(*). ! READ RECORD IRECN+1, OF LENGTH LPG, FROM UNIT NUMBER ! IPAGEF INTO THE STORAGE ARRAY RLIST(*). ! ! TO CONVERT THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE ! /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/. ! !***SEE ALSO DSPLP !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890605 Corrected references to XERRWV. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE DREADP INTEGER LIST(*) DOUBLE PRECISION RLIST(*) CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT DREADP IPAGEF=IPAGE LPG =LPAGE IRECN=IREC READ(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG) READ(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG) return ! 100 WRITE (XERN1, '(I8)') LPG WRITE (XERN2, '(I8)') IRECN call XERMSG ('SLATEC', 'DREADP', 'IN DSPLP, LPG = ' // XERN1 // & ' IRECN = ' // XERN2, 100, 1) return end subroutine DREORT (NCOMP, Y, YP, YHP, NIV, W, S, P, IP, STOWA, & IFLAG) ! !! DREORT orthonormalizes the solution vector of a homogeneous system. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DBVSUP !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (REORT-S, DREORT-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! INPUT ! ********* ! Y, YP and YHP = homogeneous solution matrix and particular ! solution vector to be orthonormalized. ! IFLAG = 1 -- store YHP into Y and YP, test for ! reorthonormalization, orthonormalize if needed, ! save restart data. ! 2 -- store YHP into Y and YP, reorthonormalization, ! no restarts. ! (preset orthonormalization mode) ! 3 -- store YHP into Y and YP, reorthonormalization ! (when INHOMO=3 and X=XEND). ! ********************************************************************** ! OUTPUT ! ********* ! Y, YP = orthonormalized solutions. ! NIV = number of independent vectors returned from DMGSBV. ! IFLAG = 0 -- reorthonormalization was performed. ! 10 -- solution process must be restarted at the last ! orthonormalization point. ! 30 -- solutions are linearly dependent, problem must ! be restarted from the beginning. ! W, P, IP = orthonormalization information. ! ********************************************************************** ! !***SEE ALSO DBVSUP !***ROUTINES CALLED DDOT, DMGSBV, DSTOR1, DSTWAY !***COMMON BLOCKS DML15T, DML18J, DML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DREORT ! DOUBLE PRECISION DDOT INTEGER ICOCO, IFLAG, IGOFX, IJK, INDPVT, INFO, INHOMO, INTEG, & IP(*), ISTKOP, IVP, J, K, KK, KNSWOT, KOP, L, LOTJP, MFLAG, & MNSWOT, MXNON, NCOMP, NCOMPD, NDISK, NEQ, NEQIVP, NFC, & NFCC, NFCP, NIC, NIV, NOPG, NPS, NSWOT, NTAPE, NTP, NUMORT, & NXPTS DOUBLE PRECISION AE, C, DND, DNDT, DX, P(*), PWCND, PX, RE, S(*), & SRP, STOWA(*), TND, TOL, VNORM, W(*), WCND, X, XBEG, XEND, & XOP, XOT, XSAV, Y(NCOMP,*), YHP(NCOMP,*), YP(*), YPNM ! ! ****************************************************************** ! COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFC COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, & ICOCO ! ! ********************************************************************** ! BEGIN BLOCK PERMITTING ...EXITS TO 210 ! BEGIN BLOCK PERMITTING ...EXITS TO 10 !***FIRST EXECUTABLE STATEMENT DREORT NFCP = NFC + 1 ! ! CHECK TO SEE if ORTHONORMALIZATION TEST IS TO BE PERFORMED ! ! ...EXIT if (IFLAG /= 1) go to 10 KNSWOT = KNSWOT + 1 ! ...EXIT if (KNSWOT >= NSWOT) go to 10 ! ......EXIT if ((XEND - X)*(X - XOT) < 0.0D0) go to 210 10 CONTINUE call DSTOR1(Y,YHP,YP,YHP(1,NFCP),1,0,0) ! ! *************************************************************** ! ! ORTHOGONALIZE THE HOMOGENEOUS SOLUTIONS Y ! AND PARTICULAR SOLUTION YP. ! NIV = NFC call DMGSBV(NCOMP,NFC,Y,NCOMP,NIV,MFLAG,S,P,IP,INHOMO,YP,W, & WCND) ! ! ************************************************************ ! ! CHECK FOR LINEAR DEPENDENCE OF THE SOLUTIONS. ! if (MFLAG == 0) go to 50 ! BEGIN BLOCK PERMITTING ...EXITS TO 40 if (IFLAG == 2) go to 30 if (NSWOT <= 1 .AND. LOTJP /= 0) go to 20 ! ! RETRIEVE DATA FOR A RESTART AT LAST ! ORTHONORMALIZATION POINT ! call DSTWAY(Y,YP,YHP,1,STOWA) LOTJP = 1 NSWOT = 1 KNSWOT = 0 MNSWOT = MNSWOT/2 TND = TND + 1.0D0 IFLAG = 10 ! .........EXIT go to 40 20 CONTINUE 30 CONTINUE IFLAG = 30 40 CONTINUE go to 200 50 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 190 ! BEGIN BLOCK PERMITTING ...EXITS TO 110 ! ! ****************************************************** ! ! ...EXIT if (IFLAG /= 1) go to 110 ! ! TEST FOR ORTHONORMALIZATION ! ! ...EXIT if (WCND < 50.0D0*TOL) go to 110 DO 60 IJK = 1, NFCP ! ......EXIT if (S(IJK) > 1.0D20) go to 110 60 CONTINUE ! ! USE LINEAR EXTRAPOLATION ON LOGARITHMIC VALUES OF THE ! NORM DECREMENTS TO DETERMINE NEXT ORTHONORMALIZATION ! CHECKPOINT. OTHER CONTROLS ON THE NUMBER OF STEPS TO ! THE NEXT CHECKPOINT ARE ADDED FOR SAFETY PURPOSES. ! NSWOT = KNSWOT KNSWOT = 0 LOTJP = 0 WCND = LOG10(WCND) if (WCND > TND + 3.0D0) NSWOT = 2*NSWOT if (WCND < PWCND) go to 70 XOT = XEND NSWOT = MIN(MNSWOT,NSWOT) PWCND = WCND PX = X go to 100 70 CONTINUE DX = X - PX DND = PWCND - WCND if (DND >= 4) NSWOT = NSWOT/2 DNDT = WCND - TND if (ABS(DX*DNDT) <= DND*ABS(XEND-X)) go to 80 XOT = XEND NSWOT = MIN(MNSWOT,NSWOT) PWCND = WCND PX = X go to 90 80 CONTINUE XOT = X + DX*DNDT/DND NSWOT = MIN(MNSWOT,NSWOT) PWCND = WCND PX = X 90 CONTINUE 100 CONTINUE ! ......EXIT go to 190 110 CONTINUE ! ! ********************************************************* ! ! ORTHONORMALIZATION NECESSARY SO WE NORMALIZE THE ! HOMOGENEOUS SOLUTION VECTORS AND CHANGE W ACCORDINGLY. ! NSWOT = 1 KNSWOT = 0 LOTJP = 1 KK = 1 L = 1 DO 150 K = 1, NFCC ! BEGIN BLOCK PERMITTING ...EXITS TO 140 SRP = SQRT(P(KK)) if (INHOMO == 1) W(K) = SRP*W(K) VNORM = 1.0D0/SRP P(KK) = VNORM KK = KK + NFCC + 1 - K if (NFC == NFCC) go to 120 ! ......EXIT if (L /= K/2) go to 140 120 CONTINUE DO 130 J = 1, NCOMP Y(J,L) = Y(J,L)*VNORM 130 CONTINUE L = L + 1 140 CONTINUE 150 CONTINUE ! if (INHOMO /= 1 .OR. NPS == 1) go to 180 ! ! NORMALIZE THE PARTICULAR SOLUTION ! YPNM = DDOT(NCOMP,YP,1,YP,1) if (YPNM == 0.0D0) YPNM = 1.0D0 YPNM = SQRT(YPNM) S(NFCP) = YPNM DO 160 J = 1, NCOMP YP(J) = YP(J)/YPNM 160 CONTINUE DO 170 J = 1, NFCC W(J) = C*W(J) 170 CONTINUE 180 CONTINUE ! if (IFLAG == 1) call DSTWAY(Y,YP,YHP,0,STOWA) IFLAG = 0 190 CONTINUE 200 CONTINUE 210 CONTINUE return end DOUBLE PRECISION FUNCTION DRF (X, Y, Z, IER) ! !! DRF computes the incomplete or complete elliptic integral of 1st kind. ! !***PURPOSE Compute the incomplete or complete elliptic integral of the ! 1st kind. For X, Y, and Z non-negative and at most one of ! them zero, RF(X,Y,Z) = Integral from zero to infinity of ! -1/2 -1/2 -1/2 ! (1/2)(t+X) (t+Y) (t+Z) dt. ! If X, Y or Z is zero, the integral is complete. !***LIBRARY SLATEC !***CATEGORY C14 !***TYPE DOUBLE PRECISION (RF-S, DRF-D) !***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, ! INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE FIRST KIND, ! TAYLOR SERIES !***AUTHOR Carlson, B. C. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Notis, E. M. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Pexton, R. L. ! Lawrence Livermore National Laboratory ! Livermore, CA 94550 !***DESCRIPTION ! ! 1. DRF ! Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL ! of the first kind ! Standard FORTRAN function routine ! Double precision version ! The routine calculates an approximation result to ! DRF(X,Y,Z) = Integral from zero to infinity of ! ! -1/2 -1/2 -1/2 ! (1/2)(t+X) (t+Y) (t+Z) dt, ! ! where X, Y, and Z are nonnegative and at most one of them ! is zero. If one of them is zero, the integral is COMPLETE. ! The duplication theorem is iterated until the variables are ! nearly equal, and the function is then expanded in Taylor ! series to fifth order. ! ! 2. Calling sequence ! DRF( X, Y, Z, IER ) ! ! Parameters On entry ! Values assigned by the calling routine ! ! X - Double precision, nonnegative variable ! ! Y - Double precision, nonnegative variable ! ! Z - Double precision, nonnegative variable ! ! ! ! On Return (values assigned by the DRF routine) ! ! DRF - Double precision approximation to the integral ! ! IER - Integer ! ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! ! IER > 0 Abnormal termination of the routine ! ! X, Y, Z are unaltered. ! ! ! 3. Error Messages ! ! ! Value of IER assigned by the DRF routine ! ! Value assigned Error Message Printed ! IER = 1 MIN(X,Y,Z) < 0.0D0 ! = 2 MIN(X+Y,X+Z,Y+Z) < LOLIM ! = 3 MAX(X,Y,Z) > UPLIM ! ! ! ! 4. Control Parameters ! ! Values of LOLIM, UPLIM, and ERRTOL are set by the ! routine. ! ! LOLIM and UPLIM determine the valid range of X, Y and Z ! ! LOLIM - Lower limit of valid arguments ! ! Not less than 5 * (machine minimum). ! ! UPLIM - Upper limit of valid arguments ! ! Not greater than (machine maximum) / 5. ! ! ! Acceptable values for: LOLIM UPLIM ! IBM 360/370 SERIES : 3.0D-78 1.0D+75 ! CDC 6000/7000 SERIES : 1.0D-292 1.0D+321 ! UNIVAC 1100 SERIES : 1.0D-307 1.0D+307 ! CRAY : 2.3D-2466 1.09D+2465 ! VAX 11 SERIES : 1.5D-38 3.0D+37 ! ! ! ! ERRTOL determines the accuracy of the answer ! ! The value assigned by the routine will result ! in solution precision within 1-2 decimals of ! "machine precision". ! ! ! ! ERRTOL - Relative error due to truncation is less than ! ERRTOL ** 6 / (4 * (1-ERRTOL) . ! ! ! ! The accuracy of the computed approximation to the integral ! can be controlled by choosing the value of ERRTOL. ! Truncation of a Taylor series after terms of fifth order ! introduces an error less than the amount shown in the ! second column of the following table for each value of ! ERRTOL in the first column. In addition to the truncation ! error there will be round-off error, but in practice the ! total error from both sources is usually less than the ! amount given in the table. ! ! ! ! ! ! Sample choices: ERRTOL Relative Truncation ! error less than ! 1.0D-3 3.0D-19 ! 3.0D-3 2.0D-16 ! 1.0D-2 3.0D-13 ! 3.0D-2 2.0D-10 ! 1.0D-1 3.0D-7 ! ! ! Decreasing ERRTOL by a factor of 10 yields six more ! decimal digits of accuracy at the expense of one or ! two more iterations of the duplication theorem. ! ! *Long Description: ! ! DRF Special Comments ! ! ! ! Check by addition theorem: DRF(X,X+Z,X+W) + DRF(Y,Y+Z,Y+W) ! = DRF(0,Z,W), where X,Y,Z,W are positive and X * Y = Z * W. ! ! ! On Input: ! ! X, Y, and Z are the variables in the integral DRF(X,Y,Z). ! ! ! On Output: ! ! ! X, Y, Z are unaltered. ! ! ! ! ******************************************************** ! ! WARNING: Changes in the program may improve speed at the ! expense of robustness. ! ! ! ! Special double precision functions via DRF ! ! ! ! ! Legendre form of ELLIPTIC INTEGRAL of 1st kind ! ! ----------------------------------------- ! ! ! ! 2 2 2 ! F(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1) ! ! ! 2 ! K(K) = DRF(0,1-K ,1) ! ! ! PI/2 2 2 -1/2 ! = INT (1-K SIN (PHI) ) D PHI ! 0 ! ! ! ! Bulirsch form of ELLIPTIC INTEGRAL of 1st kind ! ! ----------------------------------------- ! ! ! 22 2 ! EL1(X,KC) = X DRF(1,1+KC X ,1+X ) ! ! ! Lemniscate constant A ! ! ----------------------------------------- ! ! ! 1 4 -1/2 ! A = INT (1-S ) DS = DRF(0,1,2) = DRF(0,2,1) ! 0 ! ! ! ! ------------------------------------------------------------------- ! !***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete ! elliptic integrals, ACM Transactions on Mathematical ! Software 7, 3 (September 1981), pp. 398-403. ! B. C. Carlson, Computing elliptic integrals by ! duplication, Numerische Mathematik 33, (1979), ! pp. 1-16. ! B. C. Carlson, Elliptic integrals of the first kind, ! SIAM Journal of Mathematical Analysis 8, (1977), ! pp. 231-242. !***ROUTINES CALLED D1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced statement labels. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900510 Changed calls to XERMSG to standard form, and some ! editorial changes. (RWC)) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DRF CHARACTER*16 XERN3, XERN4, XERN5, XERN6 INTEGER IER DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH DOUBLE PRECISION C1, C2, C3, E2, E3, LAMDA DOUBLE PRECISION MU, S, X, XN, XNDEV DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, & ZNROOT LOGICAL FIRST SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,FIRST DATA FIRST /.TRUE./ ! !***FIRST EXECUTABLE STATEMENT DRF ! if (FIRST) THEN ERRTOL = (4.0D0*D1MACH(3))**(1.0D0/6.0D0) LOLIM = 5.0D0 * D1MACH(1) UPLIM = D1MACH(2)/5.0D0 ! C1 = 1.0D0/24.0D0 C2 = 3.0D0/44.0D0 C3 = 1.0D0/14.0D0 end if FIRST = .FALSE. ! ! call ERROR HANDLER if NECESSARY. ! DRF = 0.0D0 if (MIN(X,Y,Z) < 0.0D0) THEN IER = 1 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z call XERMSG ('SLATEC', 'DRF', & 'MIN(X,Y,Z) < 0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 // & ' AND Z = ' // XERN5, 1, 1) return end if ! if (MAX(X,Y,Z) > UPLIM) THEN IER = 3 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') UPLIM call XERMSG ('SLATEC', 'DRF', & 'MAX(X,Y,Z) > UPLIM WHERE X = ' // XERN3 // ' Y = ' // & XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, 3, 1) return end if ! if (MIN(X+Y,X+Z,Y+Z) < LOLIM) THEN IER = 2 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') LOLIM call XERMSG ('SLATEC', 'DRF', & 'MIN(X+Y,X+Z,Y+Z) < LOLIM WHERE X = ' // XERN3 // & ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // & XERN6, 2, 1) return end if ! IER = 0 XN = X YN = Y ZN = Z ! 30 MU = (XN+YN+ZN)/3.0D0 XNDEV = 2.0D0 - (MU+XN)/MU YNDEV = 2.0D0 - (MU+YN)/MU ZNDEV = 2.0D0 - (MU+ZN)/MU EPSLON = MAX(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV)) if (EPSLON < ERRTOL) go to 40 XNROOT = SQRT(XN) YNROOT = SQRT(YN) ZNROOT = SQRT(ZN) LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT XN = (XN+LAMDA)*0.250D0 YN = (YN+LAMDA)*0.250D0 ZN = (ZN+LAMDA)*0.250D0 go to 30 ! 40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV E3 = XNDEV*YNDEV*ZNDEV S = 1.0D0 + (C1*E2-0.10D0-C2*E3)*E2 + C3*E3 DRF = S/SQRT(MU) ! return end DOUBLE PRECISION FUNCTION DRJ (X, Y, Z, P, IER) ! !! DRJ computes the incomplete or complete elliptic integral of 3rd kind. ! !***PURPOSE Compute the incomplete or complete (X or Y or Z is zero) ! elliptic integral of the 3rd kind. For X, Y, and Z non- ! negative, at most one of them zero, and P positive, ! RJ(X,Y,Z,P) = Integral from zero to infinity of ! -1/2 -1/2 -1/2 -1 ! (3/2)(t+X) (t+Y) (t+Z) (t+P) dt. ! !***LIBRARY SLATEC !***CATEGORY C14 !***TYPE DOUBLE PRECISION (RJ-S, DRJ-D) !***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, ! INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE THIRD KIND, ! TAYLOR SERIES !***AUTHOR Carlson, B. C. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Notis, E. M. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Pexton, R. L. ! Lawrence Livermore National Laboratory ! Livermore, CA 94550 !***DESCRIPTION ! ! 1. DRJ ! Standard FORTRAN function routine ! Double precision version ! The routine calculates an approximation result to ! DRJ(X,Y,Z,P) = Integral from zero to infinity of ! ! -1/2 -1/2 -1/2 -1 ! (3/2)(t+X) (t+Y) (t+Z) (t+P) dt, ! ! where X, Y, and Z are nonnegative, at most one of them is ! zero, and P is positive. If X or Y or Z is zero, the ! integral is COMPLETE. The duplication theorem is iterated ! until the variables are nearly equal, and the function is ! then expanded in Taylor series to fifth order. ! ! ! 2. Calling Sequence ! DRJ( X, Y, Z, P, IER ) ! ! Parameters on Entry ! Values assigned by the calling routine ! ! X - Double precision, nonnegative variable ! ! Y - Double precision, nonnegative variable ! ! Z - Double precision, nonnegative variable ! ! P - Double precision, positive variable ! ! ! On Return (values assigned by the DRJ routine) ! ! DRJ - Double precision approximation to the integral ! ! IER - Integer ! ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! ! IER > 0 Abnormal termination of the routine ! ! ! X, Y, Z, P are unaltered. ! ! ! 3. Error Messages ! ! Value of IER assigned by the DRJ routine ! ! Value assigned Error Message printed ! IER = 1 MIN(X,Y,Z) < 0.0D0 ! = 2 MIN(X+Y,X+Z,Y+Z,P) < LOLIM ! = 3 MAX(X,Y,Z,P) > UPLIM ! ! ! ! 4. Control Parameters ! ! Values of LOLIM, UPLIM, and ERRTOL are set by the ! routine. ! ! ! LOLIM and UPLIM determine the valid range of X, Y, Z, and P ! ! LOLIM is not less than the cube root of the value ! of LOLIM used in the routine for DRC. ! ! UPLIM is not greater than 0.3 times the cube root of ! the value of UPLIM used in the routine for DRC. ! ! ! Acceptable values for: LOLIM UPLIM ! IBM 360/370 SERIES : 2.0D-26 3.0D+24 ! CDC 6000/7000 SERIES : 5.0D-98 3.0D+106 ! UNIVAC 1100 SERIES : 5.0D-103 6.0D+101 ! CRAY : 1.32D-822 1.4D+821 ! VAX 11 SERIES : 2.5D-13 9.0D+11 ! ! ! ! ERRTOL determines the accuracy of the answer ! ! the value assigned by the routine will result ! in solution precision within 1-2 decimals of ! "machine precision". ! ! ! ! ! Relative error due to truncation of the series for DRJ ! is less than 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2. ! ! ! ! The accuracy of the computed approximation to the integral ! can be controlled by choosing the value of ERRTOL. ! Truncation of a Taylor series after terms of fifth order ! introduces an error less than the amount shown in the ! second column of the following table for each value of ! ERRTOL in the first column. In addition to the truncation ! error there will be round-off error, but in practice the ! total error from both sources is usually less than the ! amount given in the table. ! ! ! ! Sample choices: ERRTOL Relative truncation ! error less than ! 1.0D-3 4.0D-18 ! 3.0D-3 3.0D-15 ! 1.0D-2 4.0D-12 ! 3.0D-2 3.0D-9 ! 1.0D-1 4.0D-6 ! ! Decreasing ERRTOL by a factor of 10 yields six more ! decimal digits of accuracy at the expense of one or ! two more iterations of the duplication theorem. ! ! *Long Description: ! ! DRJ Special Comments ! ! ! Check by addition theorem: DRJ(X,X+Z,X+W,X+P) ! + DRJ(Y,Y+Z,Y+W,Y+P) + (A-B) * DRJ(A,B,B,A) + 3.0D0 / SQRT(A) ! = DRJ(0,Z,W,P), where X,Y,Z,W,P are positive and X * Y ! = Z * W, A = P * P * (X+Y+Z+W), B = P * (P+X) * (P+Y), ! and B - A = P * (P-Z) * (P-W). The sum of the third and ! fourth terms on the left side is 3.0D0 * DRC(A,B). ! ! ! On Input: ! ! X, Y, Z, and P are the variables in the integral DRJ(X,Y,Z,P). ! ! ! On Output: ! ! ! X, Y, Z, P are unaltered. ! ! ******************************************************** ! ! WARNING: Changes in the program may improve speed at the ! expense of robustness. ! ! ------------------------------------------------------------------- ! ! ! Special double precision functions via DRJ and DRF ! ! ! Legendre form of ELLIPTIC INTEGRAL of 3rd kind ! ----------------------------------------- ! ! ! PHI 2 -1 ! P(PHI,K,N) = INT (1+N SIN (THETA) ) * ! 0 ! ! ! 2 2 -1/2 ! *(1-K SIN (THETA) ) D THETA ! ! ! 2 2 2 ! = SIN (PHI) DRF(COS (PHI), 1-K SIN (PHI),1) ! ! 3 2 2 2 ! -(N/3) SIN (PHI) DRJ(COS (PHI),1-K SIN (PHI), ! ! 2 ! 1,1+N SIN (PHI)) ! ! ! ! Bulirsch form of ELLIPTIC INTEGRAL of 3rd kind ! ----------------------------------------- ! ! ! 22 2 ! EL3(X,KC,P) = X DRF(1,1+KC X ,1+X ) + ! ! 3 22 2 2 ! +(1/3)(1-P) X DRJ(1,1+KC X ,1+X ,1+PX ) ! ! ! 2 ! CEL(KC,P,A,B) = A RF(0,KC ,1) + ! ! ! 2 ! +(1/3)(B-PA) DRJ(0,KC ,1,P) ! ! ! Heuman's LAMBDA function ! ----------------------------------------- ! ! ! 2 2 2 1/2 ! L(A,B,P) =(COS (A)SIN(B)COS(B)/(1-COS (A)SIN (B)) ) ! ! 2 2 2 ! *(SIN(P) DRF(COS (P),1-SIN (A) SIN (P),1) ! ! 2 3 2 2 ! +(SIN (A) SIN (P)/(3(1-COS (A) SIN (B)))) ! ! 2 2 2 ! *DRJ(COS (P),1-SIN (A) SIN (P),1,1- ! ! 2 2 2 2 ! -SIN (A) SIN (P)/(1-COS (A) SIN (B)))) ! ! ! ! (PI/2) LAMBDA0(A,B) =L(A,B,PI/2) = ! ! 2 2 2 -1/2 ! = COS (A) SIN(B) COS(B) (1-COS (A) SIN (B)) ! ! 2 2 2 ! *DRF(0,COS (A),1) + (1/3) SIN (A) COS (A) ! ! 2 2 -3/2 ! *SIN(B) COS(B) (1-COS (A) SIN (B)) ! ! 2 2 2 2 2 ! *DRJ(0,COS (A),1,COS (A) COS (B)/(1-COS (A) SIN (B))) ! ! ! Jacobi ZETA function ! ----------------------------------------- ! ! 2 2 2 1/2 ! Z(B,K) = (K/3) SIN(B) COS(B) (1-K SIN (B)) ! ! ! 2 2 2 2 ! *DRJ(0,1-K ,1,1-K SIN (B)) / DRF (0,1-K ,1) ! ! ! --------------------------------------------------------------------- ! !***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete ! elliptic integrals, ACM Transactions on Mathematical ! Software 7, 3 (September 1981), pp. 398-403. ! B. C. Carlson, Computing elliptic integrals by ! duplication, Numerische Mathematik 33, (1979), ! pp. 1-16. ! B. C. Carlson, Elliptic integrals of the first kind, ! SIAM Journal of Mathematical Analysis 8, (1977), ! pp. 231-242. !***ROUTINES CALLED D1MACH, DRC, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced statement labels. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900510 Changed calls to XERMSG to standard form, and some ! editorial changes. (RWC)). ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DRJ INTEGER IER CHARACTER*16 XERN3, XERN4, XERN5, XERN6, XERN7 DOUBLE PRECISION ALFA, BETA, C1, C2, C3, C4, EA, EB, EC, E2, E3 DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH DOUBLE PRECISION LAMDA, MU, P, PN, PNDEV DOUBLE PRECISION POWER4, DRC, SIGMA, S1, S2, S3, X, XN, XNDEV DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, & ZNROOT LOGICAL FIRST SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,FIRST DATA FIRST /.TRUE./ ! !***FIRST EXECUTABLE STATEMENT DRJ if (FIRST) THEN ERRTOL = (D1MACH(3)/3.0D0)**(1.0D0/6.0D0) LOLIM = (5.0D0 * D1MACH(1))**(1.0D0/3.0D0) UPLIM = 0.30D0*( D1MACH(2) / 5.0D0)**(1.0D0/3.0D0) ! C1 = 3.0D0/14.0D0 C2 = 1.0D0/3.0D0 C3 = 3.0D0/22.0D0 C4 = 3.0D0/26.0D0 end if FIRST = .FALSE. ! ! call ERROR HANDLER if NECESSARY. ! DRJ = 0.0D0 if (MIN(X,Y,Z) < 0.0D0) THEN IER = 1 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z call XERMSG ('SLATEC', 'DRJ', & 'MIN(X,Y,Z) < 0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 // & ' AND Z = ' // XERN5, 1, 1) return end if ! if (MAX(X,Y,Z,P) > UPLIM) THEN IER = 3 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') P WRITE (XERN7, '(1PE15.6)') UPLIM call XERMSG ('SLATEC', 'DRJ', & 'MAX(X,Y,Z,P) > UPLIM WHERE X = ' // XERN3 // ' Y = ' // & XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 // & ' AND UPLIM = ' // XERN7, 3, 1) return end if ! if (MIN(X+Y,X+Z,Y+Z,P) < LOLIM) THEN IER = 2 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') P WRITE (XERN7, '(1PE15.6)') LOLIM call XERMSG ('SLATEC', 'RJ', & 'MIN(X+Y,X+Z,Y+Z,P) < LOLIM WHERE X = ' // XERN3 // & ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 // & ' AND LOLIM = ', 2, 1) return end if ! IER = 0 XN = X YN = Y ZN = Z PN = P SIGMA = 0.0D0 POWER4 = 1.0D0 ! 30 MU = (XN+YN+ZN+PN+PN)*0.20D0 XNDEV = (MU-XN)/MU YNDEV = (MU-YN)/MU ZNDEV = (MU-ZN)/MU PNDEV = (MU-PN)/MU EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV), ABS(PNDEV)) if (EPSLON < ERRTOL) go to 40 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) SIGMA = SIGMA + POWER4*DRC(ALFA,BETA,IER) POWER4 = POWER4*0.250D0 XN = (XN+LAMDA)*0.250D0 YN = (YN+LAMDA)*0.250D0 ZN = (ZN+LAMDA)*0.250D0 PN = (PN+LAMDA)*0.250D0 go to 30 ! 40 EA = XNDEV*(YNDEV+ZNDEV) + YNDEV*ZNDEV EB = XNDEV*YNDEV*ZNDEV EC = PNDEV*PNDEV E2 = EA - 3.0D0*EC E3 = EB + 2.0D0*PNDEV*(EA-EC) S1 = 1.0D0 + E2*(-C1+0.750D0*C3*E2-1.50D0*C4*E3) S2 = EB*(0.50D0*C2+PNDEV*(-C3-C3+PNDEV*C4)) S3 = PNDEV*EA*(C2-PNDEV*C3) - C2*PNDEV*EC DRJ = 3.0D0*SIGMA + POWER4*(S1+S2+S3)/(MU* SQRT(MU)) return end subroutine DRKFAB (NCOMP, XPTS, NXPTS, NFC, IFLAG, Z, MXNON, P, & NTP, IP, YHP, NIV, U, V, W, S, STOWA, G, WORK, IWORK, NFCC) ! !! DRKFAB integrates an initial value problem for DBVSUP. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DBVSUP !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (RKFAB-S, DRKFAB-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! ! Subroutine DRKFAB integrates the initial value equations using ! the variable-step Runge-Kutta-Fehlberg integration scheme or ! the variable-order Adams method and orthonormalization ! determined by a linear dependence test. ! ! ********************************************************************** ! !***SEE ALSO DBVSUP !***ROUTINES CALLED DBVDER, DDEABM, DDERKF, DREORT, DSTOR1 !***COMMON BLOCKS DML15T, DML17B, DML18J, DML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DRKFAB ! INTEGER ICOCO, IDID, IFLAG, IGOFX, INDPVT, INFO, INHOMO, INTEG, & IPAR, ISTKOP, IVP, J, JFLAG, JON, & K1, K10, K11, K2, K3, K4, K5, K6, K7, K8, K9, KKKINT, & KKKZPW, KNSWOT, KOD, KOP, KOPP, L1, L2, LLLINT, LOTJP, & MNSWOT, MXNON, MXNOND, NCOMP, NCOMPD, NDISK, NEEDIW, NEEDW, & NEQ, NEQIVP, NFC, NFCC, NFCCD, NFCD, NFCP1, NIC, NIV, NON, & NOPG, NPS, NSWOT, NTAPE, NTP, NTPD, NUMORT, NXPTS, NXPTSD, & IP(NFCC,*), IWORK(*) DOUBLE PRECISION AE, C, G(*), P(NTP,*), PWCND, PX, RE, & S(*), STOWA(*), TND, TOL, U(NCOMP,NFC,*), & V(NCOMP,*), W(NFCC,*), WORK(*), X, XBEG, XEND, XOP, & XOT, XPTS(*), XSAV, XXOP, YHP(NCOMP,*), Z(*) ! ! ****************************************************************** ! COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /DML18J/ AE,RE,TOL,NXPTSD,NIC,NOPG,MXNOND,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD, & ICOCO COMMON /DML17B/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, & K10,K11,L1,L2,KKKINT,LLLINT ! EXTERNAL DBVDER ! ! ***************************************************************** ! INITIALIZATION OF COUNTERS AND VARIABLES. ! ! BEGIN BLOCK PERMITTING ...EXITS TO 220 ! BEGIN BLOCK PERMITTING ...EXITS TO 10 !***FIRST EXECUTABLE STATEMENT DRKFAB KOD = 1 NON = 1 X = XBEG JON = 1 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 1 WORK(1) = XEND ! ...EXIT if (NOPG == 0) go to 10 INFO(3) = 0 if (X == Z(1)) JON = 2 10 CONTINUE NFCP1 = NFC + 1 ! ! *************************************************************** ! *****BEGINNING OF INTEGRATION LOOP AT OUTPUT ! POINTS.****************** ! *************************************************************** ! DO 210 KOPP = 2, NXPTS KOP = KOPP XOP = XPTS(KOP) if (NDISK == 0) KOD = KOP ! 20 CONTINUE ! ! STEP BY STEP INTEGRATION LOOP BETWEEN OUTPUT POINTS. ! ! BEGIN BLOCK PERMITTING ...EXITS TO 190 ! BEGIN BLOCK PERMITTING ...EXITS TO 30 XXOP = XOP ! ...EXIT if (NOPG == 0) go to 30 if (XEND > XBEG .AND. XOP > Z(JON)) & XXOP = Z(JON) if (XEND < XBEG .AND. XOP < Z(JON)) & XXOP = Z(JON) 30 CONTINUE ! ! ****************************************************** 40 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 170 go to (50,60), INTEG ! DDERKF INTEGRATOR ! 50 CONTINUE call DDERKF(DBVDER,NEQ,X,YHP,XXOP,INFO,RE,AE, & IDID,WORK,KKKINT,IWORK,LLLINT,G, & IPAR) go to 70 ! DDEABM INTEGRATOR ! 60 CONTINUE call DDEABM(DBVDER,NEQ,X,YHP,XXOP,INFO,RE,AE, & IDID,WORK,KKKINT,IWORK,LLLINT,G, & IPAR) 70 CONTINUE if (IDID >= 1) go to 80 INFO(1) = 1 ! ......EXIT if (IDID == -1) go to 170 IFLAG = 20 - IDID ! .....................EXIT go to 220 80 CONTINUE ! ! ************************************************ ! GRAM-SCHMIDT ORTHOGONALIZATION TEST FOR ! ORTHONORMALIZATION (TEMPORARILY USING U AND ! V IN THE TEST) ! if (NOPG == 0) go to 100 if (XXOP == Z(JON)) go to 90 ! ! ****************************************** ! CONTINUE INTEGRATION if WE ARE NOT AT ! AN OUTPUT POINT. ! ! ..................EXIT if (IDID /= 1) go to 200 ! .........EXIT go to 170 90 CONTINUE JFLAG = 2 go to 110 100 CONTINUE JFLAG = 1 if (INHOMO == 3 .AND. X == XEND) & JFLAG = 3 110 CONTINUE ! if (NDISK == 0) NON = NUMORT + 1 call DREORT(NCOMP,U(1,1,KOD),V(1,KOD),YHP,NIV, & W(1,NON),S,P(1,NON),IP(1,NON),STOWA, & JFLAG) ! if (JFLAG /= 30) go to 120 IFLAG = 30 ! .....................EXIT go to 220 120 CONTINUE ! if (JFLAG /= 10) go to 130 XOP = XPTS(KOP) if (NDISK == 0) KOD = KOP ! ............EXIT go to 190 130 CONTINUE ! if (JFLAG == 0) go to 140 ! ! ********************************************* ! CONTINUE INTEGRATION if WE ARE NOT AT AN ! OUTPUT POINT. ! ! ...............EXIT if (IDID /= 1) go to 200 ! ......EXIT go to 170 140 CONTINUE ! ! ************************************************ ! STORE ORTHONORMALIZED VECTORS INTO SOLUTION ! VECTORS. ! if (NUMORT < MXNON) go to 150 if (X == XEND) go to 150 IFLAG = 13 ! .....................EXIT go to 220 150 CONTINUE ! NUMORT = NUMORT + 1 call DSTOR1(YHP,U(1,1,KOD),YHP(1,NFCP1), & V(1,KOD),1,NDISK,NTAPE) ! ! ************************************************ ! STORE ORTHONORMALIZATION INFORMATION, ! INITIALIZE INTEGRATION FLAG, AND CONTINUE ! INTEGRATION TO THE NEXT ORTHONORMALIZATION ! POINT OR OUTPUT POINT. ! Z(NUMORT) = X if (INHOMO == 1 .AND. NPS == 0) & C = S(NFCP1)*C if (NDISK == 0) go to 160 if (INHOMO == 1) & WRITE (NTAPE) (W(J,1), J = 1, NFCC) WRITE (NTAPE) & (IP(J,1), J = 1, NFCC), & (P(J,1), J = 1, NTP) 160 CONTINUE INFO(1) = 0 JON = JON + 1 ! ......EXIT if (NOPG == 1 .AND. X /= XOP) go to 180 ! ! ************************************************ ! CONTINUE INTEGRATION if WE ARE NOT AT AN ! OUTPUT POINT. ! ! ............EXIT if (IDID /= 1) go to 200 170 CONTINUE go to 40 180 CONTINUE 190 CONTINUE go to 20 200 CONTINUE ! ! STORAGE OF HOMOGENEOUS SOLUTIONS IN U AND THE PARTICULAR ! SOLUTION IN V AT THE OUTPUT POINTS. ! call DSTOR1(U(1,1,KOD),YHP,V(1,KOD),YHP(1,NFCP1),0,NDISK, & NTAPE) 210 CONTINUE ! *************************************************************** ! *************************************************************** ! IFLAG = 0 220 CONTINUE return end subroutine DRKFS (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, H, & TOLFAC, YP, F1, F2, F3, F4, F5, YS, TOLD, DTSIGN, U26, RER, & INIT, KSTEPS, KOP, IQUIT, STIFF, NONSTF, NTSTEP, NSTIFS, RPAR, & IPAR) ! !! DRKFS integrates a system of ODE's for DDERKF. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DDERKF !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (DERKFS-S, DRKFS-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! Fehlberg Fourth-Fifth Order Runge-Kutta Method ! ********************************************************************** ! ! DRKFS integrates a system of first order ordinary differential ! equations as described in the comments for DDERKF . ! ! The arrays YP,F1,F2,F3,F4,F5,and YS (of length at least NEQ) ! appear in the call list for variable dimensioning purposes. ! ! The variables H,TOLFAC,TOLD,DTSIGN,U26,RER,INIT,KSTEPS,KOP,IQUIT, ! STIFF,NONSTF,NTSTEP, and NSTIFS are used internally by the code ! and appear in the call list to eliminate local retention of ! variables between calls. Accordingly, these variables and the ! array YP should not be altered. ! Items of possible interest are ! H - An appropriate step size to be used for the next step ! TOLFAC - Factor of change in the tolerances ! YP - Derivative of solution vector at T ! KSTEPS - Counter on the number of steps attempted ! ! ********************************************************************** ! !***SEE ALSO DDERKF !***ROUTINES CALLED D1MACH, DFEHL, DHSTRT, DHVNRM, XERMSG !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891024 Changed references from DVNORM to DHVNRM. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls, change GOTOs to ! IF-THEN-ELSEs. (RWC) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DRKFS ! INTEGER IDID, INFO, INIT, IPAR, IQUIT, K, KOP, KSTEPS, KTOL, & MXKOP, MXSTEP, NATOLP, NEQ, NRTOLP, NSTIFS, NTSTEP DOUBLE PRECISION A, ATOL, BIG, D1MACH, & DT, DTSIGN, DHVNRM, DY, EE, EEOET, ES, ESTIFF, & ESTTOL, ET, F1, F2, F3, F4, F5, H, HMIN, REMIN, RER, RPAR, & RTOL, S, T, TOL, TOLD, TOLFAC, TOUT, U, U26, UTE, Y, YAVG, & YP, YS LOGICAL HFAILD,OUTPUT,STIFF,NONSTF CHARACTER*8 XERN1 CHARACTER*16 XERN3, XERN4 ! DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), & YS(*),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) ! EXTERNAL DF ! ! .................................................................. ! ! A FIFTH ORDER METHOD WILL GENERALLY NOT BE CAPABLE OF DELIVERING ! ACCURACIES NEAR LIMITING PRECISION ON COMPUTERS WITH LONG ! WORDLENGTHS. TO PROTECT AGAINST LIMITING PRECISION DIFFICULTIES ! ARISING FROM UNREASONABLE ACCURACY REQUESTS, AN APPROPRIATE ! TOLERANCE THRESHOLD REMIN IS ASSIGNED FOR THIS METHOD. THIS ! VALUE SHOULD NOT BE CHANGED ACROSS DIFFERENT MACHINES. ! SAVE REMIN, MXSTEP, MXKOP DATA REMIN /1.0D-12/ ! ! .................................................................. ! ! THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE ! NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MXSTEP, THE ! COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE ! EXCESSIVE WORK. ! DATA MXSTEP /500/ ! ! .................................................................. ! ! INEFFICIENCY CAUSED BY TOO FREQUENT OUTPUT IS MONITORED BY ! COUNTING THE NUMBER OF STEP SIZES WHICH ARE SEVERELY SHORTENED ! DUE SOLELY TO THE CHOICE OF OUTPUT POINTS. WHEN THE NUMBER OF ! ABUSES EXCEED MXKOP, THE COUNTER IS RESET TO ZERO AND THE USER ! IS INFORMED ABOUT POSSIBLE MISUSE OF THE CODE. ! DATA MXKOP /100/ ! ! .................................................................. ! !***FIRST EXECUTABLE STATEMENT DRKFS if (INFO(1) == 0) THEN ! ! ON THE FIRST call , PERFORM INITIALIZATION -- ! DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE ! FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE ! VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. ! U = D1MACH(4) ! -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS U26 = 26.0D0*U RER = 2.0D0*U + REMIN ! -- SET TERMINATION FLAG IQUIT = 0 ! -- SET INITIALIZATION INDICATOR INIT = 0 ! -- SET COUNTER FOR IMPACT OF OUTPUT POINTS KOP = 0 ! -- SET COUNTER FOR ATTEMPTED STEPS KSTEPS = 0 ! -- SET INDICATORS FOR STIFFNESS DETECTION STIFF = .FALSE. NONSTF = .FALSE. ! -- SET STEP COUNTERS FOR STIFFNESS DETECTION NTSTEP = 0 NSTIFS = 0 ! -- RESET INFO(1) FOR SUBSEQUENT CALLS INFO(1) = 1 end if ! !....................................................................... ! ! CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY ! if (INFO(1) /= 0 .AND. INFO(1) /= 1) THEN WRITE (XERN1, '(I8)') INFO(1) call XERMSG ('SLATEC', 'DRKFS', & 'IN DDERKF, INFO(1) MUST BE SET TO 0 ' // & 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // & 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // & 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE CODE ' // & 'WITH INFO(1) = ' // XERN1, 3, 1) IDID = -33 end if ! if (INFO(2) /= 0 .AND. INFO(2) /= 1) THEN WRITE (XERN1, '(I8)') INFO(2) call XERMSG ('SLATEC', 'DRKFS', & 'IN DDERKF, INFO(2) MUST BE 0 OR 1 ' // & 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // & 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // & XERN1, 4, 1) IDID = -33 end if ! if (INFO(3) /= 0 .AND. INFO(3) /= 1) THEN WRITE (XERN1, '(I8)') INFO(3) call XERMSG ('SLATEC', 'DRKFS', & 'IN DDERKF, INFO(3) MUST BE 0 OR 1 ' // & 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // & 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // & 'WITH INFO(3) = ' // XERN1, 5, 1) IDID = -33 end if ! if (NEQ < 1) THEN WRITE (XERN1, '(I8)') NEQ call XERMSG ('SLATEC', 'DRKFS', & 'IN DDERKF, THE NUMBER OF EQUATIONS ' // & 'NEQ MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // & 'CODE WITH NEQ = ' // XERN1, 6, 1) IDID = -33 end if ! NRTOLP = 0 NATOLP = 0 DO 10 K=1,NEQ if (NRTOLP == 0 .AND. RTOL(K) < 0.D0) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') RTOL(K) call XERMSG ('SLATEC', 'DRKFS', & 'IN DDERKF, THE RELATIVE ERROR ' // & 'TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU HAVE ' // & 'CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // & XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // & 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) IDID = -33 NRTOLP = 1 ENDIF ! if (NATOLP == 0 .AND. ATOL(K) < 0.D0) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') ATOL(K) call XERMSG ('SLATEC', 'DRKFS', & 'IN DDERKF, THE ABSOLUTE ERROR ' // & 'TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU HAVE ' // & 'CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // & XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // & 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) IDID = -33 NATOLP = 1 ENDIF ! if (INFO(2) == 0) go to 20 if (NATOLP > 0 .AND. NRTOLP > 0) go to 20 10 CONTINUE ! ! ! CHECK SOME CONTINUATION POSSIBILITIES ! 20 if (INIT /= 0) THEN if (T == TOUT) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'DRKFS', & 'IN DDERKF, YOU HAVE CALLED THE ' // & 'CODE WITH T = TOUT = ' // XERN3 // '$$THIS IS NOT ' // & 'ALLOWED ON CONTINUATION CALLS.', 9, 1) IDID=-33 ENDIF ! if (T /= TOLD) THEN WRITE (XERN3, '(1PE15.6)') TOLD WRITE (XERN4, '(1PE15.6)') T call XERMSG ('SLATEC', 'DRKFS', & 'IN DDERKF, YOU HAVE CHANGED THE ' // & 'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 // & '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) IDID=-33 ENDIF ! if (INIT /= 1) THEN if (DTSIGN*(TOUT-T) < 0.D0) THEN WRITE (XERN3, '(1PE15.6)') TOUT call XERMSG ('SLATEC', 'DRKFS', & 'IN DDERKF, BY CALLING THE CODE WITH TOUT = ' // & XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // & 'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' // & 'WITHOUT RESTARTING.', 11, 1) IDID=-33 ENDIF ENDIF end if ! ! INVALID INPUT DETECTED ! if (IDID == (-33)) THEN if (IQUIT /= (-33)) THEN IQUIT = -33 GOTO 540 ELSE call XERMSG ('SLATEC', 'DRKFS', & 'IN DDERKF, INVALID INPUT WAS ' // & 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // & 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // & 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) return ENDIF end if ! ! ............................................................ ! ! RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND ! INTERPRETED AS ASKING FOR THE MOST ACCURATE SOLUTION ! POSSIBLE. IN THIS CASE, THE RELATIVE ERROR TOLERANCE ! RTOL IS RESET TO THE SMALLEST VALUE RER WHICH IS LIKELY ! TO BE REASONABLE FOR THIS METHOD AND MACHINE. ! DO 190 K = 1, NEQ if (RTOL(K) + ATOL(K) > 0.0D0) go to 180 RTOL(K) = RER IDID = -2 180 CONTINUE ! ...EXIT if (INFO(2) == 0) go to 200 190 CONTINUE 200 CONTINUE ! if (IDID /= (-2)) go to 210 ! ! RTOL=ATOL=0 ON INPUT, SO RTOL WAS CHANGED TO A ! SMALL POSITIVE VALUE TOLFAC = 1.0D0 go to 530 210 CONTINUE ! ! BRANCH ON STATUS OF INITIALIZATION INDICATOR ! INIT=0 MEANS INITIAL DERIVATIVES AND ! STARTING STEP SIZE ! NOT YET COMPUTED ! INIT=1 MEANS STARTING STEP SIZE NOT YET ! COMPUTED INIT=2 MEANS NO FURTHER ! INITIALIZATION REQUIRED ! if (INIT == 0) go to 220 ! ......EXIT if (INIT == 1) go to 240 ! .........EXIT go to 260 220 CONTINUE ! ! ................................................ ! ! MORE INITIALIZATION -- ! -- EVALUATE INITIAL ! DERIVATIVES ! INIT = 1 A = T call DF(A,Y,YP,RPAR,IPAR) if (T /= TOUT) go to 230 ! ! INTERVAL MODE IDID = 2 T = TOUT TOLD = T ! .....................EXIT go to 560 230 CONTINUE 240 CONTINUE ! ! -- SET SIGN OF INTEGRATION DIRECTION AND ! -- ESTIMATE STARTING STEP SIZE ! INIT = 2 DTSIGN = SIGN(1.0D0,TOUT-T) U = D1MACH(4) BIG = SQRT(D1MACH(2)) UTE = U**0.375D0 DY = UTE*DHVNRM(Y,NEQ) if (DY == 0.0D0) DY = UTE KTOL = 1 DO 250 K = 1, NEQ if (INFO(2) == 1) KTOL = K TOL = RTOL(KTOL)*ABS(Y(K)) + ATOL(KTOL) if (TOL == 0.0D0) TOL = DY*RTOL(KTOL) F1(K) = TOL 250 CONTINUE ! call DHSTRT(DF,NEQ,T,TOUT,Y,YP,F1,4,U,BIG,F2,F3,F4, & F5,RPAR,IPAR,H) 260 CONTINUE ! ! ...................................................... ! ! SET STEP SIZE FOR INTEGRATION IN THE DIRECTION ! FROM T TO TOUT AND SET OUTPUT POINT INDICATOR ! DT = TOUT - T H = SIGN(H,DT) OUTPUT = .FALSE. ! ! TEST TO SEE if DDERKF IS BEING SEVERELY IMPACTED BY ! TOO MANY OUTPUT POINTS ! if (ABS(H) >= 2.0D0*ABS(DT)) KOP = KOP + 1 if (KOP <= MXKOP) go to 270 ! ! UNNECESSARY FREQUENCY OF OUTPUT IS RESTRICTING ! THE STEP SIZE CHOICE IDID = -5 KOP = 0 go to 510 270 CONTINUE ! if (ABS(DT) > U26*ABS(T)) go to 290 ! ! if TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND ! return ! DO 280 K = 1, NEQ Y(K) = Y(K) + DT*YP(K) 280 CONTINUE A = TOUT call DF(A,Y,YP,RPAR,IPAR) KSTEPS = KSTEPS + 1 go to 500 290 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 490 ! ! ********************************************* ! ********************************************* ! STEP BY STEP INTEGRATION ! 300 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 480 HFAILD = .FALSE. ! ! TO PROTECT AGAINST IMPOSSIBLE ACCURACY ! REQUESTS, COMPUTE A TOLERANCE FACTOR ! BASED ON THE REQUESTED ERROR TOLERANCE ! AND A LEVEL OF ACCURACY ACHIEVABLE AT ! LIMITING PRECISION ! TOLFAC = 0.0D0 KTOL = 1 DO 330 K = 1, NEQ if (INFO(2) == 1) KTOL = K ET = RTOL(KTOL)*ABS(Y(K)) & + ATOL(KTOL) if (ET > 0.0D0) go to 310 TOLFAC = MAX(TOLFAC, & RER/RTOL(KTOL)) go to 320 310 CONTINUE TOLFAC = MAX(TOLFAC, & ABS(Y(K)) & *(RER/ET)) 320 CONTINUE 330 CONTINUE if (TOLFAC <= 1.0D0) go to 340 ! ! REQUESTED ERROR UNATTAINABLE DUE TO LIMITED ! PRECISION AVAILABLE TOLFAC = 2.0D0*TOLFAC IDID = -2 ! .....................EXIT go to 520 340 CONTINUE ! ! SET SMALLEST ALLOWABLE STEP SIZE ! HMIN = U26*ABS(T) ! ! ADJUST STEP SIZE if NECESSARY TO HIT ! THE OUTPUT POINT -- LOOK AHEAD TWO ! STEPS TO AVOID DRASTIC CHANGES IN THE ! STEP SIZE AND THUS LESSEN THE IMPACT OF ! OUTPUT POINTS ON THE CODE. STRETCH THE ! STEP SIZE BY, AT MOST, AN AMOUNT EQUAL ! TO THE SAFETY FACTOR OF 9/10. ! DT = TOUT - T if (ABS(DT) >= 2.0D0*ABS(H)) & go to 370 if (ABS(DT) > ABS(H)/0.9D0) & go to 350 ! ! THE NEXT STEP, if SUCCESSFUL, ! WILL COMPLETE THE INTEGRATION TO ! THE OUTPUT POINT ! OUTPUT = .TRUE. H = DT go to 360 350 CONTINUE ! H = 0.5D0*DT 360 CONTINUE 370 CONTINUE ! ! ! *************************************** ! CORE INTEGRATOR FOR TAKING A ! SINGLE STEP ! *************************************** ! TO AVOID PROBLEMS WITH ZERO ! CROSSINGS, RELATIVE ERROR IS ! MEASURED USING THE AVERAGE OF THE ! MAGNITUDES OF THE SOLUTION AT THE ! BEGINNING AND END OF A STEP. ! THE ERROR ESTIMATE FORMULA HAS ! BEEN GROUPED TO CONTROL LOSS OF ! SIGNIFICANCE. ! LOCAL ERROR ESTIMATES FOR A FIRST ! ORDER METHOD USING THE SAME ! STEP SIZE AS THE FEHLBERG METHOD ! ARE CALCULATED AS PART OF THE ! TEST FOR STIFFNESS. ! TO DISTINGUISH THE VARIOUS ! ARGUMENTS, H IS NOT PERMITTED ! TO BECOME SMALLER THAN 26 UNITS OF ! ROUNDOFF IN T. PRACTICAL LIMITS ! ON THE CHANGE IN THE STEP SIZE ARE ! ENFORCED TO SMOOTH THE STEP SIZE ! SELECTION PROCESS AND TO AVOID ! EXCESSIVE CHATTERING ON PROBLEMS ! HAVING DISCONTINUITIES. TO ! PREVENT UNNECESSARY FAILURES, THE ! CODE USES 9/10 THE STEP SIZE ! IT ESTIMATES WILL SUCCEED. ! AFTER A STEP FAILURE, THE STEP ! SIZE IS NOT ALLOWED TO INCREASE ! FOR THE NEXT ATTEMPTED STEP. THIS ! MAKES THE CODE MORE EFFICIENT ON ! PROBLEMS HAVING DISCONTINUITIES ! AND MORE EFFECTIVE IN GENERAL ! SINCE LOCAL EXTRAPOLATION IS BEING ! USED AND EXTRA CAUTION SEEMS ! WARRANTED. ! ....................................... ! ! MONITOR NUMBER OF STEPS ATTEMPTED ! 380 CONTINUE if (KSTEPS <= MXSTEP) go to 390 ! ! A SIGNIFICANT AMOUNT OF WORK HAS ! BEEN EXPENDED IDID = -1 KSTEPS = 0 ! ........................EXIT if (.NOT.STIFF) go to 520 ! ! PROBLEM APPEARS TO BE STIFF IDID = -4 STIFF = .FALSE. NONSTF = .FALSE. NTSTEP = 0 NSTIFS = 0 ! ........................EXIT go to 520 390 CONTINUE ! ! ADVANCE AN APPROXIMATE SOLUTION OVER ! ONE STEP OF LENGTH H ! call DFEHL(DF,NEQ,T,Y,H,YP,F1,F2,F3, & F4,F5,YS,RPAR,IPAR) KSTEPS = KSTEPS + 1 ! ! .................................... ! ! COMPUTE AND TEST ALLOWABLE ! TOLERANCES VERSUS LOCAL ERROR ! ESTIMATES. NOTE THAT RELATIVE ! ERROR IS MEASURED WITH RESPECT ! TO THE AVERAGE OF THE ! MAGNITUDES OF THE SOLUTION AT ! THE BEGINNING AND END OF THE ! STEP. LOCAL ERROR ESTIMATES ! FOR A SPECIAL FIRST ORDER ! METHOD ARE CALCULATED ONLY WHEN ! THE STIFFNESS DETECTION IS ! TURNED ON. ! EEOET = 0.0D0 ESTIFF = 0.0D0 KTOL = 1 DO 420 K = 1, NEQ YAVG = 0.5D0 & *(ABS(Y(K)) & + ABS(YS(K))) if (INFO(2) == 1) KTOL = K ET = RTOL(KTOL)*YAVG + ATOL(KTOL) if (ET > 0.0D0) go to 400 ! ! PURE RELATIVE ERROR INAPPROPRIATE WHEN SOLUTION ! VANISHES IDID = -3 ! ...........................EXIT go to 520 400 CONTINUE ! EE = ABS((-2090.0D0*YP(K) & +(21970.0D0*F3(K) & -15048.0D0*F4(K))) & +(22528.0D0*F2(K) & -27360.0D0*F5(K))) if (STIFF .OR. NONSTF) go to 410 ES = ABS(H & *(0.055455D0*YP(K) & -0.035493D0*F1(K) & -0.036571D0*F2(K) & +0.023107D0*F3(K) & -0.009515D0*F4(K) & +0.003017D0*F5(K)) & ) ESTIFF = MAX(ESTIFF,ES/ET) 410 CONTINUE EEOET = MAX(EEOET,EE/ET) 420 CONTINUE ! ESTTOL = ABS(H)*EEOET/752400.0D0 ! ! ...EXIT if (ESTTOL <= 1.0D0) go to 440 ! ! .................................... ! ! UNSUCCESSFUL STEP ! if (ABS(H) > HMIN) go to 430 ! ! REQUESTED ERROR UNATTAINABLE AT SMALLEST ! ALLOWABLE STEP SIZE TOLFAC = 1.69D0*ESTTOL IDID = -2 ! ........................EXIT go to 520 430 CONTINUE ! ! REDUCE THE STEP SIZE , TRY AGAIN ! THE DECREASE IS LIMITED TO A FACTOR ! OF 1/10 ! HFAILD = .TRUE. OUTPUT = .FALSE. S = 0.1D0 if (ESTTOL < 59049.0D0) & S = 0.9D0/ESTTOL**0.2D0 H = SIGN(MAX(S*ABS(H),HMIN),H) go to 380 440 CONTINUE ! ! ....................................... ! ! SUCCESSFUL STEP ! STORE SOLUTION AT T+H ! AND EVALUATE ! DERIVATIVES THERE ! T = T + H DO 450 K = 1, NEQ Y(K) = YS(K) 450 CONTINUE A = T call DF(A,Y,YP,RPAR,IPAR) ! ! CHOOSE NEXT STEP SIZE ! THE INCREASE IS LIMITED TO A FACTOR OF ! 5 if STEP FAILURE HAS JUST OCCURRED, ! NEXT ! STEP SIZE IS NOT ALLOWED TO INCREASE ! S = 5.0D0 if (ESTTOL > 1.889568D-4) & S = 0.9D0/ESTTOL**0.2D0 if (HFAILD) S = MIN(S,1.0D0) H = SIGN(MAX(S*ABS(H),HMIN),H) ! ! ....................................... ! ! CHECK FOR STIFFNESS (IF NOT ! ALREADY DETECTED) ! ! IN A SEQUENCE OF 50 SUCCESSFUL ! STEPS BY THE FEHLBERG METHOD, 25 ! SUCCESSFUL STEPS BY THE FIRST ! ORDER METHOD INDICATES STIFFNESS ! AND TURNS THE TEST OFF. if 26 ! FAILURES BY THE FIRST ORDER METHOD ! OCCUR, THE TEST IS TURNED OFF ! UNTIL THIS SEQUENCE OF 50 STEPS BY ! THE FEHLBERG METHOD IS COMPLETED. ! ! ...EXIT if (STIFF) go to 480 NTSTEP = MOD(NTSTEP+1,50) if (NTSTEP == 1) NONSTF = .FALSE. ! ...EXIT if (NONSTF) go to 480 if (ESTIFF > 1.0D0) go to 460 ! ! SUCCESSFUL STEP WITH FIRST ORDER ! METHOD NSTIFS = NSTIFS + 1 ! TURN TEST OFF AFTER 25 INDICATIONS ! OF STIFFNESS if (NSTIFS == 25) STIFF = .TRUE. go to 470 460 CONTINUE ! ! UNSUCCESSFUL STEP WITH FIRST ORDER ! METHOD if (NTSTEP - NSTIFS <= 25) go to 470 ! TURN STIFFNESS DETECTION OFF FOR THIS BLOCK OF ! FIFTY STEPS NONSTF = .TRUE. ! RESET STIFF STEP COUNTER NSTIFS = 0 470 CONTINUE 480 CONTINUE ! ! ****************************************** ! END OF CORE INTEGRATOR ! ****************************************** ! ! ! SHOULD WE TAKE ANOTHER STEP ! ! ......EXIT if (OUTPUT) go to 490 if (INFO(3) == 0) go to 300 ! ! ********************************************* ! ********************************************* ! ! INTEGRATION SUCCESSFULLY COMPLETED ! ! ONE-STEP MODE IDID = 1 TOLD = T ! .....................EXIT go to 560 490 CONTINUE 500 CONTINUE ! ! INTERVAL MODE IDID = 2 T = TOUT TOLD = T ! ...............EXIT go to 560 510 CONTINUE 520 CONTINUE 530 CONTINUE 540 CONTINUE ! ! INTEGRATION TASK INTERRUPTED ! INFO(1) = -1 TOLD = T ! ...EXIT if (IDID /= (-2)) go to 560 ! ! THE ERROR TOLERANCES ARE INCREASED TO VALUES ! WHICH ARE APPROPRIATE FOR CONTINUING RTOL(1) = TOLFAC*RTOL(1) ATOL(1) = TOLFAC*ATOL(1) ! ...EXIT if (INFO(2) == 0) go to 560 DO 550 K = 2, NEQ RTOL(K) = TOLFAC*RTOL(K) ATOL(K) = TOLFAC*ATOL(K) 550 CONTINUE 560 CONTINUE return end subroutine DRLCAL (N, KMP, LL, MAXL, V, Q, RL, SNORMW, PROD, & R0NRM) ! !! DRLCAL calculates the scaled residual for DGMRES. ! !***SUBSIDIARY !***PURPOSE Internal routine for DGMRES. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SRLCAL-S, DRLCAL-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine calculates the scaled residual RL from the ! V(I)'s. ! *Usage: ! INTEGER N, KMP, LL, MAXL ! DOUBLE PRECISION V(N,LL), Q(2*MAXL), RL(N), SNORMW, PROD, R0NORM ! ! call DRLCAL(N, KMP, LL, MAXL, V, Q, RL, SNORMW, PROD, R0NRM) ! ! *Arguments: ! N :IN Integer ! The order of the matrix A, and the lengths ! of the vectors SR, SZ, R0 and Z. ! KMP :IN Integer ! The number of previous V vectors the new vector VNEW ! must be made orthogonal to. (KMP .le. MAXL) ! LL :IN Integer ! The current dimension of the Krylov subspace. ! MAXL :IN Integer ! The maximum dimension of the Krylov subspace. ! V :IN Double Precision V(N,LL) ! The N x LL array containing the orthogonal vectors ! V(*,1) to V(*,LL). ! Q :IN Double Precision Q(2*MAXL) ! A double precision array of length 2*MAXL containing the ! components of the Givens rotations used in the QR ! decomposition of HES. It is loaded in DHEQR and used in ! DHELS. ! RL :OUT Double Precision RL(N) ! The residual vector RL. This is either SB*(B-A*XL) if ! not preconditioning or preconditioning on the right, ! or SB*(M-inverse)*(B-A*XL) if preconditioning on the ! left. ! SNORMW :IN Double Precision ! Scale factor. ! PROD :IN Double Precision ! The product s1*s2*...*sl = the product of the sines of the ! Givens rotations used in the QR factorization of ! the Hessenberg matrix HES. ! R0NRM :IN Double Precision ! The scaled norm of initial residual R0. ! !***SEE ALSO DGMRES !***ROUTINES CALLED DCOPY, DSCAL !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Made subsidiary to DGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE DRLCAL ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. DOUBLE PRECISION PROD, R0NRM, SNORMW INTEGER KMP, LL, MAXL, N ! .. Array Arguments .. DOUBLE PRECISION Q(*), RL(N), V(N,*) ! .. Local Scalars .. DOUBLE PRECISION C, S, TEM INTEGER I, I2, IP1, K, LLM1, LLP1 ! .. External Subroutines .. EXTERNAL DCOPY, DSCAL !***FIRST EXECUTABLE STATEMENT DRLCAL if (KMP == MAXL) THEN ! ! calculate RL. Start by copying V(*,1) into RL. ! call DCOPY(N, V(1,1), 1, RL, 1) LLM1 = LL - 1 DO 20 I = 1,LLM1 IP1 = I + 1 I2 = I*2 S = Q(I2) C = Q(I2-1) DO 10 K = 1,N RL(K) = S*RL(K) + C*V(K,IP1) 10 CONTINUE 20 CONTINUE S = Q(2*LL) C = Q(2*LL-1)/SNORMW LLP1 = LL + 1 DO 30 K = 1,N RL(K) = S*RL(K) + C*V(K,LLP1) 30 CONTINUE end if ! ! When KMP < MAXL, RL vector already partially calculated. ! Scale RL by R0NRM*PROD to obtain the residual RL. ! TEM = R0NRM*PROD call DSCAL(N, TEM, RL, 1) return !------------- LAST LINE OF DRLCAL FOLLOWS ---------------------------- end subroutine DROT (N, DX, INCX, DY, INCY, DC, DS) ! !! DROT applies a plane Givens rotation. ! !***PURPOSE Apply a plane Givens rotation. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A8 !***TYPE DOUBLE PRECISION (SROT-S, DROT-D, CSROT-C) !***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, ! LINEAR ALGEBRA, PLANE ROTATION, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! DY double precision vector with N elements ! INCY storage spacing between elements of DY ! DC D.P. element of rotation matrix ! DS D.P. element of rotation matrix ! ! --Output-- ! DX rotated vector DX (unchanged if N <= 0) ! DY rotated vector DY (unchanged if N <= 0) ! ! Multiply the 2 x 2 matrix ( DC DS) times the 2 x N matrix (DX**T) ! (-DS DC) (DY**T) ! where **T indicates transpose. The elements of DX are in ! DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX >= 0, else ! LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DROT DOUBLE PRECISION DX, DY, DC, DS, ZERO, ONE, W, Z DIMENSION DX(*), DY(*) SAVE ZERO, ONE DATA ZERO, ONE /0.0D0, 1.0D0/ !***FIRST EXECUTABLE STATEMENT DROT if (N <= 0 .OR. (DS == ZERO .AND. DC == ONE)) go to 40 if (.NOT. (INCX == INCY .AND. INCX > 0)) go to 20 ! ! Code for equal and positive increments. ! NSTEPS=INCX*N DO 10 I = 1,NSTEPS,INCX W=DX(I) Z=DY(I) DX(I)=DC*W+DS*Z DY(I)=-DS*W+DC*Z 10 CONTINUE go to 40 ! ! Code for unequal or nonpositive increments. ! 20 CONTINUE KX=1 KY=1 ! if (INCX < 0) KX = 1-(N-1)*INCX if (INCY < 0) KY = 1-(N-1)*INCY ! DO 30 I = 1,N W=DX(KX) Z=DY(KY) DX(KX)=DC*W+DS*Z DY(KY)=-DS*W+DC*Z KX=KX+INCX KY=KY+INCY 30 CONTINUE 40 CONTINUE ! return end subroutine DROTG (DA, DB, DC, DS) ! !! DROTG constructs a plane Givens rotation. ! !***PURPOSE Construct a plane Givens rotation. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B10 !***TYPE DOUBLE PRECISION (SROTG-S, DROTG-D, CROTG-C) !***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, ! LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! DA double precision scalar ! DB double precision scalar ! ! --Output-- ! DA double precision result R ! DB double precision result Z ! DC double precision result ! DS double precision result ! ! Construct the Givens transformation ! ! ( DC DS ) ! G = ( ) , DC**2 + DS**2 = 1 , ! (-DS DC ) ! ! which zeros the second entry of the 2-vector (DA,DB)**T . ! ! The quantity R = (+/-)SQRT(DA**2 + DB**2) overwrites DA in ! storage. The value of DB is overwritten by a value Z which ! allows DC and DS to be recovered by the following algorithm. ! ! If Z=1 set DC=0.0 and DS=1.0 ! If ABS(Z) < 1 set DC=SQRT(1-Z**2) and DS=Z ! If ABS(Z) > 1 set DC=1/Z and DS=SQRT(1-DC**2) ! ! Normally, the subprogram DROT(N,DX,INCX,DY,INCY,DC,DS) will ! next be called to apply the transformation to a 2 by N matrix. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DROTG DOUBLE PRECISION DA, DB, DC, DS, U, V, R !***FIRST EXECUTABLE STATEMENT DROTG if (ABS(DA) <= ABS(DB)) go to 10 ! ! *** HERE ABS(DA) > ABS(DB) *** ! U = DA + DA V = DB / U ! ! NOTE THAT U AND R HAVE THE SIGN OF DA ! R = SQRT(0.25D0 + V**2) * U ! ! NOTE THAT DC IS POSITIVE ! DC = DA / R DS = V * (DC + DC) DB = DS DA = R return ! ! *** HERE ABS(DA) <= ABS(DB) *** ! 10 if (DB == 0.0D0) go to 20 U = DB + DB V = DA / U ! ! NOTE THAT U AND R HAVE THE SIGN OF DB ! (R IS IMMEDIATELY STORED IN DA) ! DA = SQRT(0.25D0 + V**2) * U ! ! NOTE THAT DS IS POSITIVE ! DS = DB / DA DC = V * (DS + DS) if (DC == 0.0D0) go to 15 DB = 1.0D0 / DC return 15 DB = 1.0D0 return ! ! *** HERE DA = DB = 0.0 *** ! 20 DC = 1.0D0 DS = 0.0D0 return ! end subroutine DROTM (N, DX, INCX, DY, INCY, DPARAM) ! !! DROTM applies a modified Givens rotation. ! !***PURPOSE Apply a modified Givens transformation. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A8 !***TYPE DOUBLE PRECISION (SROTM-S, DROTM-D) !***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! DY double precision vector with N elements ! INCY storage spacing between elements of DY ! DPARAM 5-element D.P. vector. DPARAM(1) is DFLAG described below. ! Locations 2-5 of SPARAM contain elements of the ! transformation matrix H described below. ! ! --Output-- ! DX rotated vector (unchanged if N <= 0) ! DY rotated vector (unchanged if N <= 0) ! ! Apply the modified Givens transformation, H, to the 2 by N matrix ! (DX**T) ! (DY**T) , where **T indicates transpose. The elements of DX are ! in DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX >= 0, else ! LX = 1+(1-N)*INCX, and similarly for DY using LY and INCY. ! ! With DPARAM(1)=DFLAG, H has one of the following forms: ! ! DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 ! ! (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) ! H=( ) ( ) ( ) ( ) ! (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). ! ! See DROTMG for a description of data storage in DPARAM. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DROTM DOUBLE PRECISION DFLAG, DH12, DH22, DX, TWO, Z, DH11, DH21, & DPARAM, DY, W, ZERO DIMENSION DX(*), DY(*), DPARAM(5) SAVE ZERO, TWO DATA ZERO, TWO /0.0D0, 2.0D0/ !***FIRST EXECUTABLE STATEMENT DROTM DFLAG=DPARAM(1) if (N <= 0 .OR. (DFLAG+TWO == ZERO)) go to 140 if (.NOT.(INCX == INCY.AND. INCX > 0)) go to 70 ! NSTEPS=N*INCX if (DFLAG) 50,10,30 10 CONTINUE DH12=DPARAM(4) DH21=DPARAM(3) 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) DH12=DPARAM(4) DH21=DPARAM(3) 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 < 0) KX = 1+(1-N)*INCX if (INCY < 0) KY = 1+(1-N)*INCY ! if (DFLAG) 120,80,100 80 CONTINUE DH12=DPARAM(4) DH21=DPARAM(3) 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) DH12=DPARAM(4) DH21=DPARAM(3) 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 subroutine DROTMG (DD1, DD2, DX1, DY1, DPARAM) ! !! DROTMG constructs a modified Givens rotation. ! !***PURPOSE Construct a modified Givens transformation. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B10 !***TYPE DOUBLE PRECISION (SROTMG-S, DROTMG-D) !***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! DD1 double precision scalar ! DD2 double precision scalar ! DX1 double precision scalar ! DX2 double precision scalar ! DPARAM D.P. 5-vector. DPARAM(1)=DFLAG defined below. ! Locations 2-5 contain the rotation matrix. ! ! --Output-- ! DD1 changed to represent the effect of the transformation ! DD2 changed to represent the effect of the transformation ! DX1 changed to represent the effect of the transformation ! DX2 unchanged ! ! Construct the modified Givens transformation matrix H which zeros ! the second component of the 2-vector (SQRT(DD1)*DX1,SQRT(DD2)* ! DY2)**T. ! With DPARAM(1)=DFLAG, H has one of the following forms: ! ! DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 ! ! (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) ! H=( ) ( ) ( ) ( ) ! (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). ! ! Locations 2-5 of DPARAM contain DH11, DH21, DH12, and DH22, ! respectively. (Values of 1.D0, -1.D0, or 0.D0 implied by the ! value of DPARAM(1) are not stored in DPARAM.) ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920316 Prologue corrected. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DROTMG DOUBLE PRECISION GAM, ONE, RGAMSQ, DD1, DD2, DH11, DH12, DH21, & DH22, DPARAM, DP1, DP2, DQ1, DQ2, DU, DY1, ZERO, & GAMSQ, DFLAG, DTEMP, DX1, TWO DIMENSION DPARAM(5) SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ DATA ZERO, ONE, TWO /0.0D0, 1.0D0, 2.0D0/ DATA GAM, GAMSQ, RGAMSQ /4096.0D0, 16777216.D0, 5.9604645D-8/ !***FIRST EXECUTABLE STATEMENT DROTMG if (.NOT. DD1 < ZERO) go to 10 ! GO ZERO-H-D-AND-DX1.. go to 60 10 CONTINUE ! CASE-DD1-NONNEGATIVE DP2=DD2*DY1 if (.NOT. DP2 == ZERO) go to 20 DFLAG=-TWO go to 260 ! REGULAR-CASE.. 20 CONTINUE DP1=DD1*DX1 DQ2=DP2*DY1 DQ1=DP1*DX1 ! if (.NOT. ABS(DQ1) > ABS(DQ2)) go to 40 DH21=-DY1/DX1 DH12=DP2/DP1 ! DU=ONE-DH12*DH21 ! if (.NOT. DU <= ZERO) go to 30 ! GO ZERO-H-D-AND-DX1.. go to 60 30 CONTINUE DFLAG=ZERO DD1=DD1/DU DD2=DD2/DU DX1=DX1*DU ! GO SCALE-CHECK.. go to 100 40 CONTINUE if (.NOT. DQ2 < ZERO) go to 50 ! GO ZERO-H-D-AND-DX1.. go to 60 50 CONTINUE DFLAG=ONE DH11=DP1/DP2 DH22=DX1/DY1 DU=ONE+DH11*DH22 DTEMP=DD2/DU DD2=DD1/DU DD1=DTEMP DX1=DY1*DU ! GO SCALE-CHECK go to 100 ! PROCEDURE..ZERO-H-D-AND-DX1.. 60 CONTINUE DFLAG=-ONE DH11=ZERO DH12=ZERO DH21=ZERO DH22=ZERO ! DD1=ZERO DD2=ZERO DX1=ZERO ! return.. go to 220 ! PROCEDURE..FIX-H.. 70 CONTINUE if (.NOT. DFLAG >= ZERO) go to 90 ! if (.NOT. DFLAG == ZERO) go to 80 DH11=ONE DH22=ONE DFLAG=-ONE go to 90 80 CONTINUE DH21=-ONE DH12=ONE DFLAG=-ONE 90 CONTINUE go to IGO,(120,150,180,210) ! PROCEDURE..SCALE-CHECK 100 CONTINUE 110 CONTINUE if (.NOT. DD1 <= RGAMSQ) go to 130 if (DD1 == ZERO) go to 160 ASSIGN 120 TO IGO ! FIX-H.. go to 70 120 CONTINUE DD1=DD1*GAM**2 DX1=DX1/GAM DH11=DH11/GAM DH12=DH12/GAM go to 110 130 CONTINUE 140 CONTINUE if (.NOT. DD1 >= GAMSQ) go to 160 ASSIGN 150 TO IGO ! FIX-H.. go to 70 150 CONTINUE DD1=DD1/GAM**2 DX1=DX1*GAM DH11=DH11*GAM DH12=DH12*GAM go to 140 160 CONTINUE 170 CONTINUE if (.NOT. ABS(DD2) <= RGAMSQ) go to 190 if (DD2 == ZERO) go to 220 ASSIGN 180 TO IGO ! FIX-H.. go to 70 180 CONTINUE DD2=DD2*GAM**2 DH21=DH21/GAM DH22=DH22/GAM go to 170 190 CONTINUE 200 CONTINUE if (.NOT. ABS(DD2) >= GAMSQ) go to 220 ASSIGN 210 TO IGO ! FIX-H.. go to 70 210 CONTINUE DD2=DD2/GAM**2 DH21=DH21*GAM DH22=DH22*GAM go to 200 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 DRSCO (RSAV, ISAV) ! !! DRSCO transfers data from arrays to common blocks for DDEBDF. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DDEBDF !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (RSCO-S, DRSCO-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DRSCO transfers data from arrays to a common block within the ! integrator package DDEBDF. ! !***SEE ALSO DDEBDF !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DDEBD1 !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DRSCO !----------------------------------------------------------------------- ! THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON ! BLOCK DDEBD1 , WHICH IS USED INTERNALLY IN THE DDEBDF ! PACKAGE. THIS PRESUMES THAT RSAV AND ISAV WERE LOADED BY MEANS ! OF SUBROUTINE DSVCO OR THE EQUIVALENT. !----------------------------------------------------------------------- ! INTEGER I, ILS, ISAV, LENILS, LENRLS DOUBLE PRECISION RLS, RSAV DIMENSION RSAV(*),ISAV(*) SAVE LENRLS, LENILS COMMON /DDEBD1/ RLS(218),ILS(33) DATA LENRLS /218/, LENILS /33/ ! !***FIRST EXECUTABLE STATEMENT DRSCO DO 10 I = 1, LENRLS RLS(I) = RSAV(I) 10 CONTINUE DO 20 I = 1, LENILS ILS(I) = ISAV(I) 20 CONTINUE return ! ----------------------- END OF SUBROUTINE DRSCO ! ----------------------- end subroutine DS2LT (N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL) ! !! DS2LT is the Lower Triangle Preconditioner SLAP Set Up. ! ! Routine to store the lower triangle of a matrix stored ! in the SLAP Column format. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SS2LT-S, DS2LT-D) !***KEYWORDS LINEAR SYSTEM, LOWER TRIANGLE, SLAP SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! INTEGER NEL, IEL(NEL), JEL(NEL) ! DOUBLE PRECISION A(NELT), EL(NEL) ! ! call DS2LT( N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of non-zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! NEL :OUT Integer. ! Number of non-zeros in the lower triangle of A. Also ! corresponds to the length of the IEL, JEL, EL arrays. ! IEL :OUT Integer IEL(NEL). ! JEL :OUT Integer JEL(NEL). ! EL :OUT Double Precision EL(NEL). ! IEL, JEL, EL contain the lower triangle of the A matrix ! stored in SLAP Column format. See "Description", below, ! for more details bout the SLAP Column format. ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DS2LT ! .. Scalar Arguments .. INTEGER ISYM, N, NEL, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), EL(NELT) INTEGER IA(NELT), IEL(NEL), JA(NELT), JEL(NEL) ! .. Local Scalars .. INTEGER I, ICOL, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT DS2LT if ( ISYM == 0 ) THEN ! ! The matrix is stored non-symmetricly. Pick out the lower ! triangle. ! NEL = 0 DO 20 ICOL = 1, N JEL(ICOL) = NEL+1 JBGN = JA(ICOL) JEND = JA(ICOL+1)-1 !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) >= ICOL ) THEN NEL = NEL + 1 IEL(NEL) = IA(J) EL(NEL) = A(J) ENDIF 10 CONTINUE 20 CONTINUE JEL(N+1) = NEL+1 ELSE ! ! The matrix is symmetric and only the lower triangle is ! stored. Copy it to IEL, JEL, EL. ! NEL = NELT DO 30 I = 1, NELT IEL(I) = IA(I) EL(I) = A(I) 30 CONTINUE DO 40 I = 1, N+1 JEL(I) = JA(I) 40 CONTINUE end if return !------------- LAST LINE OF DS2LT FOLLOWS ---------------------------- end subroutine DS2Y (N, NELT, IA, JA, A, ISYM) ! !! DS2Y is the SLAP Triad to SLAP Column Format Converter. ! ! Routine to convert from the SLAP Triad to SLAP Column ! format. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D1B9 !***TYPE DOUBLE PRECISION (SS2Y-S, DS2Y-D) !***KEYWORDS LINEAR SYSTEM, SLAP SPARSE !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! DOUBLE PRECISION A(NELT) ! ! call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of non-zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is used, this format is ! translated to the SLAP Column format by this routine. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! ! *Description: ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures. If the SLAP Triad format is give ! as input then this routine transforms it into SLAP Column ! format. The way this routine tells which format is given as ! input is to look at JA(N+1). If JA(N+1) = NELT+1 then we ! have the SLAP Column format. If that equality does not hold ! then it is assumed that the IA, JA, A arrays contain the ! SLAP Triad format. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! !***REFERENCES (NONE) !***ROUTINES CALLED QS2I1D !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Corrected C***FIRST EXECUTABLE STATEMENT line. (FNF) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DS2Y ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, IBGN, ICOL, IEND, ITEMP, J ! .. External Subroutines .. EXTERNAL QS2I1D !***FIRST EXECUTABLE STATEMENT DS2Y ! ! Check to see if the (IA,JA,A) arrays are in SLAP Column ! format. If it's not then transform from SLAP Triad. ! if ( JA(N+1) == NELT+1 ) RETURN ! ! Sort into ascending order by COLUMN (on the ja array). ! This will line up the columns. ! call QS2I1D( JA, IA, A, NELT, 1 ) ! ! Loop over each column to see where the column indices change ! in the column index array ja. This marks the beginning of the ! next column. ! !VD$R NOVECTOR JA(1) = 1 DO 20 ICOL = 1, N-1 DO 10 J = JA(ICOL)+1, NELT if ( JA(J) /= ICOL ) THEN JA(ICOL+1) = J GOTO 20 ENDIF 10 CONTINUE 20 CONTINUE JA(N+1) = NELT+1 ! ! Mark the n+2 element so that future calls to a SLAP routine ! utilizing the YSMP-Column storage format will be able to tell. ! JA(N+2) = 0 ! ! Now loop through the IA array making sure that the diagonal ! matrix element appears first in the column. Then sort the ! rest of the column in ascending order. ! DO 70 ICOL = 1, N IBGN = JA(ICOL) IEND = JA(ICOL+1)-1 DO 30 I = IBGN, IEND if ( IA(I) == ICOL ) THEN ! ! Swap the diagonal element with the first element in the ! column. ! ITEMP = IA(I) IA(I) = IA(IBGN) IA(IBGN) = ITEMP TEMP = A(I) A(I) = A(IBGN) A(IBGN) = TEMP GOTO 40 ENDIF 30 CONTINUE 40 IBGN = IBGN + 1 if ( IBGN < IEND ) THEN DO 60 I = IBGN, IEND DO 50 J = I+1, IEND if ( IA(I) > IA(J) ) THEN ITEMP = IA(I) IA(I) = IA(J) IA(J) = ITEMP TEMP = A(I) A(I) = A(J) A(J) = TEMP ENDIF 50 CONTINUE 60 CONTINUE ENDIF 70 CONTINUE return !------------- LAST LINE OF DS2Y FOLLOWS ---------------------------- end subroutine DSBMV (UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, & INCY) ! !! DSBMV performs the matrix-vector operation y := alpha*A*x + beta*y. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (SSBMV-S, DSBMV-D, CSBMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DSBMV performs the matrix-vector operation ! ! y := alpha*A*x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! A is an n by n symmetric band matrix, with k super-diagonals. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the band matrix A is being supplied as ! follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! being supplied. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! being supplied. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry, K specifies the number of super-diagonals of the ! matrix A. K must satisfy 0 .le. K. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) ! by n part of the array A must contain the upper triangular ! band part of the symmetric matrix, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. The top left k by k triangle ! of the array A is not referenced. ! The following program segment will transfer the upper ! triangular part of a symmetric band matrix from conventional ! full matrix storage to band storage: ! ! DO 20, J = 1, N ! M = K + 1 - J ! DO 10, I = MAX( 1, J - K ), J ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) ! by n part of the array A must contain the lower triangular ! band part of the symmetric matrix, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. The bottom right k by k triangle of the ! array A is not referenced. ! The following program segment will transfer the lower ! triangular part of a symmetric band matrix from conventional ! full matrix storage to band storage: ! ! DO 20, J = 1, N ! M = 1 - J ! DO 10, I = J, MIN( N, J + K ) ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( k + 1 ). ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the ! vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - DOUBLE PRECISION. ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! Y - DOUBLE PRECISION array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the ! vector y. On exit, Y is overwritten by the updated vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DSBMV ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, K, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX, MIN !***FIRST EXECUTABLE STATEMENT DSBMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( K < 0 )THEN INFO = 3 ELSE if ( LDA < ( K + 1 ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 ELSE if ( INCY == 0 )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'DSBMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set up the start points in X and Y. ! if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if ! ! Start the operations. In this version the elements of the array A ! are accessed sequentially with one pass through A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return if ( LSAME( UPLO, 'U' ) )THEN ! ! Form y when upper triangle of A is stored. ! KPLUS1 = K + 1 if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO L = KPLUS1 - J DO 50, I = MAX( 1, J - K ), J - 1 Y( I ) = Y( I ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + A( L + I, J )*X( I ) 50 CONTINUE Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY L = KPLUS1 - J DO 70, I = MAX( 1, J - K ), J - 1 Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + A( L + I, J )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY if ( J > K )THEN KX = KX + INCX KY = KY + INCY end if 80 CONTINUE end if ELSE ! ! Form y when lower triangle of A is stored. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*A( 1, J ) L = 1 - J DO 90, I = J + 1, MIN( N, J + K ) Y( I ) = Y( I ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + A( L + I, J )*X( I ) 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) L = 1 - J IX = JX IY = JY DO 110, I = J + 1, MIN( N, J + K ) IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + A( L + I, J )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE end if end if ! return ! ! End of DSBMV . ! end subroutine DSCAL (N, DA, DX, INCX) ! !! DSCAL multiplies a vector by a constant. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A6 !***TYPE DOUBLE PRECISION (SSCAL-S, DSCAL-D, CSCAL-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! DA double precision scale factor ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! ! --Output-- ! DX double precision result (unchanged if N <= 0) ! ! Replace double precision DX by double precision DA*DX. ! For I = 0 to N-1, replace DX(IX+I*INCX) with DA * DX(IX+I*INCX), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900821 Modified to correct problem with a negative increment. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSCAL DOUBLE PRECISION DA, DX(*) INTEGER I, INCX, IX, M, MP1, N !***FIRST EXECUTABLE STATEMENT DSCAL if (N <= 0) RETURN if (INCX == 1) GOTO 20 ! ! Code for increment not equal to 1. ! IX = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N DX(IX) = DA*DX(IX) IX = IX + INCX 10 CONTINUE return ! ! Code for increment equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 5. ! 20 M = MOD(N,5) if (M == 0) GOTO 40 DO 30 I = 1,M DX(I) = DA*DX(I) 30 CONTINUE if (N < 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 DSD2S (N, NELT, IA, JA, A, ISYM, DINV) ! !! DSD2S is the Diagonal Scaling Preconditioner SLAP Normal Eqns Set Up. ! ! Routine to compute the inverse of the diagonal of the ! matrix A*A', where A is stored in SLAP-Column format. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSD2S-S, DSD2S-D) !***KEYWORDS DIAGONAL, SLAP SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! DOUBLE PRECISION A(NELT), DINV(N) ! ! call DSD2S( N, NELT, IA, JA, A, ISYM, DINV ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of elements in arrays IA, JA, and A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! DINV :OUT Double Precision DINV(N). ! Upon return this array holds 1./DIAG(A*A'). ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format all of the "inner loops" of this ! routine should vectorize on machines with hardware support ! for vector gather/scatter operations. Your compiler may ! require a compiler directive to convince it that there are ! no implicit vector dependencies. Compiler directives for ! the Alliant FX/Fortran and CRI CFT/CFT77 compilers are ! supplied with the standard SLAP distribution. ! ! ! *Cautions: ! This routine assumes that the diagonal of A is all non-zero ! and that the operation DINV = 1.0/DIAG(A*A') will not under- ! flow or overflow. This is done so that the loop vectorizes. ! Matrices with zero or near zero or very large entries will ! have numerical difficulties and must be fixed before this ! routine is called. ! !***SEE ALSO DSDCGN !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSD2S ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), DINV(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER I, K, KBGN, KEND !***FIRST EXECUTABLE STATEMENT DSD2S DO 10 I = 1, N DINV(I) = 0 10 CONTINUE ! ! Loop over each column. !VD$R NOCONCUR DO 40 I = 1, N KBGN = JA(I) KEND = JA(I+1) - 1 ! ! Add in the contributions for each row that has a non-zero ! in this column. !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 20 K = KBGN, KEND DINV(IA(K)) = DINV(IA(K)) + A(K)**2 20 CONTINUE if ( ISYM == 1 ) THEN ! ! Lower triangle stored by columns => upper triangle stored by ! rows with Diagonal being the first entry. Loop across the ! rest of the row. KBGN = KBGN + 1 if ( KBGN <= KEND ) THEN DO 30 K = KBGN, KEND DINV(I) = DINV(I) + A(K)**2 30 CONTINUE ENDIF ENDIF 40 CONTINUE DO 50 I=1,N DINV(I) = 1.0D0/DINV(I) 50 CONTINUE ! return !------------- LAST LINE OF DSD2S FOLLOWS ---------------------------- end subroutine DSDBCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSDBCG is the Diagonally Scaled BiConjugate Gradient Sparse Ax=b Solver. ! ! Routine to solve a linear system Ax = b using the ! BiConjugate Gradient method with diagonal scaling. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSDBCG-S, DSDBCG-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, ! SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) ! ! call DSDBCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= 8*N. ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the RWORK array. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! ! *Description: ! This routine performs preconditioned BiConjugate gradient ! method on the Non-Symmetric positive definite linear system ! Ax=b. The preconditioner is M = DIAG(A), the diagonal of the ! matrix A. This is the simplest of preconditioners and ! vectorizes very well. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DBCG, DLUBCG !***REFERENCES (NONE) !***ROUTINES CALLED DBCG, DCHKW, DS2Y, DSDI, DSDS, DSMTV, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DSDBCG ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(N), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCDZ, LOCIW, LOCP, LOCPP, LOCR, LOCRR, LOCW, & LOCZ, LOCZZ ! .. External Subroutines .. EXTERNAL DBCG, DCHKW, DS2Y, DSDI, DSDS, DSMTV, DSMV !***FIRST EXECUTABLE STATEMENT DSDBCG ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the workspace. LOCIW = LOCIB ! LOCDIN = LOCRB LOCR = LOCDIN + N LOCZ = LOCR + N LOCP = LOCZ + N LOCRR = LOCP + N LOCZZ = LOCRR + N LOCPP = LOCZZ + N LOCDZ = LOCPP + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call DCHKW( 'DSDBCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCDIN IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the inverse of the diagonal of the matrix. call DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) ! ! Perform the Diagonally Scaled BiConjugate gradient algorithm. call DBCG(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSMTV, & DSDI, DSDI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), & RWORK(LOCRR), RWORK(LOCZZ), RWORK(LOCPP), & RWORK(LOCDZ), RWORK(1), IWORK(1)) return !------------- LAST LINE OF DSDBCG FOLLOWS ---------------------------- end subroutine DSDCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSDCG is the Diagonally Scaled Conjugate Gradient Sparse Ax=b Solver. ! ! Routine to solve a symmetric positive definite linear ! system Ax = b using the Preconditioned Conjugate ! Gradient method. The preconditioner is diagonal scaling. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2B4 !***TYPE DOUBLE PRECISION (SSDCG-S, DSDCG-D) !***KEYWORDS ITERATIVE PRECONDITION, SLAP, SPARSE, ! SYMMETRIC LINEAR SYSTEM !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(5*N) ! ! call DSDCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. LENW >= 5*N. ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the double precision workspace, ! RWORK. Upon return the following locations of IWORK hold ! information which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! ! *Description: ! This routine performs preconditioned conjugate gradient ! method on the symmetric positive definite linear system ! Ax=b. The preconditioner is M = DIAG(A), the diagonal of ! the matrix A. This is the simplest of preconditioners and ! vectorizes very well. This routine is simply a driver for ! the DCG routine. It calls the DSDS routine to set up the ! preconditioning and then calls DCG with the appropriate ! MATVEC and MSOLVE routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DCG, DSICCG !***REFERENCES 1. Louis Hageman and David Young, Applied Iterative ! Methods, Academic Press, New York, 1981. ! 2. Concus, Golub and O'Leary, A Generalized Conjugate ! Gradient Method for the Numerical Solution of ! Elliptic Partial Differential Equations, in Sparse ! Matrix Computations, Bunch and Rose, Eds., Academic ! Press, New York, 1979. !***ROUTINES CALLED DCG, DCHKW, DS2Y, DSDI, DSDS, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) !***END PROLOGUE DSDCG ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCD, LOCDZ, LOCIW, LOCP, LOCR, LOCW, LOCZ ! .. External Subroutines .. EXTERNAL DCG, DCHKW, DS2Y, DSDI, DSDS, DSMV !***FIRST EXECUTABLE STATEMENT DSDCG ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Modify the SLAP matrix data structure to YSMP-Column. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the work arrays. LOCIW = LOCIB ! LOCD = LOCRB LOCR = LOCD + N LOCZ = LOCR + N LOCP = LOCZ + N LOCDZ = LOCP + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call DCHKW( 'DSDCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCD IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the inverse of the diagonal of the matrix. This ! will be used as the preconditioner. call DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCD)) ! ! Do the Preconditioned Conjugate Gradient. call DCG(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSDI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCP), RWORK(LOCDZ), RWORK, IWORK) return !------------- LAST LINE OF DSDCG FOLLOWS ----------------------------- end subroutine DSDCGN (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSDCGN is the Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's. ! ! Routine to solve a general linear system Ax = b using ! diagonal scaling with the Conjugate Gradient method ! applied to the the normal equations, viz., AA'y = b, ! where x = A'y. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSDCGN-S, DSDCGN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) ! ! call DSDCGN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= 8*N. ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the RWORK array. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! ! *Description: ! This routine is simply a driver for the DCGN routine. It ! calls the DSD2S routine to set up the preconditioning and ! then calls DCGN with the appropriate MATVEC and MSOLVE ! routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DCGN, DSD2S, DSMV, DSMTV, DSDI !***REFERENCES (NONE) !***ROUTINES CALLED DCGN, DCHKW, DS2Y, DSD2S, DSDI, DSMTV, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DSDCGN ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCATD, LOCATP, LOCATZ, LOCD, LOCDZ, LOCIW, LOCP, LOCR, & LOCW, LOCZ ! .. External Subroutines .. EXTERNAL DCGN, DCHKW, DS2Y, DSD2S, DSDI, DSMTV, DSMV !***FIRST EXECUTABLE STATEMENT DSDCGN ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Modify the SLAP matrix data structure to YSMP-Column. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the work arrays. LOCIW = LOCIB ! LOCD = LOCRB LOCR = LOCD + N LOCZ = LOCR + N LOCP = LOCZ + N LOCATP = LOCP + N LOCATZ = LOCATP + N LOCDZ = LOCATZ + N LOCATD = LOCDZ + N LOCW = LOCATD + N ! ! Check the workspace allocations. call DCHKW( 'DSDCGN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCD IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the inverse of the diagonal of AA'. This will be ! used as the preconditioner. call DSD2S(N, NELT, IA, JA, A, ISYM, RWORK(1)) ! ! Perform Conjugate Gradient algorithm on the normal equations. call DCGN( N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSMTV, DSDI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCP), RWORK(LOCATP), RWORK(LOCATZ), & RWORK(LOCDZ), RWORK(LOCATD), RWORK, IWORK ) ! if ( ITER > ITMAX ) IERR = 2 return !------------- LAST LINE OF DSDCGN FOLLOWS ---------------------------- end subroutine DSDCGS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSDCGS is the Diagonally Scaled CGS Sparse Ax=b Solver. ! ! Routine to solve a linear system Ax = b using the ! BiConjugate Gradient Squared method with diagonal scaling. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSDCGS-S, DSDCGS-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, ! SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) ! ! call DSDCGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! This routine must calculate the residual from R = A*X - B. ! This is unnatural and hence expensive for this type of iter- ! ative method. ITOL=2 is *STRONGLY* recommended. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv time a vector is the pre- ! conditioning step. This is the *NATURAL* stopping for this ! iterative method and is *STRONGLY* recommended. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Breakdown of the method detected. ! (r0,r) approximately 0. ! IERR = 6 => Stagnation of the method detected. ! (r0,v) approximately 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. LENW >= 8*N. ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the RWORK array. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! ! *Description: ! This routine performs preconditioned BiConjugate gradient ! method on the Non-Symmetric positive definite linear system ! Ax=b. The preconditioner is M = DIAG(A), the diagonal of the ! matrix A. This is the simplest of preconditioners and ! vectorizes very well. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DCGS, DLUBCG !***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver ! for nonsymmetric linear systems, Delft University ! of Technology Report 84-16, Department of Mathe- ! matics and Informatics, Delft, The Netherlands. ! 2. E. F. Kaasschieter, The solution of non-symmetric ! linear systems by biconjugate gradients or conjugate ! gradients squared, Delft University of Technology ! Report 86-21, Department of Mathematics and Informa- ! tics, Delft, The Netherlands. !***ROUTINES CALLED DCGS, DCHKW, DS2Y, DSDI, DSDS, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DSDCGS ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(N), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCIW, LOCP, LOCQ, LOCR, LOCR0, LOCU, LOCV1, & LOCV2, LOCW ! .. External Subroutines .. EXTERNAL DCGS, DCHKW, DS2Y, DSDI, DSDS, DSMV !***FIRST EXECUTABLE STATEMENT DSDCGS ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the workspace. LOCIW = LOCIB ! LOCDIN = LOCRB LOCR = LOCDIN + N LOCR0 = LOCR + N LOCP = LOCR0 + N LOCQ = LOCP + N LOCU = LOCQ + N LOCV1 = LOCU + N LOCV2 = LOCV1 + N LOCW = LOCV2 + N ! ! Check the workspace allocations. call DCHKW( 'DSDCGS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCDIN IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the inverse of the diagonal of the matrix. call DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) ! ! Perform the Diagonally Scaled ! BiConjugate Gradient Squared algorithm. call DCGS(N, B, X, NELT, IA, JA, A, ISYM, DSMV, & DSDI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCR0), RWORK(LOCP), & RWORK(LOCQ), RWORK(LOCU), RWORK(LOCV1), & RWORK(LOCV2), RWORK(1), IWORK(1)) return !------------- LAST LINE OF DSDCGS FOLLOWS ---------------------------- end subroutine DSDGMR (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSDGMR is the Diagonally scaled GMRES iterative sparse Ax=b solver. ! ! This routine uses the generalized minimum residual ! (GMRES) method with diagonal scaling to solve possibly ! non-symmetric linear systems of the form: Ax = b. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSDGMR-S, DSDGMR-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL ! INTEGER ITMAX, ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) ! ! call DSDGMR(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ! $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, ! $ RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize against. ! Must be greater than 1. ! ITOL :IN Integer. ! Flag to indicate the type of convergence criterion used. ! ITOL=0 Means the iteration stops when the test described ! below on the residual RL is satisfied. This is ! the "Natural Stopping Criteria" for this routine. ! Other values of ITOL cause extra, otherwise ! unnecessary, computation per iteration and are ! therefore much less efficient. See ISDGMR (the ! stop test routine) for more information. ! ITOL=1 Means the iteration stops when the first test ! described below on the residual RL is satisfied, ! and there is either right or no preconditioning ! being used. ! ITOL=2 Implies that the user is using left ! preconditioning, and the second stopping criterion ! below is used. ! ITOL=3 Means the iteration stops when the third test ! described below on Minv*Residual is satisfied, and ! there is either left or no preconditioning begin ! used. ! ITOL=11 is often useful for checking and comparing ! different routines. For this case, the user must ! supply the "exact" solution or a very accurate ! approximation (one with an error much less than ! TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the ! difference between the iterative approximation and ! the user-supplied solution divided by the 2-norm ! of the user-supplied solution is less than TOL. ! Note that this requires the user to set up the ! "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling ! routine. The routine with this declaration should ! be loaded before the stop test so that the correct ! length is used by the loader. This procedure is ! not standard Fortran and may not work correctly on ! your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 ! then this common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described below. If TOL is set ! to zero on input, then a default value of 500*(the smallest ! positive magnitude, machine epsilon) is used. ! ITMAX :IN Integer. ! Maximum number of iterations. This routine uses the default ! of NRMAX = ITMAX/NSAVE to determine when each restart ! should occur. See the description of NRMAX and MAXL in ! DGMRES for a full and frightfully interesting discussion of ! this topic. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. Letting norm() denote the Euclidean ! norm, ERR is defined as follows... ! If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! for right or no preconditioning, and ! ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! for left preconditioning. ! If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! since right or no preconditioning ! being used. ! If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! since left preconditioning is being ! used. ! If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| ! i=1,n ! If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient storage allocated for ! RGWK or IGWK. ! IERR = 2 => Routine DPIGMR failed to reduce the norm ! of the current residual on its last call, ! and so the iteration has stalled. In ! this case, X equals the last computed ! approximation. The user must either ! increase MAXL, or choose a different ! initial guess. ! IERR =-1 => Insufficient length for RGWK array. ! IGWK(6) contains the required minimum ! length of the RGWK array. ! IERR =-2 => Inconsistent ITOL and JPRE values. ! For IERR <= 2, RGWK(1) = RHOL, which is the norm on the ! left-hand-side of the relevant stopping test defined ! below associated with the residual for the current ! approximation X(L). ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array of size LENW. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= 1 + N*(NSAVE+7) + NSAVE*(NSAVE+3). ! For the recommended values of NSAVE (10), RWORK has size at ! least 131 + 17*N. ! IWORK :INOUT Integer IWORK(USER DEFINED >= 30). ! Used to hold pointers into the RWORK array. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace IWORK. LENIW >= 30. ! ! *Description: ! DSDGMR solves a linear system A*X = B rewritten in the form: ! ! (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, ! ! with right preconditioning, or ! ! (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, ! ! with left preconditioning, where A is an n-by-n double precision ! matrix, X and B are N-vectors, SB and SX are diagonal scaling ! matrices, and M is the diagonal of A. It uses ! preconditioned Krylov subpace methods based on the ! generalized minimum residual method (GMRES). This routine ! is a driver routine which assumes a SLAP matrix data ! structure and sets up the necessary information to do ! diagonal preconditioning and calls the main GMRES routine ! DGMRES for the solution of the linear system. DGMRES ! optionally performs either the full orthogonalization ! version of the GMRES algorithm or an incomplete variant of ! it. Both versions use restarting of the linear iteration by ! default, although the user can disable this feature. ! ! The GMRES algorithm generates a sequence of approximations ! X(L) to the true solution of the above linear system. The ! convergence criteria for stopping the iteration is based on ! the size of the scaled norm of the residual R(L) = B - ! A*X(L). The actual stopping test is either: ! ! norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), ! ! for right preconditioning, or ! ! norm(SB*(M-inverse)*(B-A*X(L))) .le. ! TOL*norm(SB*(M-inverse)*B), ! ! for left preconditioning, where norm() denotes the Euclidean ! norm, and TOL is a positive scalar less than one input by ! the user. If TOL equals zero when DSDGMR is called, then a ! default value of 500*(the smallest positive magnitude, ! machine epsilon) is used. If the scaling arrays SB and SX ! are used, then ideally they should be chosen so that the ! vectors SX*X(or SX*M*X) and SB*B have all their components ! approximately equal to one in magnitude. If one wants to ! use the same scaling in X and B, then SB and SX can be the ! same array in the calling program. ! ! The following is a list of the other routines and their ! functions used by GMRES: ! DGMRES Contains the matrix structure independent driver ! routine for GMRES. ! DPIGMR Contains the main iteration loop for GMRES. ! DORTH Orthogonalizes a new vector against older basis vectors. ! DHEQR Computes a QR decomposition of a Hessenberg matrix. ! DHELS Solves a Hessenberg least-squares system, using QR ! factors. ! RLCALC Computes the scaled residual RL. ! XLCALC Computes the solution XL. ! ISDGMR User-replaceable stopping routine. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage ! Matrix Methods in Stiff ODE Systems, Lawrence Liver- ! more National Laboratory Report UCRL-95088, Rev. 1, ! Livermore, California, June 1987. !***ROUTINES CALLED DCHKW, DGMRES, DS2Y, DSDI, DSDS, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) !***END PROLOGUE DSDGMR ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, & NELT, NSAVE ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCIGW, LOCIW, LOCRGW, LOCW, MYITOL ! .. External Subroutines .. EXTERNAL DCHKW, DGMRES, DS2Y, DSDI, DSDS, DSMV !***FIRST EXECUTABLE STATEMENT DSDGMR ! IERR = 0 ERR = 0 if ( NSAVE <= 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the workspace. We assume MAXL=KMP=NSAVE. LOCIGW = LOCIB LOCIW = LOCIGW + 20 ! LOCDIN = LOCRB LOCRGW = LOCDIN + N LOCW = LOCRGW + 1+N*(NSAVE+6)+NSAVE*(NSAVE+3) ! IWORK(4) = LOCDIN IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Check the workspace allocations. call DCHKW( 'DSDGMR', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! ! Compute the inverse of the diagonal of the matrix. call DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) ! ! Perform the Diagonally Scaled Generalized Minimum ! Residual iteration algorithm. The following DGMRES ! defaults are used MAXL = KMP = NSAVE, JSCAL = 0, ! JPRE = -1, NRMAX = ITMAX/NSAVE IWORK(LOCIGW ) = NSAVE IWORK(LOCIGW+1) = NSAVE IWORK(LOCIGW+2) = 0 IWORK(LOCIGW+3) = -1 IWORK(LOCIGW+4) = ITMAX/NSAVE MYITOL = 0 ! call DGMRES( N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSDI, & MYITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, RWORK, & RWORK(LOCRGW), LENW-LOCRGW, IWORK(LOCIGW), 20, & RWORK, IWORK ) ! if ( ITER > ITMAX ) IERR = 2 return end subroutine DSDI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! DSDI is a Diagonal Matrix Vector Multiply. ! ! Routine to calculate the product X = DIAG*B, where DIAG ! is a diagonal matrix. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (SSDI-S, DSDI-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IWORK(10) ! DOUBLE PRECISION B(N), X(N), A(NELT), RWORK(USER DEFINED) ! ! call DSDI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Vector to multiply the diagonal by. ! X :OUT Double Precision X(N). ! Result of DIAG*B. ! NELT :DUMMY Integer. ! IA :DUMMY Integer IA(NELT). ! JA :DUMMY Integer JA(NELT). ! A :DUMMY Double Precision A(NELT). ! ISYM :DUMMY Integer. ! These are for compatibility with SLAP MSOLVE calling sequence. ! RWORK :IN Double Precision RWORK(USER DEFINED). ! Work array holding the diagonal of some matrix to scale ! B by. This array must be set by the user or by a call ! to the SLAP routine DSDS or DSD2S. The length of RWORK ! must be >= IWORK(4)+N. ! IWORK :IN Integer IWORK(10). ! IWORK(4) holds the offset into RWORK for the diagonal matrix ! to scale B by. This is usually set up by the SLAP pre- ! conditioner setup routines DSDS or DSD2S. ! ! *Description: ! This routine is supplied with the SLAP package to perform ! the MSOLVE operation for iterative drivers that require ! diagonal Scaling (e.g., DSDCG, DSDBCG). It conforms ! to the SLAP MSOLVE CALLING CONVENTION and hence does not ! require an interface routine as do some of the other pre- ! conditioners supplied with SLAP. ! !***SEE ALSO DSDS, DSD2S !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSDI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER I, LOCD !***FIRST EXECUTABLE STATEMENT DSDI ! ! Determine where the inverse of the diagonal ! is in the work array and then scale by it. ! LOCD = IWORK(4) - 1 DO 10 I = 1, N X(I) = RWORK(LOCD+I)*B(I) 10 CONTINUE return !------------- LAST LINE OF DSDI FOLLOWS ---------------------------- end subroutine DSDOMN (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSDOMN is a Diagonally Scaled Orthomin Sparse Iterative Ax=b Solver. ! ! Routine to solve a general linear system Ax = b using ! the Orthomin method with diagonal scaling. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSDOMN-S, DSDOMN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR ! DOUBLE PRECISION RWORK(7*N+3*N*NSAVE+NSAVE) ! ! call DSDOMN(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen, it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize against. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Breakdown of method detected. ! (p,Ap) < epsilon**2. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= 7*N+NSAVE*(3*N+1). ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the RWORK array. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! ! *Description: ! This routine is simply a driver for the DOMN routine. It ! calls the DSDS routine to set up the preconditioning and ! then calls DOMN with the appropriate MATVEC and MSOLVE ! routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the double pre- ! cision array A. In other words, for each column in the ! matrix first put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- ! th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) ! are the last elements of the ICOL-th column. Note that we ! always have JA(N+1)=NELT+1, where N is the number of columns ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DOMN, DSLUOM !***REFERENCES (NONE) !***ROUTINES CALLED DCHKW, DOMN, DS2Y, DSDI, DSDS, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DSDOMN ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, & NELT, NSAVE ! .. Array Arguments .. DOUBLE PRECISION A(N), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCAP, LOCCSA, LOCDIN, LOCDZ, LOCEMA, LOCIW, LOCP, LOCR, & LOCW, LOCZ ! .. External Subroutines .. EXTERNAL DCHKW, DOMN, DS2Y, DSDI, DSDS, DSMV !***FIRST EXECUTABLE STATEMENT DSDOMN ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the workspace. LOCIW = LOCIB ! LOCDIN = LOCRB LOCR = LOCDIN + N LOCZ = LOCR + N LOCP = LOCZ + N LOCAP = LOCP + N*(NSAVE+1) LOCEMA = LOCAP + N*(NSAVE+1) LOCDZ = LOCEMA + N*(NSAVE+1) LOCCSA = LOCDZ + N LOCW = LOCCSA + NSAVE ! ! Check the workspace allocations. call DCHKW( 'DSDOMN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCDIN IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the inverse of the diagonal of the matrix. call DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) ! ! Perform the Diagonally Scaled Orthomin iteration algorithm. call DOMN(N, B, X, NELT, IA, JA, A, ISYM, DSMV, & DSDI, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), RWORK(LOCAP), & RWORK(LOCEMA), RWORK(LOCDZ), RWORK(LOCCSA), & RWORK, IWORK ) return !------------- LAST LINE OF DSDOMN FOLLOWS ---------------------------- end DOUBLE PRECISION FUNCTION DSDOT (N, SX, INCX, SY, INCY) ! !! DSDOT computes the inner product of two vectors with extended ... ! precision accumulation and result. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A4 !***TYPE DOUBLE PRECISION (DSDOT-D, DCDOT-C) !***KEYWORDS BLAS, COMPLEX VECTORS, DOT PRODUCT, INNER PRODUCT, ! LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! SY single precision vector with N elements ! INCY storage spacing between elements of SY ! ! --Output-- ! DSDOT double precision dot product (zero if N <= 0) ! ! Returns D.P. dot product accumulated in D.P., for S.P. SX and SY ! DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSDOT REAL SX(*),SY(*) !***FIRST EXECUTABLE STATEMENT DSDOT DSDOT = 0.0D0 if (N <= 0) RETURN if (INCX == INCY .AND. INCX > 0) go to 20 ! ! Code for unequal or nonpositive increments. ! KX = 1 KY = 1 if (INCX < 0) KX = 1+(1-N)*INCX if (INCY < 0) KY = 1+(1-N)*INCY DO 10 I = 1,N DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) KX = KX + INCX KY = KY + INCY 10 CONTINUE return ! ! Code for equal, positive, non-unit increments. ! 20 NS = N*INCX DO 30 I = 1,NS,INCX DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) 30 CONTINUE return end subroutine DSDSCL (N, NELT, IA, JA, A, ISYM, X, B, DINV, JOB, & ITOL) ! !! DSDSCL carries out Diagonal Scaling of system Ax = b. ! ! This routine scales (and unscales) the system Ax = b ! by symmetric diagonal scaling. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSDSCL-S, DSDSCL-D) !***KEYWORDS DIAGONAL, SLAP SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! This routine scales (and unscales) the system Ax = b by symmetric ! diagonal scaling. The new system is: ! -1/2 -1/2 1/2 -1/2 ! D AD (D x) = D b ! when scaling is selected with the JOB parameter. When unscaling ! is selected this process is reversed. The true solution is also ! scaled or unscaled if ITOL is set appropriately, see below. ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, JOB, ITOL ! DOUBLE PRECISION A(NELT), X(N), B(N), DINV(N) ! ! call DSDSCL( N, NELT, IA, JA, A, ISYM, X, B, DINV, JOB, ITOL ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of elements in arrays IA, JA, and A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! X :INOUT Double Precision X(N). ! Initial guess that will be later used in the iterative ! solution. ! of the scaled system. ! B :INOUT Double Precision B(N). ! Right hand side vector. ! DINV :INOUT Double Precision DINV(N). ! Upon return this array holds 1./DIAG(A). ! This is an input if JOB = 0. ! JOB :IN Integer. ! Flag indicating whether to scale or not. ! JOB non-zero means do scaling. ! JOB = 0 means do unscaling. ! ITOL :IN Integer. ! Flag indicating what type of error estimation to do in the ! iterative method. When ITOL = 11 the exact solution from ! common block DSLBLK will be used. When the system is scaled ! then the true solution must also be scaled. If ITOL is not ! 11 then this vector is not referenced. ! ! *Common Blocks: ! SOLN :INOUT Double Precision SOLN(N). COMMON BLOCK /DSLBLK/ ! The true solution, SOLN, is scaled (or unscaled) if ITOL is ! set to 11, see above. ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format all of the "inner loops" of this ! routine should vectorize on machines with hardware support ! for vector gather/scatter operations. Your compiler may ! require a compiler directive to convince it that there are ! no implicit vector dependencies. Compiler directives for ! the Alliant FX/Fortran and CRI CFT/CFT77 compilers are ! supplied with the standard SLAP distribution. ! ! ! *Cautions: ! This routine assumes that the diagonal of A is all non-zero ! and that the operation DINV = 1.0/DIAG(A) will not under- ! flow or overflow. This is done so that the loop vectorizes. ! Matrices with zero or near zero or very large entries will ! have numerical difficulties and must be fixed before this ! routine is called. ! !***SEE ALSO DSDCG !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DSLBLK !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Added C***FIRST EXECUTABLE STATEMENT line. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSDSCL ! .. Scalar Arguments .. INTEGER ISYM, ITOL, JOB, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), DINV(N), X(N) INTEGER IA(NELT), JA(NELT) ! .. Arrays in Common .. DOUBLE PRECISION SOLN(1) ! .. Local Scalars .. DOUBLE PRECISION DI INTEGER ICOL, J, JBGN, JEND ! .. Intrinsic Functions .. INTRINSIC SQRT ! .. Common blocks .. COMMON /DSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT DSDSCL ! ! SCALING... ! if ( JOB /= 0 ) THEN DO 10 ICOL = 1, N DINV(ICOL) = 1.0D0/SQRT( A(JA(ICOL)) ) 10 CONTINUE ELSE ! ! UNSCALING... ! DO 15 ICOL = 1, N DINV(ICOL) = 1.0D0/DINV(ICOL) 15 CONTINUE end if ! DO 30 ICOL = 1, N JBGN = JA(ICOL) JEND = JA(ICOL+1)-1 DI = DINV(ICOL) DO 20 J = JBGN, JEND A(J) = DINV(IA(J))*A(J)*DI 20 CONTINUE 30 CONTINUE ! DO 40 ICOL = 1, N B(ICOL) = B(ICOL)*DINV(ICOL) X(ICOL) = X(ICOL)/DINV(ICOL) 40 CONTINUE ! ! Check to see if we need to scale the "true solution" as well. ! if ( ITOL == 11 ) THEN DO 50 ICOL = 1, N SOLN(ICOL) = SOLN(ICOL)/DINV(ICOL) 50 CONTINUE end if ! return !------------- LAST LINE OF DSDSCL FOLLOWS ---------------------------- end subroutine DSDS (N, NELT, IA, JA, A, ISYM, DINV) ! !! DSDS is the Diagonal Scaling Preconditioner SLAP Set Up. ! ! Routine to compute the inverse of the diagonal of a matrix ! stored in the SLAP Column format. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSDS-S, DSDS-D) !***KEYWORDS DIAGONAL, SLAP SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! DOUBLE PRECISION A(NELT), DINV(N) ! ! call DSDS( N, NELT, IA, JA, A, ISYM, DINV ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! NELT :IN Integer. ! Number of elements in arrays IA, JA, and A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! DINV :OUT Double Precision DINV(N). ! Upon return this array holds 1./DIAG(A). ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format all of the "inner loops" of this ! routine should vectorize on machines with hardware support ! for vector gather/scatter operations. Your compiler may ! require a compiler directive to convince it that there are ! no implicit vector dependencies. Compiler directives for ! the Alliant FX/Fortran and CRI CFT/CFT77 compilers are ! supplied with the standard SLAP distribution. ! ! ! *Cautions: ! This routine assumes that the diagonal of A is all non-zero ! and that the operation DINV = 1.0/DIAG(A) will not underflow ! or overflow. This is done so that the loop vectorizes. ! Matrices with zero or near zero or very large entries will ! have numerical difficulties and must be fixed before this ! routine is called. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSDS ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), DINV(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER ICOL !***FIRST EXECUTABLE STATEMENT DSDS ! ! Assume the Diagonal elements are the first in each column. ! This loop should *VECTORIZE*. If it does not you may have ! to add a compiler directive. We do not check for a zero ! (or near zero) diagonal element since this would interfere ! with vectorization. If this makes you nervous put a check ! in! It will run much slower. ! DO 10 ICOL = 1, N DINV(ICOL) = 1.0D0/A(JA(ICOL)) 10 CONTINUE ! return !------------- LAST LINE OF DSDS FOLLOWS ---------------------------- end subroutine DSGS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ITMAX, & ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSGS is the Gauss-Seidel Method Iterative Sparse Ax = b Solver. ! ! Routine to solve a general linear system Ax = b using ! Gauss-Seidel iteration. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSGS-S, DSGS-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+2*N+1), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+3*N) ! ! call DSGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= NL+3*N. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= NL+N+11. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! ! *Description ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DSJAC, DIR !***REFERENCES (NONE) !***ROUTINES CALLED DCHKW, DIR, DS2LT, DS2Y, DSLI, DSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921019 Corrected NEL to NL. (FNF) !***END PROLOGUE DSGS ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(N), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCDZ, LOCEL, LOCIEL, LOCIW, LOCJEL, & LOCR, LOCW, LOCZ, NL ! .. External Subroutines .. EXTERNAL DCHKW, DIR, DS2LT, DS2Y, DSLI, DSMV !***FIRST EXECUTABLE STATEMENT DSGS ! if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Modify the SLAP matrix data structure to YSMP-Column. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of elements in lower triangle of the matrix. if ( ISYM == 0 ) THEN NL = 0 DO 20 ICOL = 1, N JBGN = JA(ICOL) JEND = JA(ICOL+1)-1 DO 10 J = JBGN, JEND if ( IA(J) >= ICOL ) NL = NL + 1 10 CONTINUE 20 CONTINUE ELSE NL = JA(N+1)-1 end if ! ! Set up the work arrays. Then store the lower triangle of ! the matrix. ! LOCJEL = LOCIB LOCIEL = LOCJEL + N+1 LOCIW = LOCIEL + NL ! LOCEL = LOCRB LOCR = LOCEL + NL LOCZ = LOCR + N LOCDZ = LOCZ + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call DCHKW( 'DSGS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = NL IWORK(2) = LOCIEL IWORK(3) = LOCJEL IWORK(4) = LOCEL IWORK(9) = LOCIW IWORK(10) = LOCW ! call DS2LT( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIEL), & IWORK(LOCJEL), RWORK(LOCEL) ) ! ! Call iterative refinement routine. call DIR(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSLI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCDZ), RWORK, IWORK ) ! ! Set the amount of Integer and Double Precision Workspace used. IWORK(9) = LOCIW+N+NELT IWORK(10) = LOCW+NELT return !------------- LAST LINE OF DSGS FOLLOWS ------------------------------ end subroutine DSICCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSICCG is the Incomplete Cholesky Conjugate Gradient Sparse Ax=b Solver. ! ! Routine to solve a symmetric positive definite linear ! system Ax = b using the incomplete Cholesky ! Preconditioned Conjugate Gradient method. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2B4 !***TYPE DOUBLE PRECISION (SSICCG-S, DSICCG-D) !***KEYWORDS INCOMPLETE CHOLESKY, ITERATIVE PRECONDITION, SLAP, SPARSE, ! SYMMETRIC LINEAR SYSTEM !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+2*N+1), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+5*N) ! ! call DSICCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= NL+5*N. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= NL+N+11. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! ! *Description: ! This routine performs preconditioned conjugate gradient ! method on the symmetric positive definite linear system ! Ax=b. The preconditioner is the incomplete Cholesky (IC) ! factorization of the matrix A. See DSICS for details about ! the incomplete factorization algorithm. One should note ! here however, that the IC factorization is a slow process ! and that one should save factorizations for reuse, if ! possible. The MSOLVE operation (handled in DSLLTI) does ! vectorize on machines with hardware gather/scatter and is ! quite fast. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DCG, DSLLTI !***REFERENCES 1. Louis Hageman and David Young, Applied Iterative ! Methods, Academic Press, New York, 1981. ! 2. Concus, Golub and O'Leary, A Generalized Conjugate ! Gradient Method for the Numerical Solution of ! Elliptic Partial Differential Equations, in Sparse ! Matrix Computations, Bunch and Rose, Eds., Academic ! Press, New York, 1979. !***ROUTINES CALLED DCG, DCHKW, DS2Y, DSICS, DSLLTI, DSMV, XERMSG !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 900805 Changed XERRWV calls to calls to XERMSG. (RWC) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Corrected NEL to NL. (FNF) !***END PROLOGUE DSICCG ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCDZ, LOCEL, LOCIEL, LOCIW, LOCJEL, LOCP, LOCR, & LOCW, LOCZ, NL CHARACTER XERN1*8 ! .. External Subroutines .. EXTERNAL DCG, DCHKW, DS2Y, DSICS, DSLLTI, DSMV, XERMSG !***FIRST EXECUTABLE STATEMENT DSICCG ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of elements in lower triangle of the matrix. ! Then set up the work arrays. if ( ISYM == 0 ) THEN NL = (NELT + N)/2 ELSE NL = NELT end if ! LOCJEL = LOCIB LOCIEL = LOCJEL + NL LOCIW = LOCIEL + N + 1 ! LOCEL = LOCRB LOCDIN = LOCEL + NL LOCR = LOCDIN + N LOCZ = LOCR + N LOCP = LOCZ + N LOCDZ = LOCP + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call DCHKW( 'DSICCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = NL IWORK(2) = LOCJEL IWORK(3) = LOCIEL IWORK(4) = LOCEL IWORK(5) = LOCDIN IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete Cholesky decomposition. ! call DSICS(N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIEL), & IWORK(LOCJEL), RWORK(LOCEL), RWORK(LOCDIN), & RWORK(LOCR), IERR ) if ( IERR /= 0 ) THEN WRITE (XERN1, '(I8)') IERR call XERMSG ('SLATEC', 'DSICCG', & 'IC factorization broke down on step ' // XERN1 // & '. Diagonal was set to unity and factorization proceeded.', & 1, 1) IERR = 7 end if ! ! Do the Preconditioned Conjugate Gradient. call DCG(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSLLTI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCP), RWORK(LOCDZ), RWORK(1), & IWORK(1)) return !------------- LAST LINE OF DSICCG FOLLOWS ---------------------------- end subroutine DSICO (A, LDA, N, KPVT, RCOND, Z) ! !! DSICO factors a symmetric matrix by elimination with symmetric ... ! pivoting and estimate the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE DOUBLE PRECISION (SSICO-S, DSICO-D, CHICO-C, CSICO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, SYMMETRIC !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DSICO factors a double precision symmetric matrix by elimination ! with symmetric pivoting and estimates the condition of the ! matrix. ! ! If RCOND is not needed, DSIFA is slightly faster. ! To solve A*X = B , follow DSICO by DSISL. ! To compute INVERSE(A)*C , follow DSICO by DSISL. ! To compute INVERSE(A) , follow DSICO by DSIDI. ! To compute DETERMINANT(A) , follow DSICO by DSIDI. ! To compute INERTIA(A), follow DSICO by DSIDI. ! ! On Entry ! ! A DOUBLE PRECISION(LDA, N) ! the symmetric matrix to be factored. ! Only the diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! Output ! ! A a block diagonal matrix and the multipliers which ! were used to obtain it. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices, TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND DOUBLE PRECISION ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z DOUBLE PRECISION(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DASUM, DAXPY, DDOT, DSCAL, DSIFA !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSICO INTEGER LDA,N,KPVT(*) DOUBLE PRECISION A(LDA,*),Z(*) DOUBLE PRECISION RCOND ! DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T DOUBLE PRECISION ANORM,S,DASUM,YNORM INTEGER I,INFO,J,JM1,K,KP,KPS,KS ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT DSICO DO J = 1, N Z(J) = DASUM(J,A(1,J),1) JM1 = J - 1 DO I = 1, JM1 Z(I) = Z(I) + ABS(A(I,J)) end do end do ANORM = 0.0D0 DO 40 J = 1, N ANORM = MAX(ANORM,Z(J)) 40 CONTINUE ! ! FACTOR ! call DSIFA(A,LDA,N,KPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE U*D*W = E ! EK = 1.0D0 DO 50 J = 1, N Z(J) = 0.0D0 50 CONTINUE K = N 60 if (K == 0) go to 120 KS = 1 if (KPVT(K) < 0) KS = 2 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE if (Z(K) /= 0.0D0) EK = SIGN(EK,Z(K)) Z(K) = Z(K) + EK call DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) if (KS == 1) go to 80 if (Z(K-1) /= 0.0D0) EK = SIGN(EK,Z(K-1)) Z(K-1) = Z(K-1) + EK call DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) 80 CONTINUE if (KS == 2) go to 100 if (ABS(Z(K)) <= ABS(A(K,K))) go to 90 S = ABS(A(K,K))/ABS(Z(K)) call DSCAL(N,S,Z,1) EK = S*EK 90 CONTINUE if (A(K,K) /= 0.0D0) Z(K) = Z(K)/A(K,K) if (A(K,K) == 0.0D0) Z(K) = 1.0D0 go to 110 100 CONTINUE AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = Z(K)/A(K-1,K) BKM1 = Z(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0D0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 110 CONTINUE K = K - KS go to 60 120 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) ! ! SOLVE TRANS(U)*Y = W ! K = 1 130 if (K > N) go to 160 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 150 Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) if (KS == 2) & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE K = K + KS go to 130 160 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) ! YNORM = 1.0D0 ! ! SOLVE U*D*V = Y ! K = N 170 if (K == 0) go to 230 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == KS) go to 190 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 180 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 180 CONTINUE call DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) if (KS == 2) call DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) 190 CONTINUE if (KS == 2) go to 210 if (ABS(Z(K)) <= ABS(A(K,K))) go to 200 S = ABS(A(K,K))/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 200 CONTINUE if (A(K,K) /= 0.0D0) Z(K) = Z(K)/A(K,K) if (A(K,K) == 0.0D0) Z(K) = 1.0D0 go to 220 210 CONTINUE AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = Z(K)/A(K-1,K) BKM1 = Z(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0D0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 220 CONTINUE K = K - KS go to 170 230 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE TRANS(U)*Z = V ! K = 1 240 if (K > N) go to 270 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 260 Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) if (KS == 2) & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE K = K + KS go to 240 270 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0D0) RCOND = YNORM/ANORM if (ANORM == 0.0D0) RCOND = 0.0D0 return end subroutine DSICS (N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D, & R, IWARN) ! !! DSICS is the Incompl. Cholesky Decomposition Preconditioner SLAP Set Up. ! ! Routine to generate the Incomplete Cholesky decomposition, ! L*D*L-trans, of a symmetric positive definite matrix, A, ! which is stored in SLAP Column format. The unit lower ! triangular matrix L is stored by rows, and the inverse of ! the diagonal matrix D is stored. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSICS-S, DSICS-D) !***KEYWORDS INCOMPLETE CHOLESKY FACTORIZATION, ! ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! INTEGER NEL, IEL(NEL), JEL(NEL), IWARN ! DOUBLE PRECISION A(NELT), EL(NEL), D(N), R(N) ! ! call DSICS( N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D, R, ! $ IWARN ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! NELT :IN Integer. ! Number of elements in arrays IA, JA, and A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! NEL :OUT Integer. ! Number of non-zeros in the lower triangle of A. Also ! corresponds to the length of the IEL, JEL, EL arrays. ! IEL :OUT Integer IEL(NEL). ! JEL :OUT Integer JEL(NEL). ! EL :OUT Double Precision EL(NEL). ! IEL, JEL, EL contain the unit lower triangular factor of the ! incomplete decomposition of the A matrix stored in SLAP ! Row format. The Diagonal of ones *IS* stored. See ! "Description", below for more details about the SLAP Row fmt. ! D :OUT Double Precision D(N) ! Upon return this array holds D(I) = 1./DIAG(A). ! R :WORK Double Precision R(N). ! Temporary double precision workspace needed for the ! factorization. ! IWARN :OUT Integer. ! This is a warning variable and is zero if the IC factoriza- ! tion goes well. It is set to the row index corresponding to ! the last zero pivot found. See "Description", below. ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the ! double precision array A. In other words, for each row in ! the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going across the row (except the ! diagonal) in order. The JA array holds the column index for ! each non-zero. The IA array holds the offsets into the JA, ! A arrays for the beginning of each row. That is, ! JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- ! th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! are the last elements of the IROW-th row. Note that we ! always have IA(N+1) = NELT+1, where N is the number of rows ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format some of the "inner loops" of this ! routine should vectorize on machines with hardware support ! for vector gather/scatter operations. Your compiler may ! require a compiler directive to convince it that there are ! no implicit vector dependencies. Compiler directives for ! the Alliant FX/Fortran and CRI CFT/CFT77 compilers are ! supplied with the standard SLAP distribution. ! ! The IC factorization does not always exist for SPD matrices. ! In the event that a zero pivot is found it is set to be 1.0 ! and the factorization proceeds. The integer variable IWARN ! is set to the last row where the Diagonal was fudged. This ! eventuality hardly ever occurs in practice. ! !***SEE ALSO DCG, DSICCG !***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, ! Johns Hopkins University Press, Baltimore, Maryland, ! 1983. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 900805 Changed XERRWV calls to calls to XERMSG. (RWC) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSICS ! .. Scalar Arguments .. INTEGER ISYM, IWARN, N, NEL, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), D(N), EL(NEL), R(N) INTEGER IA(NELT), IEL(NEL), JA(NELT), JEL(NEL) ! .. Local Scalars .. DOUBLE PRECISION ELTMP INTEGER I, IBGN, IC, ICBGN, ICEND, ICOL, IEND, IR, IRBGN, IREND, & IROW, IRR, J, JBGN, JELTMP, JEND CHARACTER XERN1*8 ! .. External Subroutines .. EXTERNAL XERMSG !***FIRST EXECUTABLE STATEMENT DSICS ! ! Set the lower triangle in IEL, JEL, EL ! IWARN = 0 ! ! All matrix elements stored in IA, JA, A. Pick out the lower ! triangle (making sure that the Diagonal of EL is one) and ! store by rows. ! NEL = 1 IEL(1) = 1 JEL(1) = 1 EL(1) = 1 D(1) = A(1) !VD$R NOCONCUR DO 30 IROW = 2, N ! Put in the Diagonal. NEL = NEL + 1 IEL(IROW) = NEL JEL(NEL) = IROW EL(NEL) = 1 D(IROW) = A(JA(IROW)) ! ! Look in all the lower triangle columns for a matching row. ! Since the matrix is symmetric, we can look across the ! IROW-th row by looking down the IROW-th column (if it is ! stored ISYM=0)... if ( ISYM == 0 ) THEN ICBGN = JA(IROW) ICEND = JA(IROW+1)-1 ELSE ICBGN = 1 ICEND = IROW-1 ENDIF DO 20 IC = ICBGN, ICEND if ( ISYM == 0 ) THEN ICOL = IA(IC) if ( ICOL >= IROW ) GOTO 20 ELSE ICOL = IC ENDIF JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND .AND. IA(JEND) >= IROW ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) == IROW ) THEN NEL = NEL + 1 JEL(NEL) = ICOL EL(NEL) = A(J) GOTO 20 ENDIF 10 CONTINUE ENDIF 20 CONTINUE 30 CONTINUE IEL(N+1) = NEL+1 ! ! Sort ROWS of lower triangle into descending order (count out ! along rows out from Diagonal). ! DO 60 IROW = 2, N IBGN = IEL(IROW)+1 IEND = IEL(IROW+1)-1 if ( IBGN < IEND ) THEN DO 50 I = IBGN, IEND-1 !VD$ NOVECTOR DO 40 J = I+1, IEND if ( JEL(I) > JEL(J) ) THEN JELTMP = JEL(J) JEL(J) = JEL(I) JEL(I) = JELTMP ELTMP = EL(J) EL(J) = EL(I) EL(I) = ELTMP ENDIF 40 CONTINUE 50 CONTINUE ENDIF 60 CONTINUE ! ! Perform the Incomplete Cholesky decomposition by looping ! over the rows. ! Scale the first column. Use the structure of A to pick out ! the rows with something in column 1. ! IRBGN = JA(1)+1 IREND = JA(2)-1 DO 65 IRR = IRBGN, IREND IR = IA(IRR) ! Find the index into EL for EL(1,IR). ! Hint: it's the second entry. I = IEL(IR)+1 EL(I) = EL(I)/D(1) 65 CONTINUE ! DO 110 IROW = 2, N ! ! Update the IROW-th diagonal. ! DO 66 I = 1, IROW-1 R(I) = 0 66 CONTINUE IBGN = IEL(IROW)+1 IEND = IEL(IROW+1)-1 if ( IBGN <= IEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 70 I = IBGN, IEND R(JEL(I)) = EL(I)*D(JEL(I)) D(IROW) = D(IROW) - EL(I)*R(JEL(I)) 70 CONTINUE ! ! Check to see if we have a problem with the diagonal. ! if ( D(IROW) <= 0.0D0 ) THEN if ( IWARN == 0 ) IWARN = IROW D(IROW) = 1 ENDIF ENDIF ! ! Update each EL(IROW+1:N,IROW), if there are any. ! Use the structure of A to determine the Non-zero elements ! of the IROW-th column of EL. ! IRBGN = JA(IROW) IREND = JA(IROW+1)-1 DO 100 IRR = IRBGN, IREND IR = IA(IRR) if ( IR <= IROW ) GOTO 100 ! Find the index into EL for EL(IR,IROW) IBGN = IEL(IR)+1 IEND = IEL(IR+1)-1 if ( JEL(IBGN) > IROW ) GOTO 100 DO 90 I = IBGN, IEND if ( JEL(I) == IROW ) THEN ICEND = IEND 91 if ( JEL(ICEND) >= IROW ) THEN ICEND = ICEND - 1 GOTO 91 ENDIF ! Sum up the EL(IR,1:IROW-1)*R(1:IROW-1) contributions. !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO IC = IBGN, ICEND EL(I) = EL(I) - EL(IC)*R(JEL(IC)) end do EL(I) = EL(I)/D(IROW) GOTO 100 ENDIF 90 CONTINUE ! ! If we get here, we have real problems. ! WRITE (XERN1, '(I8)') IROW call XERMSG ('SLATEC', 'DSICS', & 'A and EL data structure mismatch in row '// XERN1, 1, 2) 100 CONTINUE 110 CONTINUE ! ! Replace diagonals by their inverses. ! D(1:N) = 1.0D0 / D(1:N) return end subroutine DSIDI (A, LDA, N, KPVT, DET, INERT, WORK, JOB) ! !! DSIDI computes the determinant, inertia and inverse of a real symmetric ... ! matrix using the factors from DSIFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A, D3B1A !***TYPE DOUBLE PRECISION (SSIDI-S, DSIDI-D, CHIDI-C, CSIDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! DSIDI computes the determinant, inertia and inverse ! of a double precision symmetric matrix using the factors from ! DSIFA. ! ! On Entry ! ! A DOUBLE PRECISION(LDA,N) ! the output from DSIFA. ! ! LDA INTEGER ! the leading dimension of the array A. ! ! N INTEGER ! the order of the matrix A. ! ! KPVT INTEGER(N) ! the pivot vector from DSIFA. ! ! WORK DOUBLE PRECISION(N) ! work vector. Contents destroyed. ! ! JOB INTEGER ! JOB has the decimal expansion ABC where ! if C /= 0, the inverse is computed, ! if B /= 0, the determinant is computed, ! if A /= 0, the inertia is computed. ! ! For example, JOB = 111 gives all three. ! ! On Return ! ! Variables not requested by JOB are not used. ! ! A contains the upper triangle of the inverse of ! the original matrix. The strict lower triangle ! is never referenced. ! ! DET DOUBLE PRECISION(2) ! determinant of original matrix. ! DETERMINANT = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0. ! ! INERT INTEGER(3) ! the inertia of the original matrix. ! INERT(1) = number of positive eigenvalues. ! INERT(2) = number of negative eigenvalues. ! INERT(3) = number of zero eigenvalues. ! ! Error Condition ! ! A division by zero may occur if the inverse is requested ! and DSICO has set RCOND == 0.0 ! or DSIFA has set INFO /= 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DCOPY, DDOT, DSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSIDI INTEGER LDA,N,JOB DOUBLE PRECISION A(LDA,*),WORK(*) DOUBLE PRECISION DET(2) INTEGER KPVT(*),INERT(3) ! DOUBLE PRECISION AKKP1,DDOT,TEMP DOUBLE PRECISION TEN,D,T,AK,AKP1 INTEGER J,JB,K,KM1,KS,KSTEP LOGICAL NOINV,NODET,NOERT !***FIRST EXECUTABLE STATEMENT DSIDI NOINV = MOD(JOB,10) == 0 NODET = MOD(JOB,100)/10 == 0 NOERT = MOD(JOB,1000)/100 == 0 ! 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 DO 130 K = 1, N D = A(K,K) ! ! CHECK if 1 BY 1 ! if (KPVT(K) > 0) go to 50 ! ! 2 BY 2 BLOCK ! USE DET (D S) = (D/T * C - T) * T , T = ABS(S) ! (S C) ! TO AVOID UNDERFLOW/OVERFLOW TROUBLES. ! TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. ! if (T /= 0.0D0) go to 30 T = ABS(A(K,K+1)) D = (D/T)*A(K+1,K+1) - T go to 40 30 CONTINUE D = T T = 0.0D0 40 CONTINUE 50 CONTINUE ! if (NOERT) go to 60 if (D > 0.0D0) INERT(1) = INERT(1) + 1 if (D < 0.0D0) INERT(2) = INERT(2) + 1 if (D == 0.0D0) INERT(3) = INERT(3) + 1 60 CONTINUE ! if (NODET) go to 120 DET(1) = D*DET(1) if (DET(1) == 0.0D0) go to 110 70 if (ABS(DET(1)) >= 1.0D0) go to 80 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 go to 70 80 CONTINUE 90 if (ABS(DET(1)) < TEN) go to 100 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0D0 go to 90 100 CONTINUE 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE ! ! COMPUTE INVERSE(A) ! if (NOINV) go to 270 K = 1 150 if (K > N) go to 260 KM1 = K - 1 if (KPVT(K) < 0) go to 180 ! ! 1 BY 1 ! A(K,K) = 1.0D0/A(K,K) if (KM1 < 1) go to 170 call DCOPY(KM1,A(1,K),1,WORK,1) DO 160 J = 1, KM1 A(J,K) = DDOT(J,A(1,J),1,WORK,1) call DAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 160 CONTINUE A(K,K) = A(K,K) + DDOT(KM1,WORK,1,A(1,K),1) 170 CONTINUE KSTEP = 1 go to 220 180 CONTINUE ! ! 2 BY 2 ! T = ABS(A(K,K+1)) AK = A(K,K)/T AKP1 = A(K+1,K+1)/T AKKP1 = A(K,K+1)/T D = T*(AK*AKP1 - 1.0D0) A(K,K) = AKP1/D A(K+1,K+1) = AK/D A(K,K+1) = -AKKP1/D if (KM1 < 1) go to 210 call DCOPY(KM1,A(1,K+1),1,WORK,1) DO 190 J = 1, KM1 A(J,K+1) = DDOT(J,A(1,J),1,WORK,1) call DAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1) 190 CONTINUE A(K+1,K+1) = A(K+1,K+1) + DDOT(KM1,WORK,1,A(1,K+1),1) A(K,K+1) = A(K,K+1) + DDOT(KM1,A(1,K),1,A(1,K+1),1) call DCOPY(KM1,A(1,K),1,WORK,1) DO 200 J = 1, KM1 A(J,K) = DDOT(J,A(1,J),1,WORK,1) call DAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 200 CONTINUE A(K,K) = A(K,K) + DDOT(KM1,WORK,1,A(1,K),1) 210 CONTINUE KSTEP = 2 220 CONTINUE ! ! SWAP ! KS = ABS(KPVT(K)) if (KS == K) go to 250 call DSWAP(KS,A(1,KS),1,A(1,K),1) DO 230 JB = KS, K J = K + KS - JB TEMP = A(J,K) A(J,K) = A(KS,J) A(KS,J) = TEMP 230 CONTINUE if (KSTEP == 1) go to 240 TEMP = A(KS,K+1) A(KS,K+1) = A(K,K+1) A(K,K+1) = TEMP 240 CONTINUE 250 CONTINUE K = K + KSTEP go to 150 260 CONTINUE 270 CONTINUE return end subroutine DSIFA (A, LDA, N, KPVT, INFO) ! !! DSIFA factors a real symmetric matrix by elimination with symmetric pivoting. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE DOUBLE PRECISION (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! DSIFA factors a double precision symmetric matrix by elimination ! with symmetric pivoting. ! ! To solve A*X = B , follow DSIFA by DSISL. ! To compute INVERSE(A)*C , follow DSIFA by DSISL. ! To compute DETERMINANT(A) , follow DSIFA by DSIDI. ! To compute INERTIA(A) , follow DSIFA by DSIDI. ! To compute INVERSE(A) , follow DSIFA by DSIDI. ! ! On Entry ! ! A DOUBLE PRECISION(LDA,N) ! the symmetric matrix to be factored. ! Only the diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A a block diagonal matrix and the multipliers which ! were used to obtain it. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices, TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th pivot block is singular. This is ! not an error condition for this subroutine, ! but it does indicate that DSISL or DSIDI may ! divide by zero if called. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DSWAP, IDAMAX !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSIFA INTEGER LDA,N,KPVT(*),INFO DOUBLE PRECISION A(LDA,*) ! DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,IDAMAX LOGICAL SWAP !***FIRST EXECUTABLE STATEMENT DSIFA ! ! INITIALIZE ! ! ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ! ALPHA = (1.0D0 + SQRT(17.0D0))/8.0D0 ! INFO = 0 ! ! MAIN LOOP ON K, WHICH GOES FROM N TO 1. ! K = N 10 CONTINUE ! ! LEAVE THE LOOP if K=0 OR K=1. ! if (K == 0) go to 200 if (K > 1) go to 20 KPVT(1) = 1 if (A(1,1) == 0.0D0) INFO = 1 go to 200 20 CONTINUE ! ! THIS SECTION OF CODE DETERMINES THE KIND OF ! ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, ! KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND ! SWAP WILL BE SET TO .TRUE. if AN INTERCHANGE IS ! REQUIRED. ! KM1 = K - 1 ABSAKK = ABS(A(K,K)) ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! COLUMN K. ! IMAX = IDAMAX(K-1,A(1,K),1) COLMAX = ABS(A(IMAX,K)) if (ABSAKK < ALPHA*COLMAX) go to 30 KSTEP = 1 SWAP = .FALSE. go to 90 30 CONTINUE ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! ROW IMAX. ! ROWMAX = 0.0D0 IMAXP1 = IMAX + 1 DO 40 J = IMAXP1, K ROWMAX = MAX(ROWMAX,ABS(A(IMAX,J))) 40 CONTINUE if (IMAX == 1) go to 50 JMAX = IDAMAX(IMAX-1,A(1,IMAX),1) ROWMAX = MAX(ROWMAX,ABS(A(JMAX,IMAX))) 50 CONTINUE if (ABS(A(IMAX,IMAX)) < ALPHA*ROWMAX) go to 60 KSTEP = 1 SWAP = .TRUE. go to 80 60 CONTINUE if (ABSAKK < ALPHA*COLMAX*(COLMAX/ROWMAX)) go to 70 KSTEP = 1 SWAP = .FALSE. go to 80 70 CONTINUE KSTEP = 2 SWAP = IMAX /= KM1 80 CONTINUE 90 CONTINUE if (MAX(ABSAKK,COLMAX) /= 0.0D0) go to 100 ! ! COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. ! KPVT(K) = K INFO = K go to 190 100 CONTINUE if (KSTEP == 2) go to 140 ! ! 1 X 1 PIVOT BLOCK. ! if (.NOT.SWAP) go to 120 ! ! PERFORM AN INTERCHANGE. ! call DSWAP(IMAX,A(1,IMAX),1,A(1,K),1) DO 110 JJ = IMAX, K J = K + IMAX - JJ T = A(J,K) A(J,K) = A(IMAX,J) A(IMAX,J) = T 110 CONTINUE 120 CONTINUE ! ! PERFORM THE ELIMINATION. ! DO 130 JJ = 1, KM1 J = K - JJ MULK = -A(J,K)/A(K,K) T = MULK call DAXPY(J,T,A(1,K),1,A(1,J),1) A(J,K) = MULK 130 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = K if (SWAP) KPVT(K) = IMAX go to 190 140 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (.NOT.SWAP) go to 160 ! ! PERFORM AN INTERCHANGE. ! call DSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) DO 150 JJ = IMAX, KM1 J = KM1 + IMAX - JJ T = A(J,K-1) A(J,K-1) = A(IMAX,J) A(IMAX,J) = T 150 CONTINUE T = A(K-1,K) A(K-1,K) = A(IMAX,K) A(IMAX,K) = T 160 CONTINUE ! ! PERFORM THE ELIMINATION. ! KM2 = K - 2 if (KM2 == 0) go to 180 AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) DENOM = 1.0D0 - AK*AKM1 DO 170 JJ = 1, KM2 J = KM1 - JJ BK = A(J,K)/A(K-1,K) BKM1 = A(J,K-1)/A(K-1,K) MULK = (AKM1*BK - BKM1)/DENOM MULKM1 = (AK*BKM1 - BK)/DENOM T = MULK call DAXPY(J,T,A(1,K),1,A(1,J),1) T = MULKM1 call DAXPY(J,T,A(1,K-1),1,A(1,J),1) A(J,K) = MULK A(J,K-1) = MULKM1 170 CONTINUE 180 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = 1 - K if (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE K = K - KSTEP go to 10 200 CONTINUE return end subroutine DSILUR (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSILUR is the incomplete LU Iterative Refinement Sparse Ax = b Solver. ! ! Routine to solve a general linear system Ax = b using ! the incomplete LU decomposition with iterative refinement. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSILUR-S, DSILUR-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+4*N) ! ! call DSILUR(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= NL+NU+4*N. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of integer workspace, IWORK. LENIW >= NL+NU+4*N+10. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! ! *Description ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DSJAC, DSGS, DIR !***REFERENCES (NONE) !***ROUTINES CALLED DCHKW, DIR, DS2Y, DSILUS, DSLUI, DSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921019 Corrected NEL to NL. (FNF) !***END PROLOGUE DSILUR ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCDZ, LOCIL, LOCIU, LOCIW, & LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCR, LOCU, LOCW, LOCZ, & NL, NU ! .. External Subroutines .. EXTERNAL DCHKW, DIR, DS2Y, DSILUS, DSLUI, DSMV !***FIRST EXECUTABLE STATEMENT DSILUR ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements in preconditioner ILU ! matrix. Then set up the work arrays. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE LOCIL = LOCIB LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N LOCL = LOCRB LOCDIN = LOCL + NL LOCU = LOCDIN + N LOCR = LOCU + NU LOCZ = LOCR + N LOCDZ = LOCZ + N LOCW = LOCDZ + N ! ! Check the workspace allocations. ! call DCHKW( 'DSILUR', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. ! call DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Do the Preconditioned Iterative Refinement iteration. ! call DIR(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSLUI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCDZ), RWORK, IWORK) return end subroutine DSILUS (N, NELT, IA, JA, A, ISYM, NL, IL, JL, L, DINV, & NU, IU, JU, U, NROW, NCOL) ! !! DSILUS is the incomplete LU Decomposition Preconditioner SLAP Set Up. ! ! Routine to generate the incomplete LDU decomposition of a ! matrix. The unit lower triangular factor L is stored by ! rows and the unit upper triangular factor U is stored by ! columns. The inverse of the diagonal matrix D is stored. ! No fill in is allowed. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSILUS-S, DSILUS-D) !***KEYWORDS INCOMPLETE LU FACTORIZATION, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! INTEGER NL, IL(NL), JL(NL), NU, IU(NU), JU(NU) ! INTEGER NROW(N), NCOL(N) ! DOUBLE PRECISION A(NELT), L(NL), DINV(N), U(NU) ! ! call DSILUS( N, NELT, IA, JA, A, ISYM, NL, IL, JL, L, ! $ DINV, NU, IU, JU, U, NROW, NCOL ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of elements in arrays IA, JA, and A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! NL :OUT Integer. ! Number of non-zeros in the L array. ! IL :OUT Integer IL(NL). ! JL :OUT Integer JL(NL). ! L :OUT Double Precision L(NL). ! IL, JL, L contain the unit lower triangular factor of the ! incomplete decomposition of some matrix stored in SLAP ! Row format. The Diagonal of ones *IS* stored. See ! "DESCRIPTION", below for more details about the SLAP format. ! NU :OUT Integer. ! Number of non-zeros in the U array. ! IU :OUT Integer IU(NU). ! JU :OUT Integer JU(NU). ! U :OUT Double Precision U(NU). ! IU, JU, U contain the unit upper triangular factor of the ! incomplete decomposition of some matrix stored in SLAP ! Column format. The Diagonal of ones *IS* stored. See ! "Description", below for more details about the SLAP ! format. ! NROW :WORK Integer NROW(N). ! NROW(I) is the number of non-zero elements in the I-th row ! of L. ! NCOL :WORK Integer NCOL(N). ! NCOL(I) is the number of non-zero elements in the I-th ! column of U. ! ! *Description ! IL, JL, L should contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in SLAP ! Row format. IU, JU, U should contain the unit upper factor ! of the incomplete decomposition of the A matrix stored in ! SLAP Column format This ILU factorization can be computed by ! the DSILUS routine. The diagonals (which are all one's) are ! stored. ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the ! double precision array A. In other words, for each row in ! the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going across the row (except the ! diagonal) in order. The JA array holds the column index for ! each non-zero. The IA array holds the offsets into the JA, ! A arrays for the beginning of each row. That is, ! JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- ! th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! are the last elements of the IROW-th row. Note that we ! always have IA(N+1) = NELT+1, where N is the number of rows ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! !***SEE ALSO SILUR !***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, ! Johns Hopkins University Press, Baltimore, Maryland, ! 1983. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSILUS ! .. Scalar Arguments .. INTEGER ISYM, N, NELT, NL, NU ! .. Array Arguments .. DOUBLE PRECISION A(NELT), DINV(N), L(NL), U(NU) INTEGER IA(NELT), IL(NL), IU(NU), JA(NELT), JL(NL), JU(NU), & NCOL(N), NROW(N) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, IBGN, ICOL, IEND, INDX, INDX1, INDX2, INDXC1, INDXC2, & INDXR1, INDXR2, IROW, ITEMP, J, JBGN, JEND, JTEMP, K, KC, & KR !***FIRST EXECUTABLE STATEMENT DSILUS ! ! Count number of elements in each row of the lower triangle. ! DO 10 I=1,N NROW(I) = 0 NCOL(I) = 0 10 CONTINUE !VD$R NOCONCUR !VD$R NOVECTOR DO 30 ICOL = 1, N JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN DO 20 J = JBGN, JEND if ( IA(J) < ICOL ) THEN NCOL(ICOL) = NCOL(ICOL) + 1 ELSE NROW(IA(J)) = NROW(IA(J)) + 1 if ( ISYM /= 0 ) NCOL(IA(J)) = NCOL(IA(J)) + 1 ENDIF 20 CONTINUE ENDIF 30 CONTINUE JU(1) = 1 IL(1) = 1 DO ICOL = 1, N IL(ICOL+1) = IL(ICOL) + NROW(ICOL) JU(ICOL+1) = JU(ICOL) + NCOL(ICOL) NROW(ICOL) = IL(ICOL) NCOL(ICOL) = JU(ICOL) end do ! ! Copy the matrix A into the L and U structures. ! DO 60 ICOL = 1, N DINV(ICOL) = A(JA(ICOL)) JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN DO 50 J = JBGN, JEND IROW = IA(J) if ( IROW < ICOL ) THEN ! Part of the upper triangle. IU(NCOL(ICOL)) = IROW U(NCOL(ICOL)) = A(J) NCOL(ICOL) = NCOL(ICOL) + 1 ELSE ! Part of the lower triangle (stored by row). JL(NROW(IROW)) = ICOL L(NROW(IROW)) = A(J) NROW(IROW) = NROW(IROW) + 1 if ( ISYM /= 0 ) THEN ! Symmetric...Copy lower triangle into upper triangle as well. IU(NCOL(IROW)) = ICOL U(NCOL(IROW)) = A(J) NCOL(IROW) = NCOL(IROW) + 1 ENDIF ENDIF 50 CONTINUE ENDIF 60 CONTINUE ! ! Sort the rows of L and the columns of U. DO 110 K = 2, N JBGN = JU(K) JEND = JU(K+1)-1 if ( JBGN < JEND ) THEN DO 80 J = JBGN, JEND-1 DO 70 I = J+1, JEND if ( IU(J) > IU(I) ) THEN ITEMP = IU(J) IU(J) = IU(I) IU(I) = ITEMP TEMP = U(J) U(J) = U(I) U(I) = TEMP ENDIF 70 CONTINUE 80 CONTINUE ENDIF IBGN = IL(K) IEND = IL(K+1)-1 if ( IBGN < IEND ) THEN DO 100 I = IBGN, IEND-1 DO 90 J = I+1, IEND if ( JL(I) > JL(J) ) THEN JTEMP = JU(I) JU(I) = JU(J) JU(J) = JTEMP TEMP = L(I) L(I) = L(J) L(J) = TEMP ENDIF 90 CONTINUE 100 CONTINUE ENDIF 110 CONTINUE ! ! Perform the incomplete LDU decomposition. DO 300 I=2,N ! ! I-th row of L INDX1 = IL(I) INDX2 = IL(I+1) - 1 if ( INDX1 > INDX2) go to 200 DO 190 INDX=INDX1,INDX2 if ( INDX == INDX1) go to 180 INDXR1 = INDX1 INDXR2 = INDX - 1 INDXC1 = JU(JL(INDX)) INDXC2 = JU(JL(INDX)+1) - 1 if ( INDXC1 > INDXC2) go to 180 160 KR = JL(INDXR1) 170 KC = IU(INDXC1) if ( KR > KC) THEN INDXC1 = INDXC1 + 1 if ( INDXC1 <= INDXC2) go to 170 ELSEIF(KR < KC) THEN INDXR1 = INDXR1 + 1 if ( INDXR1 <= INDXR2) go to 160 ELSEIF(KR == KC) THEN L(INDX) = L(INDX) - L(INDXR1)*DINV(KC)*U(INDXC1) INDXR1 = INDXR1 + 1 INDXC1 = INDXC1 + 1 if ( INDXR1 <= INDXR2 .AND. INDXC1 <= INDXC2) go to 160 ENDIF 180 L(INDX) = L(INDX)/DINV(JL(INDX)) 190 CONTINUE ! ! I-th column of U 200 INDX1 = JU(I) INDX2 = JU(I+1) - 1 if ( INDX1 > INDX2) go to 260 DO 250 INDX=INDX1,INDX2 if ( INDX == INDX1) go to 240 INDXC1 = INDX1 INDXC2 = INDX - 1 INDXR1 = IL(IU(INDX)) INDXR2 = IL(IU(INDX)+1) - 1 if ( INDXR1 > INDXR2) go to 240 210 KR = JL(INDXR1) 220 KC = IU(INDXC1) if ( KR > KC) THEN INDXC1 = INDXC1 + 1 if ( INDXC1 <= INDXC2) go to 220 ELSEIF(KR < KC) THEN INDXR1 = INDXR1 + 1 if ( INDXR1 <= INDXR2) go to 210 ELSEIF(KR == KC) THEN U(INDX) = U(INDX) - L(INDXR1)*DINV(KC)*U(INDXC1) INDXR1 = INDXR1 + 1 INDXC1 = INDXC1 + 1 if ( INDXR1 <= INDXR2 .AND. INDXC1 <= INDXC2) go to 210 ENDIF 240 U(INDX) = U(INDX)/DINV(IU(INDX)) 250 CONTINUE ! ! I-th diagonal element 260 INDXR1 = IL(I) INDXR2 = IL(I+1) - 1 if ( INDXR1 > INDXR2) go to 300 INDXC1 = JU(I) INDXC2 = JU(I+1) - 1 if ( INDXC1 > INDXC2) go to 300 270 KR = JL(INDXR1) 280 KC = IU(INDXC1) if ( KR > KC) THEN INDXC1 = INDXC1 + 1 if ( INDXC1 <= INDXC2) go to 280 ELSEIF(KR < KC) THEN INDXR1 = INDXR1 + 1 if ( INDXR1 <= INDXR2) go to 270 ELSEIF(KR == KC) THEN DINV(I) = DINV(I) - L(INDXR1)*DINV(KC)*U(INDXC1) INDXR1 = INDXR1 + 1 INDXC1 = INDXC1 + 1 if ( INDXR1 <= INDXR2 .AND. INDXC1 <= INDXC2) go to 270 ENDIF ! 300 CONTINUE ! ! Replace diagonal elements by their inverses. ! DINV(1:N) = 1.0D0 / DINV(1:N) return end DOUBLE PRECISION FUNCTION DSINDG (X) ! !! DSINDG computes the sine of an argument in degrees. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE DOUBLE PRECISION (SINDG-S, DSINDG-D) !***KEYWORDS DEGREES, ELEMENTARY FUNCTIONS, FNLIB, SINE, TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DSINDG(X) calculates the double precision sine for double ! precision argument X where X is in degrees. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DSINDG DOUBLE PRECISION X, RADDEG SAVE RADDEG DATA RADDEG / 0.017453292519943295769236907684886D0 / !***FIRST EXECUTABLE STATEMENT DSINDG DSINDG = SIN (RADDEG*X) ! if (MOD(X,90.D0) /= 0.D0) RETURN N = ABS(X)/90.D0 + 0.5D0 N = MOD (N, 2) if (N == 0) DSINDG = 0.D0 if (N == 1) DSINDG = SIGN (1.0D0, DSINDG) ! return end subroutine DSISL (A, LDA, N, KPVT, B) ! !! DSISL solves a real symmetric system using the factors obtained from SSIFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE DOUBLE PRECISION (SSISL-S, DSISL-D, CHISL-C, CSISL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! DSISL solves the double precision symmetric system ! A * X = B ! using the factors computed by DSIFA. ! ! On Entry ! ! A DOUBLE PRECISION(LDA,N) ! the output from DSIFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! KPVT INTEGER(N) ! the pivot vector from DSIFA. ! ! B DOUBLE PRECISION(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero may occur if DSICO has set RCOND == 0.0 ! or DSIFA has set INFO /= 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call DSIFA(A,LDA,N,KPVT,INFO) ! if (INFO /= 0) go to ... ! DO 10 J = 1, P ! call DSISL(A,LDA,N,KPVT,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSISL INTEGER LDA,N,KPVT(*) DOUBLE PRECISION A(LDA,*),B(*) ! DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP INTEGER K,KP ! ! LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND ! D INVERSE TO B. ! !***FIRST EXECUTABLE STATEMENT DSISL K = N 10 if (K == 0) go to 80 if (KPVT(K) < 0) go to 40 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 30 KP = KPVT(K) if (KP == K) go to 20 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call DAXPY(K-1,B(K),A(1,K),1,B(1),1) 30 CONTINUE ! ! APPLY D INVERSE. ! B(K) = B(K)/A(K,K) K = K - 1 go to 70 40 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (K == 2) go to 60 KP = ABS(KPVT(K)) if (KP == K - 1) go to 50 ! ! INTERCHANGE. ! TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call DAXPY(K-2,B(K),A(1,K),1,B(1),1) call DAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) 60 CONTINUE ! ! APPLY D INVERSE. ! AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = B(K)/A(K-1,K) BKM1 = B(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0D0 B(K) = (AKM1*BK - BKM1)/DENOM B(K-1) = (AK*BKM1 - BK)/DENOM K = K - 2 70 CONTINUE go to 10 80 CONTINUE ! ! LOOP FORWARD APPLYING THE TRANSFORMATIONS. ! K = 1 90 if (K > N) go to 160 if (KPVT(K) < 0) go to 120 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 110 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) KP = KPVT(K) if (KP == K) go to 100 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 100 CONTINUE 110 CONTINUE K = K + 1 go to 150 120 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (K == 1) go to 140 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) B(K+1) = B(K+1) + DDOT(K-1,A(1,K+1),1,B(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 130 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 130 CONTINUE 140 CONTINUE K = K + 2 150 CONTINUE go to 90 160 CONTINUE return end subroutine DSJAC (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSJAC is the Jacobi's Method Iterative Sparse Ax = b Solver. ! ! Routine to solve a general linear system Ax = b using ! Jacobi iteration. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSJAC-S, DSJAC-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) ! ! call DSJAC(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. LENW >= 4*N. ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the double precision workspace, ! RWORK. Upon return the following locations of IWORK hold ! information which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! ! *Description: ! Jacobi's method solves the linear system Ax=b with the ! basic iterative method (where A = L + D + U): ! ! n+1 -1 n n ! X = D (B - LX - UX ) ! ! n -1 n ! = X + D (B - AX ) ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which one ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DSGS, DIR !***REFERENCES (NONE) !***ROUTINES CALLED DCHKW, DIR, DS2Y, DSDI, DSDS, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Corrected error in C***ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE DSJAC ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCD, LOCDZ, LOCIW, LOCR, LOCW, LOCZ ! .. External Subroutines .. EXTERNAL DCHKW, DIR, DS2Y, DSDI, DSDS, DSMV !***FIRST EXECUTABLE STATEMENT DSJAC ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if LOCIW = LOCIB LOCD = LOCRB LOCR = LOCD + N LOCZ = LOCR + N LOCDZ = LOCZ + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call DCHKW( 'DSJAC', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCD IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Convert to SLAP column format. call DS2Y(N, NELT, IA, JA, A, ISYM ) ! ! Compute the inverse of the diagonal of the matrix. This ! will be used as the preconditioner. call DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCD)) ! ! Set up the work array and perform the iterative refinement. call DIR(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSDI, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), RWORK(LOCZ), & RWORK(LOCDZ), RWORK, IWORK ) return !------------- LAST LINE OF DSJAC FOLLOWS ----------------------------- end subroutine DSLI2 (N, B, X, NEL, IEL, JEL, EL) ! !! DSLI2 is the SLAP Lower Triangle Matrix Backsolve. ! ! Routine to solve a system of the form Lx = b , where L ! is a lower triangular matrix. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A3 !***TYPE DOUBLE PRECISION (SSLI2-S, DSLI2-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NEL, IEL(NEL), JEL(NEL) ! DOUBLE PRECISION B(N), X(N), EL(NEL) ! ! call DSLI2( N, B, X, NEL, IEL, JEL, EL ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right hand side vector. ! X :OUT Double Precision X(N). ! Solution to Lx = b. ! NEL :IN Integer. ! Number of non-zeros in the EL array. ! IEL :IN Integer IEL(NEL). ! JEL :IN Integer JEL(NEL). ! EL :IN Double Precision EL(NEL). ! IEL, JEL, EL contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in ! SLAP Row format. The diagonal of ones *IS* stored. This ! structure can be set up by the DS2LT routine. See the ! "Description", below, for more details about the SLAP Row ! format. ! ! *Description: ! This routine is supplied with the SLAP package as a routine ! to perform the MSOLVE operation in the DIR iteration routine ! for the driver routine DSGS. It must be called via the SLAP ! MSOLVE calling sequence convention interface routine DSLI. ! **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** ! **** SLAP MSOLVE CALLING CONVENTION **** ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the ! double precision array A. In other words, for each row in ! the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going across the row (except the ! diagonal) in order. The JA array holds the column index for ! each non-zero. The IA array holds the offsets into the JA, ! A arrays for the beginning of each row. That is, ! JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- ! th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! are the last elements of the IROW-th row. Note that we ! always have IA(N+1) = NELT+1, where N is the number of rows ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP Row format the "inner loop" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! !***SEE ALSO DSLI !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSLI2 ! .. Scalar Arguments .. INTEGER N, NEL ! .. Array Arguments .. DOUBLE PRECISION B(N), EL(NEL), X(N) INTEGER IEL(NEL), JEL(NEL) ! .. Local Scalars .. INTEGER I, ICOL, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT DSLI2 ! ! Initialize the solution by copying the right hands side ! into it. ! DO 10 I=1,N X(I) = B(I) 10 CONTINUE ! !VD$ NOCONCUR DO 30 ICOL = 1, N X(ICOL) = X(ICOL)/EL(JEL(ICOL)) JBGN = JEL(ICOL) + 1 JEND = JEL(ICOL+1) - 1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NOCONCUR !VD$ NODEPCHK DO 20 J = JBGN, JEND X(IEL(J)) = X(IEL(J)) - EL(J)*X(ICOL) 20 CONTINUE ENDIF 30 CONTINUE ! return !------------- LAST LINE OF DSLI2 FOLLOWS ---------------------------- end subroutine DSLI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! DSLI is the SLAP MSOLVE for Lower Triangle Matrix. ! ! This routine acts as an interface between the SLAP generic ! MSOLVE calling convention and the routine that actually ! computes inv(L) * B = X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A3 !***TYPE DOUBLE PRECISION (SSLI-S, DSLI-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! It is assumed that RWORK and IWORK have initialized with ! the information required for DSLI2: ! IWORK(1) = NEL ! IWORK(2) = Starting location of IEL in IWORK. ! IWORK(3) = Starting location of JEL in IWORK. ! IWORK(4) = Starting location of EL in RWORK. ! See the DESCRIPTION of DSLI2 for details. !***REFERENCES (NONE) !***ROUTINES CALLED DSLI2 !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSLI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER LOCEL, LOCIEL, LOCJEL, NEL ! .. External Subroutines .. EXTERNAL DSLI2 !***FIRST EXECUTABLE STATEMENT DSLI ! NEL = IWORK(1) LOCIEL = IWORK(2) LOCJEL = IWORK(3) LOCEL = IWORK(4) call DSLI2(N, B, X, NEL, IWORK(LOCIEL), IWORK(LOCJEL), & RWORK(LOCEL)) ! return !------------- LAST LINE OF DSLI FOLLOWS ---------------------------- end subroutine DSLLTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! DSLLTI is the SLAP MSOLVE for LDL' (IC) Factorization. ! ! This routine acts as an interface between the SLAP generic ! MSOLVE calling convention and the routine that actually ! computes inverse(LDL') B = X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSLLTI-S, DSLLTI-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! It is assumed that RWORK and IWORK have initialized with ! the information required for DLLTI2: ! IWORK(1) = NEL ! IWORK(2) = Starting location of IEL in IWORK. ! IWORK(3) = Starting location of JEL in IWORK. ! IWORK(4) = Starting location of EL in RWORK. ! IWORK(5) = Starting location of DINV in RWORK. ! See the DESCRIPTION of DLLTI2 for details. !***REFERENCES (NONE) !***ROUTINES CALLED DLLTI2 !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Corrected conversion error. (FNF) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSLLTI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(*), RWORK(*), X(*) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCEL, LOCIEL, LOCJEL, NEL ! .. External Subroutines .. EXTERNAL DLLTI2 !***FIRST EXECUTABLE STATEMENT DSLLTI NEL = IWORK(1) LOCIEL = IWORK(3) LOCJEL = IWORK(2) LOCEL = IWORK(4) LOCDIN = IWORK(5) call DLLTI2(N, B, X, NEL, IWORK(LOCIEL), IWORK(LOCJEL), & RWORK(LOCEL), RWORK(LOCDIN)) ! return !------------- LAST LINE OF DSLLTI FOLLOWS ---------------------------- end subroutine DSLUBC (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSLUBC is the incomplete LU BiConjugate Gradient Sparse Ax=b Solver. ! ! Routine to solve a linear system Ax = b using the ! BiConjugate Gradient method with Incomplete LU ! decomposition preconditioning. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSLUBC-S, DSLUBC-D) !***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) ! ! call DSLUBC(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= NL+NU+8*N. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. ! LENIW >= NL+NU+4*N+12. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! ! *Description: ! This routine is simply a driver for the DBCGN routine. It ! calls the DSILUS routine to set up the preconditioning and ! then calls DBCGN with the appropriate MATVEC, MTTVEC and ! MSOLVE, MTSOLV routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DBCG, DSDBCG !***REFERENCES (NONE) !***ROUTINES CALLED DBCG, DCHKW, DS2Y, DSILUS, DSLUI, DSLUTI, DSMTV, ! DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DSLUBC ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCDZ, LOCIL, LOCIU, LOCIW, & LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCP, LOCPP, LOCR, & LOCRR, LOCU, LOCW, LOCZ, LOCZZ, NL, NU ! .. External Subroutines .. EXTERNAL DBCG, DCHKW, DS2Y, DSILUS, DSLUI, DSLUTI, DSMTV, DSMV !***FIRST EXECUTABLE STATEMENT DSLUBC ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements preconditioner ILU matrix. ! Then set up the work arrays. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIL = LOCIB LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCU = LOCDIN + N LOCR = LOCU + NU LOCZ = LOCR + N LOCP = LOCZ + N LOCRR = LOCP + N LOCZZ = LOCRR + N LOCPP = LOCZZ + N LOCDZ = LOCPP + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call DCHKW( 'DSLUBC', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Perform the incomplete LU preconditioned ! BiConjugate Gradient algorithm. call DBCG(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSMTV, & DSLUI, DSLUTI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), & RWORK(LOCRR), RWORK(LOCZZ), RWORK(LOCPP), & RWORK(LOCDZ), RWORK, IWORK ) return !------------- LAST LINE OF DSLUBC FOLLOWS ---------------------------- end subroutine DSLUCN (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSLUCN is the ncomplete LU CG Sparse Ax=b Solver for Normal Equations. ! ! Routine to solve a general linear system Ax = b using the ! incomplete LU decomposition with the Conjugate Gradient ! method applied to the normal equations, viz., AA'y = b, ! x = A'y. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSLUCN-S, DSLUCN-D) !***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) ! ! call DSLUCN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= NL+NU+8*N. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. ! LENIW >= NL+NU+4*N+12. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! ! *Description: ! This routine is simply a driver for the DCGN routine. It ! calls the DSILUS routine to set up the preconditioning and then ! calls DCGN with the appropriate MATVEC and MSOLVE routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DCGN, SDCGN, DSILUS !***REFERENCES (NONE) !***ROUTINES CALLED DCGN, DCHKW, DS2Y, DSILUS, DSMMTI, DSMTV, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DSLUCN ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCATD, LOCATP, LOCATZ, LOCDIN, & LOCDZ, LOCIL, LOCIU, LOCIW, LOCJL, LOCJU, LOCL, LOCNC, & LOCNR, LOCP, LOCR, LOCU, LOCW, LOCZ, NL, NU ! .. External Subroutines .. EXTERNAL DCGN, DCHKW, DS2Y, DSILUS, DSMMTI, DSMTV, DSMV !***FIRST EXECUTABLE STATEMENT DSLUCN ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements preconditioner ILU matrix. ! Then set up the work arrays. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIL = LOCIB LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCU = LOCDIN + N LOCR = LOCU + NU LOCZ = LOCR + N LOCP = LOCZ + N LOCATP = LOCP + N LOCATZ = LOCATP + N LOCDZ = LOCATZ + N LOCATD = LOCDZ + N LOCW = LOCATD + N ! ! Check the workspace allocations. call DCHKW( 'DSLUCN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Perform Conjugate Gradient algorithm on the normal equations. call DCGN(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSMTV, DSMMTI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCP), RWORK(LOCATP), RWORK(LOCATZ), & RWORK(LOCDZ), RWORK(LOCATD), RWORK, IWORK ) ! if ( ITER > ITMAX ) IERR = 2 return !------------- LAST LINE OF DSLUCN FOLLOWS ---------------------------- end subroutine DSLUCS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSLUCS is the incomplete LU BiConjugate Gradient Squared Ax=b Solver. ! ! Routine to solve a linear system Ax = b using the ! BiConjugate Gradient Squared method with Incomplete LU ! decomposition preconditioning. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSLUCS-S, DSLUCS-D) !***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) ! ! call DSLUCS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! This routine must calculate the residual from R = A*X - B. ! This is unnatural and hence expensive for this type of iter- ! ative method. ITOL=2 is *STRONGLY* recommended. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv time a vector is the pre- ! conditioning step. This is the *NATURAL* stopping for this ! iterative method and is *STRONGLY* recommended. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Breakdown of the method detected. ! (r0,r) approximately 0. ! IERR = 6 => Stagnation of the method detected. ! (r0,v) approximately 0. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. NL is the number ! of non-zeros in the lower triangle of the matrix (including ! the diagonal). NU is the number of non-zeros in the upper ! triangle of the matrix (including the diagonal). ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= NL+NU+8*N. ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. NL is the number of non- ! zeros in the lower triangle of the matrix (including the ! diagonal). NU is the number of non-zeros in the upper ! triangle of the matrix (including the diagonal). ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. ! LENIW >= NL+NU+4*N+12. ! ! *Description: ! This routine is simply a driver for the DCGSN routine. It ! calls the DSILUS routine to set up the preconditioning and ! then calls DCGSN with the appropriate MATVEC, MTTVEC and ! MSOLVE, MTSOLV routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DCGS, DSDCGS !***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver ! for nonsymmetric linear systems, Delft University ! of Technology Report 84-16, Department of Mathe- ! matics and Informatics, Delft, The Netherlands. ! 2. E. F. Kaasschieter, The solution of non-symmetric ! linear systems by biconjugate gradients or conjugate ! gradients squared, Delft University of Technology ! Report 86-21, Department of Mathematics and Informa- ! tics, Delft, The Netherlands. !***ROUTINES CALLED DCGS, DCHKW, DS2Y, DSILUS, DSLUI, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DSLUCS ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCIL, LOCIU, LOCIW, LOCJL, & LOCJU, LOCL, LOCNC, LOCNR, LOCP, LOCQ, LOCR, LOCR0, LOCU, & LOCUU, LOCV1, LOCV2, LOCW, NL, NU ! .. External Subroutines .. EXTERNAL DCGS, DCHKW, DS2Y, DSILUS, DSLUI, DSMV !***FIRST EXECUTABLE STATEMENT DSLUCS ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements preconditioner ILU matrix. ! Then set up the work arrays. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIL = LOCIB LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCUU = LOCDIN + N LOCR = LOCUU + NU LOCR0 = LOCR + N LOCP = LOCR0 + N LOCQ = LOCP + N LOCU = LOCQ + N LOCV1 = LOCU + N LOCV2 = LOCV1 + N LOCW = LOCV2 + N ! ! Check the workspace allocations. call DCHKW( 'DSLUCS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCUU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCUU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Perform the incomplete LU preconditioned ! BiConjugate Gradient Squared algorithm. call DCGS(N, B, X, NELT, IA, JA, A, ISYM, DSMV, & DSLUI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCR0), RWORK(LOCP), & RWORK(LOCQ), RWORK(LOCU), RWORK(LOCV1), & RWORK(LOCV2), RWORK, IWORK ) return !------------- LAST LINE OF DSLUCS FOLLOWS ---------------------------- end subroutine DSLUGM (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSLUGM is the incomplete LU GMRES iterative sparse Ax=b solver. ! ! This routine uses the generalized minimum residual ! (GMRES) method with incomplete LU factorization for ! preconditioning to solve possibly non-symmetric linear ! systems of the form: Ax = b. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSLUGM-S, DSLUGM-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL ! INTEGER ITMAX, ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) ! ! call DSLUGM(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ! $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, ! $ RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize against. ! Must be greater than 1. ! ITOL :IN Integer. ! Flag to indicate the type of convergence criterion used. ! ITOL=0 Means the iteration stops when the test described ! below on the residual RL is satisfied. This is ! the "Natural Stopping Criteria" for this routine. ! Other values of ITOL cause extra, otherwise ! unnecessary, computation per iteration and are ! therefore much less efficient. See ISDGMR (the ! stop test routine) for more information. ! ITOL=1 Means the iteration stops when the first test ! described below on the residual RL is satisfied, ! and there is either right or no preconditioning ! being used. ! ITOL=2 Implies that the user is using left ! preconditioning, and the second stopping criterion ! below is used. ! ITOL=3 Means the iteration stops when the third test ! described below on Minv*Residual is satisfied, and ! there is either left or no preconditioning begin ! used. ! ITOL=11 is often useful for checking and comparing ! different routines. For this case, the user must ! supply the "exact" solution or a very accurate ! approximation (one with an error much less than ! TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the ! difference between the iterative approximation and ! the user-supplied solution divided by the 2-norm ! of the user-supplied solution is less than TOL. ! Note that this requires the user to set up the ! "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling ! routine. The routine with this declaration should ! be loaded before the stop test so that the correct ! length is used by the loader. This procedure is ! not standard Fortran and may not work correctly on ! your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 ! then this common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described below. If TOL is set ! to zero on input, then a default value of 500*(the smallest ! positive magnitude, machine epsilon) is used. ! ITMAX :IN Integer. ! Maximum number of iterations. This routine uses the default ! of NRMAX = ITMAX/NSAVE to determine the when each restart ! should occur. See the description of NRMAX and MAXL in ! DGMRES for a full and frightfully interesting discussion of ! this topic. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. Letting norm() denote the Euclidean ! norm, ERR is defined as follows... ! If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! for right or no preconditioning, and ! ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! for left preconditioning. ! If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! since right or no preconditioning ! being used. ! If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! since left preconditioning is being ! used. ! If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| ! i=1,n ! If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient storage allocated for ! RGWK or IGWK. ! IERR = 2 => Routine DPIGMR failed to reduce the norm ! of the current residual on its last call, ! and so the iteration has stalled. In ! this case, X equals the last computed ! approximation. The user must either ! increase MAXL, or choose a different ! initial guess. ! IERR =-1 => Insufficient length for RGWK array. ! IGWK(6) contains the required minimum ! length of the RGWK array. ! IERR =-2 => Inconsistent ITOL and JPRE values. ! For IERR <= 2, RGWK(1) = RHOL, which is the norm on the ! left-hand-side of the relevant stopping test defined ! below associated with the residual for the current ! approximation X(L). ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array of size LENW. ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= 1 + N*(NSAVE+7) + NSAVE*(NSAVE+3)+NL+NU. ! Here NL is the number of non-zeros in the lower triangle of ! the matrix (including the diagonal) and NU is the number of ! non-zeros in the upper triangle of the matrix (including the ! diagonal). ! For the recommended values, RWORK has size at least ! 131 + 17*N + NL + NU. ! IWORK :INOUT Integer IWORK(LENIW). ! Used to hold pointers into the RWORK array. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. ! LENIW >= NL+NU+4*N+32. ! ! *Description: ! DSLUGM solves a linear system A*X = B rewritten in the form: ! ! (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, ! ! with right preconditioning, or ! ! (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, ! ! with left preconditioning, where A is an n-by-n double precision ! matrix, X and B are N-vectors, SB and SX are diagonal scaling ! matrices, and M is the Incomplete LU factorization of A. It ! uses preconditioned Krylov subpace methods based on the ! generalized minimum residual method (GMRES). This routine ! is a driver routine which assumes a SLAP matrix data ! structure and sets up the necessary information to do ! diagonal preconditioning and calls the main GMRES routine ! DGMRES for the solution of the linear system. DGMRES ! optionally performs either the full orthogonalization ! version of the GMRES algorithm or an incomplete variant of ! it. Both versions use restarting of the linear iteration by ! default, although the user can disable this feature. ! ! The GMRES algorithm generates a sequence of approximations ! X(L) to the true solution of the above linear system. The ! convergence criteria for stopping the iteration is based on ! the size of the scaled norm of the residual R(L) = B - ! A*X(L). The actual stopping test is either: ! ! norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), ! ! for right preconditioning, or ! ! norm(SB*(M-inverse)*(B-A*X(L))) .le. ! TOL*norm(SB*(M-inverse)*B), ! ! for left preconditioning, where norm() denotes the Euclidean ! norm, and TOL is a positive scalar less than one input by ! the user. If TOL equals zero when DSLUGM is called, then a ! default value of 500*(the smallest positive magnitude, ! machine epsilon) is used. If the scaling arrays SB and SX ! are used, then ideally they should be chosen so that the ! vectors SX*X(or SX*M*X) and SB*B have all their components ! approximately equal to one in magnitude. If one wants to ! use the same scaling in X and B, then SB and SX can be the ! same array in the calling program. ! ! The following is a list of the other routines and their ! functions used by GMRES: ! DGMRES Contains the matrix structure independent driver ! routine for GMRES. ! DPIGMR Contains the main iteration loop for GMRES. ! DORTH Orthogonalizes a new vector against older basis vectors. ! DHEQR Computes a QR decomposition of a Hessenberg matrix. ! DHELS Solves a Hessenberg least-squares system, using QR ! factors. ! RLCALC Computes the scaled residual RL. ! XLCALC Computes the solution XL. ! ISDGMR User-replaceable stopping routine. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage ! Matrix Methods in Stiff ODE Systems, Lawrence Liver- ! more National Laboratory Report UCRL-95088, Rev. 1, ! Livermore, California, June 1987. !***ROUTINES CALLED DCHKW, DGMRES, DS2Y, DSILUS, DSLUI, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Corrected NEL to NL. (FNF) !***END PROLOGUE DSLUGM ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, & NELT, NSAVE ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCIGW, LOCIL, LOCIU, LOCIW, & LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCRGW, LOCU, LOCW, & MYITOL, NL, NU ! .. External Subroutines .. EXTERNAL DCHKW, DGMRES, DS2Y, DSILUS, DSLUI, DSMV !***FIRST EXECUTABLE STATEMENT DSLUGM ! IERR = 0 ERR = 0 if ( NSAVE <= 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements preconditioner ILU matrix. ! Then set up the work arrays. We assume MAXL=KMP=NSAVE. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIGW = LOCIB LOCIL = LOCIGW + 20 LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCU = LOCDIN + N LOCRGW = LOCU + NU LOCW = LOCRGW + 1+N*(NSAVE+6)+NSAVE*(NSAVE+3) ! ! Check the workspace allocations. call DCHKW( 'DSLUGM', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Perform the Incomplete LU Preconditioned Generalized Minimum ! Residual iteration algorithm. The following DGMRES ! defaults are used MAXL = KMP = NSAVE, JSCAL = 0, ! JPRE = -1, NRMAX = ITMAX/NSAVE IWORK(LOCIGW ) = NSAVE IWORK(LOCIGW+1) = NSAVE IWORK(LOCIGW+2) = 0 IWORK(LOCIGW+3) = -1 IWORK(LOCIGW+4) = ITMAX/NSAVE MYITOL = 0 ! call DGMRES( N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSLUI, & MYITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, RWORK, & RWORK(LOCRGW), LENW-LOCRGW, IWORK(LOCIGW), 20, & RWORK, IWORK ) ! if ( ITER > ITMAX ) IERR = 2 return !------------- LAST LINE OF DSLUGM FOLLOWS ---------------------------- end subroutine DSLUI2 (N, B, X, IL, JL, L, DINV, IU, JU, U) ! !! DSLUI2 is the SLAP Backsolve for LDU Factorization. ! ! Routine to solve a system of the form L*D*U X = B, ! where L is a unit lower triangular matrix, D is a diagonal ! matrix, and U is a unit upper triangular matrix. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSLUI2-S, DSLUI2-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) ! DOUBLE PRECISION B(N), X(N), L(NL), DINV(N), U(NU) ! ! call DSLUI2( N, B, X, IL, JL, L, DINV, IU, JU, U ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right hand side. ! X :OUT Double Precision X(N). ! Solution of L*D*U x = b. ! IL :IN Integer IL(NL). ! JL :IN Integer JL(NL). ! L :IN Double Precision L(NL). ! IL, JL, L contain the unit lower triangular factor of the ! incomplete decomposition of some matrix stored in SLAP Row ! format. The diagonal of ones *IS* stored. This structure ! can be set up by the DSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NL is the number of non-zeros in the L array.) ! DINV :IN Double Precision DINV(N). ! Inverse of the diagonal matrix D. ! IU :IN Integer IU(NU). ! JU :IN Integer JU(NU). ! U :IN Double Precision U(NU). ! IU, JU, U contain the unit upper triangular factor of the ! incomplete decomposition of some matrix stored in SLAP ! Column format. The diagonal of ones *IS* stored. This ! structure can be set up by the DSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NU is the number of non-zeros in the U array.) ! ! *Description: ! This routine is supplied with the SLAP package as a routine ! to perform the MSOLVE operation in the SIR and SBCG ! iteration routines for the drivers DSILUR and DSLUBC. It ! must be called via the SLAP MSOLVE calling sequence ! convention interface routine DSLUI. ! **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** ! **** SLAP MSOLVE CALLING CONVENTION **** ! ! IL, JL, L should contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in SLAP ! Row format. IU, JU, U should contain the unit upper factor ! of the incomplete decomposition of the A matrix stored in ! SLAP Column format This ILU factorization can be computed by ! the DSILUS routine. The diagonals (which are all one's) are ! stored. ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the ! double precision array A. In other words, for each row in ! the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going across the row (except the ! diagonal) in order. The JA array holds the column index for ! each non-zero. The IA array holds the offsets into the JA, ! A arrays for the beginning of each row. That is, ! JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- ! th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! are the last elements of the IROW-th row. Note that we ! always have IA(N+1) = NELT+1, where N is the number of rows ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format the "inner loops" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! !***SEE ALSO DSILUS !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSLUI2 ! .. Scalar Arguments .. INTEGER N ! .. Array Arguments .. DOUBLE PRECISION B(N), DINV(N), L(*), U(*), X(N) INTEGER IL(*), IU(*), JL(*), JU(*) ! .. Local Scalars .. INTEGER I, ICOL, IROW, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT DSLUI2 ! ! Solve L*Y = B, storing result in X, L stored by rows. ! DO 10 I = 1, N X(I) = B(I) 10 CONTINUE DO 30 IROW = 2, N JBGN = IL(IROW) JEND = IL(IROW+1)-1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ ASSOC !VD$ NODEPCHK DO 20 J = JBGN, JEND X(IROW) = X(IROW) - L(J)*X(JL(J)) 20 CONTINUE ENDIF 30 CONTINUE ! ! Solve D*Z = Y, storing result in X. DO 40 I=1,N X(I) = X(I)*DINV(I) 40 CONTINUE ! ! Solve U*X = Z, U stored by columns. DO 60 ICOL = N, 2, -1 JBGN = JU(ICOL) JEND = JU(ICOL+1)-1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 50 J = JBGN, JEND X(IU(J)) = X(IU(J)) - U(J)*X(ICOL) 50 CONTINUE ENDIF 60 CONTINUE ! return !------------- LAST LINE OF DSLUI2 FOLLOWS ---------------------------- end subroutine DSLUI4 (N, B, X, IL, JL, L, DINV, IU, JU, U) ! !! DSLUI4 is the SLAP Backsolve for LDU Factorization. ! ! Routine to solve a system of the form (L*D*U)' X = B, ! where L is a unit lower triangular matrix, D is a diagonal ! matrix, and U is a unit upper triangular matrix and ' ! denotes transpose. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSLUI4-S, DSLUI4-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) ! DOUBLE PRECISION B(N), X(N), L(NL), DINV(N), U(NU) ! ! call DSLUI4( N, B, X, IL, JL, L, DINV, IU, JU, U ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right hand side. ! X :OUT Double Precision X(N). ! Solution of (L*D*U)trans x = b. ! IL :IN Integer IL(NL). ! JL :IN Integer JL(NL). ! L :IN Double Precision L(NL). ! IL, JL, L contain the unit lower triangular factor of the ! incomplete decomposition of some matrix stored in SLAP Row ! format. The diagonal of ones *IS* stored. This structure ! can be set up by the DSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NL is the number of non-zeros in the L array.) ! DINV :IN Double Precision DINV(N). ! Inverse of the diagonal matrix D. ! IU :IN Integer IU(NU). ! JU :IN Integer JU(NU). ! U :IN Double Precision U(NU). ! IU, JU, U contain the unit upper triangular factor of the ! incomplete decomposition of some matrix stored in SLAP ! Column format. The diagonal of ones *IS* stored. This ! structure can be set up by the DSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NU is the number of non-zeros in the U array.) ! ! *Description: ! This routine is supplied with the SLAP package as a routine ! to perform the MTSOLV operation in the SBCG iteration ! routine for the driver DSLUBC. It must be called via the ! SLAP MTSOLV calling sequence convention interface routine ! DSLUTI. ! **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** ! **** SLAP MSOLVE CALLING CONVENTION **** ! ! IL, JL, L should contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in SLAP ! Row format. IU, JU, U should contain the unit upper factor ! of the incomplete decomposition of the A matrix stored in ! SLAP Column format This ILU factorization can be computed by ! the DSILUS routine. The diagonals (which are all one's) are ! stored. ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the ! double precision array A. In other words, for each row in ! the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going across the row (except the ! diagonal) in order. The JA array holds the column index for ! each non-zero. The IA array holds the offsets into the JA, ! A arrays for the beginning of each row. That is, ! JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- ! th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! are the last elements of the IROW-th row. Note that we ! always have IA(N+1) = NELT+1, where N is the number of rows ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format the "inner loops" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! !***SEE ALSO DSILUS !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSLUI4 ! .. Scalar Arguments .. INTEGER N ! .. Array Arguments .. DOUBLE PRECISION B(N), DINV(N), L(*), U(*), X(N) INTEGER IL(*), IU(*), JL(*), JU(*) ! .. Local Scalars .. INTEGER I, ICOL, IROW, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT DSLUI4 DO 10 I=1,N X(I) = B(I) 10 CONTINUE ! ! Solve U'*Y = X, storing result in X, U stored by columns. DO 80 IROW = 2, N JBGN = JU(IROW) JEND = JU(IROW+1) - 1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ ASSOC !VD$ NODEPCHK DO 70 J = JBGN, JEND X(IROW) = X(IROW) - U(J)*X(IU(J)) 70 CONTINUE ENDIF 80 CONTINUE ! ! Solve D*Z = Y, storing result in X. DO 90 I = 1, N X(I) = X(I)*DINV(I) 90 CONTINUE ! ! Solve L'*X = Z, L stored by rows. DO 110 ICOL = N, 2, -1 JBGN = IL(ICOL) JEND = IL(ICOL+1) - 1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 100 J = JBGN, JEND X(JL(J)) = X(JL(J)) - L(J)*X(ICOL) 100 CONTINUE ENDIF 110 CONTINUE return !------------- LAST LINE OF DSLUI4 FOLLOWS ---------------------------- end subroutine DSLUI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! DSLUI is the SLAP MSOLVE for LDU Factorization. ! ! This routine acts as an interface between the SLAP generic ! MSOLVE calling convention and the routine that actually ! computes inverse(LDU) B = X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSLUI-S, DSLUI-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! It is assumed that RWORK and IWORK have initialized with ! the information required for DSLUI2: ! IWORK(1) = Starting location of IL in IWORK. ! IWORK(2) = Starting location of JL in IWORK. ! IWORK(3) = Starting location of IU in IWORK. ! IWORK(4) = Starting location of JU in IWORK. ! IWORK(5) = Starting location of L in RWORK. ! IWORK(6) = Starting location of DINV in RWORK. ! IWORK(7) = Starting location of U in RWORK. ! See the DESCRIPTION of DSLUI2 for details. !***REFERENCES (NONE) !***ROUTINES CALLED DSLUI2 !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSLUI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU ! .. External Subroutines .. EXTERNAL DSLUI2 !***FIRST EXECUTABLE STATEMENT DSLUI ! ! Pull out the locations of the arrays holding the ILU ! factorization. ! LOCIL = IWORK(1) LOCJL = IWORK(2) LOCIU = IWORK(3) LOCJU = IWORK(4) LOCL = IWORK(5) LOCDIN = IWORK(6) LOCU = IWORK(7) ! ! Solve the system LUx = b call DSLUI2(N, B, X, IWORK(LOCIL), IWORK(LOCJL), RWORK(LOCL), & RWORK(LOCDIN), IWORK(LOCIU), IWORK(LOCJU), RWORK(LOCU) ) ! return !------------- LAST LINE OF DSLUI FOLLOWS ---------------------------- end subroutine DSLUOM (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! DSLUOM is the Incomplete LU Orthomin Sparse Iterative Ax=b Solver. ! ! Routine to solve a general linear system Ax = b using ! the Orthomin method with Incomplete LU decomposition. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SSLUOM-S, DSLUOM-D) !***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR ! DOUBLE PRECISION RWORK(NL+NU+7*N+3*N*NSAVE+NSAVE) ! ! call DSLUOM(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen, it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize against. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Double Precision. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*D1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Breakdown of the method detected. ! (p,Ap) < epsilon**2. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Double Precision RWORK(LENW). ! Double Precision array used for workspace. NL is the number ! of non-zeros in the lower triangle of the matrix (including ! the diagonal). NU is the number of non-zeros in the upper ! triangle of the matrix (including the diagonal). ! LENW :IN Integer. ! Length of the double precision workspace, RWORK. ! LENW >= NL+NU+4*N+NSAVE*(3*N+1) ! IWORK :WORK Integer IWORK(LENIW) ! Integer array used for workspace. NL is the number of non- ! zeros in the lower triangle of the matrix (including the ! diagonal). NU is the number of non-zeros in the upper ! triangle of the matrix (including the diagonal). ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Double Precision workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. ! LENIW >= NL+NU+4*N+12. ! ! *Description: ! This routine is simply a driver for the DOMN routine. It ! calls the DSILUS routine to set up the preconditioning and ! then calls DOMN with the appropriate MATVEC and MSOLVE ! routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DOMN, DSDOMN !***REFERENCES (NONE) !***ROUTINES CALLED DCHKW, DOMN, DS2Y, DSILUS, DSLUI, DSMV !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921019 Corrected NEL to NL. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE DSLUOM ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. DOUBLE PRECISION ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, & NELT, NSAVE ! .. Array Arguments .. DOUBLE PRECISION A(N), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCAP, LOCCSA, LOCDIN, LOCDZ, LOCEMA, & LOCIL, LOCIU, LOCIW, LOCJL, LOCJU, LOCL, LOCNC, LOCNR, & LOCP, LOCR, LOCU, LOCW, LOCZ, NL, NU ! .. External Subroutines .. EXTERNAL DCHKW, DOMN, DS2Y, DSILUS, DSLUI, DSMV !***FIRST EXECUTABLE STATEMENT DSLUOM ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call DS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements preconditioner ILU matrix. ! Then set up the work arrays. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIL = LOCIB LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCU = LOCDIN + N LOCR = LOCU + NU LOCZ = LOCR + N LOCP = LOCZ + N LOCAP = LOCP + N*(NSAVE+1) LOCEMA = LOCAP + N*(NSAVE+1) LOCDZ = LOCEMA + N*(NSAVE+1) LOCCSA = LOCDZ + N LOCW = LOCCSA + NSAVE ! ! Check the workspace allocations. call DCHKW( 'DSLUOM', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Perform the incomplete LU preconditioned OrthoMin algorithm. call DOMN(N, B, X, NELT, IA, JA, A, ISYM, DSMV, & DSLUI, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), RWORK(LOCAP), & RWORK(LOCEMA), RWORK(LOCDZ), RWORK(LOCCSA), & RWORK, IWORK ) return end subroutine DSLUTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! DSLUTI is the SLAP MTSOLV for LDU Factorization. ! ! This routine acts as an interface between the SLAP generic ! MTSOLV calling convention and the routine that actually ! computes inverse (LDU)' * B = X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSLUTI-S, DSLUTI-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! It is assumed that RWORK and IWORK have initialized with ! the information required for DSLUI4: ! IWORK(1) = Starting location of IL in IWORK. ! IWORK(2) = Starting location of JL in IWORK. ! IWORK(3) = Starting location of IU in IWORK. ! IWORK(4) = Starting location of JU in IWORK. ! IWORK(5) = Starting location of L in RWORK. ! IWORK(6) = Starting location of DINV in RWORK. ! IWORK(7) = Starting location of U in RWORK. ! See the DESCRIPTION of DSLUI4 for details. !***REFERENCES (NONE) !***ROUTINES CALLED DSLUI4 !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSLUTI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(N), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU ! .. External Subroutines .. EXTERNAL DSLUI4 !***FIRST EXECUTABLE STATEMENT DSLUTI ! ! Pull out the pointers to the L, D and U matrices and call ! the workhorse routine. ! LOCIL = IWORK(1) LOCJL = IWORK(2) LOCIU = IWORK(3) LOCJU = IWORK(4) LOCL = IWORK(5) LOCDIN = IWORK(6) LOCU = IWORK(7) ! call DSLUI4(N, B, X, IWORK(LOCIL), IWORK(LOCJL), RWORK(LOCL), & RWORK(LOCDIN), IWORK(LOCIU), IWORK(LOCJU), RWORK(LOCU)) ! return !------------- LAST LINE OF DSLUTI FOLLOWS ---------------------------- end subroutine DSLVS (WM, IWM, X, TEM) ! !! DSLVS is subsidiary to DDEBDF. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SLVS-S, DSLVS-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DSLVS solves the linear system in the iteration scheme for the ! integrator package DDEBDF. ! !***SEE ALSO DDEBDF !***ROUTINES CALLED DGBSL, DGESL !***COMMON BLOCKS DDEBD1 !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920422 Changed DIMENSION statement. (WRB) !***END PROLOGUE DSLVS ! INTEGER I, IER, IOWND, IOWNS, IWM, JSTART, KFLAG, L, MAXORD, & MEBAND, METH, MITER, ML, MU, N, NFE, NJE, NQ, NQU, NST DOUBLE PRECISION DI, EL0, H, HL0, HMIN, HMXI, HU, PHL0, & R, ROWND, ROWNS, TEM, TN, UROUND, WM, X DIMENSION WM(*), IWM(*), X(*), TEM(*) COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, & IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, & MAXORD,N,NQ,NST,NFE,NJE,NQU ! ------------------------------------------------------------------ ! THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING ! FROM A CHORD ITERATION. IT IS CALLED BY DSTOD if MITER /= 0. ! if MITER IS 1 OR 2, IT CALLS DGESL TO ACCOMPLISH THIS. ! if MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL ! MATRIX, AND THEN COMPUTES THE SOLUTION. ! if MITER IS 4 OR 5, IT CALLS DGBSL. ! COMMUNICATION WITH DSLVS USES THE FOLLOWING VARIABLES.. ! WM = DOUBLE PRECISION WORK SPACE CONTAINING THE INVERSE DIAGONAL ! MATRIX if MITER ! IS 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. ! STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). ! WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. ! WM(1) = SQRT(UROUND) (NOT USED HERE), ! WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED if MITER = ! 3. ! IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING ! AT IWM(21), if MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS ! THE BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) if MITER IS ! 4 OR 5. ! X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION ! VECTOR ON OUTPUT, OF LENGTH N. ! TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. ! IER = OUTPUT FLAG (IN COMMON). IER = 0 if NO TROUBLE OCCURRED. ! IER = -1 if A SINGULAR MATRIX AROSE WITH MITER = 3. ! THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. !----------------------------------------------------------------------- ! BEGIN BLOCK PERMITTING ...EXITS TO 80 ! BEGIN BLOCK PERMITTING ...EXITS TO 60 !***FIRST EXECUTABLE STATEMENT DSLVS IER = 0 go to (10,10,20,70,70), MITER 10 CONTINUE call DGESL(WM(3),N,N,IWM(21),X,0) ! ......EXIT go to 80 ! 20 CONTINUE PHL0 = WM(2) HL0 = H*EL0 WM(2) = HL0 if (HL0 == PHL0) go to 40 R = HL0/PHL0 DO 30 I = 1, N DI = 1.0D0 - R*(1.0D0 - 1.0D0/WM(I+2)) ! .........EXIT if (ABS(DI) == 0.0D0) go to 60 WM(I+2) = 1.0D0/DI 30 CONTINUE 40 CONTINUE DO 50 I = 1, N X(I) = WM(I+2)*X(I) 50 CONTINUE ! ......EXIT go to 80 60 CONTINUE IER = -1 ! ...EXIT go to 80 ! 70 CONTINUE ML = IWM(1) MU = IWM(2) MEBAND = 2*ML + MU + 1 call DGBSL(WM(3),MEBAND,N,ML,MU,IWM(21),X,0) 80 CONTINUE return end subroutine DSMMI2 (N, B, X, IL, JL, L, DINV, IU, JU, U) ! !! DSMMI2 is the SLAP Backsolve for LDU Factorization of Normal Equations. ! ! To solve a system of the form (L*D*U)*(L*D*U)' X = B, ! where L is a unit lower triangular matrix, D is a diagonal ! matrix, and U is a unit upper triangular matrix and ' ! denotes transpose. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSMMI2-S, DSMMI2-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) ! DOUBLE PRECISION B(N), X(N), L(NL), DINV(N), U(NU) ! ! call DSMMI2( N, B, X, IL, JL, L, DINV, IU, JU, U ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right hand side. ! X :OUT Double Precision X(N). ! Solution of (L*D*U)(L*D*U)trans x = b. ! IL :IN Integer IL(NL). ! JL :IN Integer JL(NL). ! L :IN Double Precision L(NL). ! IL, JL, L contain the unit lower triangular factor of the ! incomplete decomposition of some matrix stored in SLAP Row ! format. The diagonal of ones *IS* stored. This structure ! can be set up by the DSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NL is the number of non-zeros in the L array.) ! DINV :IN Double Precision DINV(N). ! Inverse of the diagonal matrix D. ! IU :IN Integer IU(NU). ! JU :IN Integer JU(NU). ! U :IN Double Precision U(NU). ! IU, JU, U contain the unit upper triangular factor of the ! incomplete decomposition of some matrix stored in SLAP ! Column format. The diagonal of ones *IS* stored. This ! structure can be set up by the DSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NU is the number of non-zeros in the U array.) ! ! *Description: ! This routine is supplied with the SLAP package as a routine ! to perform the MSOLVE operation in the SBCGN iteration ! routine for the driver DSLUCN. It must be called via the ! SLAP MSOLVE calling sequence convention interface routine ! DSMMTI. ! **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** ! **** SLAP MSOLVE CALLING CONVENTION **** ! ! IL, JL, L should contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in SLAP ! Row format. IU, JU, U should contain the unit upper factor ! of the incomplete decomposition of the A matrix stored in ! SLAP Column format This ILU factorization can be computed by ! the DSILUS routine. The diagonals (which are all one's) are ! stored. ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the ! double precision array A. In other words, for each row in ! the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going across the row (except the ! diagonal) in order. The JA array holds the column index for ! each non-zero. The IA array holds the offsets into the JA, ! A arrays for the beginning of each row. That is, ! JA(IA(IROW)),A(IA(IROW)) are the first elements of the IROW- ! th row in JA and A, and JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! are the last elements of the IROW-th row. Note that we ! always have IA(N+1) = NELT+1, where N is the number of rows ! in the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format the "inner loops" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! !***SEE ALSO DSILUS !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSMMI2 ! .. Scalar Arguments .. INTEGER N ! .. Array Arguments .. DOUBLE PRECISION B(N), DINV(N), L(*), U(N), X(N) INTEGER IL(*), IU(*), JL(*), JU(*) ! .. Local Scalars .. INTEGER I, ICOL, IROW, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT DSMMI2 ! ! Solve L*Y = B, storing result in X, L stored by rows. ! DO 10 I = 1, N X(I) = B(I) 10 CONTINUE DO 30 IROW = 2, N JBGN = IL(IROW) JEND = IL(IROW+1)-1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ ASSOC !VD$ NODEPCHK DO 20 J = JBGN, JEND X(IROW) = X(IROW) - L(J)*X(JL(J)) 20 CONTINUE ENDIF 30 CONTINUE ! ! Solve D*Z = Y, storing result in X. DO 40 I=1,N X(I) = X(I)*DINV(I) 40 CONTINUE ! ! Solve U*X = Z, U stored by columns. DO 60 ICOL = N, 2, -1 JBGN = JU(ICOL) JEND = JU(ICOL+1)-1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 50 J = JBGN, JEND X(IU(J)) = X(IU(J)) - U(J)*X(ICOL) 50 CONTINUE ENDIF 60 CONTINUE ! ! Solve U'*Y = X, storing result in X, U stored by columns. DO 80 IROW = 2, N JBGN = JU(IROW) JEND = JU(IROW+1) - 1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ ASSOC !VD$ NODEPCHK DO 70 J = JBGN, JEND X(IROW) = X(IROW) - U(J)*X(IU(J)) 70 CONTINUE ENDIF 80 CONTINUE ! ! Solve D*Z = Y, storing result in X. DO 90 I = 1, N X(I) = X(I)*DINV(I) 90 CONTINUE ! ! Solve L'*X = Z, L stored by rows. DO 110 ICOL = N, 2, -1 JBGN = IL(ICOL) JEND = IL(ICOL+1) - 1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 100 J = JBGN, JEND X(JL(J)) = X(JL(J)) - L(J)*X(ICOL) 100 CONTINUE ENDIF 110 CONTINUE ! return !------------- LAST LINE OF DSMMI2 FOLLOWS ---------------------------- end subroutine DSMMTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! DSMMTI is the SLAP MSOLVE for LDU Factorization of Normal Equations. ! ! This routine acts as an interface between the SLAP generic ! MMTSLV calling convention and the routine that actually ! computes inverse[(LDU)*(LDU)'] B = X. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE DOUBLE PRECISION (SSMMTI-S, DSMMTI-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! It is assumed that RWORK and IWORK have initialized with ! the information required for DSMMI2: ! IWORK(1) = Starting location of IL in IWORK. ! IWORK(2) = Starting location of JL in IWORK. ! IWORK(3) = Starting location of IU in IWORK. ! IWORK(4) = Starting location of JU in IWORK. ! IWORK(5) = Starting location of L in RWORK. ! IWORK(6) = Starting location of DINV in RWORK. ! IWORK(7) = Starting location of U in RWORK. ! See the DESCRIPTION of DSMMI2 for details. !***REFERENCES (NONE) !***ROUTINES CALLED DSMMI2 !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSMMTI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU ! .. External Subroutines .. EXTERNAL DSMMI2 !***FIRST EXECUTABLE STATEMENT DSMMTI ! ! Pull out the locations of the arrays holding the ILU ! factorization. ! LOCIL = IWORK(1) LOCJL = IWORK(2) LOCIU = IWORK(3) LOCJU = IWORK(4) LOCL = IWORK(5) LOCDIN = IWORK(6) LOCU = IWORK(7) ! call DSMMI2(N, B, X, IWORK(LOCIL), IWORK(LOCJL), & RWORK(LOCL), RWORK(LOCDIN), IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU)) ! return !------------- LAST LINE OF DSMMTI FOLLOWS ---------------------------- end subroutine DSMTV (N, X, Y, NELT, IA, JA, A, ISYM) ! !! DSMTV is the SLAP Column Format Sparse Matrix Transpose Vector Product. ! ! Routine to calculate the sparse matrix vector product: ! Y = A'*X, where ' denotes transpose. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (SSMTV-S, DSMTV-D) !***KEYWORDS MATRIX TRANSPOSE VECTOR MULTIPLY, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! DOUBLE PRECISION X(N), Y(N), A(NELT) ! ! call DSMTV(N, X, Y, NELT, IA, JA, A, ISYM ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! X :IN Double Precision X(N). ! The vector that should be multiplied by the transpose of ! the matrix. ! Y :OUT Double Precision Y(N). ! The product of the transpose of the matrix and the vector. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format the "inner loops" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! ! *Cautions: ! This routine assumes that the matrix A is stored in SLAP ! Column format. It does not check for this (for speed) and ! evil, ugly, ornery and nasty things will happen if the matrix ! data structure is, in fact, not SLAP Column. Beware of the ! wrong data structure! ! !***SEE ALSO DSMV !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSMTV ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), X(N), Y(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER I, IBGN, ICOL, IEND, IROW, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT DSMTV ! ! Zero out the result vector. ! DO 10 I = 1, N Y(I) = 0 10 CONTINUE ! ! Multiply by A-Transpose. ! A-Transpose is stored by rows... !VD$R NOCONCUR DO 30 IROW = 1, N IBGN = JA(IROW) IEND = JA(IROW+1)-1 !VD$ ASSOC DO 20 I = IBGN, IEND Y(IROW) = Y(IROW) + A(I)*X(IA(I)) 20 CONTINUE 30 CONTINUE ! if ( ISYM == 1 ) THEN ! ! The matrix is non-symmetric. Need to get the other half in... ! This loops assumes that the diagonal is the first entry in ! each column. ! DO 50 ICOL = 1, N JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN > JEND ) GOTO 50 !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 40 J = JBGN, JEND Y(IA(J)) = Y(IA(J)) + A(J)*X(ICOL) 40 CONTINUE 50 CONTINUE end if return !------------- LAST LINE OF DSMTV FOLLOWS ---------------------------- end subroutine DSMV (N, X, Y, NELT, IA, JA, A, ISYM) ! !! DSMV is the SLAP Column Format Sparse Matrix Vector Product. ! ! Routine to calculate the sparse matrix vector product: ! Y = A*X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (SSMV-S, DSMV-D) !***KEYWORDS MATRIX VECTOR MULTIPLY, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! DOUBLE PRECISION X(N), Y(N), A(NELT) ! ! call DSMV(N, X, Y, NELT, IA, JA, A, ISYM ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! X :IN Double Precision X(N). ! The vector that should be multiplied by the matrix. ! Y :OUT Double Precision Y(N). ! The product of the matrix and the vector. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! double precision array A. In other words, for each column ! in the matrix put the diagonal entry in A. Then put in the ! other non-zero elements going down the column (except the ! diagonal) in order. The IA array holds the row index for ! each non-zero. The JA array holds the offsets into the IA, ! A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) points to the beginning of the ! ICOL-th column in IA and A. IA(JA(ICOL+1)-1), ! A(JA(ICOL+1)-1) points to the end of the ICOL-th column. ! Note that we always have JA(N+1) = NELT+1, where N is the ! number of columns in the matrix and NELT is the number of ! non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format the "inner loops" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! ! *Cautions: ! This routine assumes that the matrix A is stored in SLAP ! Column format. It does not check for this (for speed) and ! evil, ugly, ornery and nasty things will happen if the matrix ! data structure is, in fact, not SLAP Column. Beware of the ! wrong data structure! ! !***SEE ALSO DSMTV !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DSMV ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), X(N), Y(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER I, IBGN, ICOL, IEND, IROW, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT DSMV ! ! Zero out the result vector. ! DO 10 I = 1, N Y(I) = 0 10 CONTINUE ! ! Multiply by A. ! !VD$R NOCONCUR DO 30 ICOL = 1, N IBGN = JA(ICOL) IEND = JA(ICOL+1)-1 !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 20 I = IBGN, IEND Y(IA(I)) = Y(IA(I)) + A(I)*X(ICOL) 20 CONTINUE 30 CONTINUE ! if ( ISYM == 1 ) THEN ! ! The matrix is non-symmetric. Need to get the other half in... ! This loops assumes that the diagonal is the first entry in ! each column. ! DO 50 IROW = 1, N JBGN = JA(IROW)+1 JEND = JA(IROW+1)-1 if ( JBGN > JEND ) GOTO 50 DO 40 J = JBGN, JEND Y(IROW) = Y(IROW) + A(J)*X(IA(J)) 40 CONTINUE 50 CONTINUE end if return !------------- LAST LINE OF DSMV FOLLOWS ---------------------------- end subroutine DSORT (DX, DY, N, KFLAG) ! !! DSORT sorts an array and optionally make the same interchanges in ... ! an auxiliary array. ! ! The array may be sorted in increasing ! or decreasing order. A slightly modified QUICKSORT ! algorithm is used. ! !***LIBRARY SLATEC !***CATEGORY N6A2B !***TYPE DOUBLE PRECISION (SSORT-S, DSORT-D, ISORT-I) !***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING !***AUTHOR Jones, R. E., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! DSORT sorts array DX and optionally makes the same interchanges in ! array DY. The array DX may be sorted in increasing order or ! decreasing order. A slightly modified quicksort algorithm is used. ! ! Description of Parameters ! DX - array of values to be sorted (usually abscissas) ! DY - array to be (optionally) carried along ! N - number of values in array DX to be sorted ! KFLAG - control parameter ! = 2 means sort DX in increasing order and carry DY along. ! = 1 means sort DX in increasing order (ignoring DY) ! = -1 means sort DX in decreasing order (ignoring DY) ! = -2 means sort DX in decreasing order and carry DY along. ! !***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm ! for sorting with minimal storage, Communications of ! the ACM, 12, 3 (1969), pp. 185-187. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 761101 DATE WRITTEN ! 761118 Modified to use the Singleton quicksort algorithm. (JAW) ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced statement labels. (WRB) ! 891024 Changed category. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 901012 Declared all variables; changed X,Y to DX,DY; changed ! code to parallel SSORT. (M. McClain) ! 920501 Reformatted the REFERENCES section. (DWL, WRB) ! 920519 Clarified error messages. (DWL) ! 920801 Declarations section rebuilt and code restructured to use ! IF-THEN-ELSE-ENDIF. (RWC, WRB) !***END PROLOGUE DSORT ! .. Scalar Arguments .. INTEGER KFLAG, N ! .. Array Arguments .. DOUBLE PRECISION DX(*), DY(*) ! .. Local Scalars .. DOUBLE PRECISION R, T, TT, TTY, TY INTEGER I, IJ, J, K, KK, L, M, NN ! .. Local Arrays .. INTEGER IL(21), IU(21) ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, INT !***FIRST EXECUTABLE STATEMENT DSORT NN = N if (NN < 1) THEN call XERMSG ('SLATEC', 'DSORT', & 'The number of values to be sorted is not positive.', 1, 1) return end if ! KK = ABS(KFLAG) if (KK /= 1 .AND. KK /= 2) THEN call XERMSG ('SLATEC', 'DSORT', & 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, & 1) return end if ! ! Alter array DX to get decreasing order if needed ! if (KFLAG <= -1) THEN DO 10 I=1,NN DX(I) = -DX(I) 10 CONTINUE end if ! if (KK == 2) go to 100 ! ! Sort DX only ! M = 1 I = 1 J = NN R = 0.375D0 ! 20 if (I == J) go to 60 if (R <= 0.5898437D0) THEN R = R+3.90625D-2 ELSE R = R-0.21875D0 end if ! 30 K = I ! ! Select a central element of the array and save it in location T ! IJ = I + INT((J-I)*R) T = DX(IJ) ! ! If first element of array is greater than T, interchange with T ! if (DX(I) > T) THEN DX(IJ) = DX(I) DX(I) = T T = DX(IJ) end if L = J ! ! If last element of array is less than than T, interchange with T ! if (DX(J) < T) THEN DX(IJ) = DX(J) DX(J) = T T = DX(IJ) ! ! If first element of array is greater than T, interchange with T ! if (DX(I) > T) THEN DX(IJ) = DX(I) DX(I) = T T = DX(IJ) ENDIF end if ! ! Find an element in the second half of the array which is smaller ! than T ! 40 L = L-1 if (DX(L) > T) go to 40 ! ! Find an element in the first half of the array which is greater ! than T ! 50 K = K+1 if (DX(K) < T) go to 50 ! ! Interchange these elements ! if (K <= L) THEN TT = DX(L) DX(L) = DX(K) DX(K) = TT go to 40 end if ! ! Save upper and lower subscripts of the array yet to be sorted ! if (L-I > J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 70 ! ! Begin again on another portion of the unsorted array ! 60 M = M-1 if (M == 0) go to 190 I = IL(M) J = IU(M) ! 70 if (J-I >= 1) go to 30 if (I == 1) go to 20 I = I-1 ! 80 I = I+1 if (I == J) go to 60 T = DX(I+1) if (DX(I) <= T) go to 80 K = I ! 90 DX(K+1) = DX(K) K = K-1 if (T < DX(K)) go to 90 DX(K+1) = T go to 80 ! ! Sort DX and carry DY along ! 100 M = 1 I = 1 J = NN R = 0.375D0 ! 110 if (I == J) go to 150 if (R <= 0.5898437D0) THEN R = R+3.90625D-2 ELSE R = R-0.21875D0 end if ! 120 K = I ! ! Select a central element of the array and save it in location T ! IJ = I + INT((J-I)*R) T = DX(IJ) TY = DY(IJ) ! ! If first element of array is greater than T, interchange with T ! if (DX(I) > T) THEN DX(IJ) = DX(I) DX(I) = T T = DX(IJ) DY(IJ) = DY(I) DY(I) = TY TY = DY(IJ) end if L = J ! ! If last element of array is less than T, interchange with T ! if (DX(J) < T) THEN DX(IJ) = DX(J) DX(J) = T T = DX(IJ) DY(IJ) = DY(J) DY(J) = TY TY = DY(IJ) ! ! If first element of array is greater than T, interchange with T ! if (DX(I) > T) THEN DX(IJ) = DX(I) DX(I) = T T = DX(IJ) DY(IJ) = DY(I) DY(I) = TY TY = DY(IJ) ENDIF end if ! ! Find an element in the second half of the array which is smaller ! than T ! 130 L = L-1 if (DX(L) > T) go to 130 ! ! Find an element in the first half of the array which is greater ! than T ! 140 K = K+1 if (DX(K) < T) go to 140 ! ! Interchange these elements ! if (K <= L) THEN TT = DX(L) DX(L) = DX(K) DX(K) = TT TTY = DY(L) DY(L) = DY(K) DY(K) = TTY go to 130 end if ! ! Save upper and lower subscripts of the array yet to be sorted ! if (L-I > J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 160 ! ! Begin again on another portion of the unsorted array ! 150 M = M-1 if (M == 0) go to 190 I = IL(M) J = IU(M) ! 160 if (J-I >= 1) go to 120 if (I == 1) go to 110 I = I-1 ! 170 I = I+1 if (I == J) go to 150 T = DX(I+1) TY = DY(I+1) if (DX(I) <= T) go to 170 K = I ! 180 DX(K+1) = DX(K) DY(K+1) = DY(K) K = K-1 if (T < DX(K)) go to 180 DX(K+1) = T DY(K+1) = TY go to 170 ! ! Clean up ! 190 if (KFLAG <= -1) THEN DO 200 I=1,NN DX(I) = -DX(I) 200 CONTINUE end if return end subroutine DSOSEQ (FNC, N, S, RTOLX, ATOLX, TOLF, IFLAG, MXIT, & NCJS, NSRRC, NSRI, IPRINT, FMAX, C, NC, B, P, TEMP, X, Y, FAC, & IS) ! !! DSOSEQ is subsidiary to DSOS ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SOSEQS-S, DSOSEQ-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DSOSEQ solves a system of N simultaneous nonlinear equations. ! See the comments in the interfacing routine DSOS for a more ! detailed description of some of the items in the calling list. ! ! ********************************************************************** ! -Input- ! ! FNC- Function subprogram which evaluates the equations ! N -number of equations ! S -Solution vector of initial guesses ! RTOLX-Relative error tolerance on solution components ! ATOLX-Absolute error tolerance on solution components ! TOLF-Residual error tolerance ! MXIT-Maximum number of allowable iterations. ! NCJS-Maximum number of consecutive iterative steps to perform ! using the same triangular Jacobian matrix approximation. ! NSRRC-Number of consecutive iterative steps for which the ! limiting precision accuracy test must be satisfied ! before the routine exits with IFLAG=4. ! NSRI-Number of consecutive iterative steps for which the ! diverging condition test must be satisfied before ! the routine exits with IFLAG=7. ! IPRINT-Internal printing parameter. You must set IPRINT=-1 if you ! want the intermediate solution iterates and a residual norm ! to be printed. ! C -Internal work array, dimensioned at least N*(N+1)/2. ! NC -Dimension of C array. NC >= N*(N+1)/2. ! B -Internal work array, dimensioned N. ! P -Internal work array, dimensioned N. ! TEMP-Internal work array, dimensioned N. ! X -Internal work array, dimensioned N. ! Y -Internal work array, dimensioned N. ! FAC -Internal work array, dimensioned N. ! IS -Internal work array, dimensioned N. ! ! -Output- ! S -Solution vector ! IFLAG-Status indicator flag ! MXIT-The actual number of iterations performed ! FMAX-Residual norm ! C -Upper unit triangular matrix which approximates the ! forward triangularization of the full Jacobian matrix. ! Stored in a vector with dimension at least N*(N+1)/2. ! B -Contains the residuals (function values) divided ! by the corresponding components of the P vector ! P -Array used to store the partial derivatives. After ! each iteration P(K) contains the maximal derivative ! occurring in the K-th reduced equation. ! TEMP-Array used to store the previous solution iterate. ! X -Solution vector. Contains the values achieved on the ! last iteration loop upon exit from DSOS. ! Y -Array containing the solution increments. ! FAC -Array containing factors used in computing numerical ! derivatives. ! IS -Records the pivotal information (column interchanges) ! ! ********************************************************************** ! *** Three machine dependent parameters appear in this subroutine. ! ! *** The smallest positive magnitude, zero, is defined by the function ! *** routine D1MACH(1). ! ! *** URO, the computer unit roundoff value, is defined by D1MACH(3) for ! *** machines that round or D1MACH(4) for machines that truncate. ! *** URO is the smallest positive number such that 1.+URO > 1. ! ! *** The output tape unit number, LOUN, is defined by the function ! *** I1MACH(2). ! ********************************************************************** ! !***SEE ALSO DSOS !***ROUTINES CALLED D1MACH, DSOSSL, I1MACH !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DSOSEQ ! ! INTEGER I1MACH DOUBLE PRECISION D1MACH INTEGER IC, ICR, IFLAG, IPRINT, IS(*), ISJ, ISV, IT, ITEM, ITRY, & J, JK, JS, K, KD, KJ, KK, KM1, KN, KSV, L, LOUN, LS, M, MIT, & MM, MXIT, N, NC, NCJS, NP1, NSRI, NSRRC DOUBLE PRECISION ATOLX, B(*), C(*), CSV, F, FAC(*), FACT, FDIF, & FMAX, FMIN, FMXS, FN1, FN2, FNC, FP, H, HX, P(*), PMAX, RE, & RTOLX, S(*), SRURO, TEMP(*), TEST, TOLF, URO, X(*), XNORM, & Y(*), YJ, YN1, YN2, YN3, YNORM, YNS, ZERO ! ! BEGIN BLOCK PERMITTING ...EXITS TO 430 ! BEGIN BLOCK PERMITTING ...EXITS TO 410 ! BEGIN BLOCK PERMITTING ...EXITS TO 390 !***FIRST EXECUTABLE STATEMENT DSOSEQ URO = D1MACH(4) LOUN = I1MACH(2) ZERO = D1MACH(1) RE = MAX(RTOLX,URO) SRURO = SQRT(URO) ! IFLAG = 0 NP1 = N + 1 ICR = 0 IC = 0 ITRY = NCJS YN1 = 0.0D0 YN2 = 0.0D0 YN3 = 0.0D0 YNS = 0.0D0 MIT = 0 FN1 = 0.0D0 FN2 = 0.0D0 FMXS = 0.0D0 ! ! INITIALIZE THE INTERCHANGE (PIVOTING) VECTOR AND ! SAVE THE CURRENT SOLUTION APPROXIMATION FOR FUTURE USE. ! DO 10 K = 1, N IS(K) = K X(K) = S(K) TEMP(K) = X(K) 10 CONTINUE ! ! ! ********************************************************* ! **** BEGIN PRINCIPAL ITERATION LOOP **** ! ********************************************************* ! DO 380 M = 1, MXIT ! BEGIN BLOCK PERMITTING ...EXITS TO 350 ! BEGIN BLOCK PERMITTING ...EXITS TO 240 ! DO 20 K = 1, N FAC(K) = SRURO 20 CONTINUE ! 30 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 180 KN = 1 FMAX = 0.0D0 ! ! ! ******** BEGIN SUBITERATION LOOP DEFINING ! THE LINEARIZATION OF EACH ******** ! EQUATION WHICH RESULTS IN THE CONSTRUCTION ! OF AN UPPER ******** TRIANGULAR MATRIX ! APPROXIMATING THE FORWARD ******** ! TRIANGULARIZATION OF THE FULL JACOBIAN ! MATRIX ! DO 170 K = 1, N ! BEGIN BLOCK PERMITTING ...EXITS TO 160 KM1 = K - 1 ! ! BACK-SOLVE A TRIANGULAR LINEAR ! SYSTEM OBTAINING IMPROVED SOLUTION ! VALUES FOR K-1 OF THE VARIABLES FROM ! THE FIRST K-1 EQUATIONS. THESE ! VARIABLES ARE THEN ELIMINATED FROM ! THE K-TH EQUATION. ! if (KM1 == 0) go to 50 call DSOSSL(K,N,KM1,Y,C,B,KN) DO 40 J = 1, KM1 JS = IS(J) X(JS) = TEMP(JS) + Y(J) 40 CONTINUE 50 CONTINUE ! ! ! EVALUATE THE K-TH EQUATION AND THE ! INTERMEDIATE COMPUTATION FOR THE MAX ! NORM OF THE RESIDUAL VECTOR. ! F = FNC(X,K) FMAX = MAX(FMAX,ABS(F)) ! ! if WE WISH TO PERFORM SEVERAL ! ITERATIONS USING A FIXED ! FACTORIZATION OF AN APPROXIMATE ! JACOBIAN,WE NEED ONLY UPDATE THE ! CONSTANT VECTOR. ! ! ...EXIT if (ITRY < NCJS) go to 160 ! ! IT = 0 ! ! COMPUTE PARTIAL DERIVATIVES THAT ARE ! REQUIRED IN THE LINEARIZATION OF THE ! K-TH REDUCED EQUATION ! DO 90 J = K, N ITEM = IS(J) HX = X(ITEM) H = FAC(ITEM)*HX if (ABS(H) <= ZERO) & H = FAC(ITEM) X(ITEM) = HX + H if (KM1 == 0) go to 70 Y(J) = H call DSOSSL(K,N,J,Y,C,B,KN) DO 60 L = 1, KM1 LS = IS(L) X(LS) = TEMP(LS) + Y(L) 60 CONTINUE 70 CONTINUE FP = FNC(X,K) X(ITEM) = HX FDIF = FP - F if (ABS(FDIF) > URO*ABS(F)) & go to 80 FDIF = 0.0D0 IT = IT + 1 80 CONTINUE P(J) = FDIF/H 90 CONTINUE ! if (IT <= (N - K)) go to 110 ! ! ALL COMPUTED PARTIAL DERIVATIVES ! OF THE K-TH EQUATION ARE ! EFFECTIVELY ZERO.TRY LARGER ! PERTURBATIONS OF THE INDEPENDENT ! VARIABLES. ! DO 100 J = K, N ISJ = IS(J) FACT = 100.0D0*FAC(ISJ) ! ..............................EXIT if (FACT > 1.0D10) & go to 390 FAC(ISJ) = FACT 100 CONTINUE ! ............EXIT go to 180 110 CONTINUE ! ! ...EXIT if (K == N) go to 160 ! ! ACHIEVE A PIVOTING EFFECT BY ! CHOOSING THE MAXIMAL DERIVATIVE ! ELEMENT ! PMAX = 0.0D0 DO 130 J = K, N TEST = ABS(P(J)) if (TEST <= PMAX) go to 120 PMAX = TEST ISV = J 120 CONTINUE 130 CONTINUE ! ........................EXIT if (PMAX == 0.0D0) go to 390 ! ! SET UP THE COEFFICIENTS FOR THE K-TH ! ROW OF THE TRIANGULAR LINEAR SYSTEM ! AND SAVE THE PARTIAL DERIVATIVE OF ! LARGEST MAGNITUDE ! PMAX = P(ISV) KK = KN DO 140 J = K, N if (J /= ISV) & C(KK) = -P(J)/PMAX KK = KK + 1 140 CONTINUE P(K) = PMAX ! ! ! ...EXIT if (ISV == K) go to 160 ! ! INTERCHANGE THE TWO COLUMNS OF C ! DETERMINED BY THE PIVOTAL STRATEGY ! KSV = IS(K) IS(K) = IS(ISV) IS(ISV) = KSV ! KD = ISV - K KJ = K DO 150 J = 1, K CSV = C(KJ) JK = KJ + KD C(KJ) = C(JK) C(JK) = CSV KJ = KJ + N - J 150 CONTINUE 160 CONTINUE ! KN = KN + NP1 - K ! ! STORE THE COMPONENTS FOR THE CONSTANT ! VECTOR ! B(K) = -F/P(K) ! 170 CONTINUE ! ......EXIT go to 190 180 CONTINUE go to 30 190 CONTINUE ! ! ******** ! ******** END OF LOOP CREATING THE TRIANGULAR ! LINEARIZATION MATRIX ! ******** ! ! ! SOLVE THE RESULTING TRIANGULAR SYSTEM FOR A NEW ! SOLUTION APPROXIMATION AND OBTAIN THE SOLUTION ! INCREMENT NORM. ! KN = KN - 1 Y(N) = B(N) if (N > 1) call DSOSSL(N,N,N,Y,C,B,KN) XNORM = 0.0D0 YNORM = 0.0D0 DO 200 J = 1, N YJ = Y(J) YNORM = MAX(YNORM,ABS(YJ)) JS = IS(J) X(JS) = TEMP(JS) + YJ XNORM = MAX(XNORM,ABS(X(JS))) 200 CONTINUE ! ! ! PRINT INTERMEDIATE SOLUTION ITERATES AND ! RESIDUAL NORM if DESIRED ! if (IPRINT /= (-1)) go to 220 MM = M - 1 WRITE (LOUN,210) FMAX,MM,(X(J), J = 1, N) 210 FORMAT ('0RESIDUAL NORM =', D9.2, / 1X, & 'SOLUTION ITERATE (', I3, ')', / & (1X, 5D26.14)) 220 CONTINUE ! ! TEST FOR CONVERGENCE TO A SOLUTION (RELATIVE ! AND/OR ABSOLUTE ERROR COMPARISON ON SUCCESSIVE ! APPROXIMATIONS OF EACH SOLUTION VARIABLE) ! DO 230 J = 1, N JS = IS(J) ! ......EXIT if (ABS(Y(J)) > RE*ABS(X(JS)) + ATOLX) & go to 240 230 CONTINUE if (FMAX <= FMXS) IFLAG = 1 240 CONTINUE ! ! TEST FOR CONVERGENCE TO A SOLUTION BASED ON ! RESIDUALS ! if (FMAX <= TOLF) IFLAG = IFLAG + 2 ! ............EXIT if (IFLAG > 0) go to 410 ! ! if (M > 1) go to 250 FMIN = FMAX go to 330 250 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 320 ! ! SAVE SOLUTION HAVING MINIMUM RESIDUAL NORM. ! if (FMAX >= FMIN) go to 270 MIT = M + 1 YN1 = YNORM YN2 = YNS FN1 = FMXS FMIN = FMAX DO 260 J = 1, N S(J) = X(J) 260 CONTINUE IC = 0 270 CONTINUE ! ! TEST FOR LIMITING PRECISION CONVERGENCE. VERY ! SLOWLY CONVERGENT PROBLEMS MAY ALSO BE ! DETECTED. ! if (YNORM > SRURO*XNORM) go to 290 if (FMAX < 0.2D0*FMXS & .OR. FMAX > 5.0D0*FMXS) go to 290 if (YNORM < 0.2D0*YNS & .OR. YNORM > 5.0D0*YNS) go to 290 ICR = ICR + 1 if (ICR >= NSRRC) go to 280 IC = 0 ! .........EXIT go to 320 280 CONTINUE IFLAG = 4 FMAX = FMIN ! ........................EXIT go to 430 290 CONTINUE ICR = 0 ! ! TEST FOR DIVERGENCE OF THE ITERATIVE SCHEME. ! if (YNORM > 2.0D0*YNS & .OR. FMAX > 2.0D0*FMXS) go to 300 IC = 0 go to 310 300 CONTINUE IC = IC + 1 ! ......EXIT if (IC < NSRI) go to 320 IFLAG = 7 ! .....................EXIT go to 410 310 CONTINUE 320 CONTINUE 330 CONTINUE ! ! CHECK TO SEE if NEXT ITERATION CAN USE THE OLD ! JACOBIAN FACTORIZATION ! ITRY = ITRY - 1 if (ITRY == 0) go to 340 if (20.0D0*YNORM > XNORM) go to 340 if (YNORM > 2.0D0*YNS) go to 340 ! ......EXIT if (FMAX < 2.0D0*FMXS) go to 350 340 CONTINUE ITRY = NCJS 350 CONTINUE ! ! SAVE THE CURRENT SOLUTION APPROXIMATION AND THE ! RESIDUAL AND SOLUTION INCREMENT NORMS FOR USE IN THE ! NEXT ITERATION. ! DO 360 J = 1, N TEMP(J) = X(J) 360 CONTINUE if (M /= MIT) go to 370 FN2 = FMAX YN3 = YNORM 370 CONTINUE FMXS = FMAX YNS = YNORM ! ! 380 CONTINUE ! ! ********************************************************* ! **** END OF PRINCIPAL ITERATION LOOP **** ! ********************************************************* ! ! ! TOO MANY ITERATIONS, CONVERGENCE WAS NOT ACHIEVED. M = MXIT IFLAG = 5 if (YN1 > 10.0D0*YN2 .OR. YN3 > 10.0D0*YN1) & IFLAG = 6 if (FN1 > 5.0D0*FMIN .OR. FN2 > 5.0D0*FMIN) & IFLAG = 6 if (FMAX > 5.0D0*FMIN) IFLAG = 6 ! ......EXIT go to 410 390 CONTINUE ! ! ! A JACOBIAN-RELATED MATRIX IS EFFECTIVELY SINGULAR. IFLAG = 8 DO 400 J = 1, N S(J) = TEMP(J) 400 CONTINUE ! ......EXIT go to 430 410 CONTINUE ! ! DO 420 J = 1, N S(J) = X(J) 420 CONTINUE 430 CONTINUE ! ! MXIT = M return end subroutine DSOS (FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, RW, LRW, & IW, LIW) ! !! DSOS solves a square system of nonlinear equations. ! !***LIBRARY SLATEC !***CATEGORY F2A !***TYPE DOUBLE PRECISION (SOS-S, DSOS-D) !***KEYWORDS BROWN'S METHOD, NEWTON'S METHOD, NONLINEAR EQUATIONS, ! ROOTS, SOLUTIONS !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DSOS solves a system of NEQ simultaneous nonlinear equations in ! NEQ unknowns. That is, it solves the problem F(X)=0 ! where X is a vector with components X(1),...,X(NEQ) and F ! is a vector of nonlinear functions. Each equation is of the form ! ! F (X(1),...,X(NEQ))=0 for K=1,...,NEQ. ! K ! ! The algorithm is based on an iterative method which is a ! variation of Newton's method using Gaussian elimination ! in a manner similar to the Gauss-Seidel process. Convergence ! is roughly quadratic. All partial derivatives required by ! the algorithm are approximated by first difference quotients. ! The convergence behavior of this code is affected by the ! ordering of the equations, and it is advantageous to place linear ! and mildly nonlinear equations first in the ordering. ! ! Actually, DSOS is merely an interfacing routine for ! calling subroutine DSOSEQ which embodies the solution ! algorithm. The purpose of this is to add greater ! flexibility and ease of use for the prospective user. ! ! DSOSEQ calls the accompanying routine DSOSSL which solves special ! triangular linear systems by back-substitution. ! ! The user must supply a function subprogram which evaluates the ! K-th equation only (K specified by DSOSEQ) for each call ! to the subprogram. ! ! DSOS represents an implementation of the mathematical algorithm ! described in the references below. It is a modification of the ! code SOSNLE written by H. A. Watts in 1973. ! ! ********************************************************************** ! -Input- ! ! FNC -Name of the function program which evaluates the equations. ! This name must be in an EXTERNAL statement in the calling ! program. The user must supply FNC in the form FNC(X,K), ! where X is the solution vector (which must be dimensioned ! in FNC) and FNC returns the value of the K-th function. ! ! NEQ -Number of equations to be solved. ! ! X -Solution vector. Initial guesses must be supplied. ! ! RTOLX -Relative error tolerance used in the convergence criteria. ! Each solution component X(I) is checked by an accuracy test ! of the form ABS(X(I)-XOLD(I)) <= RTOLX*ABS(X(I))+ATOLX, ! where XOLD(I) represents the previous iteration value. ! RTOLX must be non-negative. ! ! ATOLX -Absolute error tolerance used in the convergence criteria. ! ATOLX must be non-negative. If the user suspects some ! solution component may be zero, he should set ATOLX to an ! appropriate (depends on the scale of the remaining variables) ! positive value for better efficiency. ! ! TOLF -Residual error tolerance used in the convergence criteria. ! Convergence will be indicated if all residuals (values of the ! functions or equations) are not bigger than TOLF in ! magnitude. Note that extreme care must be given in assigning ! an appropriate value for TOLF because this convergence test ! is dependent on the scaling of the equations. An ! inappropriate value can cause premature termination of the ! iteration process. ! ! IFLAG -Optional input indicator. You must set IFLAG=-1 if you ! want to use any of the optional input items listed below. ! Otherwise set it to zero. ! ! RW -A DOUBLE PRECISION work array which is split apart by DSOS ! and used internally by DSOSEQ. ! ! LRW -Dimension of the RW array. LRW must be at least ! 1 + 6*NEQ + NEQ*(NEQ+1)/2 ! ! IW -An INTEGER work array which is split apart by DSOS and used ! internally by DSOSEQ. ! ! LIW -Dimension of the IW array. LIW must be at least 3 + NEQ. ! ! -Optional Input- ! ! IW(1) -Internal printing parameter. You must set IW(1)=-1 if ! you want the intermediate solution iterates to be printed. ! ! IW(2) -Iteration limit. The maximum number of allowable ! iterations can be specified, if desired. To override the ! default value of 50, set IW(2) to the number wanted. ! ! Remember, if you tell the code that you are using one of the ! options (by setting IFLAG=-1), you must supply values ! for both IW(1) and IW(2). ! ! ********************************************************************** ! -Output- ! ! X -Solution vector. ! ! IFLAG -Status indicator ! ! *** Convergence to a Solution *** ! ! 1 Means satisfactory convergence to a solution was achieved. ! Each solution component X(I) satisfies the error tolerance ! test ABS(X(I)-XOLD(I)) <= RTOLX*ABS(X(I))+ATOLX. ! ! 2 Means procedure converged to a solution such that all ! residuals are at most TOLF in magnitude, ! ABS(FNC(X,I)) <= TOLF. ! ! 3 Means that conditions for both IFLAG=1 and IFLAG=2 hold. ! ! 4 Means possible numerical convergence. Behavior indicates ! limiting precision calculations as a result of user asking ! for too much accuracy or else convergence is very slow. ! Residual norms and solution increment norms have ! remained roughly constant over several consecutive ! iterations. ! ! *** Task Interrupted *** ! ! 5 Means the allowable number of iterations has been met ! without obtaining a solution to the specified accuracy. ! Very slow convergence may be indicated. Examine the ! approximate solution returned and see if the error ! tolerances seem appropriate. ! ! 6 Means the allowable number of iterations has been met and ! the iterative process does not appear to be converging. ! A local minimum may have been encountered or there may be ! limiting precision difficulties. ! ! 7 Means that the iterative scheme appears to be diverging. ! Residual norms and solution increment norms have ! increased over several consecutive iterations. ! ! *** Task Cannot Be Continued *** ! ! 8 Means that a Jacobian-related matrix was singular. ! ! 9 Means improper input parameters. ! ! *** IFLAG should be examined after each call to *** ! *** DSOS with the appropriate action being taken. *** ! ! ! RW(1) -Contains a norm of the residual. ! ! IW(3) -Contains the number of iterations used by the process. ! ! ********************************************************************** ! !***REFERENCES K. M. Brown, Solution of simultaneous nonlinear ! equations, Algorithm 316, Communications of the ! A.C.M. 10, (1967), pp. 728-729. ! K. M. Brown, A quadratically convergent Newton-like ! method based upon Gaussian elimination, SIAM Journal ! on Numerical Analysis 6, (1969), pp. 560-569. !***ROUTINES CALLED DSOSEQ, XERMSG !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls, change Prologue ! comments to agree with SOS. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSOS INTEGER IFLAG, INPFLG, IPRINT, IW(*), K1, K2, K3, K4, K5, K6, & LIW, LRW, MXIT, NC, NCJS, NEQ, NSRI, NSRRC DOUBLE PRECISION ATOLX, FNC, RTOLX, RW(*), TOLF, X(*) CHARACTER*8 XERN1 CHARACTER*16 XERN3, XERN4 EXTERNAL FNC !***FIRST EXECUTABLE STATEMENT DSOS INPFLG = IFLAG ! ! CHECK FOR VALID INPUT ! if (NEQ <= 0) THEN WRITE (XERN1, '(I8)') NEQ call XERMSG ('SLATEC', 'DSOS', 'THE NUMBER OF EQUATIONS ' // & 'MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // & 'CODE WITH NEQ = ' // XERN1, 1, 1) IFLAG = 9 end if ! if (RTOLX < 0.0D0 .OR. ATOLX < 0.0D0) THEN WRITE (XERN3, '(1PE15.6)') ATOLX WRITE (XERN4, '(1PE15.6)') RTOLX call XERMSG ('SLATEC', 'DSOS', 'THE ERROR TOLERANCES FOR ' // & 'THE SOLUTION ITERATES CANNOT BE NEGATIVE. YOU HAVE ' // & 'CALLED THE CODE WITH RTOLX = ' // XERN3 // & ' AND ATOLX = ' // XERN4,2, 1) IFLAG = 9 end if ! if (TOLF < 0.0D0) THEN WRITE (XERN3, '(1PE15.6)') TOLF call XERMSG ('SLATEC', 'DSOS', 'THE RESIDUAL ERROR ' // & 'TOLERANCE MUST BE NON-NEGATIVE. YOU HAVE CALLED THE ' // & 'CODE WITH TOLF = ' // XERN3, 3, 1) IFLAG = 9 end if ! IPRINT = 0 MXIT = 50 if (INPFLG == (-1)) THEN if (IW(1) == (-1)) IPRINT = -1 MXIT = IW(2) if (MXIT <= 0) THEN WRITE (XERN1, '(I8)') MXIT call XERMSG ('SLATEC', 'DSOS', 'YOU HAVE TOLD THE CODE ' // & 'TO USE OPTIONAL INPUT ITEMS BY SETTING IFLAG=-1. ' // & 'HOWEVER YOU HAVE CALLED THE CODE WITH THE MAXIMUM ' // & 'ALLOWABLE NUMBER OF ITERATIONS SET TO IW(2) = ' // & XERN1, 4, 1) IFLAG = 9 ENDIF end if ! NC = (NEQ*(NEQ+1))/2 if (LRW < 1 + 6*NEQ + NC) THEN WRITE (XERN1, '(I8)') LRW call XERMSG ('SLATEC', 'DSOS', 'DIMENSION OF THE RW ARRAY ' // & 'MUST BE AT LEAST 1 + 6*NEQ + NEQ*(NEQ+1)/2 . YOU HAVE ' // & 'CALLED THE CODE WITH LRW = ' // XERN1, 5, 1) IFLAG = 9 end if ! if (LIW < 3 + NEQ) THEN WRITE (XERN1, '(I8)') LIW call XERMSG ('SLATEC', 'DSOS', 'DIMENSION OF THE IW ARRAY ' // & 'MUST BE AT LEAST 3 + NEQ. YOU HAVE CALLED THE CODE ' // & 'WITH LIW = ' // XERN1, 6, 1) IFLAG = 9 end if ! if (IFLAG /= 9) THEN NCJS = 6 NSRRC = 4 NSRI = 5 ! K1 = NC + 2 K2 = K1 + NEQ K3 = K2 + NEQ K4 = K3 + NEQ K5 = K4 + NEQ K6 = K5 + NEQ ! call DSOSEQ(FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, MXIT, NCJS, & NSRRC, NSRI, IPRINT, RW(1), RW(2), NC, RW(K1), & RW(K2), RW(K3), RW(K4), RW(K5), RW(K6), IW(4)) ! IW(3) = MXIT end if return end subroutine DSOSSL (K, N, L, X, C, B, M) ! !! DSOSSL is subsidiary to DSOS. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SOSSOL-S, DSOSSL-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DSOSSL solves an upper triangular type of linear system by back ! substitution. ! ! The matrix C is upper trapezoidal and stored as a linear array by ! rows. The equations have been normalized so that the diagonal ! entries of C are understood to be unity. The off diagonal entries ! and the elements of the constant right hand side vector B have ! already been stored as the negatives of the corresponding equation ! values. ! With each call to DSOSSL a (K-1) by (K-1) triangular system is ! resolved. For L greater than K, column L of C is included in the ! right hand side vector. ! !***SEE ALSO DSOS !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DSOSSL ! ! INTEGER J, JKM, K, KJ, KM, KM1, KMM1, KN, L, LK, M, N, NP1 DOUBLE PRECISION B(*), C(*), X(*), XMAX ! !***FIRST EXECUTABLE STATEMENT DSOSSL NP1 = N + 1 KM1 = K - 1 LK = KM1 if (L == K) LK = K KN = M ! ! DO 40 KJ = 1, KM1 KMM1 = K - KJ KM = KMM1 + 1 XMAX = 0.0D0 KN = KN - NP1 + KMM1 if (KM > LK) go to 20 JKM = KN ! DO 10 J = KM, LK JKM = JKM + 1 XMAX = XMAX + C(JKM)*X(J) 10 CONTINUE 20 CONTINUE ! if (L <= K) go to 30 JKM = KN + L - KMM1 XMAX = XMAX + C(JKM)*X(L) 30 CONTINUE X(KMM1) = XMAX + B(KMM1) 40 CONTINUE ! return end subroutine DSPCO (AP, N, KPVT, RCOND, Z) ! !! DSPCO factors a real symmetric matrix stored in packed form ... ! by elimination with symmetric pivoting and estimates the ... ! condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE DOUBLE PRECISION (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, PACKED, SYMMETRIC !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DSPCO factors a double precision symmetric matrix stored in ! packed form by elimination with symmetric pivoting and estimates ! the condition of the matrix. ! ! if RCOND is not needed, DSPFA is slightly faster. ! To solve A*X = B , follow DSPCO by DSPSL. ! To compute INVERSE(A)*C , follow DSPCO by DSPSL. ! To compute INVERSE(A) , follow DSPCO by DSPDI. ! To compute DETERMINANT(A) , follow DSPCO by DSPDI. ! To compute INERTIA(A), follow DSPCO by DSPDI. ! ! On Entry ! ! AP DOUBLE PRECISION (N*(N+1)/2) ! the packed form of a symmetric matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! Output ! ! AP a block diagonal matrix and the multipliers which ! were used to obtain it stored in packed form. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND DOUBLE PRECISION ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z DOUBLE PRECISION(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a symmetric matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DASUM, DAXPY, DDOT, DSCAL, DSPFA !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSPCO INTEGER N,KPVT(*) DOUBLE PRECISION AP(*),Z(*) DOUBLE PRECISION RCOND ! 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 ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT DSPCO J1 = 1 DO 30 J = 1, N Z(J) = DASUM(J,AP(J1),1) IJ = J1 J1 = J1 + J JM1 = J - 1 if (JM1 < 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.0D0 DO 40 J = 1, N ANORM = MAX(ANORM,Z(J)) 40 CONTINUE ! ! FACTOR ! call DSPFA(AP,N,KPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE U*D*W = E ! EK = 1.0D0 DO 50 J = 1, N Z(J) = 0.0D0 50 CONTINUE K = N IK = (N*(N - 1))/2 60 if (K == 0) go to 120 KK = IK + K IKM1 = IK - (K - 1) KS = 1 if (KPVT(K) < 0) KS = 2 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE if (Z(K) /= 0.0D0) EK = SIGN(EK,Z(K)) Z(K) = Z(K) + EK call DAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) if (KS == 1) go to 80 if (Z(K-1) /= 0.0D0) EK = SIGN(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 == 2) go to 100 if (ABS(Z(K)) <= ABS(AP(KK))) go to 90 S = ABS(AP(KK))/ABS(Z(K)) call DSCAL(N,S,Z,1) EK = S*EK 90 CONTINUE if (AP(KK) /= 0.0D0) Z(K) = Z(K)/AP(KK) if (AP(KK) == 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 == 2) IK = IK - (K + 1) go to 60 120 CONTINUE S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) ! ! SOLVE TRANS(U)*Y = W ! K = 1 IK = 0 130 if (K > N) go to 160 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 150 Z(K) = Z(K) + DDOT(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K if (KS == 2) & Z(K+1) = Z(K+1) + DDOT(K-1,AP(IKP1+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE IK = IK + K if (KS == 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) ! YNORM = 1.0D0 ! ! SOLVE U*D*V = Y ! K = N IK = N*(N - 1)/2 170 if (K == 0) go to 230 KK = IK + K IKM1 = IK - (K - 1) KS = 1 if (KPVT(K) < 0) KS = 2 if (K == KS) go to 190 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == 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 == 2) call DAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) 190 CONTINUE if (KS == 2) go to 210 if (ABS(Z(K)) <= ABS(AP(KK))) go to 200 S = ABS(AP(KK))/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 200 CONTINUE if (AP(KK) /= 0.0D0) Z(K) = Z(K)/AP(KK) if (AP(KK) == 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 == 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 ! ! SOLVE TRANS(U)*Z = V ! K = 1 IK = 0 240 if (K > N) go to 270 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 260 Z(K) = Z(K) + DDOT(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K if (KS == 2) & Z(K+1) = Z(K+1) + DDOT(K-1,AP(IKP1+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE IK = IK + K if (KS == 2) IK = IK + (K + 1) K = K + KS go to 240 270 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0D0) RCOND = YNORM/ANORM if (ANORM == 0.0D0) RCOND = 0.0D0 return end subroutine DSPDI (AP, N, KPVT, DET, INERT, WORK, JOB) ! !! DSPDI computes the determinant, inertia, inverse of a real symmetric ... ! matrix stored in packed form using the factors from DSPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A, D3B1A !***TYPE DOUBLE PRECISION (SSPDI-S, DSPDI-D, CHPDI-C, CSPDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! PACKED, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! DSPDI computes the determinant, inertia and inverse ! of a double precision symmetric matrix using the factors from ! DSPFA, where the matrix is stored in packed form. ! ! On Entry ! ! AP DOUBLE PRECISION (N*(N+1)/2) ! the output from DSPFA. ! ! N INTEGER ! the order of the matrix A. ! ! KPVT INTEGER(N) ! the pivot vector from DSPFA. ! ! WORK DOUBLE PRECISION(N) ! work vector. Contents ignored. ! ! JOB INTEGER ! JOB has the decimal expansion ABC where ! if C /= 0, the inverse is computed, ! if B /= 0, the determinant is computed, ! if A /= 0, the inertia is computed. ! ! For example, JOB = 111 gives all three. ! ! On Return ! ! Variables not requested by JOB are not used. ! ! AP contains the upper triangle of the inverse of ! the original matrix, stored in packed form. ! The columns of the upper triangle are stored ! sequentially in a one-dimensional array. ! ! DET DOUBLE PRECISION(2) ! determinant of original matrix. ! DETERMINANT = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0. ! ! INERT INTEGER(3) ! the inertia of the original matrix. ! INERT(1) = number of positive eigenvalues. ! INERT(2) = number of negative eigenvalues. ! INERT(3) = number of zero eigenvalues. ! ! Error Condition ! ! A division by zero will occur if the inverse is requested ! and DSPCO has set RCOND == 0.0 ! or DSPFA has set INFO /= 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DCOPY, DDOT, DSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSPDI INTEGER N,JOB DOUBLE PRECISION AP(*),WORK(*) DOUBLE PRECISION DET(2) INTEGER KPVT(*),INERT(3) ! 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 !***FIRST EXECUTABLE STATEMENT DSPDI NOINV = MOD(JOB,10) == 0 NODET = MOD(JOB,100)/10 == 0 NOERT = MOD(JOB,1000)/100 == 0 ! 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) ! ! CHECK if 1 BY 1 ! if (KPVT(K) > 0) go to 50 ! ! 2 BY 2 BLOCK ! USE DET (D S) = (D/T * C - T) * T , T = ABS(S) ! (S C) ! TO AVOID UNDERFLOW/OVERFLOW TROUBLES. ! TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. ! if (T /= 0.0D0) 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.0D0 40 CONTINUE 50 CONTINUE ! if (NOERT) go to 60 if (D > 0.0D0) INERT(1) = INERT(1) + 1 if (D < 0.0D0) INERT(2) = INERT(2) + 1 if (D == 0.0D0) INERT(3) = INERT(3) + 1 60 CONTINUE ! if (NODET) go to 120 DET(1) = D*DET(1) if (DET(1) == 0.0D0) go to 110 70 if (ABS(DET(1)) >= 1.0D0) go to 80 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 go to 70 80 CONTINUE 90 if (ABS(DET(1)) < 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 ! ! COMPUTE INVERSE(A) ! if (NOINV) go to 270 K = 1 IK = 0 150 if (K > N) go to 260 KM1 = K - 1 KK = IK + K IKP1 = IK + K KKP1 = IKP1 + K if (KPVT(K) < 0) go to 180 ! ! 1 BY 1 ! AP(KK) = 1.0D0/AP(KK) if (KM1 < 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 ! ! 2 BY 2 ! T = ABS(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 < 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 ! ! SWAP ! KS = ABS(KPVT(K)) if (KS == 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 == 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 == 2) IK = IK + K + 1 K = K + KSTEP go to 150 260 CONTINUE 270 CONTINUE return end DOUBLE PRECISION FUNCTION DSPENC (X) ! !! DSPENC computes a form of Spence's integral due to K. Mitchell. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C5 !***TYPE DOUBLE PRECISION (SPENC-S, DSPENC-D) !***KEYWORDS FNLIB, SPECIAL FUNCTIONS, SPENCE'S INTEGRAL !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! DSPENC(X) calculates the double precision Spence's integral ! for double precision argument X. Spence's function defined by ! integral from 0 to X of -LOG(1-Y)/Y DY. ! For ABS(X) <= 1, the uniformly convergent expansion ! DSPENC = sum K=1,infinity X**K / K**2 is valid. ! This is a form of Spence's integral due to K. Mitchell which differs ! from the definition in the NBS Handbook of Mathematical Functions. ! ! Spence's function can be used to evaluate much more general integral ! forms. For example, ! integral from 0 to Z of LOG(A*X+B)/(C*X+D) DX = ! LOG(ABS(B-A*D/C))*LOG(ABS(A*(C*X+D)/(A*D-B*C)))/C ! - DSPENC (A*(C*Z+D)/(A*D-B*C)) / C. ! ! Ref -- K. Mitchell, Philosophical Magazine, 40, p.351 (1949). ! Stegun and Abromowitz, AMS 55, p.1004. ! ! ! Series for SPEN on the interval 0. to 5.00000E-01 ! with weighted error 4.74E-32 ! log weighted error 31.32 ! significant figures required 30.37 ! decimal places required 32.11 ! !***REFERENCES (NONE) !***ROUTINES CALLED D1MACH, DCSEVL, INITDS !***REVISION HISTORY (YYMMDD) ! 780201 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891115 Corrected third argument in reference to INITDS. (WRB) ! 891115 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DSPENC DOUBLE PRECISION X, SPENCS(38), ALN, PI26, XBIG, D1MACH, DCSEVL LOGICAL FIRST SAVE SPENCS, PI26, NSPENC, XBIG, FIRST DATA SPENCS( 1) / +.1527365598892405872946684910028D+0 / DATA SPENCS( 2) / +.8169658058051014403501838185271D-1 / DATA SPENCS( 3) / +.5814157140778730872977350641182D-2 / DATA SPENCS( 4) / +.5371619814541527542247889005319D-3 / DATA SPENCS( 5) / +.5724704675185826233210603054782D-4 / DATA SPENCS( 6) / +.6674546121649336343607835438589D-5 / DATA SPENCS( 7) / +.8276467339715676981584391689011D-6 / DATA SPENCS( 8) / +.1073315673030678951270005873354D-6 / DATA SPENCS( 9) / +.1440077294303239402334590331513D-7 / DATA SPENCS( 10) / +.1984442029965906367898877139608D-8 / DATA SPENCS( 11) / +.2794005822163638720201994821615D-9 / DATA SPENCS( 12) / +.4003991310883311823072580445908D-10 / DATA SPENCS( 13) / +.5823462892044638471368135835757D-11 / DATA SPENCS( 14) / +.8576708692638689278097914771224D-12 / DATA SPENCS( 15) / +.1276862586280193045989483033433D-12 / DATA SPENCS( 16) / +.1918826209042517081162380416062D-13 / DATA SPENCS( 17) / +.2907319206977138177795799719673D-14 / DATA SPENCS( 18) / +.4437112685276780462557473641745D-15 / DATA SPENCS( 19) / +.6815727787414599527867359135607D-16 / DATA SPENCS( 20) / +.1053017386015574429547019416644D-16 / DATA SPENCS( 21) / +.1635389806752377100051821734570D-17 / DATA SPENCS( 22) / +.2551852874940463932310901642581D-18 / DATA SPENCS( 23) / +.3999020621999360112770470379519D-19 / DATA SPENCS( 24) / +.6291501645216811876514149171199D-20 / DATA SPENCS( 25) / +.9933827435675677643803887752533D-21 / DATA SPENCS( 26) / +.1573679570749964816721763805866D-21 / DATA SPENCS( 27) / +.2500595316849476129369270954666D-22 / DATA SPENCS( 28) / +.3984740918383811139210663253333D-23 / DATA SPENCS( 29) / +.6366473210082843892691326293333D-24 / DATA SPENCS( 30) / +.1019674287239678367077061973333D-24 / DATA SPENCS( 31) / +.1636881058913518841111074133333D-25 / DATA SPENCS( 32) / +.2633310439417650117345279999999D-26 / DATA SPENCS( 33) / +.4244811560123976817224362666666D-27 / DATA SPENCS( 34) / +.6855411983680052916824746666666D-28 / DATA SPENCS( 35) / +.1109122433438056434018986666666D-28 / DATA SPENCS( 36) / +.1797431304999891457365333333333D-29 / DATA SPENCS( 37) / +.2917505845976095173290666666666D-30 / DATA SPENCS( 38) / +.4742646808928671061333333333333D-31 / DATA PI26 / +1.644934066848226436472415166646025189219D0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DSPENC if (FIRST) THEN NSPENC = INITDS (SPENCS, 38, 0.1*REAL(D1MACH(3))) XBIG = 1.0D0/D1MACH(3) end if FIRST = .FALSE. ! if (X > 2.0D0) go to 60 if (X > 1.0D0) go to 50 if (X > 0.5D0) go to 40 if (X >= 0.0D0) go to 30 if (X > (-1.D0)) go to 20 ! ! HERE if X <= -1.0 ! ALN = LOG(1.0D0-X) DSPENC = -PI26 - 0.5D0*ALN*(2.0D0*LOG(-X)-ALN) if (X > (-XBIG)) DSPENC = DSPENC & + (1.D0 + DCSEVL (4.D0/(1.D0-X)-1.D0, SPENCS, NSPENC))/(1.D0-X) return ! ! -1.0 < X < 0.0 ! 20 DSPENC = -0.5D0*LOG(1.0D0-X)**2 & - X*(1.D0+DCSEVL(4.D0*X/(X-1.D0)-1.D0, SPENCS, NSPENC))/(X-1.D0) return ! ! 0.0 <= X <= 0.5 ! 30 DSPENC = X*(1.D0 + DCSEVL (4.D0*X-1.D0, SPENCS, NSPENC)) return ! ! 0.5 < X <= 1.0 ! 40 DSPENC = PI26 if (X /= 1.D0) DSPENC = PI26 - LOG(X)*LOG(1.0D0-X) & - (1.D0-X)*(1.D0+DCSEVL(4.D0*(1.D0-X)-1.D0, SPENCS, NSPENC)) return ! ! 1.0 < X <= 2.0 ! 50 DSPENC = PI26 - 0.5D0*LOG(X)*LOG((X-1.D0)**2/X) & + (X-1.D0)*(1.D0+DCSEVL(4.D0*(X-1.D0)/X-1.D0, SPENCS, NSPENC))/X return ! ! X > 2.0 ! 60 DSPENC = 2.0D0*PI26 - 0.5D0*LOG(X)**2 if (X < XBIG) DSPENC = DSPENC & - (1.D0 + DCSEVL (4.D0/X-1.D0, SPENCS, NSPENC))/X return ! end subroutine DSPFA (AP, N, KPVT, INFO) ! !! DSPFA factors a real symmetric matrix stored in packed form by ... ! elimination with symmetric pivoting. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE DOUBLE PRECISION (SSPFA-S, DSPFA-D, CHPFA-C, CSPFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, ! SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! DSPFA factors a double precision symmetric matrix stored in ! packed form by elimination with symmetric pivoting. ! ! To solve A*X = B , follow DSPFA by DSPSL. ! To compute INVERSE(A)*C , follow DSPFA by DSPSL. ! To compute DETERMINANT(A) , follow DSPFA by DSPDI. ! To compute INERTIA(A) , follow DSPFA by DSPDI. ! To compute INVERSE(A) , follow DSPFA by DSPDI. ! ! On Entry ! ! AP DOUBLE PRECISION (N*(N+1)/2) ! the packed form of a symmetric matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! Output ! ! AP a block diagonal matrix and the multipliers which ! were used to obtain it stored in packed form. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices, TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th pivot block is singular. This is ! not an error condition for this subroutine, ! but it does indicate that DSPSL or DSPDI may ! divide by zero if called. ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a symmetric matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DSWAP, IDAMAX !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSPFA INTEGER N,KPVT(*),INFO DOUBLE PRECISION AP(*) ! DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER IDAMAX,IJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP LOGICAL SWAP !***FIRST EXECUTABLE STATEMENT DSPFA ! ! INITIALIZE ! ! ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ! ALPHA = (1.0D0 + SQRT(17.0D0))/8.0D0 ! INFO = 0 ! ! MAIN LOOP ON K, WHICH GOES FROM N TO 1. ! K = N IK = (N*(N - 1))/2 10 CONTINUE ! ! LEAVE THE LOOP if K=0 OR K=1. ! if (K == 0) go to 200 if (K > 1) go to 20 KPVT(1) = 1 if (AP(1) == 0.0D0) INFO = 1 go to 200 20 CONTINUE ! ! THIS SECTION OF CODE DETERMINES THE KIND OF ! ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, ! KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND ! SWAP WILL BE SET TO .TRUE. if AN INTERCHANGE IS ! REQUIRED. ! KM1 = K - 1 KK = IK + K ABSAKK = ABS(AP(KK)) ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! COLUMN K. ! IMAX = IDAMAX(K-1,AP(IK+1),1) IMK = IK + IMAX COLMAX = ABS(AP(IMK)) if (ABSAKK < ALPHA*COLMAX) go to 30 KSTEP = 1 SWAP = .FALSE. go to 90 30 CONTINUE ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! ROW IMAX. ! ROWMAX = 0.0D0 IMAXP1 = IMAX + 1 IM = IMAX*(IMAX - 1)/2 IMJ = IM + 2*IMAX DO 40 J = IMAXP1, K ROWMAX = MAX(ROWMAX,ABS(AP(IMJ))) IMJ = IMJ + J 40 CONTINUE if (IMAX == 1) go to 50 JMAX = IDAMAX(IMAX-1,AP(IM+1),1) JMIM = JMAX + IM ROWMAX = MAX(ROWMAX,ABS(AP(JMIM))) 50 CONTINUE IMIM = IMAX + IM if (ABS(AP(IMIM)) < ALPHA*ROWMAX) go to 60 KSTEP = 1 SWAP = .TRUE. go to 80 60 CONTINUE if (ABSAKK < ALPHA*COLMAX*(COLMAX/ROWMAX)) go to 70 KSTEP = 1 SWAP = .FALSE. go to 80 70 CONTINUE KSTEP = 2 SWAP = IMAX /= KM1 80 CONTINUE 90 CONTINUE if (MAX(ABSAKK,COLMAX) /= 0.0D0) go to 100 ! ! COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. ! KPVT(K) = K INFO = K go to 190 100 CONTINUE if (KSTEP == 2) go to 140 ! ! 1 X 1 PIVOT BLOCK. ! if (.NOT.SWAP) go to 120 ! ! PERFORM AN INTERCHANGE. ! 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 ! ! PERFORM THE ELIMINATION. ! 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) AP(JK) = MULK IJ = IJ - (J - 1) 130 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = K if (SWAP) KPVT(K) = IMAX go to 190 140 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! KM1K = IK + K - 1 IKM1 = IK - (K - 1) if (.NOT.SWAP) go to 160 ! ! PERFORM AN INTERCHANGE. ! 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 ! ! PERFORM THE ELIMINATION. ! KM2 = K - 2 if (KM2 == 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 IJ = IJ - (J - 1) 170 CONTINUE 180 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = 1 - K if (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE IK = IK - (K - 1) if (KSTEP == 2) IK = IK - (K - 2) K = K - KSTEP go to 10 200 CONTINUE return end subroutine DSPLP (DUSRMT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, & BL, BU, IND, INFO, PRIMAL, DUALS, IBASIS, WORK, LW, IWORK, LIW) ! !! DSPLP solves linear programming problems involving at most a few thousand ... ! constraints and variables. ! Takes advantage of sparsity in the constraint matrix. ! !***LIBRARY SLATEC !***CATEGORY G2A2 !***TYPE DOUBLE PRECISION (SPLP-S, DSPLP-D) !***KEYWORDS LINEAR CONSTRAINTS, LINEAR OPTIMIZATION, ! LINEAR PROGRAMMING, LP, SPARSE CONSTRAINTS !***AUTHOR Hanson, R. J., (SNLA) ! Hiebert, K. L., (SNLA) !***DESCRIPTION ! ! These are the short usage instructions; for details about ! other features, options and methods for defining the matrix ! A, see the extended usage instructions which are contained in ! the Long Description section below. ! ! |------------| ! |Introduction| ! |------------| ! The subprogram DSPLP( ) solves a linear optimization problem. ! The problem statement is as follows ! ! minimize (transpose of costs)*x ! subject to A*x=w. ! ! The entries of the unknowns x and w may have simple lower or ! upper bounds (or both), or be free to take on any value. By ! setting the bounds for x and w, the user is imposing the con- ! straints of the problem. The matrix A has MRELAS rows and ! NVARS columns. The vectors costs, x, and w respectively ! have NVARS, NVARS, and MRELAS number of entries. ! ! The input for the problem includes the problem dimensions, ! MRELAS and NVARS, the array COSTS(*), data for the matrix ! A, and the bound information for the unknowns x and w, BL(*), ! BU(*), and IND(*). Only the nonzero entries of the matrix A ! are passed to DSPLP( ). ! ! The output from the problem (when output flag INFO=1) includes ! optimal values for x and w in PRIMAL(*), optimal values for ! dual variables of the equations A*x=w and the simple bounds ! on x in DUALS(*), and the indices of the basic columns, ! IBASIS(*). ! ! |------------------------------| ! |Fortran Declarations Required:| ! |------------------------------| ! ! DIMENSION COSTS(NVARS),PRGOPT(*),DATTRV(*), ! *BL(NVARS+MRELAS),BU(NVARS+MRELAS),IND(NVARS+MRELAS), ! *PRIMAL(NVARS+MRELAS),DUALS(MRELAS+NVARS),IBASIS(NVARS+MRELAS), ! *WORK(LW),IWORK(LIW) ! ! EXTERNAL DUSRMT ! ! The dimensions of PRGOPT(*) and DATTRV(*) must be at least 1. ! The exact lengths will be determined by user-required options and ! data transferred to the subprogram DUSRMT( ). ! ! The values of LW and LIW, the lengths of the arrays WORK(*) ! and IWORK(*), must satisfy the inequalities ! ! LW >= 4*NVARS+ 8*MRELAS+LAMAT+ LBM ! LIW >= NVARS+11*MRELAS+LAMAT+2*LBM ! ! It is an error if they do not both satisfy these inequalities. ! (The subprogram will inform the user of the required lengths ! if either LW or LIW is wrong.) The values of LAMAT and LBM ! nominally are ! ! LAMAT=4*NVARS+7 ! and LBM =8*MRELAS ! ! LAMAT determines the length of the sparse matrix storage area. ! The value of LBM determines the amount of storage available ! to decompose and update the active basis matrix. ! ! |------| ! |Input:| ! |------| ! ! MRELAS,NVARS ! ------------ ! These parameters are respectively the number of constraints (the ! linear relations A*x=w that the unknowns x and w are to satisfy) ! and the number of entries in the vector x. Both must be >= 1. ! Other values are errors. ! ! COSTS(*) ! -------- ! The NVARS entries of this array are the coefficients of the ! linear objective function. The value COSTS(J) is the ! multiplier for variable J of the unknown vector x. Each ! entry of this array must be defined. ! ! DUSRMT ! ------ ! This is the name of a specific subprogram in the DSPLP( ) package ! used to define the matrix A. In this usage mode of DSPLP( ) ! the user places the nonzero entries of A in the ! array DATTRV(*) as given in the description of that parameter. ! The name DUSRMT must appear in a Fortran EXTERNAL statement. ! ! DATTRV(*) ! --------- ! The array DATTRV(*) contains data for the matrix A as follows: ! Each column (numbered J) requires (floating point) data con- ! sisting of the value (-J) followed by pairs of values. Each pair ! consists of the row index immediately followed by the value ! of the matrix at that entry. A value of J=0 signals that there ! are no more columns. The required length of ! DATTRV(*) is 2*no. of nonzeros + NVARS + 1. ! ! BL(*),BU(*),IND(*) ! ------------------ ! The values of IND(*) are input parameters that define ! the form of the bounds for the unknowns x and w. The values for ! the bounds are found in the arrays BL(*) and BU(*) as follows. ! ! For values of J between 1 and NVARS, ! if IND(J)=1, then X(J) >= BL(J); BU(J) is not used. ! if IND(J)=2, then X(J) <= BU(J); BL(J) is not used. ! if IND(J)=3, then BL(J) <= X(J) <= BU(J),(BL(J)=BU(J) ok) ! if IND(J)=4, then X(J) is free to have any value, ! and BL(J), BU(J) are not used. ! ! For values of I between NVARS+1 and NVARS+MRELAS, ! if IND(I)=1, then W(I-NVARS) >= BL(I); BU(I) is not used. ! if IND(I)=2, then W(I-NVARS) <= BU(I); BL(I) is not used. ! if IND(I)=3, then BL(I) <= W(I-NVARS) <= BU(I), ! (BL(I)=BU(I) is ok). ! if IND(I)=4, then W(I-NVARS) is free to have any value, ! and BL(I), BU(I) are not used. ! ! A value of IND(*) not equal to 1,2,3 or 4 is an error. When ! IND(I)=3, BL(I) must be <= BU(I). The condition BL(I) > ! BU(I) indicates infeasibility and is an error. ! ! PRGOPT(*) ! --------- ! This array is used to redefine various parameters within DSPLP( ). ! Frequently, perhaps most of the time, a user will be satisfied ! and obtain the solutions with no changes to any of these ! parameters. To try this, simply set PRGOPT(1)=1.D0. ! ! For users with more sophisticated needs, DSPLP( ) provides several ! options that may be used to take advantage of more detailed ! knowledge of the problem or satisfy other utilitarian needs. ! The complete description of how to use this option array to ! utilize additional subprogram features is found under the ! heading of DSPLP( ) Subprogram Options in the Extended ! Usage Instructions. ! ! Briefly, the user should note the following value of the parameter ! KEY and the corresponding task or feature desired before turning ! to that document. ! ! Value Brief Statement of Purpose for Option ! of KEY ! ------ ------------------------------------- ! 50 Change from a minimization problem to a ! maximization problem. ! 51 Change the amount of printed output. ! Normally, no printed output is obtained. ! 52 Redefine the line length and precision used ! for the printed output. ! 53 Redefine the values of LAMAT and LBM that ! were discussed above under the heading ! Fortran Declarations Required. ! 54 Redefine the unit number where pages of the sparse ! data matrix A are stored. Normally, the unit ! number is 1. ! 55 A computation, partially completed, is ! being continued. Read the up-to-date ! partial results from unit number 2. ! 56 Redefine the unit number where the partial results ! are stored. Normally, the unit number is 2. ! 57 Save partial results on unit 2 either after ! maximum iterations or at the optimum. ! 58 Redefine the value for the maximum number of ! iterations. Normally, the maximum number of ! iterations is 3*(NVARS+MRELAS). ! 59 Provide DSPLP( ) with a starting (feasible) ! nonsingular basis. Normally, DSPLP( ) starts ! with the identity matrix columns corresponding ! to the vector w. ! 60 The user has provided scale factors for the ! columns of A. Normally, DSPLP( ) computes scale ! factors that are the reciprocals of the max. norm ! of each column. ! 61 The user has provided a scale factor ! for the vector costs. Normally, DSPLP( ) computes ! a scale factor equal to the reciprocal of the ! max. norm of the vector costs after the column ! scaling for the data matrix has been applied. ! 62 Size parameters, namely the smallest and ! largest magnitudes of nonzero entries in ! the matrix A, are provided. Values noted ! outside this range are to be considered errors. ! 63 Redefine the tolerance required in ! evaluating residuals for feasibility. ! Normally, this value is set to RELPR, ! where RELPR = relative precision of the arithmetic. ! 64 Change the criterion for bringing new variables ! into the basis from the steepest edge (best ! local move) to the minimum reduced cost. ! 65 Redefine the value for the number of iterations ! between recalculating the error in the primal ! solution. Normally, this value is equal to ten. ! 66 Perform "partial pricing" on variable selection. ! Redefine the value for the number of negative ! reduced costs to compute (at most) when finding ! a variable to enter the basis. Normally this ! value is set to NVARS. This implies that no ! "partial pricing" is used. ! 67 Adjust the tuning factor (normally one) to apply ! to the primal and dual error estimates. ! 68 Pass information to the subprogram DFULMT(), ! provided with the DSPLP() package, so that a Fortran ! two-dimensional array can be used as the argument ! DATTRV(*). ! 69 Pass an absolute tolerance to use for the feasibility ! test when the usual relative error test indicates ! infeasibility. The nominal value of this tolerance, ! TOLABS, is zero. ! ! ! |---------------| ! |Working Arrays:| ! |---------------| ! ! WORK(*),LW, ! IWORK(*),LIW ! ------------ ! The arrays WORK(*) and IWORK(*) are respectively floating point ! and type INTEGER working arrays for DSPLP( ) and its ! subprograms. The lengths of these arrays are respectively ! LW and LIW. These parameters must satisfy the inequalities ! noted above under the heading "Fortran Declarations Required:" ! It is an error if either value is too small. ! ! |----------------------------| ! |Input/Output files required:| ! |----------------------------| ! ! Fortran unit 1 is used by DSPLP( ) to store the sparse matrix A ! out of high-speed memory. A crude ! upper bound for the amount of information written on unit 1 ! is 6*nz, where nz is the number of nonzero entries in A. ! ! |-------| ! |Output:| ! |-------| ! ! INFO,PRIMAL(*),DUALS(*) ! ----------------------- ! The integer flag INFO indicates why DSPLP( ) has returned to the ! user. If INFO=1 the solution has been computed. In this case ! X(J)=PRIMAL(J) and W(I)=PRIMAL(I+NVARS). The dual variables ! for the equations A*x=w are in the array DUALS(I)=dual for ! equation number I. The dual value for the component X(J) that ! has an upper or lower bound (or both) is returned in ! DUALS(J+MRELAS). The only other values for INFO are < 0. ! The meaning of these values can be found by reading ! the diagnostic message in the output file, or by looking for ! error number = (-INFO) in the Extended Usage Instructions ! under the heading: ! ! List of DSPLP( ) Error and Diagnostic Messages. ! ! BL(*),BU(*),IND(*) ! ------------------ ! These arrays are output parameters only under the (unusual) ! circumstances where the stated problem is infeasible, has an ! unbounded optimum value, or both. These respective conditions ! correspond to INFO=-1,-2 or -3. See the Extended ! Usage Instructions for further details. ! ! IBASIS(I),I=1,...,MRELAS ! ------------------------ ! This array contains the indices of the variables that are ! in the active basis set at the solution (INFO=1). A value ! of IBASIS(I) between 1 and NVARS corresponds to the variable ! X(IBASIS(I)). A value of IBASIS(I) between NVARS+1 and NVARS+ ! MRELAS corresponds to the variable W(IBASIS(I)-NVARS). ! ! *Long Description: ! ! SUBROUTINE DSPLP(DUSRMT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, ! * BL,BU,IND,INFO,PRIMAL,DUALS,IBASIS,WORK,LW,IWORK,LIW) ! ! |------------| ! |Introduction| ! |------------| ! The subprogram DSPLP( ) solves a linear optimization problem. ! The problem statement is as follows ! ! minimize (transpose of costs)*x ! subject to A*x=w. ! ! The entries of the unknowns x and w may have simple lower or ! upper bounds (or both), or be free to take on any value. By ! setting the bounds for x and w, the user is imposing the con- ! straints of the problem. ! ! (The problem may also be stated as a maximization ! problem. This is done by means of input in the option array ! PRGOPT(*).) The matrix A has MRELAS rows and NVARS columns. The ! vectors costs, x, and w respectively have NVARS, NVARS, and ! MRELAS number of entries. ! ! The input for the problem includes the problem dimensions, ! MRELAS and NVARS, the array COSTS(*), data for the matrix ! A, and the bound information for the unknowns x and w, BL(*), ! BU(*), and IND(*). ! ! The output from the problem (when output flag INFO=1) includes ! optimal values for x and w in PRIMAL(*), optimal values for ! dual variables of the equations A*x=w and the simple bounds ! on x in DUALS(*), and the indices of the basic columns in ! IBASIS(*). ! ! |------------------------------| ! |Fortran Declarations Required:| ! |------------------------------| ! ! DIMENSION COSTS(NVARS),PRGOPT(*),DATTRV(*), ! *BL(NVARS+MRELAS),BU(NVARS+MRELAS),IND(NVARS+MRELAS), ! *PRIMAL(NVARS+MRELAS),DUALS(MRELAS+NVARS),IBASIS(NVARS+MRELAS), ! *WORK(LW),IWORK(LIW) ! ! EXTERNAL DUSRMT (or 'NAME', if user provides the subprogram) ! ! The dimensions of PRGOPT(*) and DATTRV(*) must be at least 1. ! The exact lengths will be determined by user-required options and ! data transferred to the subprogram DUSRMT( ) ( or 'NAME'). ! ! The values of LW and LIW, the lengths of the arrays WORK(*) ! and IWORK(*), must satisfy the inequalities ! ! LW >= 4*NVARS+ 8*MRELAS+LAMAT+ LBM ! LIW >= NVARS+11*MRELAS+LAMAT+2*LBM ! ! It is an error if they do not both satisfy these inequalities. ! (The subprogram will inform the user of the required lengths ! if either LW or LIW is wrong.) The values of LAMAT and LBM ! nominally are ! ! LAMAT=4*NVARS+7 ! and LBM =8*MRELAS ! ! These values will be as shown unless the user changes them by ! means of input in the option array PRGOPT(*). The value of LAMAT ! determines the length of the sparse matrix "staging" area. ! For reasons of efficiency the user may want to increase the value ! of LAMAT. The value of LBM determines the amount of storage ! available to decompose and update the active basis matrix. ! Due to exhausting the working space because of fill-in, ! it may be necessary for the user to increase the value of LBM. ! (If this situation occurs an informative diagnostic is printed ! and a value of INFO=-28 is obtained as an output parameter.) ! ! |------| ! |Input:| ! |------| ! ! MRELAS,NVARS ! ------------ ! These parameters are respectively the number of constraints (the ! linear relations A*x=w that the unknowns x and w are to satisfy) ! and the number of entries in the vector x. Both must be >= 1. ! Other values are errors. ! ! COSTS(*) ! -------- ! The NVARS entries of this array are the coefficients of the ! linear objective function. The value COSTS(J) is the ! multiplier for variable J of the unknown vector x. Each ! entry of this array must be defined. This array can be changed ! by the user between restarts. See options with KEY=55,57 for ! details of checkpointing and restarting. ! ! DUSRMT ! ------ ! This is the name of a specific subprogram in the DSPLP( ) package ! that is used to define the matrix entries when this data is passed ! to DSPLP( ) as a linear array. In this usage mode of DSPLP( ) ! the user gives information about the nonzero entries of A ! in DATTRV(*) as given under the description of that parameter. ! The name DUSRMT must appear in a Fortran EXTERNAL statement. ! Users who are passing the matrix data with DUSRMT( ) can skip ! directly to the description of the input parameter DATTRV(*). ! Also see option 68 for passing the constraint matrix data using ! a standard Fortran two-dimensional array. ! ! If the user chooses to provide a subprogram 'NAME'( ) to ! define the matrix A, then DATTRV(*) may be used to pass floating ! point data from the user's program unit to the subprogram ! 'NAME'( ). The content of DATTRV(*) is not changed in any way. ! ! The subprogram 'NAME'( ) can be of the user's choice ! but it must meet Fortran standards and it must appear in a ! Fortran EXTERNAL statement. The first statement of the subprogram ! has the form ! ! SUBROUTINE 'NAME'(I,J,AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) ! ! The variables I,J, INDCAT, IFLAG(10) are type INTEGER, ! while AIJ, PRGOPT(*),DATTRV(*) are type REAL. ! ! The user interacts with the contents of IFLAG(*) to ! direct the appropriate action. The algorithmic steps are ! as follows. ! ! Test IFLAG(1). ! ! if ( IFLAG(1) == 1) THEN ! ! Initialize the necessary pointers and data ! for defining the matrix A. The contents ! of IFLAG(K), K=2,...,10, may be used for ! storage of the pointers. This array remains intact ! between calls to 'NAME'( ) by DSPLP( ). ! return ! ! end if ! ! if ( IFLAG(1) == 2) THEN ! ! Define one set of values for I,J,AIJ, and INDCAT. ! Each nonzero entry of A must be defined this way. ! These values can be defined in any convenient order. ! (It is most efficient to define the data by ! columns in the order 1,...,NVARS; within each ! column define the entries in the order 1,...,MRELAS.) ! If this is the last matrix value to be ! defined or updated, then set IFLAG(1)=3. ! (When I and J are positive and respectively no larger ! than MRELAS and NVARS, the value of AIJ is used to ! define (or update) row I and column J of A.) ! return ! ! end if ! ! END ! ! Remarks: The values of I and J are the row and column ! indices for the nonzero entries of the matrix A. ! The value of this entry is AIJ. ! Set INDCAT=0 if this value defines that entry. ! Set INDCAT=1 if this entry is to be updated, ! new entry=old entry+AIJ. ! A value of I not between 1 and MRELAS, a value of J ! not between 1 and NVARS, or a value of INDCAT ! not equal to 0 or 1 are each errors. ! ! The contents of IFLAG(K), K=2,...,10, can be used to ! remember the status (of the process of defining the ! matrix entries) between calls to 'NAME'( ) by DSPLP( ). ! On entry to 'NAME'( ), only the values 1 or 2 will be ! in IFLAG(1). More than 2*NVARS*MRELAS definitions of ! the matrix elements is considered an error because ! it suggests an infinite loop in the user-written ! subprogram 'NAME'( ). Any matrix element not ! provided by 'NAME'( ) is defined to be zero. ! ! The REAL arrays PRGOPT(*) and DATTRV(*) are passed as ! arguments directly from DSPLP( ) to 'NAME'( ). ! The array PRGOPT(*) contains any user-defined program ! options. In this usage mode the array DATTRV(*) may ! now contain any (type REAL) data that the user needs ! to define the matrix A. Both arrays PRGOPT(*) and ! DATTRV(*) remain intact between calls to 'NAME'( ) ! by DSPLP( ). ! Here is a subprogram that communicates the matrix values for A, ! as represented in DATTRV(*), to DSPLP( ). This subprogram, ! called DUSRMT( ), is included as part of the DSPLP( ) package. ! This subprogram 'decodes' the array DATTRV(*) and defines the ! nonzero entries of the matrix A for DSPLP( ) to store. This ! listing is presented here as a guide and example ! for the users who find it necessary to write their own subroutine ! for this purpose. The contents of DATTRV(*) are given below in ! the description of that parameter. ! ! SUBROUTINE DUSRMT(I,J,AIJ, INDCAT,PRGOPT,DATTRV,IFLAG) ! DIMENSION PRGOPT(*),DATTRV(*),IFLAG(10) ! ! if ( IFLAG(1) == 1) THEN ! ! THIS IS THE INITIALIZATION STEP. THE VALUES OF IFLAG(K),K=2,3,4, ! ARE RESPECTIVELY THE COLUMN INDEX, THE ROW INDEX (OR THE NEXT COL. ! INDEX), AND THE POINTER TO THE MATRIX ENTRY'S VALUE WITHIN ! DATTRV(*). ALSO CHECK (DATTRV(1)=0.) SIGNIFYING NO DATA. ! if ( DATTRV(1) == 0.) THEN ! I = 0 ! J = 0 ! IFLAG(1) = 3 ! ELSE ! IFLAG(2)=-DATTRV(1) ! IFLAG(3)= DATTRV(2) ! IFLAG(4)= 3 ! end if ! ! return ! ELSE ! J=IFLAG(2) ! I=IFLAG(3) ! L=IFLAG(4) ! if ( I == 0) THEN ! ! SIGNAL THAT ALL OF THE NONZERO ENTRIES HAVE BEEN DEFINED. ! IFLAG(1)=3 ! return ! ELSE if ( I < 0) THEN ! ! SIGNAL THAT A SWITCH IS MADE TO A NEW COLUMN. ! J=-I ! I=DATTRV(L) ! L=L+1 ! end if ! ! AIJ=DATTRV(L) ! ! UPDATE THE INDICES AND POINTERS FOR THE NEXT ENTRY. ! IFLAG(2)=J ! IFLAG(3)=DATTRV(L+1) ! IFLAG(4)=L+2 ! ! INDCAT=0 DENOTES THAT ENTRIES OF THE MATRIX ARE ASSIGNED THE ! VALUES FROM DATTRV(*). NO ACCUMULATION IS PERFORMED. ! INDCAT=0 ! return ! end if ! END ! ! DATTRV(*) ! --------- ! If the user chooses to use the provided subprogram DUSRMT( ) then ! the array DATTRV(*) contains data for the matrix A as follows: ! Each column (numbered J) requires (floating point) data con- ! sisting of the value (-J) followed by pairs of values. Each pair ! consists of the row index immediately followed by the value ! of the matrix at that entry. A value of J=0 signals that there ! are no more columns. (See "Example of DSPLP( ) Usage," below.) ! The dimension of DATTRV(*) must be 2*no. of nonzeros ! + NVARS + 1 in this usage. No checking of the array ! length is done by the subprogram package. ! ! If the Save/Restore feature is in use (see options with ! KEY=55,57 for details of checkpointing and restarting) ! DUSRMT( ) can be used to redefine entries of the matrix. ! The matrix entries are redefined or overwritten. No accum- ! ulation is performed. ! Any other nonzero entry of A, defined in a previous call to ! DSPLP( ), remain intact. ! ! BL(*),BU(*),IND(*) ! ------------------ ! The values of IND(*) are input parameters that define ! the form of the bounds for the unknowns x and w. The values for ! the bounds are found in the arrays BL(*) and BU(*) as follows. ! ! For values of J between 1 and NVARS, ! if IND(J)=1, then X(J) >= BL(J); BU(J) is not used. ! if IND(J)=2, then X(J) <= BU(J); BL(J) is not used. ! if IND(J)=3, then BL(J) <= X(J) <= BU(J),(BL(J)=BU(J) ok) ! if IND(J)=4, then X(J) is free to have any value, ! and BL(J), BU(J) are not used. ! ! For values of I between NVARS+1 and NVARS+MRELAS, ! if IND(I)=1, then W(I-NVARS) >= BL(I); BU(I) is not used. ! if IND(I)=2, then W(I-NVARS) <= BU(I); BL(I) is not used. ! if IND(I)=3, then BL(I) <= W(I-NVARS) <= BU(I), ! (BL(I)=BU(I) is ok). ! if IND(I)=4, then W(I-NVARS) is free to have any value, ! and BL(I), BU(I) are not used. ! ! A value of IND(*) not equal to 1,2,3 or 4 is an error. When ! IND(I)=3, BL(I) must be <= BU(I). The condition BL(I) > ! BU(I) indicates infeasibility and is an error. These ! arrays can be changed by the user between restarts. See ! options with KEY=55,57 for details of checkpointing and ! restarting. ! ! PRGOPT(*) ! --------- ! This array is used to redefine various parameters within DSPLP( ). ! Frequently, perhaps most of the time, a user will be satisfied ! and obtain the solutions with no changes to any of these ! parameters. To try this, simply set PRGOPT(1)=1.D0. ! ! For users with more sophisticated needs, DSPLP( ) provides several ! options that may be used to take advantage of more detailed ! knowledge of the problem or satisfy other utilitarian needs. ! The complete description of how to use this option array to ! utilize additional subprogram features is found under the ! heading "Usage of DSPLP( ) Subprogram Options." ! ! Briefly, the user should note the following value of the parameter ! KEY and the corresponding task or feature desired before turning ! to that section. ! ! Value Brief Statement of Purpose for Option ! of KEY ! ------ ------------------------------------- ! 50 Change from a minimization problem to a ! maximization problem. ! 51 Change the amount of printed output. ! Normally, no printed output is obtained. ! 52 Redefine the line length and precision used ! for the printed output. ! 53 Redefine the values of LAMAT and LBM that ! were discussed above under the heading ! Fortran Declarations Required. ! 54 Redefine the unit number where pages of the sparse ! data matrix A are stored. Normally, the unit ! number is 1. ! 55 A computation, partially completed, is ! being continued. Read the up-to-date ! partial results from unit number 2. ! 56 Redefine the unit number where the partial results ! are stored. Normally, the unit number is 2. ! 57 Save partial results on unit 2 either after ! maximum iterations or at the optimum. ! 58 Redefine the value for the maximum number of ! iterations. Normally, the maximum number of ! iterations is 3*(NVARS+MRELAS). ! 59 Provide DSPLP( ) with a starting (feasible) ! nonsingular basis. Normally, DSPLP( ) starts ! with the identity matrix columns corresponding ! to the vector w. ! 60 The user has provided scale factors for the ! columns of A. Normally, DSPLP( ) computes scale ! factors that are the reciprocals of the max. norm ! of each column. ! 61 The user has provided a scale factor ! for the vector costs. Normally, DSPLP( ) computes ! a scale factor equal to the reciprocal of the ! max. norm of the vector costs after the column ! scaling for the data matrix has been applied. ! 62 Size parameters, namely the smallest and ! largest magnitudes of nonzero entries in ! the matrix A, are provided. Values noted ! outside this range are to be considered errors. ! 63 Redefine the tolerance required in ! evaluating residuals for feasibility. ! Normally, this value is set to the value RELPR, ! where RELPR = relative precision of the arithmetic. ! 64 Change the criterion for bringing new variables ! into the basis from the steepest edge (best ! local move) to the minimum reduced cost. ! 65 Redefine the value for the number of iterations ! between recalculating the error in the primal ! solution. Normally, this value is equal to ten. ! 66 Perform "partial pricing" on variable selection. ! Redefine the value for the number of negative ! reduced costs to compute (at most) when finding ! a variable to enter the basis. Normally this ! value is set to NVARS. This implies that no ! "partial pricing" is used. ! 67 Adjust the tuning factor (normally one) to apply ! to the primal and dual error estimates. ! 68 Pass information to the subprogram DFULMT(), ! provided with the DSPLP() package, so that a Fortran ! two-dimensional array can be used as the argument ! DATTRV(*). ! 69 Pass an absolute tolerance to use for the feasibility ! test when the usual relative error test indicates ! infeasibility. The nominal value of this tolerance, ! TOLABS, is zero. ! ! ! |---------------| ! |Working Arrays:| ! |---------------| ! ! WORK(*),LW, ! IWORK(*),LIW ! ------------ ! The arrays WORK(*) and IWORK(*) are respectively floating point ! and type INTEGER working arrays for DSPLP( ) and its ! subprograms. The lengths of these arrays are respectively ! LW and LIW. These parameters must satisfy the inequalities ! noted above under the heading "Fortran Declarations Required." ! It is an error if either value is too small. ! ! |----------------------------| ! |Input/Output files required:| ! |----------------------------| ! ! Fortran unit 1 is used by DSPLP( ) to store the sparse matrix A ! out of high-speed memory. This direct access file is opened ! within the package under the following two conditions. ! 1. When the Save/Restore feature is used. 2. When the ! constraint matrix is so large that storage out of high-speed ! memory is required. The user may need to close unit 1 ! (with deletion from the job step) in the main program unit ! when several calls are made to DSPLP( ). A crude ! upper bound for the amount of information written on unit 1 ! is 6*nz, where nz is the number of nonzero entries in A. ! The unit number may be redefined to any other positive value ! by means of input in the option array PRGOPT(*). ! ! Fortran unit 2 is used by DSPLP( ) only when the Save/Restore ! feature is desired. Normally this feature is not used. It is ! activated by means of input in the option array PRGOPT(*). ! On some computer systems the user may need to open unit ! 2 before executing a call to DSPLP( ). This file is type ! sequential and is unformatted. ! ! Fortran unit=I1MACH(2) (check local setting) is used by DSPLP( ) ! when the printed output feature (KEY=51) is used. Normally ! this feature is not used. It is activated by input in the ! options array PRGOPT(*). For many computer systems I1MACH(2)=6. ! ! |-------| ! |Output:| ! |-------| ! ! INFO,PRIMAL(*),DUALS(*) ! ----------------------- ! The integer flag INFO indicates why DSPLP( ) has returned to the ! user. If INFO=1 the solution has been computed. In this case ! X(J)=PRIMAL(J) and W(I)=PRIMAL(I+NVARS). The dual variables ! for the equations A*x=w are in the array DUALS(I)=dual for ! equation number I. The dual value for the component X(J) that ! has an upper or lower bound (or both) is returned in ! DUALS(J+MRELAS). The only other values for INFO are < 0. ! The meaning of these values can be found by reading ! the diagnostic message in the output file, or by looking for ! error number = (-INFO) under the heading "List of DSPLP( ) Error ! and Diagnostic Messages." ! The diagnostic messages are printed using the error processing ! subprogram XERMSG( ) with error category LEVEL=1. ! See the document "Brief Instr. for Using the Sandia Math. ! Subroutine Library," SAND79-2382, Nov., 1980, for further inform- ! ation about resetting the usual response to a diagnostic message. ! ! BL(*),BU(*),IND(*) ! ------------------ ! These arrays are output parameters only under the (unusual) ! circumstances where the stated problem is infeasible, has an ! unbounded optimum value, or both. These respective conditions ! correspond to INFO=-1,-2 or -3. For INFO=-1 or -3 certain comp- ! onents of the vectors x or w will not satisfy the input bounds. ! If component J of X or component I of W does not satisfy its input ! bound because of infeasibility, then IND(J)=-4 or IND(I+NVARS)=-4, ! respectively. For INFO=-2 or -3 certain ! components of the vector x could not be used as basic variables ! because the objective function would have become unbounded. ! In particular if component J of x corresponds to such a variable, ! then IND(J)=-3. Further, if the input value of IND(J) ! =1, then BU(J)=BL(J); ! =2, then BL(J)=BU(J); ! =4, then BL(J)=0.,BU(J)=0. ! ! (The J-th variable in x has been restricted to an appropriate ! feasible value.) ! The negative output value for IND(*) allows the user to identify ! those constraints that are not satisfied or those variables that ! would cause unbounded values of the objective function. Note ! that the absolute value of IND(*), together with BL(*) and BU(*), ! are valid input to DSPLP( ). In the case of infeasibility the ! sum of magnitudes of the infeasible values is minimized. Thus ! one could reenter DSPLP( ) with these components of x or w now ! fixed at their present values. This involves setting ! the appropriate components of IND(*) = 3, and BL(*) = BU(*). ! ! IBASIS(I),I=1,...,MRELAS ! ------------------------ ! This array contains the indices of the variables that are ! in the active basis set at the solution (INFO=1). A value ! of IBASIS(I) between 1 and NVARS corresponds to the variable ! X(IBASIS(I)). A value of IBASIS(I) between NVARS+1 and NVARS+ ! MRELAS corresponds to the variable W(IBASIS(I)-NVARS). ! ! Computing with the Matrix A after Calling DSPLP( ) ! -------------------------------------------------- ! Following the return from DSPLP( ), nonzero entries of the MRELAS ! by NVARS matrix A are available for usage by the user. The method ! for obtaining the next nonzero in column J with a row index ! strictly greater than I in value, is completed by executing ! ! call DPNNZR(I,AIJ,IPLACE,WORK,IWORK,J) ! ! The value of I is also an output parameter. If I <= 0 on output, ! then there are no more nonzeroes in column J. If I > 0, the ! output value for component number I of column J is in AIJ. The ! parameters WORK(*) and IWORK(*) are the same arguments as in the ! call to DSPLP( ). The parameter IPLACE is a single INTEGER ! working variable. ! ! The data structure used for storage of the matrix A within DSPLP() ! corresponds to sequential storage by columns as defined in ! SAND78-0785. Note that the names of the subprograms LNNZRS(), ! LCHNGS(),LINITM(),LLOC(),LRWPGE(), and LRWVIR() have been ! changed to DPNNZR(),DPCHNG(),PINITM(),IPLOC(),DPRWPG(), and ! DPRWVR() respectively. The error processing subprogram LERROR() ! is no longer used; XERMSG() is used instead. ! ! |--------------------------------| ! |Subprograms Required by DSPLP( )| ! |--------------------------------| ! Called by DSPLP() are DPLPMN(),DPLPUP(),DPINIT(),DPOPT(), ! DPLPDM(),DPLPCE(),DPINCW(),DPLPFL(), ! DPLPFE(),DPLPMU(). ! ! Error Processing Subprograms XERMSG(),I1MACH(),D1MACH() ! ! Sparse Matrix Subprograms DPNNZR(),DPCHNG(),DPRWPG(),DPRWVR(), ! PINITM(),IPLOC() ! ! Mass Storage File Subprograms SOPENM(),SCLOSM(),DREADP(),DWRITP() ! ! Basic Linear Algebra Subprograms DCOPY(),DASUM(),DDOT() ! ! Sparse Matrix Basis Handling Subprograms LA05AD(),LA05BD(), ! LA05CD(),LA05ED(),MC20AD() ! ! Vector Output Subprograms DVOUT(),IVOUT() ! ! Machine-sensitive Subprograms I1MACH( ),D1MACH( ), ! SOPENM(),SCLOSM(),DREADP(),DWRITP(). ! COMMON Block Used ! ----------------- ! /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL ! See the document AERE-R8269 for further details. ! |-------------------------| ! |Example of DSPLP( ) Usage| ! |-------------------------| ! PROGRAM LPEX ! THE OPTIMIZATION PROBLEM IS TO FIND X1, X2, X3 THAT ! MINIMIZE X1 + X2 + X3, X1 >= 0, X2 >= 0, X3 UNCONSTRAINED. ! ! THE UNKNOWNS X1,X2,X3 ARE TO SATISFY CONSTRAINTS ! ! X1 -3*X2 +4*X3 = 5 ! X1 -2*X2 <= 3 ! 2*X2 - X3 >= 4 ! ! WE FIRST DEFINE THE DEPENDENT VARIABLES ! W1=X1 -3*X2 +4*X3 ! W2=X1- 2*X2 ! W3= 2*X2 -X3 ! ! WE NOW SHOW HOW TO USE DSPLP( ) TO SOLVE THIS LINEAR OPTIMIZATION ! PROBLEM. EACH REQUIRED STEP WILL BE SHOWN IN THIS EXAMPLE. ! DIMENSION COSTS(03),PRGOPT(01),DATTRV(18),BL(06),BU(06),IND(06), ! *PRIMAL(06),DUALS(06),IBASIS(06),WORK(079),IWORK(103) ! ! EXTERNAL DUSRMT ! MRELAS=3 ! NVARS=3 ! ! DEFINE THE ARRAY COSTS(*) FOR THE OBJECTIVE FUNCTION. ! COSTS(01)=1. ! COSTS(02)=1. ! COSTS(03)=1. ! ! PLACE THE NONZERO INFORMATION ABOUT THE MATRIX IN DATTRV(*). ! DEFINE COL. 1: ! DATTRV(01)=-1 ! DATTRV(02)=1 ! DATTRV(03)=1. ! DATTRV(04)=2 ! DATTRV(05)=1. ! ! DEFINE COL. 2: ! DATTRV(06)=-2 ! DATTRV(07)=1 ! DATTRV(08)=-3. ! DATTRV(09)=2 ! DATTRV(10)=-2. ! DATTRV(11)=3 ! DATTRV(12)=2. ! ! DEFINE COL. 3: ! DATTRV(13)=-3 ! DATTRV(14)=1 ! DATTRV(15)=4. ! DATTRV(16)=3 ! DATTRV(17)=-1. ! ! DATTRV(18)=0 ! ! CONSTRAIN X1,X2 TO BE NONNEGATIVE. LET X3 HAVE NO BOUNDS. ! BL(1)=0. ! IND(1)=1 ! BL(2)=0. ! IND(2)=1 ! IND(3)=4 ! ! CONSTRAIN W1=5,W2 <= 3, AND W3 >= 4. ! BL(4)=5. ! BU(4)=5. ! IND(4)=3 ! BU(5)=3. ! IND(5)=2 ! BL(6)=4. ! IND(6)=1 ! ! INDICATE THAT NO MODIFICATIONS TO OPTIONS ARE IN USE. ! PRGOPT(01)=1 ! ! DEFINE THE WORKING ARRAY LENGTHS. ! LW=079 ! LIW=103 ! call DSPLP(DUSRMT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, ! *BL,BU,IND,INFO,PRIMAL,DUALS,IBASIS,WORK,LW,IWORK,LIW) ! ! CALCULATE VAL, THE MINIMAL VALUE OF THE OBJECTIVE FUNCTION. ! VAL=DDOT(NVARS,COSTS,1,PRIMAL,1) ! ! STOP ! END ! |------------------------| ! |End of Example of Usage | ! |------------------------| ! ! |-------------------------------------| ! |Usage of DSPLP( ) Subprogram Options.| ! |-------------------------------------| ! ! Users frequently have a large variety of requirements for linear ! optimization software. Allowing for these varied requirements ! is at cross purposes with the desire to keep the usage of DSPLP( ) ! as simple as possible. One solution to this dilemma is as follows. ! (1) Provide a version of DSPLP( ) that solves a wide class of ! problems and is easy to use. (2) Identify parameters within ! DSPLP() that certain users may want to change. (3) Provide a ! means of changing any selected number of these parameters that ! does not require changing all of them. ! ! Changing selected parameters is done by requiring ! that the user provide an option array, PRGOPT(*), to DSPLP( ). ! The contents of PRGOPT(*) inform DSPLP( ) of just those options ! that are going to be modified within the total set of possible ! parameters that can be modified. The array PRGOPT(*) is a linked ! list consisting of groups of data of the following form ! ! LINK ! KEY ! SWITCH ! data set ! ! that describe the desired options. The parameters LINK, KEY and ! switch are each one word and are always required. The data set ! can be comprised of several words or can be empty. The number of ! words in the data set for each option depends on the value of ! the parameter KEY. ! ! The value of LINK points to the first entry of the next group ! of data within PRGOPT(*). The exception is when there are no more ! options to change. In that case, LINK=1 and the values for KEY, ! SWITCH and data set are not referenced. The general layout of ! PRGOPT(*) is as follows: ! ...PRGOPT(1)=LINK1 (link to first entry of next group) ! . PRGOPT(2)=KEY1 (KEY to the option change) ! . PRGOPT(3)=SWITCH1 (on/off switch for the option) ! . PRGOPT(4)=data value ! . . ! . . ! . . ! ...PRGOPT(LINK1)=LINK2 (link to first entry of next group) ! . PRGOPT(LINK1+1)=KEY2 (KEY to option change) ! . PRGOPT(LINK1+2)=SWITCH2 (on/off switch for the option) ! . PRGOPT(LINK1+3)=data value ! ... . ! . . ! . . ! ...PRGOPT(LINK)=1 (no more options to change) ! ! A value of LINK that is <= 0 or > 10000 is an error. ! In this case DSPLP( ) returns with an error message, INFO=-14. ! This helps prevent using invalid but positive values of LINK that ! will probably extend beyond the program limits of PRGOPT(*). ! Unrecognized values of KEY are ignored. If the value of SWITCH is ! zero then the option is turned off. For any other value of SWITCH ! the option is turned on. This is used to allow easy changing of ! options without rewriting PRGOPT(*). The order of the options is ! arbitrary and any number of options can be changed with the ! following restriction. To prevent cycling in processing of the ! option array PRGOPT(*), a count of the number of options changed ! is maintained. Whenever this count exceeds 1000 an error message ! (INFO=-15) is printed and the subprogram returns. ! ! In the following description of the options, the value of ! LATP indicates the amount of additional storage that a particular ! option requires. The sum of all of these values (plus one) is ! the minimum dimension for the array PRGOPT(*). ! ! If a user is satisfied with the nominal form of DSPLP( ), ! set PRGOPT(1)=1 (or PRGOPT(1)=1.D0). ! ! Options: ! ! -----KEY = 50. Change from a minimization problem to a maximization ! problem. ! If SWITCH=0 option is off; solve minimization problem. ! =1 option is on; solve maximization problem. ! data set =empty ! LATP=3 ! ! -----KEY = 51. Change the amount of printed output. The nominal form ! of DSPLP( ) has no printed output. ! The first level of output (SWITCH=1) includes ! ! (1) Minimum dimensions for the arrays COSTS(*),BL(*),BU(*),IND(*), ! PRIMAL(*),DUALS(*),IBASIS(*), and PRGOPT(*). ! (2) Problem dimensions MRELAS,NVARS. ! (3) The types of and values for the bounds on x and w, ! and the values of the components of the vector costs. ! (4) Whether optimization problem is minimization or ! maximization. ! (5) Whether steepest edge or smallest reduced cost criteria used ! for exchanging variables in the revised simplex method. ! ! Whenever a solution has been found, (INFO=1), ! ! (6) the value of the objective function, ! (7) the values of the vectors x and w, ! (8) the dual variables for the constraints A*x=w and the ! bounded components of x, ! (9) the indices of the basic variables, ! (10) the number of revised simplex method iterations, ! (11) the number of full decompositions of the basis matrix. ! ! The second level of output (SWITCH=2) includes all for SWITCH=1 ! plus ! ! (12) the iteration number, ! (13) the column number to enter the basis, ! (14) the column number to leave the basis, ! (15) the length of the step taken. ! ! The third level of output (SWITCH=3) includes all for SWITCH=2 ! plus ! (16) critical quantities required in the revised simplex method. ! This output is rather voluminous. It is intended to be used ! as a diagnostic tool in case of a failure in DSPLP( ). ! ! If SWITCH=0 option is off; no printed output. ! =1 summary output. ! =2 lots of output. ! =3 even more output. ! data set =empty ! LATP=3 ! ! -----KEY = 52. Redefine the parameter, IDIGIT, which determines the ! format and precision used for the printed output. In the printed ! output, at least ABS(IDIGIT) decimal digits per number is ! printed. If IDIGIT < 0, 72 printing columns are used. If ! IDIGIT > 0, 133 printing columns are used. ! If SWITCH=0 option is off; IDIGIT=-4. ! =1 option is on. ! data set =IDIGIT ! LATP=4 ! ! -----KEY = 53. Redefine LAMAT and LBM, the lengths of the portions of ! WORK(*) and IWORK(*) that are allocated to the sparse matrix ! storage and the sparse linear equation solver, respectively. ! LAMAT must be >= NVARS+7 and LBM must be positive. ! If SWITCH=0 option is off; LAMAT=4*NVARS+7 ! LBM =8*MRELAS. ! =1 option is on. ! data set =LAMAT ! LBM ! LATP=5 ! ! -----KEY = 54. Redefine IPAGEF, the file number where the pages of the ! sparse data matrix are stored. IPAGEF must be positive and ! different from ISAVE (see option 56). ! If SWITCH=0 option is off; IPAGEF=1. ! =1 option is on. ! data set =IPAGEF ! LATP=4 ! ! -----KEY = 55. Partial results have been computed and stored on unit ! number ISAVE (see option 56), during a previous run of ! DSPLP( ). This is a continuation from these partial results. ! The arrays COSTS(*),BL(*),BU(*),IND(*) do not have to have ! the same values as they did when the checkpointing occurred. ! This feature makes it possible for the user to do certain ! types of parameter studies such as changing costs and varying ! the constraints of the problem. This file is rewound both be- ! fore and after reading the partial results. ! If SWITCH=0 option is off; start a new problem. ! =1 option is on; continue from partial results ! that are stored in file ISAVE. ! data set = empty ! LATP=3 ! ! -----KEY = 56. Redefine ISAVE, the file number where the partial ! results are stored (see option 57). ISAVE must be positive and ! different from IPAGEF (see option 54). ! If SWITCH=0 option is off; ISAVE=2. ! =1 option is on. ! data set =ISAVE ! LATP=4 ! ! -----KEY = 57. Save the partial results after maximum number of ! iterations, MAXITR, or at the optimum. When this option is on, ! data essential to continuing the calculation is saved on a file ! using a Fortran binary write operation. The data saved includes ! all the information about the sparse data matrix A. Also saved ! is information about the current basis. Nominally the partial ! results are saved on Fortran unit 2. This unit number can be ! redefined (see option 56). If the save option is on, ! this file must be opened (or declared) by the user prior to the ! call to DSPLP( ). A crude upper bound for the number of words ! written to this file is 6*nz. Here nz= number of nonzeros in A. ! If SWITCH=0 option is off; do not save partial results. ! =1 option is on; save partial results. ! data set = empty ! LATP=3 ! ! -----KEY = 58. Redefine the maximum number of iterations, MAXITR, to ! be taken before returning to the user. ! If SWITCH=0 option is off; MAXITR=3*(NVARS+MRELAS). ! =1 option is on. ! data set =MAXITR ! LATP=4 ! ! -----KEY = 59. Provide DSPLP( ) with exactly MRELAS indices which ! comprise a feasible, nonsingular basis. The basis must define a ! feasible point: values for x and w such that A*x=w and all the ! stated bounds on x and w are satisfied. The basis must also be ! nonsingular. The failure of either condition will cause an error ! message (INFO=-23 or =-24, respectively). Normally, DSPLP( ) uses ! identity matrix columns which correspond to the components of w. ! This option would normally not be used when restarting from ! a previously saved run (KEY=57). ! In numbering the unknowns, ! the components of x are numbered (1-NVARS) and the components ! of w are numbered (NVARS+1)-(NVARS+MRELAS). A value for an ! index <= 0 or > (NVARS+MRELAS) is an error (INFO=-16). ! If SWITCH=0 option is off; DSPLP( ) chooses the initial basis. ! =1 option is on; user provides the initial basis. ! data set =MRELAS indices of basis; order is arbitrary. ! LATP=MRELAS+3 ! ! -----KEY = 60. Provide the scale factors for the columns of the data ! matrix A. Normally, DSPLP( ) computes the scale factors as the ! reciprocals of the max. norm of each column. ! If SWITCH=0 option is off; DSPLP( ) computes the scale factors. ! =1 option is on; user provides the scale factors. ! data set =scaling for column J, J=1,NVARS; order is sequential. ! LATP=NVARS+3 ! ! -----KEY = 61. Provide a scale factor, COSTSC, for the vector of ! costs. Normally, DSPLP( ) computes this scale factor to be the ! reciprocal of the max. norm of the vector costs after the column ! scaling has been applied. ! If SWITCH=0 option is off; DSPLP( ) computes COSTSC. ! =1 option is on; user provides COSTSC. ! data set =COSTSC ! LATP=4 ! ! -----KEY = 62. Provide size parameters, ASMALL and ABIG, the smallest ! and largest magnitudes of nonzero entries in the data matrix A, ! respectively. When this option is on, DSPLP( ) will check the ! nonzero entries of A to see if they are in the range of ASMALL and ! ABIG. If an entry of A is not within this range, DSPLP( ) returns ! an error message, INFO=-22. Both ASMALL and ABIG must be positive ! with ASMALL <= ABIG. Otherwise, an error message is returned, ! INFO=-17. ! If SWITCH=0 option is off; no checking of the data matrix is done ! =1 option is on; checking is done. ! data set =ASMALL ! ABIG ! LATP=5 ! ! -----KEY = 63. Redefine the relative tolerance, TOLLS, used in ! checking if the residuals are feasible. Normally, ! TOLLS=RELPR, where RELPR is the machine precision. ! If SWITCH=0 option is off; TOLLS=RELPR. ! =1 option is on. ! data set =TOLLS ! LATP=4 ! ! -----KEY = 64. Use the minimum reduced cost pricing strategy to choose ! columns to enter the basis. Normally, DSPLP( ) uses the steepest ! edge pricing strategy which is the best local move. The steepest ! edge pricing strategy generally uses fewer iterations than the ! minimum reduced cost pricing, but each iteration costs more in the ! number of calculations done. The steepest edge pricing is ! considered to be more efficient. However, this is very problem ! dependent. That is why DSPLP( ) provides the option of either ! pricing strategy. ! If SWITCH=0 option is off; steepest option edge pricing is used. ! =1 option is on; minimum reduced cost pricing is used. ! data set =empty ! LATP=3 ! ! -----KEY = 65. Redefine MXITBR, the number of iterations between ! recalculating the error in the primal solution. Normally, MXITBR ! is set to 10. The error in the primal solution is used to monitor ! the error in solving the linear system. This is an expensive ! calculation and every tenth iteration is generally often enough. ! If SWITCH=0 option is off; MXITBR=10. ! =1 option is on. ! data set =MXITBR ! LATP=4 ! ! -----KEY = 66. Redefine NPP, the number of negative reduced costs ! (at most) to be found at each iteration of choosing ! a variable to enter the basis. Normally NPP is set ! to NVARS which implies that all of the reduced costs ! are computed at each such step. This "partial ! pricing" may very well increase the total number ! of iterations required. However it decreases the ! number of calculations at each iteration. ! therefore the effect on overall efficiency is quite ! problem-dependent. ! ! if SWITCH=0 option is off; NPP=NVARS ! =1 option is on. ! data set =NPP ! LATP=4 ! ! -----KEY = 67. Redefine the tuning factor (PHI) used to scale the ! error estimates for the primal and dual linear algebraic systems ! of equations. Normally, PHI = 1.D0, but in some environments it ! may be necessary to reset PHI to the range 0.001-0.01. This is ! particularly important for machines with short word lengths. ! ! if SWITCH = 0 option is off; PHI=1.D0. ! = 1 option is on. ! Data Set = PHI ! LATP=4 ! ! -----KEY = 68. Used together with the subprogram DFULMT(), provided ! with the DSPLP() package, for passing a standard Fortran two- ! dimensional array containing the constraint matrix. Thus the sub- ! program DFULMT must be declared in a Fortran EXTERNAL statement. ! The two-dimensional array is passed as the argument DATTRV. ! The information about the array and problem dimensions are passed ! in the option array PRGOPT(*). It is an error if DFULMT() is ! used and this information is not passed in PRGOPT(*). ! ! if SWITCH = 0 option is off; this is an error is DFULMT() is ! used. ! = 1 option is on. ! Data Set = IA = row dimension of two-dimensional array. ! MRELAS = number of constraint equations. ! NVARS = number of dependent variables. ! LATP = 6 ! -----KEY = 69. Normally a relative tolerance (TOLLS, see option 63) ! is used to decide if the problem is feasible. If this test fails ! an absolute test will be applied using the value TOLABS. ! Nominally TOLABS = zero. ! If SWITCH = 0 option is off; TOLABS = zero. ! = 1 option is on. ! Data set = TOLABS ! LATP = 4 ! ! |-----------------------------| ! |Example of Option array Usage| ! |-----------------------------| ! To illustrate the usage of the option array, let us suppose that ! the user has the following nonstandard requirements: ! ! a) Wants to change from minimization to maximization problem. ! b) Wants to limit the number of simplex steps to 100. ! c) Wants to save the partial results after 100 steps on ! Fortran unit 2. ! ! After these 100 steps are completed the user wants to continue the ! problem (until completed) using the partial results saved on ! Fortran unit 2. Here are the entries of the array PRGOPT(*) ! that accomplish these tasks. (The definitions of the other ! required input parameters are not shown.) ! ! CHANGE TO A MAXIMIZATION PROBLEM; KEY=50. ! PRGOPT(01)=4 ! PRGOPT(02)=50 ! PRGOPT(03)=1 ! ! LIMIT THE NUMBER OF SIMPLEX STEPS TO 100; KEY=58. ! PRGOPT(04)=8 ! PRGOPT(05)=58 ! PRGOPT(06)=1 ! PRGOPT(07)=100 ! ! SAVE THE PARTIAL RESULTS, AFTER 100 STEPS, ON FORTRAN ! UNIT 2; KEY=57. ! PRGOPT(08)=11 ! PRGOPT(09)=57 ! PRGOPT(10)=1 ! ! NO MORE OPTIONS TO CHANGE. ! PRGOPT(11)=1 ! The user makes the call statement for DSPLP( ) at this point. ! Now to restart, using the partial results after 100 steps, define ! new values for the array PRGOPT(*): ! ! AGAIN INFORM DSPLP( ) THAT THIS IS A MAXIMIZATION PROBLEM. ! PRGOPT(01)=4 ! PRGOPT(02)=50 ! PRGOPT(03)=1 ! ! RESTART, USING SAVED PARTIAL RESULTS; KEY=55. ! PRGOPT(04)=7 ! PRGOPT(05)=55 ! PRGOPT(06)=1 ! ! NO MORE OPTIONS TO CHANGE. THE SUBPROGRAM DSPLP( ) IS NO LONGER ! LIMITED TO 100 SIMPLEX STEPS BUT WILL RUN UNTIL COMPLETION OR ! MAX.=3*(MRELAS+NVARS) ITERATIONS. ! PRGOPT(07)=1 ! The user now makes a call to subprogram DSPLP( ) to compute the ! solution. ! |--------------------------------------------| ! |End of Usage of DSPLP( ) Subprogram Options.| ! |--------------------------------------------| ! ! |-----------------------------------------------| ! |List of DSPLP( ) Error and Diagnostic Messages.| ! |-----------------------------------------------| ! This section may be required to understand the meanings of the ! error flag =-INFO that may be returned from DSPLP( ). ! ! -----1. There is no set of values for x and w that satisfy A*x=w and ! the stated bounds. The problem can be made feasible by ident- ! ifying components of w that are now infeasible and then rede- ! signating them as free variables. Subprogram DSPLP( ) only ! identifies an infeasible problem; it takes no other action to ! change this condition. Message: ! DSPLP( ). THE PROBLEM APPEARS TO BE INFEASIBLE. ! ERROR NUMBER = 1 ! ! 2. One of the variables in either the vector x or w was con- ! strained at a bound. Otherwise the objective function value, ! (transpose of costs)*x, would not have a finite optimum. ! Message: ! DSPLP( ). THE PROBLEM APPEARS TO HAVE NO FINITE SOLN. ! ERROR NUMBER = 2 ! ! 3. Both of the conditions of 1. and 2. above have occurred. ! Message: ! DSPLP( ). THE PROBLEM APPEARS TO BE INFEASIBLE AND TO ! HAVE NO FINITE SOLN. ! ERROR NUMBER = 3 ! ! -----4. The REAL and INTEGER working arrays, WORK(*) and IWORK(*), ! are not long enough. The values (I1) and (I2) in the message ! below will give you the minimum length required. Also redefine ! LW and LIW, the lengths of these arrays. Message: ! DSPLP( ). WORK OR IWORK IS NOT LONG ENOUGH. LW MUST BE (I1) ! AND LIW MUST BE (I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 0 ! ERROR NUMBER = 4 ! ! -----5. and 6. These error messages often mean that one or more ! arguments were left out of the call statement to DSPLP( ) or ! that the values of MRELAS and NVARS have been over-written ! by garbage. Messages: ! DSPLP( ). VALUE OF MRELAS MUST BE > 0. NOW=(I1). ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 5 ! ! DSPLP( ). VALUE OF NVARS MUST BE > 0. NOW=(I1). ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 6 ! ! -----7.,8., and 9. These error messages can occur as the data matrix ! is being defined by either DUSRMT( ) or the user-supplied sub- ! program, 'NAME'( ). They would indicate a mistake in the contents ! of DATTRV(*), the user-written subprogram or that data has been ! over-written. ! Messages: ! DSPLP( ). MORE THAN 2*NVARS*MRELAS ITERS. DEFINING OR UPDATING ! MATRIX DATA. ! ERROR NUMBER = 7 ! ! DSPLP( ). ROW INDEX (I1) OR COLUMN INDEX (I2) IS OUT OF RANGE. ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 12 ! ERROR NUMBER = 8 ! ! DSPLP( ). INDICATION FLAG (I1) FOR MATRIX DATA MUST BE ! EITHER 0 OR 1. ! IN ABOVE MESSAGE, I1= 12 ! ERROR NUMBER = 9 ! ! -----10. and 11. The type of bound (even no bound) and the bounds ! must be specified for each independent variable. If an independent ! variable has both an upper and lower bound, the bounds must be ! consistent. The lower bound must be <= the upper bound. ! Messages: ! DSPLP( ). INDEPENDENT VARIABLE (I1) IS NOT DEFINED. ! IN ABOVE MESSAGE, I1= 1 ! ERROR NUMBER = 10 ! ! DSPLP( ). LOWER BOUND (R1) AND UPPER BOUND (R2) FOR INDEP. ! VARIABLE (I1) ARE NOT CONSISTENT. ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, R1= 0. ! IN ABOVE MESSAGE, R2= -.1000000000E+01 ! ERROR NUMBER = 11 ! ! -----12. and 13. The type of bound (even no bound) and the bounds ! must be specified for each dependent variable. If a dependent ! variable has both an upper and lower bound, the bounds must be ! consistent. The lower bound must be <= the upper bound. ! Messages: ! DSPLP( ). DEPENDENT VARIABLE (I1) IS NOT DEFINED. ! IN ABOVE MESSAGE, I1= 1 ! ERROR NUMBER = 12 ! ! DSPLP( ). LOWER BOUND (R1) AND UPPER BOUND (R2) FOR DEP. ! VARIABLE (I1) ARE NOT CONSISTENT. ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, R1= 0. ! IN ABOVE MESSAGE, R2= -.1000000000E+01 ! ERROR NUMBER = 13 ! ! -----14. - 21. These error messages can occur when processing the ! option array, PRGOPT(*), supplied by the user. They would ! indicate a mistake in defining PRGOPT(*) or that data has been ! over-written. See heading Usage of DSPLP( ) ! Subprogram Options, for details on how to define PRGOPT(*). ! Messages: ! DSPLP( ). THE USER OPTION ARRAY HAS UNDEFINED DATA. ! ERROR NUMBER = 14 ! ! DSPLP( ). OPTION ARRAY PROCESSING IS CYCLING. ! ERROR NUMBER = 15 ! ! DSPLP( ). AN INDEX OF USER-SUPPLIED BASIS IS OUT OF RANGE. ! ERROR NUMBER = 16 ! ! DSPLP( ). SIZE PARAMETERS FOR MATRIX MUST BE SMALLEST AND LARGEST ! MAGNITUDES OF NONZERO ENTRIES. ! ERROR NUMBER = 17 ! ! DSPLP( ). THE NUMBER OF REVISED SIMPLEX STEPS BETWEEN CHECK-POINTS ! MUST BE POSITIVE. ! ERROR NUMBER = 18 ! ! DSPLP( ). FILE NUMBERS FOR SAVED DATA AND MATRIX PAGES MUST BE ! POSITIVE AND NOT EQUAL. ! ERROR NUMBER = 19 ! ! DSPLP( ). USER-DEFINED VALUE OF LAMAT (I1) ! MUST BE >= NVARS+7. ! IN ABOVE MESSAGE, I1= 1 ! ERROR NUMBER = 20 ! ! DSPLP( ). USER-DEFINED VALUE OF LBM MUST BE >= 0. ! ERROR NUMBER = 21 ! ! -----22. The user-option, number 62, to check the size of the matrix ! data has been used. An element of the matrix does not lie within ! the range of ASMALL and ABIG, parameters provided by the user. ! (See the heading: Usage of DSPLP( ) Subprogram Options, ! for details about this feature.) Message: ! DSPLP( ). A MATRIX ELEMENT'S SIZE IS OUT OF THE SPECIFIED RANGE. ! ERROR NUMBER = 22 ! ! -----23. The user has provided an initial basis that is singular. ! In this case, the user can remedy this problem by letting ! subprogram DSPLP( ) choose its own initial basis. Message: ! DSPLP( ). A SINGULAR INITIAL BASIS WAS ENCOUNTERED. ! ERROR NUMBER = 23 ! ! -----24. The user has provided an initial basis which is infeasible. ! The x and w values it defines do not satisfy A*x=w and the stated ! bounds. In this case, the user can let subprogram DSPLP( ) ! choose its own initial basis. Message: ! DSPLP( ). AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED. ! ERROR NUMBER = 24 ! ! -----25.Subprogram DSPLP( ) has completed the maximum specified number ! of iterations. (The nominal maximum number is 3*(MRELAS+NVARS).) ! The results, necessary to continue on from ! this point, can be saved on Fortran unit 2 by activating option ! KEY=57. If the user anticipates continuing the calculation, then ! the contents of Fortran unit 2 must be retained intact. This ! is not done by subprogram DSPLP( ), so the user needs to save unit ! 2 by using the appropriate system commands. Message: ! DSPLP( ). MAX. ITERS. (I1) TAKEN. UP-TO-DATE RESULTS ! SAVED ON FILE (I2). if ( I2)=0, NO SAVE. ! IN ABOVE MESSAGE, I1= 500 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 25 ! ! -----26. This error should never happen. Message: ! DSPLP( ). MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN. ! ERROR NUMBER = 26 ! ! -----27. The subprogram LA05A( ), which decomposes the basis matrix, ! has returned with an error flag (R1). (See the document, ! "Fortran subprograms for handling sparse linear programming ! bases", AERE-R8269, J.K. Reid, Jan., 1976, H.M. Stationery Office, ! for an explanation of this error.) Message: ! DSPLP( ). LA05A( ) RETURNED ERROR FLAG (R1) BELOW. ! IN ABOVE MESSAGE, R1= -.5000000000E+01 ! ERROR NUMBER = 27 ! ! -----28. The sparse linear solver package, LA05*( ), requires more ! space. The value of LBM must be increased. See the companion ! document, Usage of DSPLP( ) Subprogram Options, for details on how ! to increase the value of LBM. Message: ! DSPLP( ). SHORT ON STORAGE FOR LA05*( ) PACKAGE. USE PRGOPT(*) ! TO GIVE MORE. ! ERROR NUMBER = 28 ! ! -----29. The row dimension of the two-dimensional Fortran array, ! the number of constraint equations (MRELAS), and the number ! of variables (NVARS), were not passed to the subprogram ! DFULMT(). See KEY = 68 for details. Message: ! DFULMT() OF DSPLP() PACKAGE. ROW DIM., MRELAS, NVARS ARE ! MISSING FROM PRGOPT(*). ! ERROR NUMBER = 29 ! ! |-------------------------------------------------------| ! |End of List of DSPLP( ) Error and Diagnostic Messages. | ! |-------------------------------------------------------| !***REFERENCES R. J. Hanson and K. L. Hiebert, A sparse linear ! programming subprogram, Report SAND81-0297, Sandia ! National Laboratories, 1981. !***ROUTINES CALLED DPLPMN, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Corrected references to XERRWV. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSPLP DOUBLE PRECISION BL(*),BU(*),COSTS(*),DATTRV(*),DUALS(*), & PRGOPT(*),PRIMAL(*),WORK(*),ZERO ! INTEGER IBASIS(*),IND(*),IWORK(*) CHARACTER*8 XERN1, XERN2 ! EXTERNAL DUSRMT ! !***FIRST EXECUTABLE STATEMENT DSPLP ZERO=0.D0 IOPT=1 ! ! VERIFY THAT MRELAS, NVARS > 0. ! if (MRELAS <= 0) THEN WRITE (XERN1, '(I8)') MRELAS call XERMSG ('SLATEC', 'DSPLP', 'VALUE OF MRELAS MUST BE ' // & ' > 0. NOW = ' // XERN1, 5, 1) INFO = -5 return end if ! if (NVARS <= 0) THEN WRITE (XERN1, '(I8)') NVARS call XERMSG ('SLATEC', 'DSPLP', 'VALUE OF NVARS MUST BE ' // & ' > 0. NOW = ' // XERN1, 6, 1) INFO = -6 return end if ! LMX=4*NVARS+7 LBM=8*MRELAS LAST = 1 IADBIG=10000 ICTMAX=1000 ICTOPT= 0 ! ! LOOK IN OPTION ARRAY FOR CHANGES TO WORK ARRAY LENGTHS. 20008 NEXT=PRGOPT(LAST) if (.NOT.(NEXT <= 0 .OR. NEXT > IADBIG)) go to 20010 ! ! THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT ! WORKING WITH UNDEFINED DATA. NERR=14 call XERMSG ('SLATEC', 'DSPLP', & 'THE USER OPTION ARRAY HAS UNDEFINED DATA.', NERR, IOPT) INFO=-NERR return 20010 if (.NOT.(NEXT == 1)) go to 10001 go to 20009 10001 if (.NOT.(ICTOPT > ICTMAX)) go to 10002 NERR=15 call XERMSG ('SLATEC', 'DSPLP', & 'OPTION ARRAY PROCESSING IS CYCLING.', NERR, IOPT) INFO=-NERR return 10002 CONTINUE KEY = PRGOPT(LAST+1) ! ! if KEY = 53, USER MAY SPECIFY LENGTHS OF PORTIONS ! OF WORK(*) AND IWORK(*) THAT ARE ALLOCATED TO THE ! SPARSE MATRIX STORAGE AND SPARSE LINEAR EQUATION ! SOLVING. if (.NOT.(KEY == 53)) go to 20013 if (.NOT.(PRGOPT(LAST+2) /= ZERO)) go to 20016 LMX=PRGOPT(LAST+3) LBM=PRGOPT(LAST+4) 20016 CONTINUE 20013 ICTOPT = ICTOPT+1 LAST = NEXT go to 20008 ! ! CHECK LENGTH VALIDITY OF SPARSE MATRIX STAGING AREA. ! 20009 if (LMX < NVARS+7) THEN WRITE (XERN1, '(I8)') LMX call XERMSG ('SLATEC', 'DSPLP', 'USER-DEFINED VALUE OF ' // & 'LAMAT = ' // XERN1 // ' MUST BE >= NVARS+7.', 20, 1) INFO = -20 return end if ! ! TRIVIAL CHECK ON LENGTH OF LA05*() MATRIX AREA. ! if (.NOT.(LBM < 0)) go to 20022 NERR=21 call XERMSG ('SLATEC', 'DSPLP', & 'USER-DEFINED VALUE OF LBM MUST BE >= 0.', NERR, IOPT) INFO=-NERR return 20022 CONTINUE ! ! DEFINE POINTERS FOR STARTS OF SUBARRAYS USED IN WORK(*) ! AND IWORK(*) IN OTHER SUBPROGRAMS OF THE PACKAGE. LAMAT=1 LCSC=LAMAT+LMX LCOLNR=LCSC+NVARS LERD=LCOLNR+NVARS LERP=LERD+MRELAS LBASMA=LERP+MRELAS LWR=LBASMA+LBM LRZ=LWR+MRELAS LRG=LRZ+NVARS+MRELAS LRPRIM=LRG+NVARS+MRELAS LRHS=LRPRIM+MRELAS LWW=LRHS+MRELAS LWORK=LWW+MRELAS-1 LIMAT=1 LIBB=LIMAT+LMX LIBRC=LIBB+NVARS+MRELAS LIPR=LIBRC+2*LBM LIWR=LIPR+2*MRELAS LIWORK=LIWR+8*MRELAS-1 ! ! CHECK ARRAY LENGTH VALIDITY OF WORK(*), IWORK(*). ! if (LW < LWORK .OR. LIW < LIWORK) THEN WRITE (XERN1, '(I8)') LWORK WRITE (XERN2, '(I8)') LIWORK call XERMSG ('SLATEC', 'DSPLP', 'WORK OR IWORK IS NOT LONG ' // & 'ENOUGH. LW MUST BE = ' // XERN1 // ' AND LIW MUST BE = ' // & XERN2, 4, 1) INFO = -4 return end if ! call DPLPMN(DUSRMT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, & BL,BU,IND,INFO,PRIMAL,DUALS,WORK(LAMAT), & WORK(LCSC),WORK(LCOLNR),WORK(LERD),WORK(LERP),WORK(LBASMA), & WORK(LWR),WORK(LRZ),WORK(LRG),WORK(LRPRIM),WORK(LRHS), & WORK(LWW),LMX,LBM,IBASIS,IWORK(LIBB),IWORK(LIMAT), & IWORK(LIBRC),IWORK(LIPR),IWORK(LIWR)) ! ! call DPLPMN(DUSRMT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, ! 1 BL,BU,IND,INFO,PRIMAL,DUALS,AMAT, ! 2 CSC,COLNRM,ERD,ERP,BASMAT, ! 3 WR,RZ,RG,RPRIM,RHS, ! 4 WW,LMX,LBM,IBASIS,IBB,IMAT, ! 5 IBRC,IPR,IWR) ! return end subroutine DSPMV (UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) ! !! DSPMV performs the matrix-vector operation y := alpha*A*x + beta*y. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (SSPMV-S, DSPMV-D, CSPMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DSPMV performs the matrix-vector operation ! ! y := alpha*A*x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! A is an n by n symmetric matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the matrix A is supplied in the packed ! array AP as follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! supplied in AP. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! supplied in AP. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! AP - DOUBLE PRECISION array of DIMENSION at least ! ( ( n*( n + 1))/2). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - DOUBLE PRECISION. ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. On exit, Y is overwritten by the updated ! vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DSPMV ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, N CHARACTER*1 UPLO ! .. Array Arguments .. DOUBLE PRECISION AP( * ), X( * ), Y( * ) ! .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA !***FIRST EXECUTABLE STATEMENT DSPMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 6 ELSE if ( INCY == 0 )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'DSPMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set up the start points in X and Y. ! if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return KK = 1 if ( LSAME( UPLO, 'U' ) )THEN ! ! Form y when AP contains the upper triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO K = KK DO 50, I = 1, J - 1 Y( I ) = Y( I ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( I ) K = K + 1 50 CONTINUE Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 KK = KK + J 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY DO 70, K = KK, KK + J - 2 Y( IY ) = Y( IY ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY KK = KK + J 80 CONTINUE end if ELSE ! ! Form y when AP contains the lower triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*AP( KK ) K = KK + 1 DO 90, I = J + 1, N Y( I ) = Y( I ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( I ) K = K + 1 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 KK = KK + ( N - J + 1 ) 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*AP( KK ) IX = JX IY = JY DO 110, K = KK + 1, KK + N - J IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY KK = KK + ( N - J + 1 ) 120 CONTINUE end if end if ! return ! ! End of DSPMV . ! end subroutine DSPR2 (UPLO, N, ALPHA, X, INCX, Y, INCY, AP) ! !! DSPR2 performs a symmetric rank 2 operation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (SSPR2-S, DSPR2-D, CSPR2-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DSPR2 performs the symmetric rank 2 operation ! ! A := alpha*x*y' + alpha*y*x' + A, ! ! where alpha is a scalar, x and y are n element vectors and A is an ! n by n symmetric matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the matrix A is supplied in the packed ! array AP as follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! supplied in AP. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! supplied in AP. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! Y - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. ! Unchanged on exit. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! ! AP - DOUBLE PRECISION array of DIMENSION at least ! ( ( n*( n + 1 ) )/2 ). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. On exit, the array ! AP is overwritten by the upper triangular part of the ! updated matrix. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. On exit, the array ! AP is overwritten by the lower triangular part of the ! updated matrix. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DSPR2 ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, INCY, N CHARACTER*1 UPLO ! .. Array Arguments .. DOUBLE PRECISION AP( * ), X( * ), Y( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA !***FIRST EXECUTABLE STATEMENT DSPR2 ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( INCY == 0 )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'DSPR2 ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ( ( INCX /= 1 ).OR.( INCY /= 1 ) )THEN if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if JX = KX JY = KY end if ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! KK = 1 if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when upper triangle is stored in AP. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 20, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) K = KK DO 10, I = 1, J AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 K = K + 1 10 CONTINUE end if KK = KK + J 20 CONTINUE ELSE DO 40, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = KX IY = KY DO 30, K = KK, KK + J - 1 AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE end if JX = JX + INCX JY = JY + INCY KK = KK + J 40 CONTINUE end if ELSE ! ! Form A when lower triangle is stored in AP. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) K = KK DO 50, I = J, N AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 K = K + 1 50 CONTINUE end if KK = KK + N - J + 1 60 CONTINUE ELSE DO 80, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = JX IY = JY DO K = KK, KK + N - J AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY end do end if JX = JX + INCX JY = JY + INCY KK = KK + N - J + 1 80 CONTINUE end if end if return end subroutine DSPR (UPLO, N, ALPHA, X, INCX, AP) ! !! DSPR performs a symmetric rank 1 operation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (DSPR-D) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DSPR performs the symmetric rank 1 operation ! ! A := alpha*x*x' + A, ! ! where alpha is a real scalar, x is an n element vector and A is an ! n by n symmetric matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the matrix A is supplied in the packed ! array AP as follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! supplied in AP. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! supplied in AP. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! AP - DOUBLE PRECISION array of DIMENSION at least ! ( ( n*( n + 1 ) )/2 ). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. On exit, the array ! AP is overwritten by the upper triangular part of the ! updated matrix. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. On exit, the array ! AP is overwritten by the lower triangular part of the ! updated matrix. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DSPR ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, N CHARACTER*1 UPLO ! .. Array Arguments .. DOUBLE PRECISION AP( * ), X( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA !***FIRST EXECUTABLE STATEMENT DSPR ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 end if if ( INFO /= 0 )THEN call XERBLA( 'DSPR ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Set the start point in X if the increment is not unity. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! KK = 1 if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when upper triangle is stored in AP. ! if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*X( J ) K = KK DO 10, I = 1, J AP( K ) = AP( K ) + X( I )*TEMP K = K + 1 10 CONTINUE end if KK = KK + J 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IX = KX DO 30, K = KK, KK + J - 1 AP( K ) = AP( K ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE end if JX = JX + INCX KK = KK + J 40 CONTINUE end if ELSE ! ! Form A when lower triangle is stored in AP. ! if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*X( J ) K = KK DO 50, I = J, N AP( K ) = AP( K ) + X( I )*TEMP K = K + 1 50 CONTINUE end if KK = KK + N - J + 1 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IX = JX DO 70, K = KK, KK + N - J AP( K ) = AP( K ) + X( IX )*TEMP IX = IX + INCX 70 CONTINUE end if JX = JX + INCX KK = KK + N - J + 1 80 CONTINUE end if end if ! return ! ! End of DSPR . ! end subroutine DSPSL (AP, N, KPVT, B) ! !! DSPSL solves a real symmetric system using the factors obtained from DSPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE DOUBLE PRECISION (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! DSISL solves the double precision symmetric system ! A * X = B ! using the factors computed by DSPFA. ! ! On Entry ! ! AP DOUBLE PRECISION(N*(N+1)/2) ! the output from DSPFA. ! ! N INTEGER ! the order of the matrix A . ! ! KPVT INTEGER(N) ! the pivot vector from DSPFA. ! ! B DOUBLE PRECISION(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero may occur if DSPCO has set RCOND == 0.0 ! or DSPFA has set INFO /= 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call DSPFA(AP,N,KPVT,INFO) ! if (INFO /= 0) go to ... ! DO 10 J = 1, P ! call DSPSL(AP,N,KPVT,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSPSL INTEGER N,KPVT(*) DOUBLE PRECISION AP(*),B(*) ! DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP ! ! LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND ! D INVERSE TO B. ! !***FIRST EXECUTABLE STATEMENT DSPSL K = N IK = (N*(N - 1))/2 10 if (K == 0) go to 80 KK = IK + K if (KPVT(K) < 0) go to 40 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 30 KP = KPVT(K) if (KP == K) go to 20 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call DAXPY(K-1,B(K),AP(IK+1),1,B(1),1) 30 CONTINUE ! ! APPLY D INVERSE. ! B(K) = B(K)/AP(KK) K = K - 1 IK = IK - K go to 70 40 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! IKM1 = IK - (K - 1) if (K == 2) go to 60 KP = ABS(KPVT(K)) if (KP == K - 1) go to 50 ! ! INTERCHANGE. ! TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE ! ! APPLY THE TRANSFORMATION. ! 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 ! ! APPLY D INVERSE. ! 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 ! ! LOOP FORWARD APPLYING THE TRANSFORMATIONS. ! K = 1 IK = 0 90 if (K > N) go to 160 if (KPVT(K) < 0) go to 120 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 110 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + DDOT(K-1,AP(IK+1),1,B(1),1) KP = KPVT(K) if (KP == K) go to 100 ! ! INTERCHANGE. ! 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 ! ! 2 X 2 PIVOT BLOCK. ! if (K == 1) go to 140 ! ! APPLY THE TRANSFORMATION. ! 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 = ABS(KPVT(K)) if (KP == K) go to 130 ! ! INTERCHANGE. ! 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 DSTEPS (DF, NEQN, Y, X, H, EPS, WT, START, HOLD, K, & KOLD, CRASH, PHI, P, YP, PSI, ALPHA, BETA, SIG, V, W, G, & PHASE1, NS, NORND, KSTEPS, TWOU, FOURU, XOLD, KPREV, IVC, IV, & KGI, GI, RPAR, IPAR) ! !! DSTEPS integrates a system of first order ODE's one step. ! !***LIBRARY SLATEC (DEPAC) !***CATEGORY I1A1B !***TYPE DOUBLE PRECISION (STEPS-S, DSTEPS-D) !***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR !***AUTHOR Shampine, L. F., (SNLA) ! Gordon, M. K., (SNLA) ! MODIFIED BY H.A. WATTS !***DESCRIPTION ! ! Written by L. F. Shampine and M. K. Gordon ! ! Abstract ! ! Subroutine DSTEPS is normally used indirectly through subroutine ! DDEABM . Because DDEABM suffices for most problems and is much ! easier to use, using it should be considered before using DSTEPS ! alone. ! ! Subroutine DSTEPS integrates a system of NEQN first order ordinary ! differential equations one step, normally from X to X+H, using a ! modified divided difference form of the Adams Pece formulas. Local ! extrapolation is used to improve absolute stability and accuracy. ! The code adjusts its order and step size to control the local error ! per unit step in a generalized sense. Special devices are included ! to control roundoff error and to detect when the user is requesting ! too much accuracy. ! ! This code is completely explained and documented in the text, ! Computer Solution of Ordinary Differential Equations, The Initial ! Value Problem by L. F. Shampine and M. K. Gordon. ! Further details on use of this code are available in "Solving ! Ordinary Differential Equations with ODE, STEP, and INTRP", ! by L. F. Shampine and M. K. Gordon, SLA-73-1060. ! ! ! The parameters represent -- ! DF -- subroutine to evaluate derivatives ! NEQN -- number of equations to be integrated ! Y(*) -- solution vector at X ! X -- independent variable ! H -- appropriate step size for next step. Normally determined by ! code ! EPS -- local error tolerance ! WT(*) -- vector of weights for error criterion ! START -- logical variable set .TRUE. for first step, .FALSE. ! otherwise ! HOLD -- step size used for last successful step ! K -- appropriate order for next step (determined by code) ! KOLD -- order used for last successful step ! CRASH -- logical variable set .TRUE. when no step can be taken, ! .FALSE. otherwise. ! YP(*) -- derivative of solution vector at X after successful ! step ! KSTEPS -- counter on attempted steps ! TWOU -- 2.*U where U is machine unit roundoff quantity ! FOURU -- 4.*U where U is machine unit roundoff quantity ! RPAR,IPAR -- parameter arrays which you may choose to use ! for communication between your program and subroutine F. ! They are not altered or used by DSTEPS. ! The variables X,XOLD,KOLD,KGI and IVC and the arrays Y,PHI,ALPHA,G, ! W,P,IV and GI are required for the interpolation subroutine SINTRP. ! The remaining variables and arrays are included in the call list ! only to eliminate local retention of variables between calls. ! ! Input to DSTEPS ! ! First call -- ! ! The user must provide storage in his calling program for all arrays ! in the call list, namely ! ! 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),GI(11),IV(10), ! 2 RPAR(*),IPAR(*) ! ! **Note** ! ! The user must also declare START , CRASH , PHASE1 and NORND ! logical variables and DF an EXTERNAL subroutine, supply the ! subroutine DF(X,Y,YP) to evaluate ! DY(I)/DX = YP(I) = DF(X,Y(1),Y(2),...,Y(NEQN)) ! and initialize only the following parameters. ! NEQN -- number of equations to be integrated ! Y(*) -- vector of initial values of dependent variables ! X -- initial value of the independent variable ! H -- nominal step size indicating direction of integration ! and maximum size of step. Must be variable ! EPS -- local error tolerance per step. Must be variable ! WT(*) -- vector of non-zero weights for error criterion ! START -- .TRUE. ! YP(*) -- vector of initial derivative values ! KSTEPS -- set KSTEPS to zero ! TWOU -- 2.*U where U is machine unit roundoff quantity ! FOURU -- 4.*U where U is machine unit roundoff quantity ! Define U to be the machine unit roundoff quantity by calling ! the function routine D1MACH, U = D1MACH(4), or by ! computing U so that U is the smallest positive number such ! that 1.0+U > 1.0. ! ! DSTEPS requires that the L2 norm of the vector with components ! LOCAL ERROR(L)/WT(L) be less than EPS for a successful step. The ! array WT allows the user to specify an error test appropriate ! for his problem. For example, ! WT(L) = 1.0 specifies absolute error, ! = ABS(Y(L)) error relative to the most recent value of the ! L-th component of the solution, ! = ABS(YP(L)) error relative to the most recent value of ! the L-th component of the derivative, ! = MAX(WT(L),ABS(Y(L))) error relative to the largest ! magnitude of L-th component obtained so far, ! = ABS(Y(L))*RELERR/EPS + ABSERR/EPS specifies a mixed ! relative-absolute test where RELERR is relative ! error, ABSERR is absolute error and EPS = ! MAX(RELERR,ABSERR) . ! ! Subsequent calls -- ! ! Subroutine DSTEPS is designed so that all information needed to ! continue the integration, including the step size H and the order ! K , is returned with each step. With the exception of the step ! size, the error tolerance, and the weights, none of the parameters ! should be altered. The array WT must be updated after each step ! to maintain relative error tests like those above. Normally the ! integration is continued just beyond the desired endpoint and the ! solution interpolated there with subroutine SINTRP . If it is ! impossible to integrate beyond the endpoint, the step size may be ! reduced to hit the endpoint since the code will not take a step ! larger than the H input. Changing the direction of integration, ! i.e., the sign of H , requires the user set START = .TRUE. before ! calling DSTEPS again. This is the only situation in which START ! should be altered. ! ! Output from DSTEPS ! ! Successful Step -- ! ! The subroutine returns after each successful step with START and ! CRASH set .FALSE. . X represents the independent variable ! advanced one step of length HOLD from its value on input and Y ! the solution vector at the new value of X . All other parameters ! represent information corresponding to the new X needed to ! continue the integration. ! ! Unsuccessful Step -- ! ! When the error tolerance is too small for the machine precision, ! the subroutine returns without taking a step and CRASH = .TRUE. . ! An appropriate step size and error tolerance for continuing are ! estimated and all other information is restored as upon input ! before returning. To continue with the larger tolerance, the user ! just calls the code again. A restart is neither required nor ! desirable. ! !***REFERENCES L. F. Shampine and M. K. Gordon, Solving ordinary ! differential equations with ODE, STEP, and INTRP, ! Report SLA-73-1060, Sandia Laboratories, 1973. !***ROUTINES CALLED D1MACH, DHSTRT !***REVISION HISTORY (YYMMDD) ! 740101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSTEPS ! INTEGER I, IFAIL, IM1, IP1, IPAR, IQ, J, K, KM1, KM2, KNEW, & KOLD, KP1, KP2, KSTEPS, L, LIMIT1, LIMIT2, NEQN, NS, NSM2, & NSP1, NSP2 DOUBLE PRECISION ABSH, ALPHA, BETA, BIG, D1MACH, & EPS, ERK, ERKM1, ERKM2, ERKP1, ERR, & FOURU, G, GI, GSTR, H, HNEW, HOLD, P, P5EPS, PHI, PSI, R, & REALI, REALNS, RHO, ROUND, RPAR, SIG, TAU, TEMP1, & TEMP2, TEMP3, TEMP4, TEMP5, TEMP6, TWO, TWOU, U, V, W, WT, & X, XOLD, Y, YP LOGICAL START,CRASH,PHASE1,NORND DIMENSION Y(*),WT(*),PHI(NEQN,16),P(*),YP(*),PSI(12), & ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), & RPAR(*),IPAR(*) DIMENSION TWO(13),GSTR(13) EXTERNAL DF SAVE TWO, GSTR ! DATA TWO(1),TWO(2),TWO(3),TWO(4),TWO(5),TWO(6),TWO(7),TWO(8), & TWO(9),TWO(10),TWO(11),TWO(12),TWO(13) & /2.0D0,4.0D0,8.0D0,16.0D0,32.0D0,64.0D0,128.0D0,256.0D0, & 512.0D0,1024.0D0,2048.0D0,4096.0D0,8192.0D0/ DATA GSTR(1),GSTR(2),GSTR(3),GSTR(4),GSTR(5),GSTR(6),GSTR(7), & GSTR(8),GSTR(9),GSTR(10),GSTR(11),GSTR(12),GSTR(13) & /0.5D0,0.0833D0,0.0417D0,0.0264D0,0.0188D0,0.0143D0,0.0114D0, & 0.00936D0,0.00789D0,0.00679D0,0.00592D0,0.00524D0,0.00468D0/ ! ! *** BEGIN BLOCK 0 *** ! CHECK if STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE ! PRECISION. if FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A ! STARTING STEP SIZE. ! *** ! ! if STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE ! !***FIRST EXECUTABLE STATEMENT DSTEPS CRASH = .TRUE. if ( ABS(H) >= FOURU*ABS(X)) go to 5 H = SIGN(FOURU*ABS(X),H) return 5 P5EPS = 0.5D0*EPS ! ! if ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE ! ROUND = 0.0D0 DO 10 L = 1,NEQN 10 ROUND = ROUND + (Y(L)/WT(L))**2 ROUND = TWOU*SQRT(ROUND) if ( P5EPS >= ROUND) go to 15 EPS = 2.0D0*ROUND*(1.0D0 + FOURU) return 15 CRASH = .FALSE. G(1) = 1.0D0 G(2) = 0.5D0 SIG(1) = 1.0D0 if ( .NOT.START) go to 99 ! ! INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP ! ! call DF(X,Y,YP,RPAR,IPAR) ! SUM = 0.0 DO 20 L = 1,NEQN PHI(L,1) = YP(L) 20 PHI(L,2) = 0.0D0 !20 SUM = SUM + (YP(L)/WT(L))**2 ! SUM = SQRT(SUM) ! ABSH = ABS(H) ! if ( EPS < 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) ! H = SIGN(MAX(ABSH,FOURU*ABS(X)),H) ! U = D1MACH(4) BIG = SQRT(D1MACH(2)) call DHSTRT(DF,NEQN,X,X+H,Y,YP,WT,1,U,BIG, & PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H) ! HOLD = 0.0D0 K = 1 KOLD = 0 KPREV = 0 START = .FALSE. PHASE1 = .TRUE. NORND = .TRUE. if ( P5EPS > 100.0D0*ROUND) go to 99 NORND = .FALSE. DO 25 L = 1,NEQN 25 PHI(L,15) = 0.0D0 99 IFAIL = 0 ! *** END BLOCK 0 *** ! ! *** BEGIN BLOCK 1 *** ! COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING ! THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. ! *** ! 100 KP1 = K+1 KP2 = K+2 KM1 = K-1 KM2 = K-2 ! ! NS IS THE NUMBER OF DSTEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT ! ONE. WHEN K < NS, NO COEFFICIENTS CHANGE ! if ( H /= HOLD) NS = 0 if (NS <= KOLD) NS = NS+1 NSP1 = NS+1 if (K < NS) go to 199 ! ! COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH ! ARE CHANGED ! BETA(NS) = 1.0D0 REALNS = NS ALPHA(NS) = 1.0D0/REALNS TEMP1 = H*REALNS SIG(NSP1) = 1.0D0 if ( K < 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 ! ! COMPUTE COEFFICIENTS G(*) ! ! INITIALIZE V(*) AND SET W(*). ! if ( NS > 1) go to 120 DO 115 IQ = 1,K TEMP3 = IQ*(IQ+1) V(IQ) = 1.0D0/TEMP3 115 W(IQ) = V(IQ) IVC = 0 KGI = 0 if (K == 1) go to 140 KGI = 1 GI(1) = W(2) go to 140 ! ! if ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) ! 120 if ( K <= KPREV) go to 130 if (IVC == 0) go to 122 JV = KP1 - IV(IVC) IVC = IVC - 1 go to 123 122 JV = 1 TEMP4 = K*KP1 V(K) = 1.0D0/TEMP4 W(K) = V(K) if (K /= 2) go to 123 KGI = 1 GI(1) = W(2) 123 NSM2 = NS-2 if ( NSM2 < JV) go to 130 DO 125 J = JV,NSM2 I = K-J V(I) = V(I) - ALPHA(J+1)*V(I+1) 125 W(I) = V(I) if (I /= 2) go to 130 KGI = NS - 1 GI(KGI) = W(2) ! ! UPDATE V(*) AND SET W(*) ! 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) if (LIMIT1 == 1) go to 137 KGI = NS GI(KGI) = W(2) 137 W(LIMIT1+1) = V(LIMIT1+1) if (K >= KOLD) go to 140 IVC = IVC + 1 IV(IVC) = LIMIT1 + 2 ! ! COMPUTE THE G(*) IN THE WORK VECTOR W(*) ! 140 NSP2 = NS + 2 KPREV = K if ( KP1 < 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 ! *** END BLOCK 1 *** ! ! *** BEGIN BLOCK 2 *** ! PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED ! SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, ! K-1, K-2 AS if CONSTANT STEP SIZE WERE USED. ! *** ! ! INCREMENT COUNTER ON ATTEMPTED DSTEPS ! KSTEPS = KSTEPS + 1 ! ! CHANGE PHI TO PHI STAR ! if ( K < 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 ! ! PREDICT SOLUTION AND DIFFERENCES ! 215 DO 220 L = 1,NEQN PHI(L,KP2) = PHI(L,KP1) PHI(L,KP1) = 0.0D0 220 P(L) = 0.0D0 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 DF(X,P,YP,RPAR,IPAR) ! ! ESTIMATE ERRORS AT ORDERS K,K-1,K-2 ! ERKM2 = 0.0D0 ERKM1 = 0.0D0 ERK = 0.0D0 DO 265 L = 1,NEQN TEMP3 = 1.0D0/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 ! ! TEST if ORDER SHOULD BE LOWERED ! if ( KM2)299,290,285 285 if ( MAX(ERKM1,ERKM2) <= ERK) KNEW = KM1 go to 299 290 if ( ERKM1 <= 0.5D0*ERK) KNEW = KM1 ! ! TEST if STEP SUCCESSFUL ! 299 if ( ERR <= EPS) go to 400 ! *** END BLOCK 2 *** ! ! *** BEGIN BLOCK 3 *** ! THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . ! if THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE ! THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR ! TOLERANCE AND RETURN if ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE ! PRECISION. ! *** ! ! RESTORE X, PHI(*,*) AND PSI(*) ! PHASE1 = .FALSE. X = XOLD DO 310 I = 1,K TEMP1 = 1.0D0/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 < 2) go to 320 DO 315 I = 2,K 315 PSI(I-1) = PSI(I) - H ! ! ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP ! SIZE ! 320 IFAIL = IFAIL + 1 TEMP2 = 0.5D0 if ( IFAIL - 3) 335,330,325 325 if ( P5EPS < 0.25D0*ERK) TEMP2 = SQRT(P5EPS/ERK) 330 KNEW = 1 335 H = TEMP2*H K = KNEW NS = 0 if ( ABS(H) >= FOURU*ABS(X)) go to 340 CRASH = .TRUE. H = SIGN(FOURU*ABS(X),H) EPS = EPS + EPS return 340 go to 100 ! *** END BLOCK 3 *** ! ! *** BEGIN BLOCK 4 *** ! THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE ! THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE ! DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. ! *** 400 KOLD = K HOLD = H ! ! CORRECT AND EVALUATE ! TEMP1 = H*G(KP1) if ( NORND) go to 410 DO 405 L = 1,NEQN TEMP3 = Y(L) RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) Y(L) = P(L) + RHO PHI(L,15) = (Y(L) - P(L)) - RHO 405 P(L) = TEMP3 go to 420 410 DO 415 L = 1,NEQN TEMP3 = Y(L) Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) 415 P(L) = TEMP3 420 call DF(X,Y,YP,RPAR,IPAR) ! ! UPDATE DIFFERENCES FOR NEXT STEP ! 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 ! ! ESTIMATE ERROR AT ORDER K+1 UNLESS: ! IN FIRST PHASE WHEN ALWAYS RAISE ORDER, ! ALREADY DECIDED TO LOWER ORDER, ! STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE ! ERKP1 = 0.0D0 if ( KNEW == KM1 .OR. K == 12) PHASE1 = .FALSE. if ( PHASE1) go to 450 if ( KNEW == KM1) go to 455 if ( KP1 > NS) go to 460 DO 440 L = 1,NEQN 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) ! ! USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER ! FOR NEXT STEP ! if ( K > 1) go to 445 if ( ERKP1 >= 0.5D0*ERK) go to 460 go to 450 445 if ( ERKM1 <= MIN(ERK,ERKP1)) go to 455 if ( ERKP1 >= ERK .OR. K == 12) go to 460 ! ! HERE ERKP1 < ERK < MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE ! BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED ! ! RAISE ORDER ! 450 K = KP1 ERK = ERKP1 go to 460 ! ! LOWER ORDER ! 455 K = KM1 ERK = ERKM1 ! ! WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP ! 460 HNEW = H + H if ( PHASE1) go to 465 if ( P5EPS >= ERK*TWO(K+1)) go to 465 HNEW = H if ( P5EPS >= ERK) go to 465 TEMP2 = K+1 R = (P5EPS/ERK)**(1.0D0/TEMP2) HNEW = ABSH*MAX(0.5D0,MIN(0.9D0,R)) HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) 465 H = HNEW return ! *** END BLOCK 4 *** end subroutine DSTOD (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, WM, IWM, & DF, DJAC, RPAR, IPAR) ! !! DSTOD is subsidiary to DDEBDF. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (STOD-S, DSTOD-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DSTOD integrates a system of first order odes over one step in the ! integrator package DDEBDF. ! ---------------------------------------------------------------------- ! DSTOD performs one step of the integration of an initial value ! problem for a system of ordinary differential equations. ! Note.. DSTOD is independent of the value of the iteration method ! indicator MITER, when this is /= 0, and hence is independent ! of the type of chord method used, or the Jacobian structure. ! Communication with DSTOD is done with the following variables.. ! ! Y = An array of length >= N used as the Y argument in ! all calls to DF and DJAC. ! NEQ = Integer array containing problem size in NEQ(1), and ! passed as the NEQ argument in all calls to DF and DJAC. ! YH = An NYH by LMAX array containing the dependent variables ! and their approximate scaled derivatives, where ! LMAX = MAXORD + 1. YH(I,J+1) contains the approximate ! J-th derivative of Y(I), scaled by H**J/FACTORIAL(J) ! (J = 0,1,...,NQ). On entry for the first step, the first ! two columns of YH must be set from the initial values. ! NYH = A constant integer >= N, the first dimension of YH. ! YH1 = A one-dimensional array occupying the same space as YH. ! EWT = An array of N elements with which the estimated local ! errors in YH are compared. ! SAVF = An array of working storage, of length N. ! ACOR = A work array of length N, used for the accumulated ! corrections. On a successful return, ACOR(I) contains ! the estimated one-step local error in Y(I). ! WM,IWM = DOUBLE PRECISION and INTEGER work arrays associated with ! matrix operations in chord iteration (MITER /= 0). ! DPJAC = Name of routine to evaluate and preprocess Jacobian matrix ! if a chord method is being used. ! DSLVS = Name of routine to solve linear system in chord iteration. ! H = The step size to be attempted on the next step. ! H is altered by the error control algorithm during the ! problem. H can be either positive or negative, but its ! sign must remain constant throughout the problem. ! HMIN = The minimum absolute value of the step size H to be used. ! HMXI = Inverse of the maximum absolute value of H to be used. ! HMXI = 0.0 is allowed and corresponds to an infinite HMAX. ! HMIN and HMXI may be changed at any time, but will not ! take effect until the next change of H is considered. ! TN = The independent variable. TN is updated on each step taken. ! JSTART = An integer used for input only, with the following ! values and meanings.. ! 0 Perform the first step. ! > 0 Take a new step continuing from the last. ! -1 Take the next step with a new value of H, MAXORD, ! N, METH, MITER, and/or matrix parameters. ! -2 Take the next step with a new value of H, ! but with other inputs unchanged. ! On return, JSTART is set to 1 to facilitate continuation. ! KFLAG = a completion code with the following meanings.. ! 0 The step was successful. ! -1 The requested error could not be achieved. ! -2 Corrector convergence could not be achieved. ! A return with KFLAG = -1 or -2 means either ! ABS(H) = HMIN or 10 consecutive failures occurred. ! On a return with KFLAG negative, the values of TN and ! the YH array are as of the beginning of the last ! step, and H is the last step size attempted. ! MAXORD = The maximum order of integration method to be allowed. ! METH/MITER = The method flags. See description in driver. ! N = The number of first-order differential equations. ! ---------------------------------------------------------------------- ! !***SEE ALSO DDEBDF !***ROUTINES CALLED DCFOD, DPJAC, DSLVS, DVNRMS !***COMMON BLOCKS DDEBD1 !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920422 Changed DIMENSION statement. (WRB) !***END PROLOGUE DSTOD ! INTEGER I, I1, IALTH, IER, IOD, IOWND, IPAR, IPUP, IREDO, IRET, & IWM, J, JB, JSTART, KFLAG, KSTEPS, L, LMAX, M, MAXORD, & MEO, METH, MITER, N, NCF, NEQ, NEWQ, NFE, NJE, NQ, NQNYH, & NQU, NST, NSTEPJ, NYH DOUBLE PRECISION ACOR, CONIT, CRATE, DCON, DDN, & DEL, DELP, DSM, DUP, DVNRMS, EL, EL0, ELCO, & EWT, EXDN, EXSM, EXUP, H, HMIN, HMXI, HOLD, HU, R, RC, & RH, RHDN, RHSM, RHUP, RMAX, ROWND, RPAR, SAVF, TESCO, & TN, TOLD, UROUND, WM, Y, YH, YH1 EXTERNAL DF, DJAC ! DIMENSION Y(*),YH(NYH,*),YH1(*),EWT(*),SAVF(*),ACOR(*),WM(*), & IWM(*),RPAR(*),IPAR(*) COMMON /DDEBD1/ ROWND,CONIT,CRATE,EL(13),ELCO(13,12),HOLD,RC,RMAX, & TESCO(3,12),EL0,H,HMIN,HMXI,HU,TN,UROUND,IOWND(7), & KSTEPS,IOD(6),IALTH,IPUP,LMAX,MEO,NQNYH,NSTEPJ, & IER,JSTART,KFLAG,L,METH,MITER,MAXORD,N,NQ,NST,NFE, & NJE,NQU ! ! ! BEGIN BLOCK PERMITTING ...EXITS TO 690 ! BEGIN BLOCK PERMITTING ...EXITS TO 60 !***FIRST EXECUTABLE STATEMENT DSTOD KFLAG = 0 TOLD = TN NCF = 0 if (JSTART > 0) go to 160 if (JSTART == -1) go to 10 if (JSTART == -2) go to 90 ! --------------------------------------------------------- ! ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER ! VARIABLES ARE INITIALIZED. RMAX IS THE MAXIMUM RATIO BY ! WHICH H CAN BE INCREASED IN A SINGLE STEP. IT IS ! INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL INITIAL H, ! BUT THEN IS NORMALLY EQUAL TO 10. if A FAILURE OCCURS ! (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT ! 2 FOR THE NEXT INCREASE. ! --------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 IALTH = 2 RMAX = 10000.0D0 RC = 0.0D0 EL0 = 1.0D0 CRATE = 0.7D0 DELP = 0.0D0 HOLD = H MEO = METH NSTEPJ = 0 IRET = 3 go to 50 10 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 30 ! ------------------------------------------------------ ! THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN ! JSTART = -1. IPUP IS SET TO MITER TO FORCE A MATRIX ! UPDATE. if AN ORDER INCREASE IS ABOUT TO BE ! CONSIDERED (IALTH = 1), IALTH IS RESET TO 2 TO ! POSTPONE CONSIDERATION ONE MORE STEP. if THE CALLER ! HAS CHANGED METH, DCFOD IS CALLED TO RESET THE ! COEFFICIENTS OF THE METHOD. if THE CALLER HAS ! CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT ! ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ! ACCORDINGLY. if H IS TO BE CHANGED, YH MUST BE ! RESCALED. if H OR METH IS BEING CHANGED, IALTH IS ! RESET TO L = NQ + 1 TO PREVENT FURTHER CHANGES IN H ! FOR THAT MANY STEPS. ! ------------------------------------------------------ IPUP = MITER LMAX = MAXORD + 1 if (IALTH == 1) IALTH = 2 if (METH == MEO) go to 20 call DCFOD(METH,ELCO,TESCO) MEO = METH ! ......EXIT if (NQ > MAXORD) go to 30 IALTH = L IRET = 1 ! ............EXIT go to 60 20 CONTINUE if (NQ <= MAXORD) go to 90 30 CONTINUE NQ = MAXORD L = LMAX DO 40 I = 1, L EL(I) = ELCO(I,NQ) 40 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) DDN = DVNRMS(N,SAVF,EWT)/TESCO(1,L) EXDN = 1.0D0/L RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) RH = MIN(RHDN,1.0D0) IREDO = 3 if (H == HOLD) go to 660 RH = MIN(RH,ABS(H/HOLD)) H = HOLD go to 100 50 CONTINUE ! ------------------------------------------------------------ ! DCFOD IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS ! FOR THE CURRENT METH. THEN THE EL VECTOR AND RELATED ! CONSTANTS ARE RESET WHENEVER THE ORDER NQ IS CHANGED, OR AT ! THE START OF THE PROBLEM. ! ------------------------------------------------------------ call DCFOD(METH,ELCO,TESCO) 60 CONTINUE 70 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 680 DO 80 I = 1, L EL(I) = ELCO(I,NQ) 80 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) go to (90,660,160), IRET ! --------------------------------------------------------- ! if H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST ! RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH ! IS SET TO L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT ! MANY STEPS, UNLESS FORCED BY A CONVERGENCE OR ERROR TEST ! FAILURE. ! --------------------------------------------------------- 90 CONTINUE if (H == HOLD) go to 160 RH = H/HOLD H = HOLD IREDO = 3 100 CONTINUE 110 CONTINUE RH = MIN(RH,RMAX) RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) R = 1.0D0 DO 130 J = 2, L R = R*RH DO 120 I = 1, N YH(I,J) = YH(I,J)*R 120 CONTINUE 130 CONTINUE H = H*RH RC = RC*RH IALTH = L if (IREDO /= 0) go to 150 RMAX = 10.0D0 R = 1.0D0/TESCO(2,NQU) DO 140 I = 1, N ACOR(I) = ACOR(I)*R 140 CONTINUE ! ...............EXIT go to 690 150 CONTINUE ! ------------------------------------------------------ ! THIS SECTION COMPUTES THE PREDICTED VALUES BY ! EFFECTIVELY MULTIPLYING THE YH ARRAY BY THE PASCAL ! TRIANGLE MATRIX. RC IS THE RATIO OF NEW TO OLD ! VALUES OF THE COEFFICIENT H*EL(1). WHEN RC DIFFERS ! FROM 1 BY MORE THAN 30 PERCENT, IPUP IS SET TO MITER ! TO FORCE DPJAC TO BE CALLED, if A JACOBIAN IS ! INVOLVED. IN ANY CASE, DPJAC IS CALLED AT LEAST ! EVERY 20-TH STEP. ! ------------------------------------------------------ 160 CONTINUE 170 CONTINUE ! BEGIN BLOCK PERMITTING ...EXITS TO 610 ! BEGIN BLOCK PERMITTING ...EXITS TO 490 if (ABS(RC-1.0D0) > 0.3D0) IPUP = MITER if (NST >= NSTEPJ + 20) IPUP = MITER TN = TN + H I1 = NQNYH + 1 DO 190 JB = 1, NQ I1 = I1 - NYH DO 180 I = I1, NQNYH YH1(I) = YH1(I) + YH1(I+NYH) 180 CONTINUE 190 CONTINUE KSTEPS = KSTEPS + 1 ! --------------------------------------------- ! UP TO 3 CORRECTOR ITERATIONS ARE TAKEN. A ! CONVERGENCE TEST IS MADE ON THE R.M.S. NORM ! OF EACH CORRECTION, WEIGHTED BY THE ERROR ! WEIGHT VECTOR EWT. THE SUM OF THE ! CORRECTIONS IS ACCUMULATED IN THE VECTOR ! ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE ! CORRECTOR LOOP. ! --------------------------------------------- 200 CONTINUE M = 0 DO 210 I = 1, N Y(I) = YH(I,1) 210 CONTINUE call DF(TN,Y,SAVF,RPAR,IPAR) NFE = NFE + 1 if (IPUP <= 0) go to 220 ! --------------------------------------- ! if INDICATED, THE MATRIX P = I - ! H*EL(1)*J IS REEVALUATED AND ! PREPROCESSED BEFORE STARTING THE ! CORRECTOR ITERATION. IPUP IS SET TO 0 ! AS AN INDICATOR THAT THIS HAS BEEN ! DONE. ! --------------------------------------- IPUP = 0 RC = 1.0D0 NSTEPJ = NST CRATE = 0.7D0 call DPJAC(NEQ,Y,YH,NYH,EWT,ACOR,SAVF, & WM,IWM,DF,DJAC,RPAR,IPAR) ! ......EXIT if (IER /= 0) go to 440 220 CONTINUE DO 230 I = 1, N ACOR(I) = 0.0D0 230 CONTINUE 240 CONTINUE if (MITER /= 0) go to 270 ! ------------------------------------ ! IN THE CASE OF FUNCTIONAL ! ITERATION, UPDATE Y DIRECTLY FROM ! THE RESULT OF THE LAST FUNCTION ! EVALUATION. ! ------------------------------------ DO 250 I = 1, N SAVF(I) = H*SAVF(I) - YH(I,2) Y(I) = SAVF(I) - ACOR(I) 250 CONTINUE DEL = DVNRMS(N,Y,EWT) DO 260 I = 1, N Y(I) = YH(I,1) + EL(1)*SAVF(I) ACOR(I) = SAVF(I) 260 CONTINUE go to 300 270 CONTINUE ! ------------------------------------ ! IN THE CASE OF THE CHORD METHOD, ! COMPUTE THE CORRECTOR ERROR, AND ! SOLVE THE LINEAR SYSTEM WITH THAT ! AS RIGHT-HAND SIDE AND P AS ! COEFFICIENT MATRIX. ! ------------------------------------ DO 280 I = 1, N Y(I) = H*SAVF(I) & - (YH(I,2) + ACOR(I)) 280 CONTINUE call DSLVS(WM,IWM,Y,SAVF) ! ......EXIT if (IER /= 0) go to 430 DEL = DVNRMS(N,Y,EWT) DO 290 I = 1, N ACOR(I) = ACOR(I) + Y(I) Y(I) = YH(I,1) + EL(1)*ACOR(I) 290 CONTINUE 300 CONTINUE ! --------------------------------------- ! TEST FOR CONVERGENCE. if M > 0, AN ! ESTIMATE OF THE CONVERGENCE RATE ! CONSTANT IS STORED IN CRATE, AND THIS ! IS USED IN THE TEST. ! --------------------------------------- if (M /= 0) & CRATE = MAX(0.2D0*CRATE,DEL/DELP) DCON = DEL*MIN(1.0D0,1.5D0*CRATE) & /(TESCO(2,NQ)*CONIT) if (DCON > 1.0D0) go to 420 ! ------------------------------------ ! THE CORRECTOR HAS CONVERGED. IPUP ! IS SET TO -1 if MITER /= 0, TO ! SIGNAL THAT THE JACOBIAN INVOLVED ! MAY NEED UPDATING LATER. THE LOCAL ! ERROR TEST IS MADE AND CONTROL ! PASSES TO STATEMENT 500 if IT ! FAILS. ! ------------------------------------ if (MITER /= 0) IPUP = -1 if (M == 0) DSM = DEL/TESCO(2,NQ) if (M > 0) & DSM = DVNRMS(N,ACOR,EWT) & /TESCO(2,NQ) if (DSM > 1.0D0) go to 380 ! BEGIN BLOCK ! PERMITTING ...EXITS TO 360 ! ------------------------------ ! AFTER A SUCCESSFUL STEP, ! UPDATE THE YH ARRAY. ! CONSIDER CHANGING H if IALTH ! = 1. OTHERWISE DECREASE ! IALTH BY 1. if IALTH IS THEN ! 1 AND NQ < MAXORD, THEN ! ACOR IS SAVED FOR USE IN A ! POSSIBLE ORDER INCREASE ON ! THE NEXT STEP. if A CHANGE ! IN H IS CONSIDERED, AN ! INCREASE OR DECREASE IN ORDER ! BY ONE IS CONSIDERED ALSO. A ! CHANGE IN H IS MADE ONLY IF ! IT IS BY A FACTOR OF AT LEAST ! 1.1. if NOT, IALTH IS SET TO ! 3 TO PREVENT TESTING FOR THAT ! MANY STEPS. ! ------------------------------ KFLAG = 0 IREDO = 0 NST = NST + 1 HU = H NQU = NQ DO 320 J = 1, L DO 310 I = 1, N YH(I,J) = YH(I,J) & + EL(J) & *ACOR(I) 310 CONTINUE 320 CONTINUE IALTH = IALTH - 1 if (IALTH /= 0) go to 340 ! --------------------------- ! REGARDLESS OF THE SUCCESS ! OR FAILURE OF THE STEP, ! FACTORS RHDN, RHSM, AND ! RHUP ARE COMPUTED, BY ! WHICH H COULD BE ! MULTIPLIED AT ORDER NQ - ! 1, ORDER NQ, OR ORDER NQ + ! 1, RESPECTIVELY. IN THE ! CASE OF FAILURE, RHUP = ! 0.0 TO AVOID AN ORDER ! INCREASE. THE LARGEST OF ! THESE IS DETERMINED AND ! THE NEW ORDER CHOSEN ! ACCORDINGLY. if THE ORDER ! IS TO BE INCREASED, WE ! COMPUTE ONE ADDITIONAL ! SCALED DERIVATIVE. ! --------------------------- RHUP = 0.0D0 ! .....................EXIT if (L == LMAX) go to 490 DO 330 I = 1, N SAVF(I) = ACOR(I) & - YH(I,LMAX) 330 CONTINUE DUP = DVNRMS(N,SAVF,EWT) & /TESCO(3,NQ) EXUP = 1.0D0/(L+1) RHUP = 1.0D0 & /(1.4D0*DUP**EXUP & + 0.0000014D0) ! .....................EXIT go to 490 340 CONTINUE ! ...EXIT if (IALTH > 1) go to 360 ! ...EXIT if (L == LMAX) go to 360 DO 350 I = 1, N YH(I,LMAX) = ACOR(I) 350 CONTINUE 360 CONTINUE R = 1.0D0/TESCO(2,NQU) DO 370 I = 1, N ACOR(I) = ACOR(I)*R 370 CONTINUE ! .................................EXIT go to 690 380 CONTINUE ! ------------------------------------ ! THE ERROR TEST FAILED. KFLAG KEEPS ! TRACK OF MULTIPLE FAILURES. ! RESTORE TN AND THE YH ARRAY TO ! THEIR PREVIOUS VALUES, AND PREPARE ! TO TRY THE STEP AGAIN. COMPUTE THE ! OPTIMUM STEP SIZE FOR THIS OR ONE ! LOWER ORDER. AFTER 2 OR MORE ! FAILURES, H IS FORCED TO DECREASE ! BY A FACTOR OF 0.2 OR LESS. ! ------------------------------------ KFLAG = KFLAG - 1 TN = TOLD I1 = NQNYH + 1 DO 400 JB = 1, NQ I1 = I1 - NYH DO 390 I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 390 CONTINUE 400 CONTINUE RMAX = 2.0D0 if (ABS(H) > HMIN*1.00001D0) & go to 410 ! --------------------------------- ! ALL RETURNS ARE MADE THROUGH ! THIS SECTION. H IS SAVED IN ! HOLD TO ALLOW THE CALLER TO ! CHANGE H ON THE NEXT STEP. ! --------------------------------- KFLAG = -1 ! .................................EXIT go to 690 410 CONTINUE ! ...............EXIT if (KFLAG <= -3) go to 610 IREDO = 2 RHUP = 0.0D0 ! ............EXIT go to 490 420 CONTINUE M = M + 1 ! ...EXIT if (M == 3) go to 430 ! ...EXIT if (M >= 2 .AND. DEL > 2.0D0*DELP) & go to 430 DELP = DEL call DF(TN,Y,SAVF,RPAR,IPAR) NFE = NFE + 1 go to 240 430 CONTINUE ! ------------------------------------------ ! THE CORRECTOR ITERATION FAILED TO ! CONVERGE IN 3 TRIES. if MITER /= 0 AND ! THE JACOBIAN IS OUT OF DATE, DPJAC IS ! CALLED FOR THE NEXT TRY. OTHERWISE THE ! YH ARRAY IS RETRACTED TO ITS VALUES ! BEFORE PREDICTION, AND H IS REDUCED, IF ! POSSIBLE. if H CANNOT BE REDUCED OR 10 ! FAILURES HAVE OCCURRED, EXIT WITH KFLAG = ! -2. ! ------------------------------------------ ! ...EXIT if (IPUP == 0) go to 440 IPUP = MITER go to 200 440 CONTINUE TN = TOLD NCF = NCF + 1 RMAX = 2.0D0 I1 = NQNYH + 1 DO 460 JB = 1, NQ I1 = I1 - NYH DO 450 I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 450 CONTINUE 460 CONTINUE if (ABS(H) > HMIN*1.00001D0) go to 470 KFLAG = -2 ! ........................EXIT go to 690 470 CONTINUE if (NCF /= 10) go to 480 KFLAG = -2 ! ........................EXIT go to 690 480 CONTINUE RH = 0.25D0 IPUP = MITER IREDO = 1 ! .........EXIT go to 650 490 CONTINUE EXSM = 1.0D0/L RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) RHDN = 0.0D0 if (NQ == 1) go to 500 DDN = DVNRMS(N,YH(1,L),EWT)/TESCO(1,NQ) EXDN = 1.0D0/NQ RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 500 CONTINUE if (RHSM >= RHUP) go to 550 if (RHUP <= RHDN) go to 540 NEWQ = L RH = RHUP if (RH >= 1.1D0) go to 520 IALTH = 3 R = 1.0D0/TESCO(2,NQU) DO 510 I = 1, N ACOR(I) = ACOR(I)*R 510 CONTINUE ! ...........................EXIT go to 690 520 CONTINUE R = EL(L)/L DO 530 I = 1, N YH(I,NEWQ+1) = ACOR(I)*R 530 CONTINUE NQ = NEWQ L = NQ + 1 IRET = 2 ! ..................EXIT go to 680 540 CONTINUE go to 580 550 CONTINUE if (RHSM < RHDN) go to 580 NEWQ = NQ RH = RHSM if (KFLAG == 0 .AND. RH < 1.1D0) & go to 560 if (KFLAG <= -2) RH = MIN(RH,0.2D0) ! ------------------------------------------ ! if THERE IS A CHANGE OF ORDER, RESET NQ, ! L, AND THE COEFFICIENTS. IN ANY CASE H ! IS RESET ACCORDING TO RH AND THE YH ARRAY ! IS RESCALED. THEN EXIT FROM 680 if THE ! STEP WAS OK, OR REDO THE STEP OTHERWISE. ! ------------------------------------------ ! ............EXIT if (NEWQ == NQ) go to 650 NQ = NEWQ L = NQ + 1 IRET = 2 ! ..................EXIT go to 680 560 CONTINUE IALTH = 3 R = 1.0D0/TESCO(2,NQU) DO 570 I = 1, N ACOR(I) = ACOR(I)*R 570 CONTINUE ! .....................EXIT go to 690 580 CONTINUE NEWQ = NQ - 1 RH = RHDN if (KFLAG < 0 .AND. RH > 1.0D0) RH = 1.0D0 if (KFLAG == 0 .AND. RH < 1.1D0) go to 590 if (KFLAG <= -2) RH = MIN(RH,0.2D0) ! --------------------------------------------- ! if THERE IS A CHANGE OF ORDER, RESET NQ, L, ! AND THE COEFFICIENTS. IN ANY CASE H IS ! RESET ACCORDING TO RH AND THE YH ARRAY IS ! RESCALED. THEN EXIT FROM 680 if THE STEP ! WAS OK, OR REDO THE STEP OTHERWISE. ! --------------------------------------------- ! .........EXIT if (NEWQ == NQ) go to 650 NQ = NEWQ L = NQ + 1 IRET = 2 ! ...............EXIT go to 680 590 CONTINUE IALTH = 3 R = 1.0D0/TESCO(2,NQU) DO 600 I = 1, N ACOR(I) = ACOR(I)*R 600 CONTINUE ! ..................EXIT go to 690 610 CONTINUE ! --------------------------------------------------- ! CONTROL REACHES THIS SECTION if 3 OR MORE FAILURES ! HAVE OCCURRED. if 10 FAILURES HAVE OCCURRED, EXIT ! WITH KFLAG = -1. IT IS ASSUMED THAT THE ! DERIVATIVES THAT HAVE ACCUMULATED IN THE YH ARRAY ! HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST ! DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO ! 1. THEN H IS REDUCED BY A FACTOR OF 10, AND THE ! STEP IS RETRIED, UNTIL IT SUCCEEDS OR H REACHES ! HMIN. ! --------------------------------------------------- if (KFLAG /= -10) go to 620 ! ------------------------------------------------ ! ALL RETURNS ARE MADE THROUGH THIS SECTION. H ! IS SAVED IN HOLD TO ALLOW THE CALLER TO CHANGE ! H ON THE NEXT STEP. ! ------------------------------------------------ KFLAG = -1 ! ..................EXIT go to 690 620 CONTINUE RH = 0.1D0 RH = MAX(HMIN/ABS(H),RH) H = H*RH DO 630 I = 1, N Y(I) = YH(I,1) 630 CONTINUE call DF(TN,Y,SAVF,RPAR,IPAR) NFE = NFE + 1 DO 640 I = 1, N YH(I,2) = H*SAVF(I) 640 CONTINUE IPUP = MITER IALTH = 5 ! ......EXIT if (NQ /= 1) go to 670 go to 170 650 CONTINUE 660 CONTINUE RH = MAX(RH,HMIN/ABS(H)) go to 110 670 CONTINUE NQ = 1 L = 2 IRET = 3 680 CONTINUE go to 70 690 CONTINUE HOLD = H JSTART = 1 return ! ----------------------- END OF SUBROUTINE DSTOD ! ----------------------- end subroutine DSTOR1 (U, YH, V, YP, NTEMP, NDISK, NTAPE) ! !! DSTOR1 is subsidiary to DBVSUP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (STOR1-S, DSTOR1-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! 0 -- storage at output points. ! NTEMP = ! 1 -- temporary storage ! ********************************************************************** ! !***SEE ALSO DBVSUP !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DSTOR1 INTEGER IGOFX, INHOMO, IVP, J, NCOMP, NCTNF, NDISK, NFC, NTAPE, & NTEMP DOUBLE PRECISION C, U(*), V(*), XSAV, YH(*), YP(*) ! ! ****************************************************************** ! COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC ! ! ***************************************************************** ! ! BEGIN BLOCK PERMITTING ...EXITS TO 80 !***FIRST EXECUTABLE STATEMENT DSTOR1 NCTNF = NCOMP*NFC DO 10 J = 1, NCTNF U(J) = YH(J) 10 CONTINUE if (INHOMO == 1) go to 30 ! ! ZERO PARTICULAR SOLUTION ! ! ......EXIT if (NTEMP == 1) go to 80 DO 20 J = 1, NCOMP V(J) = 0.0D0 20 CONTINUE go to 70 30 CONTINUE ! ! NONZERO PARTICULAR SOLUTION ! if (NTEMP == 0) go to 50 ! DO 40 J = 1, NCOMP V(J) = YP(J) 40 CONTINUE ! .........EXIT go to 80 50 CONTINUE ! DO 60 J = 1, NCOMP V(J) = C*YP(J) 60 CONTINUE 70 CONTINUE ! ! IS OUTPUT INFORMATION TO BE WRITTEN TO DISK ! if (NDISK == 1) & WRITE (NTAPE) (V(J), J = 1, NCOMP),(U(J), J = 1, NCTNF) 80 CONTINUE ! return end subroutine DSTWAY (U, V, YHP, INOUT, STOWA) ! !! DSTWAY is subsidiary to DBVSUP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (STWAY-S, DSTWAY-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This subroutine stores (recalls) integration data in the event ! that a restart is needed (the homogeneous solution vectors become ! too dependent to continue). ! !***SEE ALSO DBVSUP !***ROUTINES CALLED DSTOR1 !***COMMON BLOCKS DML15T, DML18J, DML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DSTWAY ! INTEGER ICOCO, IGOFX, INDPVT, INFO, INHOMO, INOUT, INTEG, ISTKOP, & IVP, J, K, KNSWOT, KO, KOP, KS, KSJ, LOTJP, MNSWOT, MXNON, & NCOMP, NDISK, NEQ, NEQIVP, NFC, NFCC, NIC, NOPG, NPS, NSWOT, & NTAPE, NTP, NUMORT, NXPTS DOUBLE PRECISION AE, C, PWCND, PX, RE, STOWA(*), TND, TOL, U(*), & V(*), X, XBEG, XEND, XOP, XOT, XSAV, YHP(*) ! COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, & ICOCO ! !***FIRST EXECUTABLE STATEMENT DSTWAY if (INOUT == 1) go to 30 ! ! SAVE IN STOWA ARRAY AND ISTKOP ! KS = NFC*NCOMP call DSTOR1(STOWA,U,STOWA(KS+1),V,1,0,0) KS = KS + NCOMP if (NEQIVP < 1) go to 20 DO 10 J = 1, NEQIVP KSJ = KS + J STOWA(KSJ) = YHP(KSJ) 10 CONTINUE 20 CONTINUE KS = KS + NEQIVP STOWA(KS+1) = X ISTKOP = KOP if (XOP == X) ISTKOP = KOP + 1 go to 80 30 CONTINUE ! ! RECALL FROM STOWA ARRAY AND ISTKOP ! KS = NFC*NCOMP call DSTOR1(YHP,STOWA,YHP(KS+1),STOWA(KS+1),1,0,0) KS = KS + NCOMP if (NEQIVP < 1) go to 50 DO 40 J = 1, NEQIVP KSJ = KS + J YHP(KSJ) = STOWA(KSJ) 40 CONTINUE 50 CONTINUE KS = KS + NEQIVP X = STOWA(KS+1) INFO(1) = 0 KO = KOP - ISTKOP KOP = ISTKOP if (NDISK == 0 .OR. KO == 0) go to 70 DO 60 K = 1, KO BACKSPACE NTAPE 60 CONTINUE 70 CONTINUE 80 CONTINUE return end subroutine DSUDS (A, X, B, NEQ, NUK, NRDA, IFLAG, MLSO, WORK, & IWORK) ! !! DSUDS solves an underdetermined system for DBVSUP. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DBVSUP !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SUDS-S, DSUDS-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! DSUDS solves the underdetermined system of linear equations A Z = ! B where A is NEQ by NUK and NEQ <= NUK. in particular, if rank ! A equals IRA, a vector X and a matrix U are determined such that ! X is the UNIQUE solution of smallest length, satisfying A X = B, ! and the columns of U form an orthonormal basis for the null ! space of A, satisfying A U = 0 . Then all solutions Z are ! given by ! Z = X + C(1)*U(1) + ..... + C(NUK-IRA)*U(NUK-IRA) ! where U(J) represents the J-th column of U and the C(J) are ! arbitrary constants. ! If the system of equations are not compatible, only the least ! squares solution of minimal length is computed. ! DSUDS is an interfacing routine which calls subroutine DLSSUD ! for the solution. DLSSUD in turn calls subroutine DORTHR and ! possibly subroutine DOHTRL for the decomposition of A by ! orthogonal transformations. In the process, DORTHR calls upon ! subroutine DCSCAL for scaling. ! ! ******************************************************************** ! INPUT ! ******************************************************************** ! ! A -- Contains the matrix of NEQ equations in NUK unknowns and must ! be dimensioned NRDA by NUK. The original A is destroyed. ! X -- Solution array of length at least NUK. ! B -- Given constant vector of length NEQ, B is destroyed. ! NEQ -- Number of equations, NEQ greater or equal to 1. ! NUK -- Number of columns in the matrix (which is also the number ! of unknowns), NUK not smaller than NEQ. ! NRDA -- Row dimension of A, NRDA greater or equal to NEQ. ! IFLAG -- Status indicator ! =0 for the first call (and for each new problem defined by ! a new matrix A) when the matrix data is treated as exact ! =-K for the first call (and for each new problem defined by ! a new matrix A) when the matrix data is assumed to be ! accurate to about K digits. ! =1 for subsequent calls whenever the matrix A has already ! been decomposed (problems with new vectors B but ! same matrix A can be handled efficiently). ! MLSO -- =0 if only the minimal length solution is wanted. ! =1 if the complete solution is wanted, includes the ! linear space defined by the matrix U in the abstract. ! WORK(*),IWORK(*) -- Arrays for storage of internal information, ! WORK must be dimensioned at least ! NUK + 3*NEQ + MLSO*NUK*(NUK-RANK A) ! where it is possible for 0 <= RANK A <= NEQ ! IWORK must be dimensioned at least 3 + NEQ ! IWORK(2) -- Scaling indicator ! =-1 if the matrix is to be pre-scaled by ! columns when appropriate. ! If the scaling indicator is not equal to -1 ! no scaling will be attempted. ! For most problems scaling will probably not be necessary ! ! ********************************************************************* ! OUTPUT ! ********************************************************************* ! ! IFLAG -- Status indicator ! =1 if solution was obtained. ! =2 if improper input is detected. ! =3 if rank of matrix is less than NEQ. ! to continue simply reset IFLAG=1 and call DSUDS again. ! =4 if the system of equations appears to be inconsistent. ! However, the least squares solution of minimal length ! was obtained. ! X -- Minimal length least squares solution of A X = B. ! A -- Contains the strictly upper triangular part of the reduced ! matrix and transformation information. ! WORK(*),IWORK(*) -- Contains information needed on subsequent ! calls (IFLAG=1 case on input) which must not ! be altered. ! The matrix U described in the abstract is ! stored in the NUK*(NUK-rank A) elements of ! the WORK array beginning at WORK(1+NUK+3*NEQ). ! However U is not defined when MLSO=0 or ! IFLAG=4. ! IWORK(1) contains the numerically determined ! rank of the matrix A ! ! ********************************************************************* ! !***SEE ALSO DBVSUP !***REFERENCES H. A. Watts, Solving linear least squares problems ! using SODS/SUDS/CODS, Sandia Report SAND77-0683, ! Sandia Laboratories, 1977. !***ROUTINES CALLED DLSSUD !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSUDS INTEGER IFLAG, IL, IP, IS, IWORK(*), KS, KT, KU, KV, MLSO, NEQ, & NRDA, NUK DOUBLE PRECISION A(NRDA,*), B(*), WORK(*), X(*) ! !***FIRST EXECUTABLE STATEMENT DSUDS IS = 2 IP = 3 IL = IP + NEQ KV = 1 + NEQ KT = KV + NEQ KS = KT + NEQ KU = KS + NUK ! call DLSSUD(A,X,B,NEQ,NUK,NRDA,WORK(KU),NUK,IFLAG,MLSO,IWORK(1), & IWORK(IS),A,WORK(1),IWORK(IP),B,WORK(KV),WORK(KT), & IWORK(IL),WORK(KS)) ! return end subroutine DSVCO (RSAV, ISAV) ! !! DSVCO transfers data from a common block to arrays for DDEBDF. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DDEBDF !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SVCO-S, DSVCO-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DSVCO transfers data from a common block to arrays within the ! integrator package DDEBDF. ! !***SEE ALSO DDEBDF !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DDEBD1 !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DSVCO !----------------------------------------------------------------------- ! THIS ROUTINE STORES IN RSAV AND ISAV THE CONTENTS OF COMMON BLOCK ! DDEBD1 , WHICH IS USED INTERNALLY IN THE DDEBDF PACKAGE. ! ! RSAV = DOUBLE PRECISION ARRAY OF LENGTH 218 OR MORE. ! ISAV = INTEGER ARRAY OF LENGTH 33 OR MORE. !----------------------------------------------------------------------- INTEGER I, ILS, ISAV, LENILS, LENRLS DOUBLE PRECISION RLS, RSAV DIMENSION RSAV(*),ISAV(*) SAVE LENRLS, LENILS COMMON /DDEBD1/ RLS(218),ILS(33) DATA LENRLS /218/, LENILS /33/ ! !***FIRST EXECUTABLE STATEMENT DSVCO DO 10 I = 1, LENRLS RSAV(I) = RLS(I) 10 CONTINUE DO 20 I = 1, LENILS ISAV(I) = ILS(I) 20 CONTINUE return ! ----------------------- END OF SUBROUTINE DSVCO ! ----------------------- end subroutine DSVDC (X, LDX, N, P, S, E, U, LDU, V, LDV, WORK, JOB, & INFO) ! !! DSVDC performs the singular value decomposition of a rectangular matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D6 !***TYPE DOUBLE PRECISION (SSVDC-S, DSVDC-D, CSVDC-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ! SINGULAR VALUE DECOMPOSITION !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! DSVDC is a subroutine to reduce a double precision NxP matrix X ! by orthogonal transformations U and V to diagonal form. The ! diagonal elements S(I) are the singular values of X. The ! columns of U are the corresponding left singular vectors, ! and the columns of V the right singular vectors. ! ! On Entry ! ! X DOUBLE PRECISION(LDX,P), where LDX >= N. ! X contains the matrix whose singular value ! decomposition is to be computed. X is ! destroyed by DSVDC. ! ! LDX INTEGER. ! LDX is the leading dimension of the array X. ! ! N INTEGER. ! N is the number of rows of the matrix X. ! ! P INTEGER. ! P is the number of columns of the matrix X. ! ! LDU INTEGER. ! LDU is the leading dimension of the array U. ! (See below). ! ! LDV INTEGER. ! LDV is the leading dimension of the array V. ! (See below). ! ! WORK DOUBLE PRECISION(N). ! WORK is a scratch array. ! ! JOB INTEGER. ! JOB controls the computation of the singular ! vectors. It has the decimal expansion AB ! with the following meaning ! ! A == 0 do not compute the left singular ! vectors. ! A == 1 return the N left singular vectors ! in U. ! A >= 2 return the first MIN(N,P) singular ! vectors in U. ! B == 0 do not compute the right singular ! vectors. ! B == 1 return the right singular vectors ! in V. ! ! On Return ! ! S DOUBLE PRECISION(MM), where MM=MIN(N+1,P). ! The first MIN(N,P) entries of S contain the ! singular values of X arranged in descending ! order of magnitude. ! ! E DOUBLE PRECISION(P). ! E ordinarily contains zeros. However see the ! discussion of INFO for exceptions. ! ! U DOUBLE PRECISION(LDU,K), where LDU >= N. ! If JOBA == 1, then K == N. ! If JOBA >= 2, then K == MIN(N,P). ! U contains the matrix of right singular vectors. ! U is not referenced if JOBA == 0. If N <= P ! or if JOBA == 2, then U may be identified with X ! in the subroutine call. ! ! V DOUBLE PRECISION(LDV,P), where LDV >= P. ! V contains the matrix of right singular vectors. ! V is not referenced if JOB == 0. If P <= N, ! then V may be identified with X in the ! subroutine call. ! ! INFO INTEGER. ! The singular values (and their corresponding ! singular vectors) S(INFO+1),S(INFO+2),...,S(M) ! are correct (here M=MIN(N,P)). Thus if ! INFO == 0, all the singular values and their ! vectors are correct. In any event, the matrix ! B = TRANS(U)*X*V is the bidiagonal matrix ! with the elements of S on its diagonal and the ! elements of E on its super-diagonal (TRANS(U) ! is the transpose of U). Thus the singular ! values of X and B are the same. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT, DNRM2, DROT, DROTG, DSCAL, DSWAP !***REVISION HISTORY (YYMMDD) ! 790319 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSVDC INTEGER LDX,N,P,LDU,LDV,JOB,INFO DOUBLE PRECISION X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) ! ! 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 !***FIRST EXECUTABLE STATEMENT DSVDC ! ! SET THE MAXIMUM NUMBER OF ITERATIONS. ! MAXIT = 30 ! ! DETERMINE WHAT IS TO BE COMPUTED. ! WANTU = .FALSE. WANTV = .FALSE. JOBU = MOD(JOB,100)/10 NCU = N if (JOBU > 1) NCU = MIN(N,P) if (JOBU /= 0) WANTU = .TRUE. if (MOD(JOB,10) /= 0) WANTV = .TRUE. ! ! REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS ! IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. ! INFO = 0 NCT = MIN(N-1,P) NRT = MAX(0,MIN(P-2,N)) LU = MAX(NCT,NRT) if (LU < 1) go to 170 DO 160 L = 1, LU LP1 = L + 1 if (L > NCT) go to 20 ! ! COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND ! PLACE THE L-TH DIAGONAL IN S(L). ! S(L) = DNRM2(N-L+1,X(L,L),1) if (S(L) == 0.0D0) go to 10 if (X(L,L) /= 0.0D0) S(L) = SIGN(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 < LP1) go to 50 DO 40 J = LP1, P if (L > NCT) go to 30 if (S(L) == 0.0D0) go to 30 ! ! APPLY THE TRANSFORMATION. ! 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 ! ! PLACE THE L-TH ROW OF X INTO E FOR THE ! SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. ! E(J) = X(L,J) 40 CONTINUE 50 CONTINUE if (.NOT.WANTU .OR. L > NCT) go to 70 ! ! PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK ! MULTIPLICATION. ! DO 60 I = L, N U(I,L) = X(I,L) 60 CONTINUE 70 CONTINUE if (L > NRT) go to 150 ! ! COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE ! L-TH SUPER-DIAGONAL IN E(L). ! E(L) = DNRM2(P-L,E(LP1),1) if (E(L) == 0.0D0) go to 80 if (E(LP1) /= 0.0D0) E(L) = SIGN(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 > N .OR. E(L) == 0.0D0) go to 120 ! ! APPLY THE TRANSFORMATION. ! 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 ! ! PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT ! BACK MULTIPLICATION. ! DO 130 I = LP1, P V(I,L) = E(I) 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE ! ! SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. ! M = MIN(P,N+1) NCTP1 = NCT + 1 NRTP1 = NRT + 1 if (NCT < P) S(NCTP1) = X(NCTP1,NCTP1) if (N < M) S(M) = 0.0D0 if (NRTP1 < M) E(NRTP1) = X(NRTP1,M) E(M) = 0.0D0 ! ! if REQUIRED, GENERATE U. ! if (.NOT.WANTU) go to 300 if (NCU < 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 < 1) go to 290 DO 280 LL = 1, NCT L = NCT - LL + 1 if (S(L) == 0.0D0) go to 250 LP1 = L + 1 if (NCU < 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 < 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 ! ! if IT IS REQUIRED, GENERATE V. ! if (.NOT.WANTV) go to 350 DO 340 LL = 1, P L = P - LL + 1 LP1 = L + 1 if (L > NRT) go to 320 if (E(L) == 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 ! ! MAIN ITERATION LOOP FOR THE SINGULAR VALUES. ! MM = M ITER = 0 360 CONTINUE ! ! QUIT if ALL THE SINGULAR VALUES HAVE BEEN FOUND. ! if (M == 0) go to 620 ! ! if TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET ! FLAG AND RETURN. ! if (ITER < MAXIT) go to 370 INFO = M go to 620 370 CONTINUE ! ! THIS SECTION OF THE PROGRAM INSPECTS FOR ! NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON ! COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. ! ! KASE = 1 if S(M) AND E(L-1) ARE NEGLIGIBLE AND L < M ! KASE = 2 if S(L) IS NEGLIGIBLE AND L < M ! KASE = 3 if E(L-1) IS NEGLIGIBLE, L < M, AND ! S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). ! KASE = 4 if E(M-1) IS NEGLIGIBLE (CONVERGENCE). ! DO 390 LL = 1, M L = M - LL if (L == 0) go to 400 TEST = ABS(S(L)) + ABS(S(L+1)) ZTEST = TEST + ABS(E(L)) if (ZTEST /= TEST) go to 380 E(L) = 0.0D0 go to 400 380 CONTINUE 390 CONTINUE 400 CONTINUE if (L /= 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 if (LS == L) go to 440 TEST = 0.0D0 if (LS /= M) TEST = TEST + ABS(E(LS)) if (LS /= L + 1) TEST = TEST + ABS(E(LS-1)) ZTEST = TEST + ABS(S(LS)) if (ZTEST /= TEST) go to 420 S(LS) = 0.0D0 go to 440 420 CONTINUE 430 CONTINUE 440 CONTINUE if (LS /= L) go to 450 KASE = 3 go to 470 450 CONTINUE if (LS /= M) go to 460 KASE = 1 go to 470 460 CONTINUE KASE = 2 L = LS 470 CONTINUE 480 CONTINUE L = L + 1 ! ! PERFORM THE TASK INDICATED BY KASE. ! go to (490,520,540,570), KASE ! ! DEFLATE NEGLIGIBLE S(M). ! 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 == 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 ! ! SPLIT AT NEGLIGIBLE S(L). ! 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 ! ! PERFORM ONE QR STEP. ! 540 CONTINUE ! ! CALCULATE THE SHIFT. ! SCALE = MAX(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.0D0 C = (SM*EMM1)**2 SHIFT = 0.0D0 if (B == 0.0D0 .AND. C == 0.0D0) go to 550 SHIFT = SQRT(B**2+C) if (B < 0.0D0) SHIFT = -SHIFT SHIFT = C/(B + SHIFT) 550 CONTINUE F = (SL + SM)*(SL - SM) - SHIFT G = SL*EL ! ! CHASE ZEROS. ! MM1 = M - 1 DO 560 K = L, MM1 call DROTG(F,G,CS,SN) if (K /= 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 < 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 ! ! CONVERGENCE. ! 570 CONTINUE ! ! MAKE THE SINGULAR VALUE POSITIVE. ! if (S(L) >= 0.0D0) go to 580 S(L) = -S(L) if (WANTV) call DSCAL(P,-1.0D0,V(1,L),1) 580 CONTINUE ! ! ORDER THE SINGULAR VALUE. ! 590 if (L == MM) go to 600 if (S(L) >= S(L+1)) go to 600 T = S(L) S(L) = S(L+1) S(L+1) = T if (WANTV .AND. L < P) & call DSWAP(P,V(1,L),1,V(1,L+1),1) if (WANTU .AND. L < 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 DSWAP (N, DX, INCX, DY, INCY) ! !! DSWAP interchanges two vectors. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A5 !***TYPE DOUBLE PRECISION (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) !***KEYWORDS BLAS, INTERCHANGE, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! DY double precision vector with N elements ! INCY storage spacing between elements of DY ! ! --Output-- ! DX input vector DY (unchanged if N <= 0) ! DY input vector DX (unchanged if N <= 0) ! ! Interchange double precision DX and double precision DY. ! For I = 0 to N-1, interchange DX(LX+I*INCX) and DY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DSWAP DOUBLE PRECISION DX(*), DY(*), DTEMP1, DTEMP2, DTEMP3 !***FIRST EXECUTABLE STATEMENT DSWAP if (N <= 0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IX = 1 IY = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP1 = DX(IX) DX(IX) = DY(IY) DY(IY) = DTEMP1 IX = IX + INCX IY = IY + INCY 10 CONTINUE return ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 3. ! 20 M = MOD(N,3) if (M == 0) go to 40 DO 30 I = 1,M DTEMP1 = DX(I) DX(I) = DY(I) DY(I) = DTEMP1 30 CONTINUE if (N < 3) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 DTEMP1 = DX(I) DTEMP2 = DX(I+1) DTEMP3 = DX(I+2) DX(I) = DY(I) DX(I+1) = DY(I+1) DX(I+2) = DY(I+2) DY(I) = DTEMP1 DY(I+1) = DTEMP2 DY(I+2) = DTEMP3 50 CONTINUE return ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX DTEMP1 = DX(I) DX(I) = DY(I) DY(I) = DTEMP1 70 CONTINUE return end subroutine DSYMM (SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, & C, LDC) ! !! DSYMM performs C = alpha*A*B + beta*C or C = alpha*B*A + beta*C. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE DOUBLE PRECISION (SSYMM-S, DSYMM-D, CSYMM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! DSYMM performs one of the matrix-matrix operations ! ! C := alpha*A*B + beta*C, ! ! or ! ! C := alpha*B*A + beta*C, ! ! where alpha and beta are scalars, A is a symmetric matrix and B and ! C are m by n matrices. ! ! Parameters ! ========== ! ! SIDE - CHARACTER*1. ! On entry, SIDE specifies whether the symmetric matrix A ! appears on the left or right in the operation as follows: ! ! SIDE = 'L' or 'l' C := alpha*A*B + beta*C, ! ! SIDE = 'R' or 'r' C := alpha*B*A + beta*C, ! ! Unchanged on exit. ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the symmetric matrix A is to be ! referenced as follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of the ! symmetric matrix is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of the ! symmetric matrix is to be referenced. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix C. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix C. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is ! m when SIDE = 'L' or 'l' and is n otherwise. ! Before entry with SIDE = 'L' or 'l', the m by m part of ! the array A must contain the symmetric matrix, such that ! when UPLO = 'U' or 'u', the leading m by m upper triangular ! part of the array A must contain the upper triangular part ! of the symmetric matrix and the strictly lower triangular ! part of A is not referenced, and when UPLO = 'L' or 'l', ! the leading m by m lower triangular part of the array A ! must contain the lower triangular part of the symmetric ! matrix and the strictly upper triangular part of A is not ! referenced. ! Before entry with SIDE = 'R' or 'r', the n by n part of ! the array A must contain the symmetric matrix, such that ! when UPLO = 'U' or 'u', the leading n by n upper triangular ! part of the array A must contain the upper triangular part ! of the symmetric matrix and the strictly lower triangular ! part of A is not referenced, and when UPLO = 'L' or 'l', ! the leading n by n lower triangular part of the array A ! must contain the lower triangular part of the symmetric ! matrix and the strictly upper triangular part of A is not ! referenced. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When SIDE = 'L' or 'l' then ! LDA must be at least max( 1, m ), otherwise LDA must be at ! least max( 1, n ). ! Unchanged on exit. ! ! B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). ! Before entry, the leading m by n part of the array B must ! contain the matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. LDB must be at least ! max( 1, m ). ! Unchanged on exit. ! ! BETA - DOUBLE PRECISION. ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then C need not be set on input. ! Unchanged on exit. ! ! C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). ! Before entry, the leading m by n part of the array C must ! contain the matrix C, except when beta is zero, in which ! case C need not be set on entry. ! On exit, the array C is overwritten by the m by n updated ! matrix. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DSYMM ! .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, K, NROWA DOUBLE PRECISION TEMP1, TEMP2 ! .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) !***FIRST EXECUTABLE STATEMENT DSYMM ! ! Set NROWA as the number of rows of A. ! if ( LSAME( SIDE, 'L' ) )THEN NROWA = M ELSE NROWA = N end if UPPER = LSAME( UPLO, 'U' ) ! ! Test the input parameters. ! INFO = 0 if ( ( .NOT.LSAME( SIDE, 'L' ) ).AND. & ( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE if ( M < 0 )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDB < MAX( 1, M ) )THEN INFO = 9 ELSE if ( LDC < MAX( 1, M ) )THEN INFO = 12 end if if ( INFO /= 0 )THEN call XERBLA( 'DSYMM ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if return end if ! ! Start the operations. ! if ( LSAME( SIDE, 'L' ) )THEN ! ! Form C := alpha*A*B + beta*C. ! if ( UPPER )THEN DO 70, J = 1, N DO 60, I = 1, M TEMP1 = ALPHA*B( I, J ) TEMP2 = ZERO DO 50, K = 1, I - 1 C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) TEMP2 = TEMP2 + B( K, J )*A( K, I ) 50 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & TEMP1*A( I, I ) + ALPHA*TEMP2 end if 60 CONTINUE 70 CONTINUE ELSE DO 100, J = 1, N DO 90, I = M, 1, -1 TEMP1 = ALPHA*B( I, J ) TEMP2 = ZERO DO 80, K = I + 1, M C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) TEMP2 = TEMP2 + B( K, J )*A( K, I ) 80 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & TEMP1*A( I, I ) + ALPHA*TEMP2 end if 90 CONTINUE 100 CONTINUE end if ELSE ! ! Form C := alpha*B*A + beta*C. ! DO 170, J = 1, N TEMP1 = ALPHA*A( J, J ) if ( BETA == ZERO )THEN DO 110, I = 1, M C( I, J ) = TEMP1*B( I, J ) 110 CONTINUE ELSE DO 120, I = 1, M C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) 120 CONTINUE end if DO 140, K = 1, J - 1 if ( UPPER )THEN TEMP1 = ALPHA*A( K, J ) ELSE TEMP1 = ALPHA*A( J, K ) end if DO 130, I = 1, M C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 130 CONTINUE 140 CONTINUE DO 160, K = J + 1, N if ( UPPER )THEN TEMP1 = ALPHA*A( J, K ) ELSE TEMP1 = ALPHA*A( K, J ) end if DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 150 CONTINUE 160 CONTINUE 170 CONTINUE end if ! return ! ! End of DSYMM . ! end subroutine DSYMV (UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) ! !! DSYMV performs y = alpha*A*x + beta*y. ! !***PURPOSE Perform the matrix-vector operation. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (SSYMV-S, DSYMV-D, CSYMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DSYMV performs the matrix-vector operation ! ! y := alpha*A*x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! A is an n by n symmetric matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array A is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of A ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of A ! is to be referenced. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of A is not referenced. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - DOUBLE PRECISION. ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. On exit, Y is overwritten by the updated ! vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DSYMV ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT DSYMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 5 ELSE if ( INCX == 0 )THEN INFO = 7 ELSE if ( INCY == 0 )THEN INFO = 10 end if if ( INFO /= 0 )THEN call XERBLA( 'DSYMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set up the start points in X and Y. ! if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return if ( LSAME( UPLO, 'U' ) )THEN ! ! Form y when A is stored in upper triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO DO 50, I = 1, J - 1 Y( I ) = Y( I ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( I ) 50 CONTINUE Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY DO 70, I = 1, J - 1 Y( IY ) = Y( IY ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 80 CONTINUE end if ELSE ! ! Form y when A is stored in lower triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*A( J, J ) DO 90, I = J + 1, N Y( I ) = Y( I ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( I ) 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*A( J, J ) IX = JX IY = JY DO 110, I = J + 1, N IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE end if end if ! return ! ! End of DSYMV . ! end subroutine DSYR2 (UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) ! !! DSYR2 performs A = alpha*x*y' + alpha*y*x' + A. ! !***PURPOSE Perform the symmetric rank 2 operation. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (SSYR2-S, DSYR2-D, CSYR2-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DSYR2 performs the symmetric rank 2 operation ! ! A := alpha*x*y' + alpha*y*x' + A, ! ! where alpha is a scalar, x and y are n element vectors and A is an n ! by n symmetric matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array A is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of A ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of A ! is to be referenced. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! Y - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. ! Unchanged on exit. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of A is not referenced. On exit, the ! upper triangular part of the array A is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of A is not referenced. On exit, the ! lower triangular part of the array A is overwritten by the ! lower triangular part of the updated matrix. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DSYR2 ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, INCY, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT DSYR2 ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( INCY == 0 )THEN INFO = 7 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'DSYR2 ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ( ( INCX /= 1 ).OR.( INCY /= 1 ) )THEN if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if JX = KX JY = KY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when A is stored in the upper triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 20, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) DO 10, I = 1, J A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 10 CONTINUE end if 20 CONTINUE ELSE DO 40, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = KX IY = KY DO 30, I = 1, J A( I, J ) = A( I, J ) + X( IX )*TEMP1 & + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE end if JX = JX + INCX JY = JY + INCY 40 CONTINUE end if ELSE ! ! Form A when A is stored in the lower triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) DO 50, I = J, N A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 50 CONTINUE end if 60 CONTINUE ELSE DO 80, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = JX IY = JY DO 70, I = J, N A( I, J ) = A( I, J ) + X( IX )*TEMP1 & + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 70 CONTINUE end if JX = JX + INCX JY = JY + INCY 80 CONTINUE end if end if ! return ! ! End of DSYR2 . ! end subroutine DSYR2K (UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, & C, LDC) ! !! DSYR2K performs a symmetric rank 2k update operation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE DOUBLE PRECISION (SSYR2-S, DSYR2-D, CSYR2-C, DSYR2K-D) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! DSYR2K performs one of the symmetric rank 2k operations ! ! C := alpha*A*B' + alpha*B*A' + beta*C, ! ! or ! ! C := alpha*A'*B + alpha*B'*A + beta*C, ! ! where alpha and beta are scalars, C is an n by n symmetric matrix ! and A and B are n by k matrices in the first case and k by n ! matrices in the second case. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array C is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of C ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of C ! is to be referenced. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + ! beta*C. ! ! TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + ! beta*C. ! ! TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + ! beta*C. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with TRANS = 'N' or 'n', K specifies the number ! of columns of the matrices A and B, and on entry with ! TRANS = 'T' or 't' or 'C' or 'c', K specifies the number ! of rows of the matrices A and B. K must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array A must contain the matrix A, otherwise ! the leading k by n part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDA must be at least max( 1, n ), otherwise LDA must ! be at least max( 1, k ). ! Unchanged on exit. ! ! B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array B must contain the matrix B, otherwise ! the leading k by n part of the array B must contain the ! matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDB must be at least max( 1, n ), otherwise LDB must ! be at least max( 1, k ). ! Unchanged on exit. ! ! BETA - DOUBLE PRECISION. ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array C must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of C is not referenced. On exit, the ! upper triangular part of the array C is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array C must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of C is not referenced. On exit, the ! lower triangular part of the array C is overwritten by the ! lower triangular part of the updated matrix. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DSYR2K ! .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) ! ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, L, NROWA DOUBLE PRECISION TEMP1, TEMP2 ! .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) !***FIRST EXECUTABLE STATEMENT DSYR2K ! ! Test the input parameters. ! if ( LSAME( TRANS, 'N' ) )THEN NROWA = N ELSE NROWA = K end if UPPER = LSAME( UPLO, 'U' ) ! INFO = 0 if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.LSAME( TRANS, 'N' ) ).AND. & ( .NOT.LSAME( TRANS, 'T' ) ).AND. & ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( K < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDB < MAX( 1, NROWA ) )THEN INFO = 9 ELSE if ( LDC < MAX( 1, N ) )THEN INFO = 12 end if if ( INFO /= 0 )THEN call XERBLA( 'DSYR2K', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( UPPER )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, J C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, J C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if ELSE if ( BETA == ZERO )THEN DO 60, J = 1, N DO 50, I = J, N C( I, J ) = ZERO 50 CONTINUE 60 CONTINUE ELSE DO 80, J = 1, N DO 70, I = J, N C( I, J ) = BETA*C( I, J ) 70 CONTINUE 80 CONTINUE end if end if return end if ! ! Start the operations. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form C := alpha*A*B' + alpha*B*A' + C. ! if ( UPPER )THEN DO 130, J = 1, N if ( BETA == ZERO )THEN DO 90, I = 1, J C( I, J ) = ZERO 90 CONTINUE ELSE if ( BETA /= ONE )THEN DO 100, I = 1, J C( I, J ) = BETA*C( I, J ) 100 CONTINUE end if DO 120, L = 1, K if ( ( A( J, L ) /= ZERO ).OR. & ( B( J, L ) /= ZERO ) )THEN TEMP1 = ALPHA*B( J, L ) TEMP2 = ALPHA*A( J, L ) DO 110, I = 1, J C( I, J ) = C( I, J ) + & A( I, L )*TEMP1 + B( I, L )*TEMP2 110 CONTINUE end if 120 CONTINUE 130 CONTINUE ELSE DO 180, J = 1, N if ( BETA == ZERO )THEN DO 140, I = J, N C( I, J ) = ZERO 140 CONTINUE ELSE if ( BETA /= ONE )THEN DO 150, I = J, N C( I, J ) = BETA*C( I, J ) 150 CONTINUE end if DO 170, L = 1, K if ( ( A( J, L ) /= ZERO ).OR. & ( B( J, L ) /= ZERO ) )THEN TEMP1 = ALPHA*B( J, L ) TEMP2 = ALPHA*A( J, L ) DO 160, I = J, N C( I, J ) = C( I, J ) + & A( I, L )*TEMP1 + B( I, L )*TEMP2 160 CONTINUE end if 170 CONTINUE 180 CONTINUE end if ELSE ! ! Form C := alpha*A'*B + alpha*B'*A + C. ! if ( UPPER )THEN DO 210, J = 1, N DO 200, I = 1, J TEMP1 = ZERO TEMP2 = ZERO DO 190, L = 1, K TEMP1 = TEMP1 + A( L, I )*B( L, J ) TEMP2 = TEMP2 + B( L, I )*A( L, J ) 190 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & ALPHA*TEMP1 + ALPHA*TEMP2 end if 200 CONTINUE 210 CONTINUE ELSE DO 240, J = 1, N DO 230, I = J, N TEMP1 = ZERO TEMP2 = ZERO DO 220, L = 1, K TEMP1 = TEMP1 + A( L, I )*B( L, J ) TEMP2 = TEMP2 + B( L, I )*A( L, J ) 220 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & ALPHA*TEMP1 + ALPHA*TEMP2 end if 230 CONTINUE 240 CONTINUE end if end if ! return ! ! End of DSYR2K. ! end subroutine DSYR (UPLO, N, ALPHA, X, INCX, A, LDA) ! !! DSYR performs A = alpha*x*x' + A. ! !***PURPOSE Perform the symmetric rank 1 operation. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (DSYR-D) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DSYR performs the symmetric rank 1 operation ! ! A := alpha*x*x' + A, ! ! where alpha is a real scalar, x is an n element vector and A is an ! n by n symmetric matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array A is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of A ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of A ! is to be referenced. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of A is not referenced. On exit, the ! upper triangular part of the array A is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of A is not referenced. On exit, the ! lower triangular part of the array A is overwritten by the ! lower triangular part of the updated matrix. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DSYR ! .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT DSYR ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'DSYR ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Set the start point in X if the increment is not unity. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when A is stored in upper triangle. ! if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*X( J ) DO 10, I = 1, J A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE end if 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IX = KX DO 30, I = 1, J A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE end if JX = JX + INCX 40 CONTINUE end if ELSE ! ! Form A when A is stored in lower triangle. ! if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*X( J ) DO 50, I = J, N A( I, J ) = A( I, J ) + X( I )*TEMP 50 CONTINUE end if 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IX = JX DO 70, I = J, N A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if end if ! return end subroutine DSYRK (UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) ! !! DSYRK performs a symmetric rank k update operation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE DOUBLE PRECISION (SSYRK-S, DSYRK-D, CSYRK-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! DSYRK performs one of the symmetric rank k operations ! ! C := alpha*A*A' + beta*C, ! ! or ! ! C := alpha*A'*A + beta*C, ! ! where alpha and beta are scalars, C is an n by n symmetric matrix ! and A is an n by k matrix in the first case and a k by n matrix ! in the second case. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array C is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of C ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of C ! is to be referenced. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. ! ! TRANS = 'T' or 't' C := alpha*A'*A + beta*C. ! ! TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with TRANS = 'N' or 'n', K specifies the number ! of columns of the matrix A, and on entry with ! TRANS = 'T' or 't' or 'C' or 'c', K specifies the number ! of rows of the matrix A. K must be at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array A must contain the matrix A, otherwise ! the leading k by n part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDA must be at least max( 1, n ), otherwise LDA must ! be at least max( 1, k ). ! Unchanged on exit. ! ! BETA - DOUBLE PRECISION. ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array C must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of C is not referenced. On exit, the ! upper triangular part of the array C is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array C must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of C is not referenced. On exit, the ! lower triangular part of the array C is overwritten by the ! lower triangular part of the updated matrix. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DSYRK ! .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC DOUBLE PRECISION ALPHA, BETA ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, L, NROWA DOUBLE PRECISION TEMP ! .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) !***FIRST EXECUTABLE STATEMENT DSYRK ! ! Test the input parameters. ! if ( LSAME( TRANS, 'N' ) )THEN NROWA = N ELSE NROWA = K end if UPPER = LSAME( UPLO, 'U' ) ! INFO = 0 if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.LSAME( TRANS, 'N' ) ).AND. & ( .NOT.LSAME( TRANS, 'T' ) ).AND. & ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( K < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDC < MAX( 1, N ) )THEN INFO = 10 end if if ( INFO /= 0 )THEN call XERBLA( 'DSYRK ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( UPPER )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, J C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, J C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if ELSE if ( BETA == ZERO )THEN DO 60, J = 1, N DO 50, I = J, N C( I, J ) = ZERO 50 CONTINUE 60 CONTINUE ELSE DO 80, J = 1, N DO 70, I = J, N C( I, J ) = BETA*C( I, J ) 70 CONTINUE 80 CONTINUE end if end if return end if ! ! Start the operations. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form C := alpha*A*A' + beta*C. ! if ( UPPER )THEN DO 130, J = 1, N if ( BETA == ZERO )THEN DO 90, I = 1, J C( I, J ) = ZERO 90 CONTINUE ELSE if ( BETA /= ONE )THEN DO 100, I = 1, J C( I, J ) = BETA*C( I, J ) 100 CONTINUE end if DO 120, L = 1, K if ( A( J, L ) /= ZERO )THEN TEMP = ALPHA*A( J, L ) DO 110, I = 1, J C( I, J ) = C( I, J ) + TEMP*A( I, L ) 110 CONTINUE end if 120 CONTINUE 130 CONTINUE ELSE DO 180, J = 1, N if ( BETA == ZERO )THEN DO 140, I = J, N C( I, J ) = ZERO 140 CONTINUE ELSE if ( BETA /= ONE )THEN DO 150, I = J, N C( I, J ) = BETA*C( I, J ) 150 CONTINUE end if DO 170, L = 1, K if ( A( J, L ) /= ZERO )THEN TEMP = ALPHA*A( J, L ) DO 160, I = J, N C( I, J ) = C( I, J ) + TEMP*A( I, L ) 160 CONTINUE end if 170 CONTINUE 180 CONTINUE end if ELSE ! ! Form C := alpha*A'*A + beta*C. ! if ( UPPER )THEN DO 210, J = 1, N DO 200, I = 1, J TEMP = ZERO DO 190, L = 1, K TEMP = TEMP + A( L, I )*A( L, J ) 190 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 200 CONTINUE 210 CONTINUE ELSE DO 240, J = 1, N DO 230, I = J, N TEMP = ZERO DO 220, L = 1, K TEMP = TEMP + A( L, I )*A( L, J ) 220 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 230 CONTINUE 240 CONTINUE end if end if ! return ! ! End of DSYRK . ! end subroutine DTBMV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) ! !! DTBMV computes x = A*x or x = A'*x when A is a triangular band matrix. ! !***PURPOSE Perform one of the matrix-vector operations. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (STBMV-S, DTBMV-D, CTBMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DTBMV performs one of the matrix-vector operations ! ! x := A*x, or x := A'*x, ! ! where x is an n element vector and A is an n by n unit, or non-unit, ! upper or lower triangular band matrix, with ( k + 1) diagonals. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' x := A*x. ! ! TRANS = 'T' or 't' x := A'*x. ! ! TRANS = 'C' or 'c' x := A'*x. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with UPLO = 'U' or 'u', K specifies the number of ! super-diagonals of the matrix A. ! On entry with UPLO = 'L' or 'l', K specifies the number of ! sub-diagonals of the matrix A. ! K must satisfy 0 .le. K. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) ! by n part of the array A must contain the upper triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. The top left k by k triangle ! of the array A is not referenced. ! The following program segment will transfer an upper ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = K + 1 - J ! DO 10, I = MAX( 1, J - K ), J ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) ! by n part of the array A must contain the lower triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. The bottom right k by k triangle of the ! array A is not referenced. ! The following program segment will transfer a lower ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = 1 - J ! DO 10, I = J, MIN( N, J + K ) ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Note that when DIAG = 'U' or 'u' the elements of the array A ! corresponding to the diagonal elements of the matrix are not ! referenced, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( k + 1 ). ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. On exit, X is overwritten with the ! transformed vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DTBMV ! .. Scalar Arguments .. INTEGER INCX, K, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX, MIN !***FIRST EXECUTABLE STATEMENT DTBMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( K < 0 )THEN INFO = 5 ELSE if ( LDA < ( K + 1 ) )THEN INFO = 7 ELSE if ( INCX == 0 )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'DTBMV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := A*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = X( J ) L = KPLUS1 - J DO 10, I = MAX( 1, J - K ), J - 1 X( I ) = X( I ) + TEMP*A( L + I, J ) 10 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( KPLUS1, J ) end if 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX L = KPLUS1 - J DO 30, I = MAX( 1, J - K ), J - 1 X( IX ) = X( IX ) + TEMP*A( L + I, J ) IX = IX + INCX 30 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( KPLUS1, J ) end if JX = JX + INCX if ( J > K ) & KX = KX + INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = N, 1, -1 if ( X( J ) /= ZERO )THEN TEMP = X( J ) L = 1 - J DO 50, I = MIN( N, J + K ), J + 1, -1 X( I ) = X( I ) + TEMP*A( L + I, J ) 50 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( 1, J ) end if 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX L = 1 - J DO 70, I = MIN( N, J + K ), J + 1, -1 X( IX ) = X( IX ) + TEMP*A( L + I, J ) IX = IX - INCX 70 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( 1, J ) end if JX = JX - INCX if ( ( N - J ) >= K ) & KX = KX - INCX 80 CONTINUE end if end if ELSE ! ! Form x := A'*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) L = KPLUS1 - J if ( NOUNIT ) & TEMP = TEMP*A( KPLUS1, J ) DO 90, I = J - 1, MAX( 1, J - K ), -1 TEMP = TEMP + A( L + I, J )*X( I ) 90 CONTINUE X( J ) = TEMP 100 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 120, J = N, 1, -1 TEMP = X( JX ) KX = KX - INCX IX = KX L = KPLUS1 - J if ( NOUNIT ) & TEMP = TEMP*A( KPLUS1, J ) DO 110, I = J - 1, MAX( 1, J - K ), -1 TEMP = TEMP + A( L + I, J )*X( IX ) IX = IX - INCX 110 CONTINUE X( JX ) = TEMP JX = JX - INCX 120 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 140, J = 1, N TEMP = X( J ) L = 1 - J if ( NOUNIT ) & TEMP = TEMP*A( 1, J ) DO 130, I = J + 1, MIN( N, J + K ) TEMP = TEMP + A( L + I, J )*X( I ) 130 CONTINUE X( J ) = TEMP 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) KX = KX + INCX IX = KX L = 1 - J if ( NOUNIT ) & TEMP = TEMP*A( 1, J ) DO 150, I = J + 1, MIN( N, J + K ) TEMP = TEMP + A( L + I, J )*X( IX ) IX = IX + INCX 150 CONTINUE X( JX ) = TEMP JX = JX + INCX 160 CONTINUE end if end if end if ! return ! ! End of DTBMV . ! end subroutine DTBSV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) ! !! DTBSV solves a triangular band linear system. ! !***PURPOSE Solve one of the systems of equations. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (STBSV-S, DTBSV-D, CTBSV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DTBSV solves one of the systems of equations ! ! A*x = b, or A'*x = b, ! ! where b and x are n element vectors and A is an n by n unit, or ! non-unit, upper or lower triangular band matrix, with ( k + 1) ! diagonals. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the equations to be solved as ! follows: ! ! TRANS = 'N' or 'n' A*x = b. ! ! TRANS = 'T' or 't' A'*x = b. ! ! TRANS = 'C' or 'c' A'*x = b. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with UPLO = 'U' or 'u', K specifies the number of ! super-diagonals of the matrix A. ! On entry with UPLO = 'L' or 'l', K specifies the number of ! sub-diagonals of the matrix A. ! K must satisfy 0 .le. K. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) ! by n part of the array A must contain the upper triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. The top left k by k triangle ! of the array A is not referenced. ! The following program segment will transfer an upper ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = K + 1 - J ! DO 10, I = MAX( 1, J - K ), J ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) ! by n part of the array A must contain the lower triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. The bottom right k by k triangle of the ! array A is not referenced. ! The following program segment will transfer a lower ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = 1 - J ! DO 10, I = J, MIN( N, J + K ) ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Note that when DIAG = 'U' or 'u' the elements of the array A ! corresponding to the diagonal elements of the matrix are not ! referenced, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( k + 1 ). ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element right-hand side vector b. On exit, X is overwritten ! with the solution vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DTBSV ! .. Scalar Arguments .. INTEGER INCX, K, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX, MIN !***FIRST EXECUTABLE STATEMENT DTBSV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( K < 0 )THEN INFO = 5 ELSE if ( LDA < ( K + 1 ) )THEN INFO = 7 ELSE if ( INCX == 0 )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'DTBSV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed by sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := inv( A )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 20, J = N, 1, -1 if ( X( J ) /= ZERO )THEN L = KPLUS1 - J if ( NOUNIT ) & X( J ) = X( J )/A( KPLUS1, J ) TEMP = X( J ) DO 10, I = J - 1, MAX( 1, J - K ), -1 X( I ) = X( I ) - TEMP*A( L + I, J ) 10 CONTINUE end if 20 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 40, J = N, 1, -1 KX = KX - INCX if ( X( JX ) /= ZERO )THEN IX = KX L = KPLUS1 - J if ( NOUNIT ) & X( JX ) = X( JX )/A( KPLUS1, J ) TEMP = X( JX ) DO 30, I = J - 1, MAX( 1, J - K ), -1 X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX - INCX 30 CONTINUE end if JX = JX - INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN L = 1 - J if ( NOUNIT ) & X( J ) = X( J )/A( 1, J ) TEMP = X( J ) DO 50, I = J + 1, MIN( N, J + K ) X( I ) = X( I ) - TEMP*A( L + I, J ) 50 CONTINUE end if 60 CONTINUE ELSE JX = KX DO 80, J = 1, N KX = KX + INCX if ( X( JX ) /= ZERO )THEN IX = KX L = 1 - J if ( NOUNIT ) & X( JX ) = X( JX )/A( 1, J ) TEMP = X( JX ) DO 70, I = J + 1, MIN( N, J + K ) X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX + INCX 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if end if ELSE ! ! Form x := inv( A')*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 100, J = 1, N TEMP = X( J ) L = KPLUS1 - J DO 90, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( I ) 90 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( KPLUS1, J ) X( J ) = TEMP 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX L = KPLUS1 - J DO 110, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX + INCX 110 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( KPLUS1, J ) X( JX ) = TEMP JX = JX + INCX if ( J > K ) & KX = KX + INCX 120 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) L = 1 - J DO 130, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( I ) 130 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( 1, J ) X( J ) = TEMP 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX L = 1 - J DO 150, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX - INCX 150 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( 1, J ) X( JX ) = TEMP JX = JX - INCX if ( ( N - J ) >= K ) & KX = KX - INCX 160 CONTINUE end if end if end if ! return ! ! End of DTBSV . ! end subroutine DTIN (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) ! !! DTIN reads in SLAP Triad Format Linear System. ! Routine to read in a SLAP Triad format matrix and right ! hand side and solution to the system, if known. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY N1 !***TYPE DOUBLE PRECISION (STIN-S, DTIN-D) !***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB ! DOUBLE PRECISION A(NELT), SOLN(N), RHS(N) ! ! call DTIN( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) ! ! *Arguments: ! N :OUT Integer ! Order of the Matrix. ! NELT :INOUT Integer. ! On input NELT is the maximum number of non-zeros that ! can be stored in the IA, JA, A arrays. ! On output NELT is the number of non-zeros stored in A. ! IA :OUT Integer IA(NELT). ! JA :OUT Integer JA(NELT). ! A :OUT Double Precision A(NELT). ! On output these arrays hold the matrix A in the SLAP ! Triad format. See "Description", below. ! ISYM :OUT Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! SOLN :OUT Double Precision SOLN(N). ! The solution to the linear system, if present. This array ! is accessed if and only if JOB to read it in, see below. ! If the user requests that SOLN be read in, but it is not in ! the file, then it is simply zeroed out. ! RHS :OUT Double Precision RHS(N). ! The right hand side vector. This array is accessed if and ! only if JOB is set to read it in, see below. ! If the user requests that RHS be read in, but it is not in ! the file, then it is simply zeroed out. ! IUNIT :IN Integer. ! Fortran logical I/O device unit number to write the matrix ! to. This unit must be connected in a system dependent fashion ! to a file or the console or you will get a nasty message ! from the Fortran I/O libraries. ! JOB :INOUT Integer. ! Flag indicating what I/O operations to perform. ! On input JOB indicates what Input operations to try to ! perform. ! JOB = 0 => Read only the matrix. ! JOB = 1 => Read matrix and RHS (if present). ! JOB = 2 => Read matrix and SOLN (if present). ! JOB = 3 => Read matrix, RHS and SOLN (if present). ! On output JOB indicates what operations were actually ! performed. ! JOB = 0 => Read in only the matrix. ! JOB = 1 => Read in the matrix and RHS. ! JOB = 2 => Read in the matrix and SOLN. ! JOB = 3 => Read in the matrix, RHS and SOLN. ! ! *Description: ! The format for the input is as follows. On the first line ! are counters and flags: N, NELT, ISYM, IRHS, ISOLN. N, NELT ! and ISYM are described above. IRHS is a flag indicating if ! the RHS was written out (1 is yes, 0 is no). ISOLN is a ! flag indicating if the SOLN was written out (1 is yes, 0 is ! no). The format for the fist line is: 5i10. Then comes the ! NELT Triad's IA(I), JA(I) and A(I), I = 1, NELT. The format ! for these lines is : 1X,I5,1X,I5,1X,D16.7. Then comes ! RHS(I), I = 1, N, if IRHS = 1. Then comes SOLN(I), I = 1, ! N, if ISOLN = 1. The format for these lines is: 1X,D16.7. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921007 Changed E's to D's in formats. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DTIN ! .. Scalar Arguments .. INTEGER ISYM, IUNIT, JOB, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), RHS(N), SOLN(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER I, IRHS, ISOLN, JOBRET, NELTMX ! .. Intrinsic Functions .. INTRINSIC MIN !***FIRST EXECUTABLE STATEMENT DTIN ! ! Read in the information heading. ! NELTMX = NELT READ(IUNIT,1000) N, NELT, ISYM, IRHS, ISOLN NELT = MIN( NELT, NELTMX ) ! ! Read in the matrix non-zeros in Triad format. DO 10 I = 1, NELT READ(IUNIT,1010) IA(I), JA(I), A(I) 10 CONTINUE ! ! If requested, read in the rhs. JOBRET = 0 if ( JOB == 1 .OR. JOB == 3 ) THEN ! ! Check to see if rhs is in the file. if ( IRHS == 1 ) THEN JOBRET = 1 READ(IUNIT,1020) (RHS(I),I=1,N) ELSE DO 20 I = 1, N RHS(I) = 0 20 CONTINUE ENDIF end if ! ! If requested, read in the solution. if ( JOB > 1 ) THEN ! ! Check to see if solution is in the file. if ( ISOLN == 1 ) THEN JOBRET = JOBRET + 2 READ(IUNIT,1020) (SOLN(I),I=1,N) ELSE DO 30 I = 1, N SOLN(I) = 0 30 CONTINUE ENDIF end if ! JOB = JOBRET return 1000 FORMAT(5I10) 1010 FORMAT(1X,I5,1X,I5,1X,D16.7) 1020 FORMAT(1X,D16.7) !------------- LAST LINE OF DTIN FOLLOWS ---------------------------- end subroutine DTOUT (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) ! !! DTOUT writes out SLAP Triad Format Linear System. ! Routine to write out a SLAP Triad format matrix and right ! hand side and solution to the system, if known. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY N1 !***TYPE DOUBLE PRECISION (STOUT-S, DTOUT-D) !***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB ! DOUBLE PRECISION A(NELT), SOLN(N), RHS(N) ! ! call DTOUT( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of non-zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in the SLAP ! Triad format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! SOLN :IN Double Precision SOLN(N). ! The solution to the linear system, if known. This array ! is accessed if and only if JOB is set to print it out, ! see below. ! RHS :IN Double Precision RHS(N). ! The right hand side vector. This array is accessed if and ! only if JOB is set to print it out, see below. ! IUNIT :IN Integer. ! Fortran logical I/O device unit number to write the matrix ! to. This unit must be connected in a system dependent fashion ! to a file or the console or you will get a nasty message ! from the Fortran I/O libraries. ! JOB :IN Integer. ! Flag indicating what I/O operations to perform. ! JOB = 0 => Print only the matrix. ! = 1 => Print matrix and RHS. ! = 2 => Print matrix and SOLN. ! = 3 => Print matrix, RHS and SOLN. ! ! *Description: ! The format for the output is as follows. On the first line ! are counters and flags: N, NELT, ISYM, IRHS, ISOLN. N, NELT ! and ISYM are described above. IRHS is a flag indicating if ! the RHS was written out (1 is yes, 0 is no). ISOLN is a ! flag indicating if the SOLN was written out (1 is yes, 0 is ! no). The format for the fist line is: 5i10. Then comes the ! NELT Triad's IA(I), JA(I) and A(I), I = 1, NELT. The format ! for these lines is : 1X,I5,1X,I5,1X,D16.7. Then comes ! RHS(I), I = 1, N, if IRHS = 1. Then comes SOLN(I), I = 1, ! N, if ISOLN = 1. The format for these lines is: 1X,D16.7. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921007 Changed E's to D's in formats. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE DTOUT ! .. Scalar Arguments .. INTEGER ISYM, IUNIT, JOB, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), RHS(N), SOLN(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER I, IRHS, ISOLN !***FIRST EXECUTABLE STATEMENT DTOUT ! ! If RHS and SOLN are to be printed also. ! Write out the information heading. ! IRHS = 0 ISOLN = 0 if ( JOB == 1 .OR. JOB == 3 ) IRHS = 1 if ( JOB > 1 ) ISOLN = 1 WRITE(IUNIT,1000) N, NELT, ISYM, IRHS, ISOLN ! ! Write out the matrix non-zeros in Triad format. DO 10 I = 1, NELT WRITE(IUNIT,1010) IA(I), JA(I), A(I) 10 CONTINUE ! ! If requested, write out the rhs. if ( IRHS == 1 ) THEN WRITE(IUNIT,1020) (RHS(I),I=1,N) end if ! ! If requested, write out the solution. if ( ISOLN == 1 ) THEN WRITE(IUNIT,1020) (SOLN(I),I=1,N) end if return 1000 FORMAT(5I10) 1010 FORMAT(1X,I5,1X,I5,1X,D16.7) 1020 FORMAT(1X,D16.7) !------------- LAST LINE OF DTOUT FOLLOWS ---------------------------- end subroutine DTPMV (UPLO, TRANS, DIAG, N, AP, X, INCX) ! !! DTPMV computes x = A*x or x = A'*x where A is a packed triangular matrix. ! !***PURPOSE Perform one of the matrix-vector operations. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (STPMV-S, DTPMV-D, CTPMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DTPMV performs one of the matrix-vector operations ! ! x := A*x, or x := A'*x, ! ! where x is an n element vector and A is an n by n unit, or non-unit, ! upper or lower triangular matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' x := A*x. ! ! TRANS = 'T' or 't' x := A'*x. ! ! TRANS = 'C' or 'c' x := A'*x. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! AP - DOUBLE PRECISION array of DIMENSION at least ! ( ( n*( n + 1))/2). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) ! respectively, and so on. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) ! respectively, and so on. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced, but are assumed to be unity. ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. On exit, X is overwritten with the ! transformed vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DTPMV ! .. Scalar Arguments .. INTEGER INCX, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. DOUBLE PRECISION AP( * ), X( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA !***FIRST EXECUTABLE STATEMENT DTPMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( INCX == 0 )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'DTPMV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x:= A*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK =1 if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = X( J ) K = KK DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*AP( K ) K = K + 1 10 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*AP( KK + J - 1 ) end if KK = KK + J 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 30, K = KK, KK + J - 2 X( IX ) = X( IX ) + TEMP*AP( K ) IX = IX + INCX 30 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*AP( KK + J - 1 ) end if JX = JX + INCX KK = KK + J 40 CONTINUE end if ELSE KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 60, J = N, 1, -1 if ( X( J ) /= ZERO )THEN TEMP = X( J ) K = KK DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*AP( K ) K = K - 1 50 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*AP( KK - N + J ) end if KK = KK - ( N - J + 1 ) 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 X( IX ) = X( IX ) + TEMP*AP( K ) IX = IX - INCX 70 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*AP( KK - N + J ) end if JX = JX - INCX KK = KK - ( N - J + 1 ) 80 CONTINUE end if end if ELSE ! ! Form x := A'*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) if ( NOUNIT ) & TEMP = TEMP*AP( KK ) K = KK - 1 DO 90, I = J - 1, 1, -1 TEMP = TEMP + AP( K )*X( I ) K = K - 1 90 CONTINUE X( J ) = TEMP KK = KK - J 100 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 120, J = N, 1, -1 TEMP = X( JX ) IX = JX if ( NOUNIT ) & TEMP = TEMP*AP( KK ) DO 110, K = KK - 1, KK - J + 1, -1 IX = IX - INCX TEMP = TEMP + AP( K )*X( IX ) 110 CONTINUE X( JX ) = TEMP JX = JX - INCX KK = KK - J 120 CONTINUE end if ELSE KK = 1 if ( INCX == 1 )THEN DO 140, J = 1, N TEMP = X( J ) if ( NOUNIT ) & TEMP = TEMP*AP( KK ) K = KK + 1 DO 130, I = J + 1, N TEMP = TEMP + AP( K )*X( I ) K = K + 1 130 CONTINUE X( J ) = TEMP KK = KK + ( N - J + 1 ) 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) IX = JX if ( NOUNIT ) & TEMP = TEMP*AP( KK ) DO 150, K = KK + 1, KK + N - J IX = IX + INCX TEMP = TEMP + AP( K )*X( IX ) 150 CONTINUE X( JX ) = TEMP JX = JX + INCX KK = KK + ( N - J + 1 ) 160 CONTINUE end if end if end if ! return ! ! End of DTPMV . ! end subroutine DTPSV (UPLO, TRANS, DIAG, N, AP, X, INCX) ! !! DTPSV solves A*x=b or A'*x=b where A is a packed triangular matrix. ! !***PURPOSE Solve one of the systems of equations. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (STPSV-S, DTPSV-D, CTPSV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DTPSV solves one of the systems of equations ! ! A*x = b, or A'*x = b, ! ! where b and x are n element vectors and A is an n by n unit, or ! non-unit, upper or lower triangular matrix, supplied in packed form. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the equations to be solved as ! follows: ! ! TRANS = 'N' or 'n' A*x = b. ! ! TRANS = 'T' or 't' A'*x = b. ! ! TRANS = 'C' or 'c' A'*x = b. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! AP - DOUBLE PRECISION array of DIMENSION at least ! ( ( n*( n + 1))/2). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) ! respectively, and so on. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) ! respectively, and so on. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced, but are assumed to be unity. ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element right-hand side vector b. On exit, X is overwritten ! with the solution vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DTPSV ! .. Scalar Arguments .. INTEGER INCX, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. DOUBLE PRECISION AP( * ), X( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA !***FIRST EXECUTABLE STATEMENT DTPSV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( INCX == 0 )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'DTPSV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := inv( A )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 20, J = N, 1, -1 if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/AP( KK ) TEMP = X( J ) K = KK - 1 DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*AP( K ) K = K - 1 10 CONTINUE end if KK = KK - J 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/AP( KK ) TEMP = X( JX ) IX = JX DO 30, K = KK - 1, KK - J + 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*AP( K ) 30 CONTINUE end if JX = JX - INCX KK = KK - J 40 CONTINUE end if ELSE KK = 1 if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/AP( KK ) TEMP = X( J ) K = KK + 1 DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*AP( K ) K = K + 1 50 CONTINUE end if KK = KK + ( N - J + 1 ) 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/AP( KK ) TEMP = X( JX ) IX = JX DO 70, K = KK + 1, KK + N - J IX = IX + INCX X( IX ) = X( IX ) - TEMP*AP( K ) 70 CONTINUE end if JX = JX + INCX KK = KK + ( N - J + 1 ) 80 CONTINUE end if end if ELSE ! ! Form x := inv( A' )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK = 1 if ( INCX == 1 )THEN DO 100, J = 1, N TEMP = X( J ) K = KK DO 90, I = 1, J - 1 TEMP = TEMP - AP( K )*X( I ) K = K + 1 90 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK + J - 1 ) X( J ) = TEMP KK = KK + J 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX DO 110, K = KK, KK + J - 2 TEMP = TEMP - AP( K )*X( IX ) IX = IX + INCX 110 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK + J - 1 ) X( JX ) = TEMP JX = JX + INCX KK = KK + J 120 CONTINUE end if ELSE KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) K = KK DO 130, I = N, J + 1, -1 TEMP = TEMP - AP( K )*X( I ) K = K - 1 130 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK - N + J ) X( J ) = TEMP KK = KK - ( N - J + 1 ) 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1 TEMP = TEMP - AP( K )*X( IX ) IX = IX - INCX 150 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK - N + J ) X( JX ) = TEMP JX = JX - INCX KK = KK - (N - J + 1 ) 160 CONTINUE end if end if end if ! return ! ! End of DTPSV . ! end subroutine DTRCO (T, LDT, N, RCOND, Z, JOB) ! !! DTRCO estimates the condition number of a triangular matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A3 !***TYPE DOUBLE PRECISION (STRCO-S, DTRCO-D, CTRCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! TRIANGULAR MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DTRCO estimates the condition of a double precision triangular ! matrix. ! ! On Entry ! ! T DOUBLE PRECISION(LDT,N) ! T contains the triangular matrix. The zero ! elements of the matrix are not referenced, and ! the corresponding elements of the array can be ! used to store other information. ! ! LDT INTEGER ! LDT is the leading dimension of the array T. ! ! N INTEGER ! N is the order of the system. ! ! JOB INTEGER ! = 0 T is lower triangular. ! = nonzero T is upper triangular. ! ! On Return ! ! RCOND DOUBLE PRECISION ! an estimate of the reciprocal condition of T . ! For the system T*X = B , relative perturbations ! in T and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then T may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z DOUBLE PRECISION(N) ! a work vector whose contents are usually unimportant. ! If T is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DASUM, DAXPY, DSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DTRCO INTEGER LDT,N,JOB DOUBLE PRECISION T(LDT,*),Z(*) DOUBLE PRECISION RCOND ! DOUBLE PRECISION W,WK,WKM,EK DOUBLE PRECISION TNORM,YNORM,S,SM,DASUM INTEGER I1,J,J1,J2,K,KK,L LOGICAL LOWER !***FIRST EXECUTABLE STATEMENT DTRCO LOWER = JOB == 0 ! ! COMPUTE 1-NORM OF T ! TNORM = 0.0D0 DO 10 J = 1, N L = J if (LOWER) L = N + 1 - J I1 = 1 if (LOWER) I1 = J TNORM = MAX(TNORM,DASUM(L,T(I1,J),1)) 10 CONTINUE ! ! RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . ! TRANS(T) IS THE TRANSPOSE OF T . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF Y . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE TRANS(T)*Y = E ! EK = 1.0D0 DO 20 J = 1, N Z(J) = 0.0D0 20 CONTINUE DO 100 KK = 1, N K = KK if (LOWER) K = N + 1 - KK if (Z(K) /= 0.0D0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= ABS(T(K,K))) go to 30 S = ABS(T(K,K))/ABS(EK-Z(K)) call DSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) if (T(K,K) == 0.0D0) go to 40 WK = WK/T(K,K) WKM = WKM/T(K,K) go to 50 40 CONTINUE WK = 1.0D0 WKM = 1.0D0 50 CONTINUE if (KK == N) go to 90 J1 = K + 1 if (LOWER) J1 = 1 J2 = N if (LOWER) J2 = K - 1 DO 60 J = J1, J2 SM = SM + ABS(Z(J)+WKM*T(K,J)) Z(J) = Z(J) + WK*T(K,J) S = S + ABS(Z(J)) 60 CONTINUE if (S >= SM) go to 80 W = WKM - WK WK = WKM DO 70 J = J1, J2 Z(J) = Z(J) + W*T(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) ! YNORM = 1.0D0 ! ! SOLVE T*Z = Y ! DO 130 KK = 1, N K = N + 1 - KK if (LOWER) K = KK if (ABS(Z(K)) <= ABS(T(K,K))) go to 110 S = ABS(T(K,K))/ABS(Z(K)) call DSCAL(N,S,Z,1) YNORM = S*YNORM 110 CONTINUE if (T(K,K) /= 0.0D0) Z(K) = Z(K)/T(K,K) if (T(K,K) == 0.0D0) Z(K) = 1.0D0 I1 = 1 if (LOWER) I1 = K + 1 if (KK >= N) go to 120 W = -Z(K) call DAXPY(N-KK,W,T(I1,K),1,Z(I1),1) 120 CONTINUE 130 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) call DSCAL(N,S,Z,1) YNORM = S*YNORM ! if (TNORM /= 0.0D0) RCOND = YNORM/TNORM if (TNORM == 0.0D0) RCOND = 0.0D0 return end subroutine DTRDI (T, LDT, N, DET, JOB, INFO) ! !! DTRDI computes the determinant and inverse of a triangular matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A3, D3A3 !***TYPE DOUBLE PRECISION (STRDI-S, DTRDI-D, CTRDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, ! TRIANGULAR MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! DTRDI computes the determinant and inverse of a double precision ! triangular matrix. ! ! On Entry ! ! T DOUBLE PRECISION(LDT,N) ! T contains the triangular matrix. The zero ! elements of the matrix are not referenced, and ! the corresponding elements of the array can be ! used to store other information. ! ! LDT INTEGER ! LDT is the leading dimension of the array T. ! ! N INTEGER ! N is the order of the system. ! ! JOB INTEGER ! = 010 no det, inverse of lower triangular. ! = 011 no det, inverse of upper triangular. ! = 100 det, no inverse. ! = 110 det, inverse of lower triangular. ! = 111 det, inverse of upper triangular. ! ! On Return ! ! T inverse of original matrix if requested. ! Otherwise unchanged. ! ! DET DOUBLE PRECISION(2) ! determinant of original matrix if requested. ! Otherwise not referenced. ! DETERMINANT = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) == 0.0 . ! ! INFO INTEGER ! INFO contains zero if the system is nonsingular ! and the inverse is requested. ! Otherwise INFO contains the index of ! a zero diagonal element of T. ! ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DTRDI INTEGER LDT,N,JOB,INFO DOUBLE PRECISION T(LDT,*),DET(2) ! DOUBLE PRECISION TEMP DOUBLE PRECISION TEN INTEGER I,J,K,KB,KM1,KP1 !***FIRST EXECUTABLE STATEMENT DTRDI ! ! COMPUTE DETERMINANT ! if (JOB/100 == 0) go to 70 DET(1) = 1.0D0 DET(2) = 0.0D0 TEN = 10.0D0 DO 50 I = 1, N DET(1) = T(I,I)*DET(1) if (DET(1) == 0.0D0) go to 60 10 if (ABS(DET(1)) >= 1.0D0) go to 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 go to 10 20 CONTINUE 30 if (ABS(DET(1)) < 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 ! ! COMPUTE INVERSE OF UPPER TRIANGULAR ! if (MOD(JOB/10,10) == 0) go to 170 if (MOD(JOB,10) == 0) go to 120 DO 100 K = 1, N INFO = K if (T(K,K) == 0.0D0) go to 110 T(K,K) = 1.0D0/T(K,K) TEMP = -T(K,K) call DSCAL(K-1,TEMP,T(1,K),1) KP1 = K + 1 if (N < KP1) go to 90 DO 80 J = KP1, N TEMP = T(K,J) T(K,J) = 0.0D0 call DAXPY(K,TEMP,T(1,K),1,T(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE INFO = 0 110 CONTINUE go to 160 120 CONTINUE ! ! COMPUTE INVERSE OF LOWER TRIANGULAR ! DO 150 KB = 1, N K = N + 1 - KB INFO = K if (T(K,K) == 0.0D0) go to 180 T(K,K) = 1.0D0/T(K,K) TEMP = -T(K,K) if (K /= N) call DSCAL(N-K,TEMP,T(K+1,K),1) KM1 = K - 1 if (KM1 < 1) go to 140 DO 130 J = 1, KM1 TEMP = T(K,J) T(K,J) = 0.0D0 call DAXPY(N-K+1,TEMP,T(K,K),1,T(K,J),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE INFO = 0 160 CONTINUE 170 CONTINUE 180 CONTINUE return end subroutine DTRMM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, & B, LDB) ! !! DTRMM performs B = alpha*op(A)*B or B = alpha*B*op(A), A triangular. ! !***PURPOSE Perform one of the matrix-matrix operations. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE DOUBLE PRECISION (STRMM-S, DTRMM-D, CTRMM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! DTRMM performs one of the matrix-matrix operations ! ! B := alpha*op( A )*B, or B := alpha*B*op( A ), ! ! where alpha is a scalar, B is an m by n matrix, A is a unit, or ! non-unit, upper or lower triangular matrix and op( A ) is one of ! ! op( A ) = A or op( A ) = A'. ! ! Parameters ! ========== ! ! SIDE - CHARACTER*1. ! On entry, SIDE specifies whether op( A ) multiplies B from ! the left or right as follows: ! ! SIDE = 'L' or 'l' B := alpha*op( A )*B. ! ! SIDE = 'R' or 'r' B := alpha*B*op( A ). ! ! Unchanged on exit. ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix A is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANSA - CHARACTER*1. ! On entry, TRANSA specifies the form of op( A ) to be used in ! the matrix multiplication as follows: ! ! TRANSA = 'N' or 'n' op( A ) = A. ! ! TRANSA = 'T' or 't' op( A ) = A'. ! ! TRANSA = 'C' or 'c' op( A ) = A'. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit triangular ! as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of B. M must be at ! least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of B. N must be ! at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. When alpha is ! zero then A is not referenced and B need not be set before ! entry. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m ! when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. ! Before entry with UPLO = 'U' or 'u', the leading k by k ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading k by k ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When SIDE = 'L' or 'l' then ! LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' ! then LDA must be at least max( 1, n ). ! Unchanged on exit. ! ! B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). ! Before entry, the leading m by n part of the array B must ! contain the matrix B, and on exit is overwritten by the ! transformed matrix. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. LDB must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DTRMM ! .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB DOUBLE PRECISION ALPHA ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA DOUBLE PRECISION TEMP ! .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) !***FIRST EXECUTABLE STATEMENT DTRMM ! ! Test the input parameters. ! LSIDE = LSAME( SIDE , 'L' ) if ( LSIDE )THEN NROWA = M ELSE NROWA = N end if NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) ! INFO = 0 if ( ( .NOT.LSIDE ).AND. & ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE if ( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. & ( .NOT.LSAME( TRANSA, 'T' ) ).AND. & ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE if ( ( .NOT.LSAME( DIAG , 'U' ) ).AND. & ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE if ( M < 0 )THEN INFO = 5 ELSE if ( N < 0 )THEN INFO = 6 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 9 ELSE if ( LDB < MAX( 1, M ) )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'DTRMM ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE return end if ! ! Start the operations. ! if ( LSIDE )THEN if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*A*B. ! if ( UPPER )THEN DO 50, J = 1, N DO 40, K = 1, M if ( B( K, J ) /= ZERO )THEN TEMP = ALPHA*B( K, J ) DO 30, I = 1, K - 1 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 30 CONTINUE if ( NOUNIT ) & TEMP = TEMP*A( K, K ) B( K, J ) = TEMP end if 40 CONTINUE 50 CONTINUE ELSE DO 80, J = 1, N DO 70 K = M, 1, -1 if ( B( K, J ) /= ZERO )THEN TEMP = ALPHA*B( K, J ) B( K, J ) = TEMP if ( NOUNIT ) & B( K, J ) = B( K, J )*A( K, K ) DO 60, I = K + 1, M B( I, J ) = B( I, J ) + TEMP*A( I, K ) 60 CONTINUE end if 70 CONTINUE 80 CONTINUE end if ELSE ! ! Form B := alpha*B*A'. ! if ( UPPER )THEN DO 110, J = 1, N DO 100, I = M, 1, -1 TEMP = B( I, J ) if ( NOUNIT ) & TEMP = TEMP*A( I, I ) DO 90, K = 1, I - 1 TEMP = TEMP + A( K, I )*B( K, J ) 90 CONTINUE B( I, J ) = ALPHA*TEMP 100 CONTINUE 110 CONTINUE ELSE DO 140, J = 1, N DO 130, I = 1, M TEMP = B( I, J ) if ( NOUNIT ) & TEMP = TEMP*A( I, I ) DO 120, K = I + 1, M TEMP = TEMP + A( K, I )*B( K, J ) 120 CONTINUE B( I, J ) = ALPHA*TEMP 130 CONTINUE 140 CONTINUE end if end if ELSE if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*B*A. ! if ( UPPER )THEN DO 180, J = N, 1, -1 TEMP = ALPHA if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 150, I = 1, M B( I, J ) = TEMP*B( I, J ) 150 CONTINUE DO 170, K = 1, J - 1 if ( A( K, J ) /= ZERO )THEN TEMP = ALPHA*A( K, J ) DO 160, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 160 CONTINUE end if 170 CONTINUE 180 CONTINUE ELSE DO 220, J = 1, N TEMP = ALPHA if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 190, I = 1, M B( I, J ) = TEMP*B( I, J ) 190 CONTINUE DO 210, K = J + 1, N if ( A( K, J ) /= ZERO )THEN TEMP = ALPHA*A( K, J ) DO 200, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 200 CONTINUE end if 210 CONTINUE 220 CONTINUE end if ELSE ! ! Form B := alpha*B*A'. ! if ( UPPER )THEN DO 260, K = 1, N DO 240, J = 1, K - 1 if ( A( J, K ) /= ZERO )THEN TEMP = ALPHA*A( J, K ) DO 230, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 230 CONTINUE end if 240 CONTINUE TEMP = ALPHA if ( NOUNIT ) & TEMP = TEMP*A( K, K ) if ( TEMP /= ONE )THEN DO 250, I = 1, M B( I, K ) = TEMP*B( I, K ) 250 CONTINUE end if 260 CONTINUE ELSE DO 300, K = N, 1, -1 DO 280, J = K + 1, N if ( A( J, K ) /= ZERO )THEN TEMP = ALPHA*A( J, K ) DO 270, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 270 CONTINUE end if 280 CONTINUE TEMP = ALPHA if ( NOUNIT ) & TEMP = TEMP*A( K, K ) if ( TEMP /= ONE )THEN DO 290, I = 1, M B( I, K ) = TEMP*B( I, K ) 290 CONTINUE end if 300 CONTINUE end if end if end if ! return ! ! End of DTRMM . ! end subroutine DTRMV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) ! !! DTRMV computes x=A*x or x=A'*x where A is triangular. ! !***PURPOSE Perform one of the matrix-vector operations. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (STRMV-S, DTRMV-D, CTRMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DTRMV performs one of the matrix-vector operations ! ! x := A*x, or x := A'*x, ! ! where x is an n element vector and A is an n by n unit, or non-unit, ! upper or lower triangular matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' x := A*x. ! ! TRANS = 'T' or 't' x := A'*x. ! ! TRANS = 'C' or 'c' x := A'*x. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. On exit, X is overwritten with the ! transformed vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DTRMV ! .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT DTRMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 end if if ( INFO /= 0 )THEN call XERBLA( 'DTRMV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := A*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = X( J ) DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*A( I, J ) 10 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( J, J ) end if 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 30, I = 1, J - 1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX + INCX 30 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( J, J ) end if JX = JX + INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = N, 1, -1 if ( X( J ) /= ZERO )THEN TEMP = X( J ) DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*A( I, J ) 50 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( J, J ) end if 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 70, I = N, J + 1, -1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX - INCX 70 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( J, J ) end if JX = JX - INCX 80 CONTINUE end if end if ELSE ! ! Form x := A'*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE X( J ) = TEMP 100 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 120, J = N, 1, -1 TEMP = X( JX ) IX = JX if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 110, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + A( I, J )*X( IX ) 110 CONTINUE X( JX ) = TEMP JX = JX - INCX 120 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 140, J = 1, N TEMP = X( J ) if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 130, I = J + 1, N TEMP = TEMP + A( I, J )*X( I ) 130 CONTINUE X( J ) = TEMP 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) IX = JX if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 150, I = J + 1, N IX = IX + INCX TEMP = TEMP + A( I, J )*X( IX ) 150 CONTINUE X( JX ) = TEMP JX = JX + INCX 160 CONTINUE end if end if end if ! return ! ! End of DTRMV . ! end subroutine DTRSL (T, LDT, N, B, JOB, INFO) ! !! DTRSL solves a triangular system of linear equations. ! !***PURPOSE Solve a system of the form T*X=B or TRANS(T)*X=B, where ! T is a triangular matrix. !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A3 !***TYPE DOUBLE PRECISION (STRSL-S, DTRSL-D, CTRSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM, ! TRIANGULAR MATRIX !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! DTRSL solves systems of the form ! ! T * X = B ! or ! TRANS(T) * X = B ! ! where T is a triangular matrix of order N. Here TRANS(T) ! denotes the transpose of the matrix T. ! ! On Entry ! ! T DOUBLE PRECISION(LDT,N) ! T contains the matrix of the system. The zero ! elements of the matrix are not referenced, and ! the corresponding elements of the array can be ! used to store other information. ! ! LDT INTEGER ! LDT is the leading dimension of the array T. ! ! N INTEGER ! N is the order of the system. ! ! B DOUBLE PRECISION(N). ! B contains the right hand side of the system. ! ! JOB INTEGER ! JOB specifies what kind of system is to be solved. ! If JOB is ! ! 00 solve T*X=B, T lower triangular, ! 01 solve T*X=B, T upper triangular, ! 10 solve TRANS(T)*X=B, T lower triangular, ! 11 solve TRANS(T)*X=B, T upper triangular. ! ! On Return ! ! B B contains the solution, if INFO == 0. ! Otherwise B is unaltered. ! ! INFO INTEGER ! INFO contains zero if the system is nonsingular. ! Otherwise INFO contains the index of ! the first zero diagonal element of T. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DAXPY, DDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DTRSL INTEGER LDT,N,JOB,INFO DOUBLE PRECISION T(LDT,*),B(*) ! ! DOUBLE PRECISION DDOT,TEMP INTEGER CASE,J,JJ !***FIRST EXECUTABLE STATEMENT DTRSL ! ! CHECK FOR ZERO DIAGONAL ELEMENTS. ! DO 10 INFO = 1, N if (T(INFO,INFO) == 0.0D0) go to 150 10 CONTINUE INFO = 0 ! ! DETERMINE THE TASK AND go to IT. ! CASE = 1 if (MOD(JOB,10) /= 0) CASE = 2 if (MOD(JOB,100)/10 /= 0) CASE = CASE + 2 go to (20,50,80,110), CASE ! ! SOLVE T*X=B FOR T LOWER TRIANGULAR ! 20 CONTINUE B(1) = B(1)/T(1,1) if (N < 2) go to 40 DO 30 J = 2, N TEMP = -B(J-1) call DAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) B(J) = B(J)/T(J,J) 30 CONTINUE 40 CONTINUE go to 140 ! ! SOLVE T*X=B FOR T UPPER TRIANGULAR. ! 50 CONTINUE B(N) = B(N)/T(N,N) if (N < 2) go to 70 DO 60 JJ = 2, N J = N - JJ + 1 TEMP = -B(J+1) call DAXPY(J,TEMP,T(1,J+1),1,B(1),1) B(J) = B(J)/T(J,J) 60 CONTINUE 70 CONTINUE go to 140 ! ! SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. ! 80 CONTINUE B(N) = B(N)/T(N,N) if (N < 2) go to 100 DO 90 JJ = 2, N J = N - JJ + 1 B(J) = B(J) - DDOT(JJ-1,T(J+1,J),1,B(J+1),1) B(J) = B(J)/T(J,J) 90 CONTINUE 100 CONTINUE go to 140 ! ! SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. ! 110 CONTINUE B(1) = B(1)/T(1,1) if (N < 2) go to 130 DO 120 J = 2, N B(J) = B(J) - DDOT(J-1,T(1,J),1,B(1),1) B(J) = B(J)/T(J,J) 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE return end subroutine DTRSM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, & B, LDB) ! !! DTRSM solves a matrix equation op(A)*X=alpha*B or X*op(A)=alpha*B. ! !***PURPOSE Solve one of the matrix equations. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE DOUBLE PRECISION (STRSM-S, DTRSM-D, CTRSM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! DTRSM solves one of the matrix equations ! ! op( A )*X = alpha*B, or X*op( A ) = alpha*B, ! ! where alpha is a scalar, X and B are m by n matrices, A is a unit, or ! non-unit, upper or lower triangular matrix and op( A ) is one of ! ! op( A ) = A or op( A ) = A'. ! ! The matrix X is overwritten on B. ! ! Parameters ! ========== ! ! SIDE - CHARACTER*1. ! On entry, SIDE specifies whether op( A ) appears on the left ! or right of X as follows: ! ! SIDE = 'L' or 'l' op( A )*X = alpha*B. ! ! SIDE = 'R' or 'r' X*op( A ) = alpha*B. ! ! Unchanged on exit. ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix A is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANSA - CHARACTER*1. ! On entry, TRANSA specifies the form of op( A ) to be used in ! the matrix multiplication as follows: ! ! TRANSA = 'N' or 'n' op( A ) = A. ! ! TRANSA = 'T' or 't' op( A ) = A'. ! ! TRANSA = 'C' or 'c' op( A ) = A'. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit triangular ! as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of B. M must be at ! least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of B. N must be ! at least zero. ! Unchanged on exit. ! ! ALPHA - DOUBLE PRECISION. ! On entry, ALPHA specifies the scalar alpha. When alpha is ! zero then A is not referenced and B need not be set before ! entry. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m ! when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. ! Before entry with UPLO = 'U' or 'u', the leading k by k ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading k by k ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When SIDE = 'L' or 'l' then ! LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' ! then LDA must be at least max( 1, n ). ! Unchanged on exit. ! ! B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). ! Before entry, the leading m by n part of the array B must ! contain the right-hand side matrix B, and on exit is ! overwritten by the solution matrix X. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. LDB must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DTRSM ! .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB DOUBLE PRECISION ALPHA ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) ! ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA DOUBLE PRECISION TEMP ! .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) !***FIRST EXECUTABLE STATEMENT DTRSM ! ! Test the input parameters. ! LSIDE = LSAME( SIDE , 'L' ) if ( LSIDE )THEN NROWA = M ELSE NROWA = N end if NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) ! INFO = 0 if ( ( .NOT.LSIDE ).AND. & ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE if ( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. & ( .NOT.LSAME( TRANSA, 'T' ) ).AND. & ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE if ( ( .NOT.LSAME( DIAG , 'U' ) ).AND. & ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE if ( M < 0 )THEN INFO = 5 ELSE if ( N < 0 )THEN INFO = 6 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 9 ELSE if ( LDB < MAX( 1, M ) )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'DTRSM ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE return end if ! ! Start the operations. ! if ( LSIDE )THEN if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*inv( A )*B. ! if ( UPPER )THEN DO 60, J = 1, N if ( ALPHA /= ONE )THEN DO 30, I = 1, M B( I, J ) = ALPHA*B( I, J ) 30 CONTINUE end if DO 50, K = M, 1, -1 if ( B( K, J ) /= ZERO )THEN if ( NOUNIT ) & B( K, J ) = B( K, J )/A( K, K ) DO 40, I = 1, K - 1 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 40 CONTINUE end if 50 CONTINUE 60 CONTINUE ELSE DO 100, J = 1, N if ( ALPHA /= ONE )THEN DO 70, I = 1, M B( I, J ) = ALPHA*B( I, J ) 70 CONTINUE end if DO 90 K = 1, M if ( B( K, J ) /= ZERO )THEN if ( NOUNIT ) & B( K, J ) = B( K, J )/A( K, K ) DO 80, I = K + 1, M B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 80 CONTINUE end if 90 CONTINUE 100 CONTINUE end if ELSE ! ! Form B := alpha*inv( A' )*B. ! if ( UPPER )THEN DO 130, J = 1, N DO 120, I = 1, M TEMP = ALPHA*B( I, J ) DO 110, K = 1, I - 1 TEMP = TEMP - A( K, I )*B( K, J ) 110 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 120 CONTINUE 130 CONTINUE ELSE DO 160, J = 1, N DO 150, I = M, 1, -1 TEMP = ALPHA*B( I, J ) DO 140, K = I + 1, M TEMP = TEMP - A( K, I )*B( K, J ) 140 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 150 CONTINUE 160 CONTINUE end if end if ELSE if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*B*inv( A ). ! if ( UPPER )THEN DO 210, J = 1, N if ( ALPHA /= ONE )THEN DO 170, I = 1, M B( I, J ) = ALPHA*B( I, J ) 170 CONTINUE end if DO 190, K = 1, J - 1 if ( A( K, J ) /= ZERO )THEN DO 180, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 180 CONTINUE end if 190 CONTINUE if ( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 200, I = 1, M B( I, J ) = TEMP*B( I, J ) 200 CONTINUE end if 210 CONTINUE ELSE DO 260, J = N, 1, -1 if ( ALPHA /= ONE )THEN DO 220, I = 1, M B( I, J ) = ALPHA*B( I, J ) 220 CONTINUE end if DO 240, K = J + 1, N if ( A( K, J ) /= ZERO )THEN DO 230, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 230 CONTINUE end if 240 CONTINUE if ( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 250, I = 1, M B( I, J ) = TEMP*B( I, J ) 250 CONTINUE end if 260 CONTINUE end if ELSE ! ! Form B := alpha*B*inv( A' ). ! if ( UPPER )THEN DO 310, K = N, 1, -1 if ( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 270, I = 1, M B( I, K ) = TEMP*B( I, K ) 270 CONTINUE end if DO 290, J = 1, K - 1 if ( A( J, K ) /= ZERO )THEN TEMP = A( J, K ) DO 280, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 280 CONTINUE end if 290 CONTINUE if ( ALPHA /= ONE )THEN DO 300, I = 1, M B( I, K ) = ALPHA*B( I, K ) 300 CONTINUE end if 310 CONTINUE ELSE DO 360, K = 1, N if ( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 320, I = 1, M B( I, K ) = TEMP*B( I, K ) 320 CONTINUE end if DO 340, J = K + 1, N if ( A( J, K ) /= ZERO )THEN TEMP = A( J, K ) DO 330, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 330 CONTINUE end if 340 CONTINUE if ( ALPHA /= ONE )THEN DO 350, I = 1, M B( I, K ) = ALPHA*B( I, K ) 350 CONTINUE end if 360 CONTINUE end if end if end if ! return ! ! End of DTRSM . ! end subroutine DTRSV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) ! !! DTRSV solves A*x=b or A'*x=b where A is triangular. ! !***PURPOSE Solve one of the systems of equations. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE DOUBLE PRECISION (STRSV-S, DTRSV-D, CTRSV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DTRSV solves one of the systems of equations ! ! A*x = b, or A'*x = b, ! ! where b and x are n element vectors and A is an n by n unit, or ! non-unit, upper or lower triangular matrix. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the equations to be solved as ! follows: ! ! TRANS = 'N' or 'n' A*x = b. ! ! TRANS = 'T' or 't' A'*x = b. ! ! TRANS = 'C' or 'c' A'*x = b. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! A - DOUBLE PRECISION array of DIMENSION ( LDA, n). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! ! X - DOUBLE PRECISION array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element right-hand side vector b. On exit, X is overwritten ! with the solution vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE DTRSV ! .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) ! .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) ! .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT DTRSV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 end if if ( INFO /= 0 )THEN call XERBLA( 'DTRSV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := inv( A )*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 20, J = N, 1, -1 if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE end if 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE end if JX = JX - INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE end if 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if end if ELSE ! ! Form x := inv( A' )*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 100, J = 1, N TEMP = X( J ) DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) X( J ) = TEMP 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX DO 110, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX + INCX 120 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) DO 130, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 130 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) X( J ) = TEMP 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 150 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX - INCX 160 CONTINUE end if end if end if return end subroutine DU11LS (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, & H, W, EB, IC, IR) ! !! DU11LS performs QR factorization for DLLSIA. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DLLSIA !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (U11LS-S, DU11LS-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! **** Double Precision version of U11LS **** ! ! This routine performs a QR factorization of A ! using Householder transformations. Row and ! column pivots are chosen to reduce the growth ! of round-off and to help detect possible rank ! deficiency. ! !***SEE ALSO DLLSIA !***ROUTINES CALLED DAXPY, DDOT, DNRM2, DSCAL, DSWAP, IDAMAX, ISWAP, ! XERMSG !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DU11LS IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION DDOT,DNRM2 DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*) INTEGER IC(*),IR(*) ! ! INITIALIZATION ! !***FIRST EXECUTABLE STATEMENT DU11LS J=0 KRANK=N DO 10 I=1,N IC(I)=I 10 CONTINUE DO 12 I=1,M IR(I)=I 12 CONTINUE ! ! DETERMINE REL AND ABS ERROR VECTORS ! ! ! ! CALCULATE COL LENGTH ! DO 30 I=1,N H(I)=DNRM2(M,A(1,I),1) W(I)=H(I) 30 CONTINUE ! ! INITIALIZE ERROR BOUNDS ! DO 40 I=1,N EB(I)=MAX(DB(I),UB(I)*H(I)) UB(I)=EB(I) DB(I)=0.0D0 40 CONTINUE ! ! DISCARD SELF DEPENDENT COLUMNS ! I=1 50 if ( EB(I) >= H(I)) go to 60 if ( I == KRANK) go to 70 I=I+1 go to 50 ! ! MATRIX REDUCTION ! 60 CONTINUE KK=KRANK KRANK=KRANK-1 if ( MODE == 0) RETURN if ( I > NP) go to 64 call XERMSG ('SLATEC', 'DU11LS', & 'FIRST NP COLUMNS ARE LINEARLY DEPENDENT', 8, 0) KRANK=I-1 return 64 CONTINUE if ( I > 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 ! ! TEST FOR ZERO RANK ! 70 if ( KRANK > 0) go to 80 KRANK=0 KSURE=0 return 80 CONTINUE ! ! M A I N L O O P ! 110 CONTINUE J=J+1 JP1=J+1 JM1=J-1 KZ=KRANK if ( J <= NP) KZ=J ! ! EACH COL HAS MM=M-J+1 COMPONENTS ! MM=M-J+1 ! ! UB DETERMINES COLUMN PIVOT ! 115 IMIN=J if ( H(J) == 0.D0) go to 170 RMIN=UB(J)/H(J) DO 120 I=J,KZ if ( UB(I) >= H(I)*RMIN) go to 120 RMIN=UB(I)/H(I) IMIN=I 120 CONTINUE ! ! TEST FOR RANK DEFICIENCY ! if ( RMIN < 1.0D0) go to 200 TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN) if ( TT >= 1.0D0) go to 170 ! COMPUTE EXACT UB DO 125 I=1,JM1 W(I)=A(I,IMIN) 125 CONTINUE L=JM1 130 W(L)=W(L)/A(L,L) if ( L == 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 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) >= 1.0D0) go to 170 go to 200 ! ! MATRIX REDUCTION ! 170 CONTINUE KK=KRANK KRANK=KRANK-1 KZ=KRANK if ( MODE == 0) RETURN if ( J > NP) go to 172 call XERMSG ('SLATEC', 'DU11LS', & 'FIRST NP COLUMNS ARE LINEARLY DEPENDENT', 8, 0) KRANK=J-1 return 172 CONTINUE if ( IMIN > 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 > KRANK) go to 300 go to 115 ! ! COLUMN PIVOT ! 200 if ( IMIN == J) go to 230 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) ! ! ROW PIVOT ! 230 CONTINUE JMAX=IDAMAX(MM,A(J,J),1) JMAX=JMAX+J-1 if ( JMAX == J) go to 240 call DSWAP(N,A(J,1),MDA,A(JMAX,1),MDA) call ISWAP(1,IR(J),1,IR(JMAX),1) 240 CONTINUE ! ! APPLY HOUSEHOLDER TRANSFORMATION ! TN=DNRM2(MM,A(J,J),1) if ( TN == 0.0D0) go to 170 if ( A(J,J) /= 0.0D0) TN=SIGN(TN,A(J,J)) call DSCAL(MM,1.0D0/TN,A(J,J),1) A(J,J)=A(J,J)+1.0D0 if ( J == N) go to 250 DO 248 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 <= NP) go to 248 if ( H(I) == 0.0D0) go to 248 TT=1.0D0-(ABS(A(J,I))/H(I))**2 TT=MAX(TT,0.0D0) T=TT TT=1.0D0+.05D0*TT*(H(I)/W(I))**2 if ( TT == 1.0D0) go to 244 H(I)=H(I)*SQRT(T) go to 246 244 CONTINUE H(I)=DNRM2(M-J,A(J+1,I),1) W(I)=H(I) 246 CONTINUE 248 CONTINUE 250 CONTINUE H(J)=A(J,J) A(J,J)=-TN ! ! ! UPDATE UB, DB ! UB(J)=UB(J)/ABS(A(J,J)) DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J) if ( J == 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 110 ! ! E N D M A I N L O O P ! 300 CONTINUE ! ! COMPUTE KSURE ! KM1=KRANK-1 DO 318 I=1,KM1 IS=0 KMI=KRANK-I DO 315 II=1,KMI if ( UB(II) <= UB(II+1)) go to 315 IS=1 TEMP=UB(II) UB(II)=UB(II+1) UB(II+1)=TEMP 315 CONTINUE if ( IS == 0) go to 320 318 CONTINUE 320 CONTINUE KSURE=0 SUM=0.0D0 DO 328 I=1,KRANK R2=UB(I)*UB(I) if ( R2+SUM >= 1.0D0) go to 330 SUM=SUM+R2 KSURE=KSURE+1 328 CONTINUE 330 CONTINUE ! ! if SYSTEM IS OF REDUCED RANK AND MODE = 2 ! COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION ! if ( KRANK == N .OR. MODE < 2) go to 360 NMK=N-KRANK KP1=KRANK+1 I=KRANK 340 TN=DNRM2(NMK,A(I,KP1),MDA)/A(I,I) TN=A(I,I)*SQRT(1.0D0+TN*TN) call DSCAL(NMK,1.0D0/TN,A(I,KP1),MDA) W(I)=A(I,I)/TN+1.0D0 A(I,I)=-TN if ( I == 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 350 CONTINUE 360 CONTINUE return end subroutine DU11US (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, & H, W, EB, IR, IC) ! !! DU11US performs LQ factorization for DULSIA. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DULSIA !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (U11US-S, DU11US-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This routine performs an LQ factorization of the ! matrix A using Householder transformations. Row ! and column pivots are chosen to reduce the growth ! of round-off and to help detect possible rank ! deficiency. ! !***SEE ALSO DULSIA !***ROUTINES CALLED DAXPY, DDOT, DNRM2, DSCAL, DSWAP, IDAMAX, ISWAP, ! XERMSG !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DU11US IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION DDOT,DNRM2 DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*) INTEGER IC(*),IR(*) ! ! INITIALIZATION ! !***FIRST EXECUTABLE STATEMENT DU11US J=0 KRANK=M DO 10 I=1,N IC(I)=I 10 CONTINUE DO 12 I=1,M IR(I)=I 12 CONTINUE ! ! DETERMINE REL AND ABS ERROR VECTORS ! ! ! ! CALCULATE ROW LENGTH ! DO 30 I=1,M H(I)=DNRM2(N,A(I,1),MDA) W(I)=H(I) 30 CONTINUE ! ! INITIALIZE ERROR BOUNDS ! DO 40 I=1,M EB(I)=MAX(DB(I),UB(I)*H(I)) UB(I)=EB(I) DB(I)=0.0D0 40 CONTINUE ! ! DISCARD SELF DEPENDENT ROWS ! I=1 50 if ( EB(I) >= H(I)) go to 60 if ( I == KRANK) go to 70 I=I+1 go to 50 ! ! MATRIX REDUCTION ! 60 CONTINUE KK=KRANK KRANK=KRANK-1 if ( MODE == 0) RETURN if ( I > NP) go to 64 call XERMSG ('SLATEC', 'DU11US', & 'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0) KRANK=I-1 return 64 CONTINUE if ( I > 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 ! ! TEST FOR ZERO RANK ! 70 if ( KRANK > 0) go to 80 KRANK=0 KSURE=0 return 80 CONTINUE ! ! M A I N L O O P ! 110 CONTINUE J=J+1 JP1=J+1 JM1=J-1 KZ=KRANK if ( J <= NP) KZ=J ! ! EACH ROW HAS NN=N-J+1 COMPONENTS ! NN=N-J+1 ! ! UB DETERMINES ROW PIVOT ! 115 IMIN=J if ( H(J) == 0.D0) go to 170 RMIN=UB(J)/H(J) DO 120 I=J,KZ if ( UB(I) >= H(I)*RMIN) go to 120 RMIN=UB(I)/H(I) IMIN=I 120 CONTINUE ! ! TEST FOR RANK DEFICIENCY ! if ( RMIN < 1.0D0) go to 200 TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN) if ( TT >= 1.0D0) go to 170 ! COMPUTE EXACT UB DO 125 I=1,JM1 W(I)=A(IMIN,I) 125 CONTINUE L=JM1 130 W(L)=W(L)/A(L,L) if ( L == 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 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) >= 1.0D0) go to 170 go to 200 ! ! MATRIX REDUCTION ! 170 CONTINUE KK=KRANK KRANK=KRANK-1 KZ=KRANK if ( MODE == 0) RETURN if ( J > NP) go to 172 call XERMSG ('SLATEC', 'DU11US', & 'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0) KRANK=J-1 return 172 CONTINUE if ( IMIN > 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 > KRANK) go to 300 go to 115 ! ! ROW PIVOT ! 200 if ( IMIN == J) go to 230 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) ! ! COLUMN PIVOT ! 230 CONTINUE JMAX=IDAMAX(NN,A(J,J),MDA) JMAX=JMAX+J-1 if ( JMAX == J) go to 240 call DSWAP(M,A(1,J),1,A(1,JMAX),1) call ISWAP(1,IC(J),1,IC(JMAX),1) 240 CONTINUE ! ! APPLY HOUSEHOLDER TRANSFORMATION ! TN=DNRM2(NN,A(J,J),MDA) if ( TN == 0.0D0) go to 170 if ( A(J,J) /= 0.0D0) TN=SIGN(TN,A(J,J)) call DSCAL(NN,1.0D0/TN,A(J,J),MDA) A(J,J)=A(J,J)+1.0D0 if ( J == M) go to 250 DO 248 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 <= NP) go to 248 if ( H(I) == 0.0D0) go to 248 TT=1.0D0-(ABS(A(I,J))/H(I))**2 TT=MAX(TT,0.0D0) T=TT TT=1.0D0+.05D0*TT*(H(I)/W(I))**2 if ( TT == 1.0D0) go to 244 H(I)=H(I)*SQRT(T) go to 246 244 CONTINUE H(I)=DNRM2(N-J,A(I,J+1),MDA) W(I)=H(I) 246 CONTINUE 248 CONTINUE 250 CONTINUE H(J)=A(J,J) A(J,J)=-TN ! ! ! UPDATE UB, DB ! UB(J)=UB(J)/ABS(A(J,J)) DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J) if ( J == 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 110 ! ! E N D M A I N L O O P ! 300 CONTINUE ! ! COMPUTE KSURE ! KM1=KRANK-1 DO 318 I=1,KM1 IS=0 KMI=KRANK-I DO 315 II=1,KMI if ( UB(II) <= UB(II+1)) go to 315 IS=1 TEMP=UB(II) UB(II)=UB(II+1) UB(II+1)=TEMP 315 CONTINUE if ( IS == 0) go to 320 318 CONTINUE 320 CONTINUE KSURE=0 SUM=0.0D0 DO 328 I=1,KRANK R2=UB(I)*UB(I) if ( R2+SUM >= 1.0D0) go to 330 SUM=SUM+R2 KSURE=KSURE+1 328 CONTINUE 330 CONTINUE ! ! if SYSTEM IS OF REDUCED RANK AND MODE = 2 ! COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION ! if ( KRANK == M .OR. MODE < 2) go to 360 MMK=M-KRANK KP1=KRANK+1 I=KRANK 340 TN=DNRM2(MMK,A(KP1,I),1)/A(I,I) TN=A(I,I)*SQRT(1.0D0+TN*TN) call DSCAL(MMK,1.0D0/TN,A(KP1,I),1) W(I)=A(I,I)/TN+1.0D0 A(I,I)=-TN if ( I == 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 350 CONTINUE 360 CONTINUE return end subroutine DU12LS (A, MDA, M, N, B, MDB, NB, MODE, KRANK, RNORM, & H, W, IC, IR) ! !! DU12LS solves a QR factored linear system for DLLSIA. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DLLSIA !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (U12LS-S, DU12LS-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given the Householder QR factorization of A, this ! subroutine solves the system AX=B. If the system ! is of reduced rank, this routine returns a solution ! according to the selected mode. ! ! Note - If MODE /= 2, W is never accessed. ! !***SEE ALSO DLLSIA !***ROUTINES CALLED DAXPY, DDOT, DNRM2, DSWAP !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DU12LS IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION DDOT,DNRM2 DIMENSION A(MDA,*),B(MDB,*),RNORM(*),H(*),W(*) INTEGER IC(*),IR(*) !***FIRST EXECUTABLE STATEMENT DU12LS K=KRANK KP1=K+1 ! ! RANK=0 ! if ( K > 0) go to 410 DO 404 JB=1,NB RNORM(JB)=DNRM2(M,B(1,JB),1) 404 CONTINUE DO 406 JB=1,NB DO 406 I=1,N B(I,JB)=0.0D0 406 CONTINUE return ! ! REORDER B TO REFLECT ROW INTERCHANGES ! 410 CONTINUE I=0 412 I=I+1 if ( I == M) go to 418 J=IR(I) if ( J == I) go to 412 if ( J < 0) go to 412 IR(I)=-IR(I) DO 413 JB=1,NB RNORM(JB)=B(I,JB) 413 CONTINUE IJ=I 414 DO 415 JB=1,NB B(IJ,JB)=B(J,JB) 415 CONTINUE IJ=J J=IR(IJ) IR(IJ)=-IR(IJ) if ( J /= I) go to 414 DO 416 JB=1,NB B(IJ,JB)=RNORM(JB) 416 CONTINUE go to 412 418 CONTINUE DO 420 I=1,M IR(I)=ABS(IR(I)) 420 CONTINUE ! ! APPLY HOUSEHOLDER TRANSFORMATIONS TO B ! DO 430 J=1,K TT=A(J,J) A(J,J)=H(J) DO 425 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) 425 CONTINUE A(J,J)=TT 430 CONTINUE ! ! FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) ! DO 440 JB=1,NB RNORM(JB)=DNRM2((M-K),B(KP1,JB),1) 440 CONTINUE ! ! BACK SOLVE UPPER TRIANGULAR R ! I=K 442 DO 444 JB=1,NB B(I,JB)=B(I,JB)/A(I,I) 444 CONTINUE if ( I == 1) go to 450 IM1=I-1 DO 448 JB=1,NB call DAXPY(IM1,-B(I,JB),A(1,I),1,B(1,JB),1) 448 CONTINUE I=IM1 go to 442 450 CONTINUE ! ! RANK LT N ! ! TRUNCATED SOLUTION ! if ( K == N) go to 480 DO 460 JB=1,NB DO 460 I=KP1,N B(I,JB)=0.0D0 460 CONTINUE if ( MODE == 1) go to 480 ! ! MINIMAL LENGTH SOLUTION ! NMK=N-K DO 470 JB=1,NB DO 465 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) 465 CONTINUE 470 CONTINUE ! ! ! REORDER B TO REFLECT COLUMN INTERCHANGES ! 480 CONTINUE I=0 482 I=I+1 if ( I == N) go to 488 J=IC(I) if ( J == I) go to 482 if ( J < 0) go to 482 IC(I)=-IC(I) 484 call DSWAP(NB,B(J,1),MDB,B(I,1),MDB) IJ=IC(J) IC(J)=-IC(J) J=IJ if ( J == I) go to 482 go to 484 488 CONTINUE DO 490 I=1,N IC(I)=ABS(IC(I)) 490 CONTINUE ! ! SOLUTION VECTORS ARE IN FIRST N ROWS OF B(,) ! return end subroutine DU12US (A, MDA, M, N, B, MDB, NB, MODE, KRANK, RNORM, & H, W, IR, IC) ! !! DU12US solves a QR factored system for DULSIA. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DULSIA !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (U12US-S, DU12US-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given the Householder LQ factorization of A, this ! subroutine solves the system AX=B. If the system ! is of reduced rank, this routine returns a solution ! according to the selected mode. ! ! Note - If MODE /= 2, W is never accessed. ! !***SEE ALSO DULSIA !***ROUTINES CALLED DAXPY, DDOT, DNRM2, DSWAP !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DU12US IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION DDOT,DNRM2 DIMENSION A(MDA,*),B(MDB,*),RNORM(*),H(*),W(*) INTEGER IC(*),IR(*) !***FIRST EXECUTABLE STATEMENT DU12US K=KRANK KP1=K+1 ! ! RANK=0 ! if ( K > 0) go to 410 DO 404 JB=1,NB RNORM(JB)=DNRM2(M,B(1,JB),1) 404 CONTINUE DO 406 JB=1,NB DO 406 I=1,N B(I,JB)=0.0D0 406 CONTINUE return ! ! REORDER B TO REFLECT ROW INTERCHANGES ! 410 CONTINUE I=0 412 I=I+1 if ( I == M) go to 418 J=IR(I) if ( J == I) go to 412 if ( J < 0) go to 412 IR(I)=-IR(I) DO 413 JB=1,NB RNORM(JB)=B(I,JB) 413 CONTINUE IJ=I 414 DO 415 JB=1,NB B(IJ,JB)=B(J,JB) 415 CONTINUE IJ=J J=IR(IJ) IR(IJ)=-IR(IJ) if ( J /= I) go to 414 DO 416 JB=1,NB B(IJ,JB)=RNORM(JB) 416 CONTINUE go to 412 418 CONTINUE DO 420 I=1,M IR(I)=ABS(IR(I)) 420 CONTINUE ! ! if A IS OF REDUCED RANK AND MODE=2, ! APPLY HOUSEHOLDER TRANSFORMATIONS TO B ! if ( MODE < 2 .OR. K == M) go to 440 MMK=M-K DO 430 JB=1,NB DO 425 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) 425 CONTINUE 430 CONTINUE ! ! FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) ! 440 DO 442 JB=1,NB RNORM(JB)=DNRM2((M-K),B(KP1,JB),1) 442 CONTINUE ! ! BACK SOLVE LOWER TRIANGULAR L ! DO 450 JB=1,NB DO 448 I=1,K B(I,JB)=B(I,JB)/A(I,I) if ( I == K) go to 450 IP1=I+1 call DAXPY(K-I,-B(I,JB),A(IP1,I),1,B(IP1,JB),1) 448 CONTINUE 450 CONTINUE ! ! ! TRUNCATED SOLUTION ! if ( K == N) go to 462 DO 460 JB=1,NB DO 460 I=KP1,N B(I,JB)=0.0D0 460 CONTINUE ! ! APPLY HOUSEHOLDER TRANSFORMATIONS TO B ! 462 DO 470 I=1,K J=KP1-I TT=A(J,J) A(J,J)=H(J) DO 465 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) 465 CONTINUE A(J,J)=TT 470 CONTINUE ! ! ! REORDER B TO REFLECT COLUMN INTERCHANGES ! I=0 482 I=I+1 if ( I == N) go to 488 J=IC(I) if ( J == I) go to 482 if ( J < 0) go to 482 IC(I)=-IC(I) 484 call DSWAP(NB,B(J,1),MDB,B(I,1),MDB) IJ=IC(J) IC(J)=-IC(J) J=IJ if ( J == I) go to 482 go to 484 488 CONTINUE DO 490 I=1,N IC(I)=ABS(IC(I)) 490 CONTINUE ! ! SOLUTION VECTORS ARE IN FIRST N ROWS OF B(,) ! return end subroutine DULSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, & NP, KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO) ! !! DULSIA solves an underdetermined linear system of equations by ... ! performing an LQ factorization of the matrix using ! Householder transformations. Emphasis is put on detecting ! possible rank deficiency. ! !***LIBRARY SLATEC !***CATEGORY D9 !***TYPE DOUBLE PRECISION (ULSIA-S, DULSIA-D) !***KEYWORDS LINEAR LEAST SQUARES, LQ FACTORIZATION, ! UNDERDETERMINED LINEAR SYSTEM !***AUTHOR Manteuffel, T. A., (LANL) !***DESCRIPTION ! ! DULSIA computes the minimal length solution(s) to the problem AX=B ! where A is an M by N matrix with M <= N and B is the M by NB ! matrix of right hand sides. User input bounds on the uncertainty ! in the elements of A are used to detect numerical rank deficiency. ! The algorithm employs a row and column pivot strategy to ! minimize the growth of uncertainty and round-off errors. ! ! DULSIA requires (MDA+1)*N + (MDB+1)*NB + 6*M dimensioned space ! ! ****************************************************************** ! * * ! * WARNING - All input arrays are changed on exit. * ! * * ! ****************************************************************** ! ! Input.. All TYPE REAL variables are DOUBLE PRECISION ! ! A(,) Linear coefficient matrix of AX=B, with MDA the ! MDA,M,N actual first dimension of A in the calling program. ! M is the row dimension (no. of EQUATIONS of the ! problem) and N the col dimension (no. of UNKNOWNS). ! Must have MDA >= M and M <= N. ! ! B(,) Right hand side(s), with MDB the actual first ! MDB,NB dimension of B in the calling program. NB is the ! number of M by 1 right hand sides. Since the ! solution is returned in B, must have MDB >= N. If ! NB = 0, B is never accessed. ! ! ****************************************************************** ! * * ! * Note - Use of RE and AE are what make this * ! * code significantly different from * ! * other linear least squares solvers. * ! * However, the inexperienced user is * ! * advised to set RE=0.,AE=0.,KEY=0. * ! * * ! ****************************************************************** ! ! RE(),AE(),KEY ! RE() RE() is a vector of length N such that RE(I) is ! the maximum relative uncertainty in row I of ! the matrix A. The values of RE() must be between ! 0 and 1. A minimum of 10*machine precision will ! be enforced. ! ! AE() AE() is a vector of length N such that AE(I) is ! the maximum absolute uncertainty in row I of ! the matrix A. The values of AE() must be greater ! than or equal to 0. ! ! KEY For ease of use, RE and AE may be input as either ! vectors or scalars. If a scalar is input, the algo- ! rithm will use that value for each column of A. ! The parameter KEY indicates whether scalars or ! vectors are being input. ! KEY=0 RE scalar AE scalar ! KEY=1 RE vector AE scalar ! KEY=2 RE scalar AE vector ! KEY=3 RE vector AE vector ! ! ! MODE The integer MODE indicates how the routine ! is to react if rank deficiency is detected. ! If MODE = 0 return immediately, no solution ! 1 compute truncated solution ! 2 compute minimal length least squares sol ! The inexperienced user is advised to set MODE=0 ! ! NP The first NP rows of A will not be interchanged ! with other rows even though the pivot strategy ! would suggest otherwise. ! The inexperienced user is advised to set NP=0. ! ! WORK() A real work array dimensioned 5*M. However, if ! RE or AE have been specified as vectors, dimension ! WORK 4*M. If both RE and AE have been specified ! as vectors, dimension WORK 3*M. ! ! LW Actual dimension of WORK ! ! IWORK() Integer work array dimensioned at least N+M. ! ! LIW Actual dimension of IWORK. ! ! ! INFO Is a flag which provides for the efficient ! solution of subsequent problems involving the ! same A but different B. ! If INFO = 0 original call ! INFO = 1 subsequent calls ! On subsequent calls, the user must supply A, KRANK, ! LW, IWORK, LIW, and the first 2*M locations of WORK ! as output by the original call to DULSIA. MODE must ! be equal to the value of MODE in the original call. ! If MODE < 2, only the first N locations of WORK ! are accessed. AE, RE, KEY, and NP are not accessed. ! ! ! ! ! Output..All TYPE REAL variables are DOUBLE PRECISION ! ! A(,) Contains the lower triangular part of the reduced ! matrix and the transformation information. It togeth ! with the first M elements of WORK (see below) ! completely specify the LQ factorization of A. ! ! B(,) Contains the N by NB solution matrix for X. ! ! KRANK,KSURE The numerical rank of A, based upon the relative ! and absolute bounds on uncertainty, is bounded ! above by KRANK and below by KSURE. The algorithm ! returns a solution based on KRANK. KSURE provides ! an indication of the precision of the rank. ! ! RNORM() Contains the Euclidean length of the NB residual ! vectors B(I)-AX(I), I=1,NB. If the matrix A is of ! full rank, then RNORM=0.0. ! ! WORK() The first M locations of WORK contain values ! necessary to reproduce the Householder ! transformation. ! ! IWORK() The first N locations contain the order in ! which the columns of A were used. The next ! M locations contain the order in which the ! rows of A were used. ! ! INFO Flag to indicate status of computation on completion ! -1 Parameter error(s) ! 0 - Rank deficient, no solution ! 1 - Rank deficient, truncated solution ! 2 - Rank deficient, minimal length least squares sol ! 3 - Numerical rank 0, zero solution ! 4 - Rank < NP ! 5 - Full rank ! !***REFERENCES T. Manteuffel, An interval analysis approach to rank ! determination in linear least squares problems, ! Report SAND80-0655, Sandia Laboratories, June 1980. !***ROUTINES CALLED D1MACH, DU11US, DU12US, XERMSG !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Fixed an error message. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DULSIA IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION D1MACH DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*) INTEGER IWORK(*) ! !***FIRST EXECUTABLE STATEMENT DULSIA if ( INFO < 0 .OR. INFO > 1) go to 514 IT=INFO INFO=-1 if ( NB == 0 .AND. IT == 1) go to 501 if ( M < 1) go to 502 if ( N < 1) go to 503 if ( N < M) go to 504 if ( MDA < M) go to 505 if ( LIW < M+N) go to 506 if ( MODE < 0 .OR. MODE > 3) go to 515 if ( NB == 0) go to 4 if ( NB < 0) go to 507 if ( MDB < N) go to 508 if ( IT == 0) go to 4 go to 400 4 if ( KEY < 0.OR.KEY > 3) go to 509 if ( KEY == 0 .AND. LW < 5*M) go to 510 if ( KEY == 1 .AND. LW < 4*M) go to 510 if ( KEY == 2 .AND. LW < 4*M) go to 510 if ( KEY == 3 .AND. LW < 3*M) go to 510 if ( NP < 0 .OR. NP > M) go to 516 ! EPS=10.*D1MACH(3) M1=1 M2=M1+M M3=M2+M M4=M3+M M5=M4+M ! if ( KEY == 1) go to 100 if ( KEY == 2) go to 200 if ( KEY == 3) go to 300 ! if ( RE(1) < 0.D00) go to 511 if ( RE(1) > 1.0D0) go to 512 if ( RE(1) < EPS) RE(1)=EPS if ( AE(1) < 0.0D0) go to 513 DO 20 I=1,M W(M4-1+I)=RE(1) W(M5-1+I)=AE(1) 20 CONTINUE call DU11US(A,MDA,M,N,W(M4),W(M5),MODE,NP,KRANK,KSURE, & W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) go to 400 ! 100 CONTINUE if ( AE(1) < 0.0D0) go to 513 DO 120 I=1,M if ( RE(I) < 0.0D0) go to 511 if ( RE(I) > 1.0D0) go to 512 if ( RE(I) < EPS) RE(I)=EPS W(M4-1+I)=AE(1) 120 CONTINUE call DU11US(A,MDA,M,N,RE,W(M4),MODE,NP,KRANK,KSURE, & W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) go to 400 ! 200 CONTINUE if ( RE(1) < 0.0D0) go to 511 if ( RE(1) > 1.0D0) go to 512 if ( RE(1) < EPS) RE(1)=EPS DO 220 I=1,M W(M4-1+I)=RE(1) if ( AE(I) < 0.0D0) go to 513 220 CONTINUE call DU11US(A,MDA,M,N,W(M4),AE,MODE,NP,KRANK,KSURE, & W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) go to 400 ! 300 CONTINUE DO 320 I=1,M if ( RE(I) < 0.0D0) go to 511 if ( RE(I) > 1.0D0) go to 512 if ( RE(I) < EPS) RE(I)=EPS if ( AE(I) < 0.0D0) go to 513 320 CONTINUE call DU11US(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE, & W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) ! ! DETERMINE INFO ! 400 if ( KRANK /= M) go to 402 INFO=5 go to 410 402 if ( KRANK /= 0) go to 404 INFO=3 go to 410 404 if ( KRANK >= NP) go to 406 INFO=4 return 406 INFO=MODE if ( MODE == 0) RETURN 410 if ( NB == 0) RETURN ! ! ! SOLUTION PHASE ! M1=1 M2=M1+M M3=M2+M if ( INFO == 2) go to 420 if ( LW < M2-1) go to 510 call DU12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK, & RNORM,W(M1),W(M1),IWORK(M1),IWORK(M2)) return ! 420 if ( LW < M3-1) go to 510 call DU12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK, & RNORM,W(M1),W(M2),IWORK(M1),IWORK(M2)) return ! ! ERROR MESSAGES ! 501 call XERMSG ('SLATEC', 'DULSIA', & 'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0) return 502 call XERMSG ('SLATEC', 'DULSIA', 'M < 1', 2, 1) return 503 call XERMSG ('SLATEC', 'DULSIA', 'N < 1', 2, 1) return 504 call XERMSG ('SLATEC', 'DULSIA', 'N < M', 2, 1) return 505 call XERMSG ('SLATEC', 'DULSIA', 'MDA < M', 2, 1) return 506 call XERMSG ('SLATEC', 'DULSIA', 'LIW < M+N', 2, 1) return 507 call XERMSG ('SLATEC', 'DULSIA', 'NB < 0', 2, 1) return 508 call XERMSG ('SLATEC', 'DULSIA', 'MDB < N', 2, 1) return 509 call XERMSG ('SLATEC', 'DULSIA', 'KEY OUT OF RANGE', 2, 1) return 510 call XERMSG ('SLATEC', 'DULSIA', 'INSUFFICIENT WORK SPACE', 8, 1) INFO=-1 return 511 call XERMSG ('SLATEC', 'DULSIA', 'RE(I) < 0', 2, 1) return 512 call XERMSG ('SLATEC', 'DULSIA', 'RE(I) > 1', 2, 1) return 513 call XERMSG ('SLATEC', 'DULSIA', 'AE(I) < 0', 2, 1) return 514 call XERMSG ('SLATEC', 'DULSIA', 'INFO OUT OF RANGE', 2, 1) return 515 call XERMSG ('SLATEC', 'DULSIA', 'MODE OUT OF RANGE', 2, 1) return 516 call XERMSG ('SLATEC', 'DULSIA', 'NP OUT OF RANGE', 2, 1) return end subroutine DUSRMT (I, J, AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) ! !! DUSRMT is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (USRMAT-S, DUSRMT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! The user may supply this code ! !***SEE ALSO DSPLP !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DUSRMT DOUBLE PRECISION PRGOPT(*),DATTRV(*),AIJ INTEGER IFLAG(*) ! !***FIRST EXECUTABLE STATEMENT DUSRMT if ( IFLAG(1) == 1) THEN ! ! THIS IS THE INITIALIZATION STEP. THE VALUES OF IFLAG(K),K=2,3,4, ! ARE RESPECTIVELY THE COLUMN INDEX, THE ROW INDEX (OR THE NEXT COL. ! INDEX), AND THE POINTER TO THE MATRIX ENTRY'S VALUE WITHIN ! DATTRV(*). ALSO CHECK (DATTRV(1)=0.) SIGNIFYING NO DATA. if ( DATTRV(1) == 0.D0) THEN I = 0 J = 0 IFLAG(1) = 3 ELSE IFLAG(2)=-DATTRV(1) IFLAG(3)= DATTRV(2) IFLAG(4)= 3 ENDIF ! return ELSE J=IFLAG(2) I=IFLAG(3) L=IFLAG(4) if ( I == 0) THEN ! ! SIGNAL THAT ALL OF THE NONZERO ENTRIES HAVE BEEN DEFINED. IFLAG(1)=3 return ELSE if ( I < 0) THEN ! ! SIGNAL THAT A SWITCH IS MADE TO A NEW COLUMN. J=-I I=DATTRV(L) L=L+1 ENDIF ! AIJ=DATTRV(L) ! ! UPDATE THE INDICES AND POINTERS FOR THE NEXT ENTRY. IFLAG(2)=J IFLAG(3)=DATTRV(L+1) IFLAG(4)=L+2 ! ! INDCAT=0 DENOTES THAT ENTRIES OF THE MATRIX ARE ASSIGNED THE ! VALUES FROM DATTRV(*). NO ACCUMULATION IS PERFORMED. INDCAT=0 return end if end subroutine DVECS (NCOMP, LNFC, YHP, WORK, IWORK, INHOMO, IFLAG) ! !! DVECS is subsidiary to DBVSUP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SVECS-S, DVECS-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This subroutine is used for the special structure of COMPLEX*16 ! valued problems. DMGSBV is called upon to obtain LNFC vectors from an ! original set of 2*LNFC independent vectors so that the resulting ! LNFC vectors together with their imaginary product or mate vectors ! form an independent set. ! !***SEE ALSO DBVSUP !***ROUTINES CALLED DMGSBV !***COMMON BLOCKS DML18J !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891009 Removed unreferenced statement label. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE DVECS ! INTEGER ICOCO, IDP, IFLAG, INDPVT, INHOMO, INTEG, IWORK(*), K, & KP, LNFC, LNFCC, MXNON, NCOMP, NDISK, NEQ, NEQIVP, NIC, NIV, & NOPG, NPS, NTAPE, NTP, NUMORT, NXPTS DOUBLE PRECISION AE, DUM, RE, TOL, WORK(*), YHP(NCOMP,*) COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,LNFCC, & ICOCO !***FIRST EXECUTABLE STATEMENT DVECS if (LNFC /= 1) go to 20 DO 10 K = 1, NCOMP YHP(K,LNFC+1) = YHP(K,LNFCC+1) 10 CONTINUE IFLAG = 1 go to 60 20 CONTINUE NIV = LNFC LNFC = 2*LNFC LNFCC = 2*LNFCC KP = LNFC + 2 + LNFCC IDP = INDPVT INDPVT = 0 call DMGSBV(NCOMP,LNFC,YHP,NCOMP,NIV,IFLAG,WORK(1),WORK(KP), & IWORK(1),INHOMO,YHP(1,LNFC+1),WORK(LNFC+2),DUM) LNFC = LNFC/2 LNFCC = LNFCC/2 INDPVT = IDP if (IFLAG /= 0 .OR. NIV /= LNFC) go to 40 DO 30 K = 1, NCOMP YHP(K,LNFC+1) = YHP(K,LNFCC+1) 30 CONTINUE IFLAG = 1 go to 50 40 CONTINUE IFLAG = 99 50 CONTINUE 60 CONTINUE CONTINUE return end DOUBLE PRECISION FUNCTION DVNRMS (N, V, W) ! !! DVNRMS computes a weighted root-mean-square vector norm for DDEBDF. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DDEBDF !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (VNWRMS-S, DVNRMS-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DVNRMS computes a weighted root-mean-square vector norm for the ! integrator package DDEBDF. ! !***SEE ALSO DDEBDF !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DVNRMS INTEGER I, N DOUBLE PRECISION SUM, V, W DIMENSION V(*),W(*) !***FIRST EXECUTABLE STATEMENT DVNRMS SUM = 0.0D0 DO 10 I = 1, N SUM = SUM + (V(I)/W(I))**2 10 CONTINUE DVNRMS = SQRT(SUM/N) return ! ----------------------- END OF FUNCTION DVNRMS ! ------------------------ end subroutine DVOUT (N, DX, IFMT, IDIGIT) ! !! DVOUT prints a double precision vector. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DSPLP !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SVOUT-S, DVOUT-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! DOUBLE PRECISION VECTOR OUTPUT ROUTINE. ! ! INPUT.. ! ! N,DX(*) PRINT THE DOUBLE PRECISION ARRAY DX(I),I=1,...,N, ON ! OUTPUT UNIT LOUT. THE HEADING IN THE FORTRAN FORMAT ! STATEMENT IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST ! STEP. THE COMPONENTS DX(I) ARE INDEXED, ON OUTPUT, ! IN A PLEASANT FORMAT. ! IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON OUTPUT ! UNIT LOUT WITH THE VARIABLE FORMAT FORTRAN STATEMENT ! WRITE(LOUT,IFMT) ! IDIGIT PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. ! THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10 OR 14 ! WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF ! PLACES. if IDIGIT < 0, 72 PRINTING COLUMNS ARE UTILIZED ! TO WRITE EACH LINE OF OUTPUT OF THE ARRAY DX(*). (THIS ! CAN BE USED ON MOST TIME-SHARING TERMINALS). IF ! IDIGIT >= 0, 133 PRINTING COLUMNS ARE UTILIZED. (THIS CAN ! BE USED ON MOST LINE PRINTERS). ! ! EXAMPLE.. ! ! PRINT AN ARRAY CALLED (COSTS OF PURCHASES) OF LENGTH 100 SHOWING ! 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING ! SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. ! ! DOUBLE PRECISION COSTS(100) ! N = 100 ! IDIGIT = -6 ! call DVOUT(N,COSTS,'(''1COSTS OF PURCHASES'')',IDIGIT) ! !***SEE ALSO DSPLP !***ROUTINES CALLED I1MACH !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891107 Added comma after 1P edit descriptor in FORMAT ! statements. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910403 Updated AUTHOR section. (WRB) !***END PROLOGUE DVOUT IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION DX(*) CHARACTER IFMT*(*) !***FIRST EXECUTABLE STATEMENT DVOUT LOUT=I1MACH(2) WRITE(LOUT,IFMT) if ( N <= 0) RETURN NDIGIT = IDIGIT if ( IDIGIT == 0) NDIGIT = 6 if ( IDIGIT >= 0) go to 80 ! NDIGIT = -IDIGIT if ( NDIGIT > 6) go to 20 ! DO 10 K1=1,N,4 K2 = MIN(N,K1+3) WRITE(LOUT,1000) K1,K2,(DX(I),I = K1, K2) 10 CONTINUE return ! 20 CONTINUE if ( NDIGIT > 14) go to 40 ! DO 30 K1=1,N,2 K2 = MIN(N,K1+1) WRITE(LOUT,1001) K1,K2,(DX(I),I = K1, K2) 30 CONTINUE return ! 40 CONTINUE if ( NDIGIT > 20) go to 60 ! DO 50 K1=1,N,2 K2=MIN(N,K1+1) WRITE(LOUT,1002) K1,K2,(DX(I),I = K1, K2) 50 CONTINUE return ! 60 CONTINUE DO 70 K1=1,N K2 = K1 WRITE(LOUT,1003) K1,K2,(DX(I),I = K1, K2) 70 CONTINUE return ! 80 CONTINUE if ( NDIGIT > 6) go to 100 ! DO 90 K1=1,N,8 K2 = MIN(N,K1+7) WRITE(LOUT,1000) K1,K2,(DX(I),I = K1, K2) 90 CONTINUE return ! 100 CONTINUE if ( NDIGIT > 14) go to 120 ! DO 110 K1=1,N,5 K2 = MIN(N,K1+4) WRITE(LOUT,1001) K1,K2,(DX(I),I = K1, K2) 110 CONTINUE return ! 120 CONTINUE if ( NDIGIT > 20) go to 140 ! DO 130 K1=1,N,4 K2 = MIN(N,K1+3) WRITE(LOUT,1002) K1,K2,(DX(I),I = K1, K2) 130 CONTINUE return ! 140 CONTINUE DO 150 K1=1,N,3 K2 = MIN(N,K1+2) WRITE(LOUT,1003) K1,K2,(DX(I),I = K1, K2) 150 CONTINUE return 1000 FORMAT(1X,I4,3H - ,I4,1X,1P,8D14.5) 1001 FORMAT(1X,I4,3H - ,I4,1X,1P,5D22.13) 1002 FORMAT(1X,I4,3H - ,I4,1X,1P,4D28.19) 1003 FORMAT(1X,I4,3H - ,I4,1X,1P,3D36.27) end subroutine DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, & RNORM, IDOPE, DOPE, DONE) ! !! DWNLIT is subsidiary to DWNNLS. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (WNLIT-S, DWNLIT-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! This is a companion subprogram to DWNNLS( ). ! The documentation for DWNNLS( ) has complete usage instructions. ! ! Note The M by (N+1) matrix W( , ) contains the rt. hand side ! B as the (N+1)st col. ! ! Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with ! col interchanges. ! !***SEE ALSO DWNNLS !***ROUTINES CALLED DCOPY, DH12, DROTM, DROTMG, DSCAL, DSWAP, DWNLT1, ! DWNLT2, DWNLT3, IDAMAX !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and revised. (WRB & RWC) ! 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900604 DP version created from SP version. . (RWC) !***END PROLOGUE DWNLIT INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N DOUBLE PRECISION DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) LOGICAL DONE ! EXTERNAL DCOPY, DH12, DROTM, DROTMG, DSCAL, DSWAP, DWNLT1, & DWNLT2, DWNLT3, IDAMAX INTEGER IDAMAX LOGICAL DWNLT2 ! DOUBLE PRECISION ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), & T, TAU INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, & MEND, NIV, NSOLN LOGICAL INDEP, RECALC ! !***FIRST EXECUTABLE STATEMENT DWNLIT ME = IDOPE(1) NSOLN = IDOPE(2) L1 = IDOPE(3) ! ALSQ = DOPE(1) EANORM = DOPE(2) TAU = DOPE(3) ! LB = MIN(M-1,L) RECALC = .TRUE. RNORM = 0.D0 KRANK = 0 ! ! We set FACTOR=1.0 so that the heavy weight ALAMDA will be ! included in the test for column independence. ! FACTOR = 1.D0 LEND = L DO 180 I=1,LB ! ! Set IR to point to the I-th row. ! IR = I MEND = M call DWNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, & W) ! ! Update column SS and find pivot column. ! call DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) ! ! Perform column interchange. ! Test independence of incoming column. ! 130 if (DWNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN ! ! Eliminate I-th column below diagonal using modified Givens ! transformations applied to (A B). ! ! When operating near the ME line, use the largest element ! above it as the pivot. ! DO 160 J=M,I+1,-1 JP = J-1 if (J == ME+1) THEN IMAX = ME AMAX = SCALE(ME)*W(ME,I)**2 DO 150 JP=J-1,I,-1 T = SCALE(JP)*W(JP,I)**2 if (T > AMAX) THEN IMAX = JP AMAX = T ENDIF 150 CONTINUE JP = IMAX ENDIF ! if (W(J,I) /= 0.D0) THEN call DROTMG (SCALE(JP), SCALE(J), W(JP,I), W(J,I), & SPARAM) W(J,I) = 0.D0 call DROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), MDW, & SPARAM) ENDIF 160 CONTINUE ELSE if (LEND > I) THEN ! ! Column I is dependent. Swap with column LEND. ! Perform column interchange, ! and find column in remaining set with largest SS. ! call DWNLT3 (I, LEND, M, MDW, IPIVOT, H, W) LEND = LEND - 1 IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 HBAR = H(IMAX) go to 130 ELSE KRANK = I - 1 go to 190 ENDIF 180 CONTINUE KRANK = L1 ! 190 if (KRANK < ME) THEN FACTOR = ALSQ DO 200 I=KRANK+1,ME call dinit ( L, 0.D0, W(I,1), MDW) 200 CONTINUE ! ! Determine the rank of the remaining equality constraint ! equations by eliminating within the block of constrained ! variables. Remove any redundant constraints. ! RECALC = .TRUE. LB = MIN(L+ME-KRANK, N) DO 270 I=L+1,LB IR = KRANK + I - L LEND = N MEND = ME call DWNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, & SCALE, W) ! ! Update col ss and find pivot col ! call DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) ! ! Perform column interchange ! Eliminate elements in the I-th col. ! DO 240 J=ME,IR+1,-1 if (W(J,I) /= 0.D0) THEN call DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), W(J,I), & SPARAM) W(J,I) = 0.D0 call DROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), MDW, & SPARAM) ENDIF 240 CONTINUE ! ! I=column being eliminated. ! Test independence of incoming column. ! Remove any redundant or dependent equality constraints. ! if (.NOT.DWNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN JJ = IR DO 260 IR=JJ,ME call dinit ( N, 0.D0, W(IR,1), MDW) RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) W(IR,N+1) = 0.D0 SCALE(IR) = 1.D0 ! ! Reclassify the zeroed row as a least squares equation. ! ITYPE(IR) = 1 260 CONTINUE ! ! Reduce ME to reflect any discovered dependent equality ! constraints. ! ME = JJ - 1 go to 280 ENDIF 270 CONTINUE end if ! ! Try to determine the variables KRANK+1 through L1 from the ! least squares equations. Continue the triangularization with ! pivot element W(ME+1,I). ! 280 if (KRANK < L1) THEN RECALC = .TRUE. ! ! Set FACTOR=ALSQ to remove effect of heavy weight from ! test for column independence. ! FACTOR = ALSQ DO 350 I=KRANK+1,L1 ! ! Set IR to point to the ME+1-st row. ! IR = ME+1 LEND = L MEND = M call DWNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, & W) ! ! Update column SS and find pivot column. ! call DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) ! ! Perform column interchange. ! Eliminate I-th column below the IR-th element. ! DO 320 J=M,IR+1,-1 if (W(J,I) /= 0.D0) THEN call DROTMG (SCALE(J-1), SCALE(J), W(J-1,I), W(J,I), & SPARAM) W(J,I) = 0.D0 call DROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), MDW, & SPARAM) ENDIF 320 CONTINUE ! ! Test if new pivot element is near zero. ! If so, the column is dependent. ! Then check row norm test to be classified as independent. ! T = SCALE(IR)*W(IR,I)**2 INDEP = T > (TAU*EANORM)**2 if (INDEP) THEN RN = 0.D0 DO 340 I1=IR,M DO 330 J1=I+1,N RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) 330 CONTINUE 340 CONTINUE INDEP = T > RN*TAU**2 ENDIF ! ! If independent, swap the IR-th and KRANK+1-th rows to ! maintain the triangular form. Update the rank indicator ! KRANK and the equality constraint pointer ME. ! if (.NOT.INDEP) go to 360 call DSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) call DSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) ! ! Reclassify the least square equation as an equality ! constraint and rescale it. ! ITYPE(IR) = 0 T = SQRT(SCALE(KRANK+1)) call DSCAL(N+1, T, W(KRANK+1,1), MDW) SCALE(KRANK+1) = ALSQ ME = ME+1 KRANK = KRANK+1 350 CONTINUE end if ! ! If pseudorank is less than L, apply Householder transformation. ! from right. ! 360 if (KRANK < L) THEN DO 370 J=KRANK,1,-1 call DH12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, & J-1) 370 CONTINUE end if ! NIV = KRANK + NSOLN - L if (L == N) DONE = .TRUE. ! ! End of initial triangularization. ! IDOPE(1) = ME IDOPE(2) = KRANK IDOPE(3) = NIV return end subroutine DWNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, & IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) ! !! DWNLSM is subsidiary to DWNNLS. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (WNLSM-S, DWNLSM-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! This is a companion subprogram to DWNNLS. ! The documentation for DWNNLS has complete usage instructions. ! ! In addition to the parameters discussed in the prologue to ! subroutine DWNNLS, the following work arrays are used in ! subroutine DWNLSM (they are passed through the calling ! sequence from DWNNLS for purposes of variable dimensioning). ! Their contents will in general be of no interest to the user. ! ! Variables of type REAL are DOUBLE PRECISION. ! ! IPIVOT(*) ! An array of length N. Upon completion it contains the ! pivoting information for the cols of W(*,*). ! ! ITYPE(*) ! An array of length M which is used to keep track ! of the classification of the equations. ITYPE(I)=0 ! denotes equation I as an equality constraint. ! ITYPE(I)=1 denotes equation I as a least squares ! equation. ! ! WD(*) ! An array of length N. Upon completion it contains the ! dual solution vector. ! ! H(*) ! An array of length N. Upon completion it contains the ! pivot scalars of the Householder transformations performed ! in the case KRANK < L. ! ! SCALE(*) ! An array of length M which is used by the subroutine ! to store the diagonal matrix of weights. ! These are used to apply the modified Givens ! transformations. ! ! Z(*),TEMP(*) ! Working arrays of length N. ! ! D(*) ! An array of length N that contains the ! column scaling for the matrix (E). ! (A) ! !***SEE ALSO DWNNLS !***ROUTINES CALLED D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, DROTM, ! DROTMG, DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and revised. (WRB & RWC) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Fixed an error message. (RWC) ! 900604 DP version created from SP version. (RWC) ! 900911 Restriction on value of ALAMDA included. (WRB) !***END PROLOGUE DWNLSM INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N DOUBLE PRECISION D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), & W(MDW,*), WD(*), X(*), Z(*) ! EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DH12, DNRM2, DROTM, DROTMG, & DSCAL, DSWAP, DWNLIT, IDAMAX, XERMSG DOUBLE PRECISION D1MACH, DASUM, DNRM2 INTEGER IDAMAX ! DOUBLE PRECISION ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, & DOPE(3), DRELPR, EANORM, FAC, SM, SPARAM(5), T, TAU, WMAX, Z2, & ZZ INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, & JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, & NOPT, NSOLN, NTIMES LOGICAL DONE, FEASBL, FIRST, HITCON, POS ! SAVE DRELPR, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT DWNLSM ! ! Initialize variables. ! DRELPR is the precision for the particular machine ! being used. This logic avoids resetting it every entry. ! if (FIRST) DRELPR = D1MACH(4) FIRST = .FALSE. ! ! Set the nominal tolerance used in the code. ! TAU = SQRT(DRELPR) ! M = MA + MME ME = MME MODE = 2 ! ! To process option vector ! FAC = 1.D-4 ! ! Set the nominal blow up factor used in the code. ! BLOWUP = TAU ! ! The nominal column scaling used in the code is ! the identity scaling. ! call dinit ( N, 1.D0, D, 1) ! ! Define bound for number of options to change. ! NOPT = 1000 ! ! Define bound for positive value of LINK. ! NLINK = 100000 NTIMES = 0 LAST = 1 LINK = PRGOPT(1) if (LINK <= 0 .OR. LINK > NLINK) THEN call XERMSG ('SLATEC', 'DWNLSM', & 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) return end if ! 100 if (LINK > 1) THEN NTIMES = NTIMES + 1 if (NTIMES > NOPT) THEN call XERMSG ('SLATEC', 'DWNLSM', & 'IN DWNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', & 3, 1) return ENDIF ! KEY = PRGOPT(LAST+1) if (KEY == 6 .AND. PRGOPT(LAST+2) /= 0.D0) THEN DO 110 J = 1,N T = DNRM2(M,W(1,J),1) if (T /= 0.D0) T = 1.D0/T D(J) = T 110 CONTINUE ENDIF ! if (KEY == 7) call DCOPY (N, PRGOPT(LAST+2), 1, D, 1) if (KEY == 8) TAU = MAX(DRELPR,PRGOPT(LAST+2)) if (KEY == 9) BLOWUP = MAX(DRELPR,PRGOPT(LAST+2)) ! NEXT = PRGOPT(LINK) if (NEXT <= 0 .OR. NEXT > NLINK) THEN call XERMSG ('SLATEC', 'DWNLSM', & 'IN DWNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) return ENDIF ! LAST = LINK LINK = NEXT go to 100 end if ! DO 120 J = 1,N call DSCAL (M, D(J), W(1,J), 1) 120 CONTINUE ! ! Process option vector ! DONE = .FALSE. ITER = 0 ITMAX = 3*(N-L) MODE = 0 NSOLN = L L1 = MIN(M,L) ! ! Compute scale factor to apply to equality constraint equations. ! DO 130 J = 1,N WD(J) = DASUM(M,W(1,J),1) 130 CONTINUE ! IMAX = IDAMAX(N,WD,1) EANORM = WD(IMAX) BNORM = DASUM(M,W(1,N+1),1) ALAMDA = EANORM/(DRELPR*FAC) ! ! On machines, such as the VAXes using D floating, with a very ! limited exponent range for double precision values, the previously ! computed value of ALAMDA may cause an overflow condition. ! Therefore, this code further limits the value of ALAMDA. ! ALAMDA = MIN(ALAMDA,SQRT(D1MACH(2))) ! ! Define scaling diagonal matrix for modified Givens usage and ! classify equation types. ! ALSQ = ALAMDA**2 DO 140 I = 1,M ! ! When equation I is heavily weighted ITYPE(I)=0, ! else ITYPE(I)=1. ! if (I <= ME) THEN T = ALSQ ITEMP = 0 ELSE T = 1.D0 ITEMP = 1 ENDIF SCALE(I) = T ITYPE(I) = ITEMP 140 CONTINUE ! ! Set the solution vector X(*) to zero and the column interchange ! matrix to the identity. ! call dinit ( N, 0.D0, X, 1) DO 150 I = 1,N IPIVOT(I) = I 150 CONTINUE ! ! Perform initial triangularization in the submatrix ! corresponding to the unconstrained variables. ! Set first L components of dual vector to zero because ! these correspond to the unconstrained variables. ! call dinit ( L, 0.D0, WD, 1) ! ! The arrays IDOPE(*) and DOPE(*) are used to pass ! information to DWNLIT(). This was done to avoid ! a long calling sequence or the use of COMMON. ! IDOPE(1) = ME IDOPE(2) = NSOLN IDOPE(3) = L1 ! DOPE(1) = ALSQ DOPE(2) = EANORM DOPE(3) = TAU call DWNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, & IDOPE, DOPE, DONE) ME = IDOPE(1) KRANK = IDOPE(2) NIV = IDOPE(3) ! ! Perform WNNLS algorithm using the following steps. ! ! Until(DONE) ! compute search direction and feasible point ! when (HITCON) add constraints ! else perform multiplier test and drop a constraint ! fin ! Compute-Final-Solution ! ! To compute search direction and feasible point, ! solve the triangular system of currently non-active ! variables and store the solution in Z(*). ! ! To solve system ! Copy right hand side into TEMP vector to use overwriting method. ! 160 if (DONE) go to 330 ISOL = L + 1 if (NSOLN >= ISOL) THEN call DCOPY (NIV, W(1,N+1), 1, TEMP, 1) DO 170 J = NSOLN,ISOL,-1 if (J > KRANK) THEN I = NIV - NSOLN + J ELSE I = J ENDIF ! if (J > KRANK .AND. J <= L) THEN Z(J) = 0.D0 ELSE Z(J) = TEMP(I)/W(I,J) call DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) ENDIF 170 CONTINUE end if ! ! Increment iteration counter and check against maximum number ! of iterations. ! ITER = ITER + 1 if (ITER > ITMAX) THEN MODE = 1 DONE = .TRUE. end if ! ! Check to see if any constraints have become active. ! If so, calculate an interpolation factor so that all ! active constraints are removed from the basis. ! ALPHA = 2.D0 HITCON = .FALSE. DO 180 J = L+1,NSOLN ZZ = Z(J) if (ZZ <= 0.D0) THEN T = X(J)/(X(J)-ZZ) if (T < ALPHA) THEN ALPHA = T JCON = J ENDIF HITCON = .TRUE. ENDIF 180 CONTINUE ! ! Compute search direction and feasible point ! if (HITCON) THEN ! ! To add constraints, use computed ALPHA to interpolate between ! last feasible solution X(*) and current unconstrained (and ! infeasible) solution Z(*). ! DO 190 J = L+1,NSOLN X(J) = X(J) + ALPHA*(Z(J)-X(J)) 190 CONTINUE FEASBL = .FALSE. ! ! Remove column JCON and shift columns JCON+1 through N to the ! left. Swap column JCON into the N th position. This achieves ! upper Hessenberg form for the nonactive constraints and ! leaves an upper Hessenberg matrix to retriangularize. ! 200 DO 210 I = 1,M T = W(I,JCON) call DCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) W(I,N) = T 210 CONTINUE ! ! Update permuted index vector to reflect this shift and swap. ! ITEMP = IPIVOT(JCON) DO 220 I = JCON,N - 1 IPIVOT(I) = IPIVOT(I+1) 220 CONTINUE IPIVOT(N) = ITEMP ! ! Similarly permute X(*) vector. ! call DCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) X(N) = 0.D0 NSOLN = NSOLN - 1 NIV = NIV - 1 ! ! Retriangularize upper Hessenberg matrix after adding ! constraints. ! I = KRANK + JCON - L DO 230 J = JCON,NSOLN if (ITYPE(I) == 0 .AND. ITYPE(I+1) == 0) THEN ! ! Zero IP1 to I in column J ! if (W(I+1,J) /= 0.D0) THEN call DROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), & SPARAM) W(I+1,J) = 0.D0 call DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, & SPARAM) ENDIF ELSEIF (ITYPE(I) == 1 .AND. ITYPE(I+1) == 1) THEN ! ! Zero IP1 to I in column J ! if (W(I+1,J) /= 0.D0) THEN call DROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), & SPARAM) W(I+1,J) = 0.D0 call DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, & SPARAM) ENDIF ELSEIF (ITYPE(I) == 1 .AND. ITYPE(I+1) == 0) THEN call DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) call DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) ITEMP = ITYPE(I+1) ITYPE(I+1) = ITYPE(I) ITYPE(I) = ITEMP ! ! Swapped row was formerly a pivot element, so it will ! be large enough to perform elimination. ! Zero IP1 to I in column J. ! if (W(I+1,J) /= 0.D0) THEN call DROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), & SPARAM) W(I+1,J) = 0.D0 call DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, & SPARAM) ENDIF ELSEIF (ITYPE(I) == 0 .AND. ITYPE(I+1) == 1) THEN if (SCALE(I)*W(I,J)**2/ALSQ > (TAU*EANORM)**2) THEN ! ! Zero IP1 to I in column J ! if (W(I+1,J) /= 0.D0) THEN call DROTMG (SCALE(I), SCALE(I+1), W(I,J), & W(I+1,J), SPARAM) W(I+1,J) = 0.D0 call DROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, & SPARAM) ENDIF ELSE call DSWAP (N+1, W(I,1), MDW, W(I+1,1), MDW) call DSWAP (1, SCALE(I), 1, SCALE(I+1), 1) ITEMP = ITYPE(I+1) ITYPE(I+1) = ITYPE(I) ITYPE(I) = ITEMP W(I+1,J) = 0.D0 ENDIF ENDIF I = I + 1 230 CONTINUE ! ! See if the remaining coefficients in the solution set are ! feasible. They should be because of the way ALPHA was ! determined. If any are infeasible, it is due to roundoff ! error. Any that are non-positive will be set to zero and ! removed from the solution set. ! DO 240 JCON = L+1,NSOLN if (X(JCON) <= 0.D0) go to 250 240 CONTINUE FEASBL = .TRUE. 250 if (.NOT.FEASBL) go to 200 ELSE ! ! To perform multiplier test and drop a constraint. ! call DCOPY (NSOLN, Z, 1, X, 1) if (NSOLN < N) call dinit ( N-NSOLN, 0.D0, X(NSOLN+1), 1) ! ! Reclassify least squares equations as equalities as necessary. ! I = NIV + 1 260 if (I <= ME) THEN if (ITYPE(I) == 0) THEN I = I + 1 ELSE call DSWAP (N+1, W(I,1), MDW, W(ME,1), MDW) call DSWAP (1, SCALE(I), 1, SCALE(ME), 1) ITEMP = ITYPE(I) ITYPE(I) = ITYPE(ME) ITYPE(ME) = ITEMP ME = ME - 1 ENDIF go to 260 ENDIF ! ! Form inner product vector WD(*) of dual coefficients. ! DO 280 J = NSOLN+1,N SM = 0.D0 DO 270 I = NSOLN+1,M SM = SM + SCALE(I)*W(I,J)*W(I,N+1) 270 CONTINUE WD(J) = SM 280 CONTINUE ! ! Find J such that WD(J)=WMAX is maximum. This determines ! that the incoming column J will reduce the residual vector ! and be positive. ! 290 WMAX = 0.D0 IWMAX = NSOLN + 1 DO 300 J = NSOLN+1,N if (WD(J) > WMAX) THEN WMAX = WD(J) IWMAX = J ENDIF 300 CONTINUE if (WMAX <= 0.D0) go to 330 ! ! Set dual coefficients to zero for incoming column. ! WD(IWMAX) = 0.D0 ! ! WMAX > 0.D0, so okay to move column IWMAX to solution set. ! Perform transformation to retriangularize, and test for near ! linear dependence. ! ! Swap column IWMAX into NSOLN-th position to maintain upper ! Hessenberg form of adjacent columns, and add new column to ! triangular decomposition. ! NSOLN = NSOLN + 1 NIV = NIV + 1 if (NSOLN /= IWMAX) THEN call DSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) WD(IWMAX) = WD(NSOLN) WD(NSOLN) = 0.D0 ITEMP = IPIVOT(NSOLN) IPIVOT(NSOLN) = IPIVOT(IWMAX) IPIVOT(IWMAX) = ITEMP ENDIF ! ! Reduce column NSOLN so that the matrix of nonactive constraints ! variables is triangular. ! DO 320 J = M,NIV+1,-1 JP = J - 1 ! ! When operating near the ME line, test to see if the pivot ! element is near zero. If so, use the largest element above ! it as the pivot. This is to maintain the sharp interface ! between weighted and non-weighted rows in all cases. ! if (J == ME+1) THEN IMAX = ME AMAX = SCALE(ME)*W(ME,NSOLN)**2 DO 310 JP = J - 1,NIV,-1 T = SCALE(JP)*W(JP,NSOLN)**2 if (T > AMAX) THEN IMAX = JP AMAX = T ENDIF 310 CONTINUE JP = IMAX ENDIF ! if (W(J,NSOLN) /= 0.D0) THEN call DROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), & W(J,NSOLN), SPARAM) W(J,NSOLN) = 0.D0 call DROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, W(J,NSOLN+1), & MDW, SPARAM) ENDIF 320 CONTINUE ! ! Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if ! this is nonpositive or too large. If this was true or if the ! pivot term was zero, reject the column as dependent. ! if (W(NIV,NSOLN) /= 0.D0) THEN ISOL = NIV Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) Z(NSOLN) = Z2 POS = Z2 > 0.D0 if (Z2*EANORM >= BNORM .AND. POS) THEN POS = .NOT. (BLOWUP*Z2*EANORM >= BNORM) ENDIF ! ! Try to add row ME+1 as an additional equality constraint. ! Check size of proposed new solution component. ! Reject it if it is too large. ! ELSEIF (NIV <= ME .AND. W(ME+1,NSOLN) /= 0.D0) THEN ISOL = ME + 1 if (POS) THEN ! ! Swap rows ME+1 and NIV, and scale factors for these rows. ! call DSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) call DSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) ITEMP = ITYPE(ME+1) ITYPE(ME+1) = ITYPE(NIV) ITYPE(NIV) = ITEMP ME = ME + 1 ENDIF ELSE POS = .FALSE. ENDIF ! if (.NOT.POS) THEN NSOLN = NSOLN - 1 NIV = NIV - 1 ENDIF if (.NOT.(POS.OR.DONE)) go to 290 end if go to 160 ! ! Else perform multiplier test and drop a constraint. To compute ! final solution. Solve system, store results in X(*). ! ! Copy right hand side into TEMP vector to use overwriting method. ! 330 ISOL = 1 if (NSOLN >= ISOL) THEN call DCOPY (NIV, W(1,N+1), 1, TEMP, 1) DO 340 J = NSOLN,ISOL,-1 if (J > KRANK) THEN I = NIV - NSOLN + J ELSE I = J ENDIF ! if (J > KRANK .AND. J <= L) THEN Z(J) = 0.D0 ELSE Z(J) = TEMP(I)/W(I,J) call DAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) ENDIF 340 CONTINUE end if ! ! Solve system. ! call DCOPY (NSOLN, Z, 1, X, 1) ! ! Apply Householder transformations to X(*) if KRANK < L ! if (KRANK < L) THEN DO 350 I = 1,KRANK call DH12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) 350 CONTINUE end if ! ! Fill in trailing zeroes for constrained variables not in solution. ! if (NSOLN < N) call dinit ( N-NSOLN, 0.D0, X(NSOLN+1), 1) ! ! Permute solution vector to natural order. ! DO 380 I = 1,N J = I 360 if (IPIVOT(J) == I) go to 370 J = J + 1 go to 360 ! 370 IPIVOT(J) = IPIVOT(I) IPIVOT(I) = J call DSWAP (1, X(J), 1, X(I), 1) 380 CONTINUE ! ! Rescale the solution using the column scaling. ! DO 390 J = 1,N X(J) = X(J)*D(J) 390 CONTINUE ! DO 400 I = NSOLN+1,M T = W(I,N+1) if (I <= ME) T = T/ALAMDA T = (SCALE(I)*T)*T RNORM = RNORM + T 400 CONTINUE ! RNORM = SQRT(RNORM) return end subroutine DWNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, & SCALE, W) ! !! DWNLT1 is subsidiary to WNLIT. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (WNLT1-S, DWNLT1-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! To update the column Sum Of Squares and find the pivot column. ! The column Sum of Squares Vector will be updated at each step. ! When numerically necessary, these values will be recomputed. ! !***SEE ALSO DWNLIT !***ROUTINES CALLED IDAMAX !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890620 Code extracted from WNLIT and made a subroutine. (RWC)) ! 900604 DP version created from SP version. (RWC) !***END PROLOGUE DWNLT1 INTEGER I, IMAX, IR, LEND, MDW, MEND DOUBLE PRECISION H(*), HBAR, SCALE(*), W(MDW,*) LOGICAL RECALC ! EXTERNAL IDAMAX INTEGER IDAMAX ! INTEGER J, K ! !***FIRST EXECUTABLE STATEMENT DWNLT1 if (IR /= 1 .AND. (.NOT.RECALC)) THEN ! ! Update column SS=sum of squares. ! DO 10 J=I,LEND H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 10 CONTINUE ! ! Test for numerical accuracy. ! IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 RECALC = (HBAR+1.E-3*H(IMAX)) == HBAR end if ! ! If required, recalculate column SS, using rows IR through MEND. ! if (RECALC) THEN DO 30 J=I,LEND H(J) = 0.D0 DO 20 K=IR,MEND H(J) = H(J) + SCALE(K)*W(K,J)**2 20 CONTINUE 30 CONTINUE ! ! Find column with largest SS. ! IMAX = IDAMAX(LEND-I+1, H(I), 1) + I - 1 HBAR = H(IMAX) end if return end LOGICAL FUNCTION DWNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) ! !! DWNLT2 is subsidiary to WNLIT. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (WNLT2-S, DWNLT2-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! To test independence of incoming column. ! ! Test the column IC to determine if it is linearly independent ! of the columns already in the basis. In the initial tri. step, ! we usually want the heavy weight ALAMDA to be included in the ! test for independence. In this case, the value of FACTOR will ! have been set to 1.E0 before this procedure is invoked. ! In the potentially rank deficient problem, the value of FACTOR ! will have been set to ALSQ=ALAMDA**2 to remove the effect of the ! heavy weight from the test for independence. ! ! Write new column as partitioned vector ! (A1) number of components in solution so far = NIV ! (A2) M-NIV components ! And compute SN = inverse weighted length of A1 ! RN = inverse weighted length of A2 ! Call the column independent when RN > TAU*SN ! !***SEE ALSO DWNLIT !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890620 Code extracted from WNLIT and made a subroutine. (RWC)) ! 900604 DP version created from SP version. (RWC) !***END PROLOGUE DWNLT2 DOUBLE PRECISION FACTOR, SCALE(*), TAU, WIC(*) INTEGER IR, ME, MEND ! DOUBLE PRECISION RN, SN, T INTEGER J ! !***FIRST EXECUTABLE STATEMENT DWNLT2 SN = 0.E0 RN = 0.E0 DO 10 J=1,MEND T = SCALE(J) if (J <= ME) T = T/FACTOR T = T*WIC(J)**2 ! if (J < IR) THEN SN = SN + T ELSE RN = RN + T ENDIF 10 CONTINUE DWNLT2 = RN > SN*TAU**2 return end subroutine DWNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) ! !! DWNLT3 is subsidiary to WNLIT. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (WNLT3-S, DWNLT3-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! Perform column interchange. ! Exchange elements of permuted index vector and perform column ! interchanges. ! !***SEE ALSO DWNLIT !***ROUTINES CALLED DSWAP !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890620 Code extracted from WNLIT and made a subroutine. (RWC)) ! 900604 DP version created from SP version. (RWC) !***END PROLOGUE DWNLT3 INTEGER I, IMAX, IPIVOT(*), M, MDW DOUBLE PRECISION H(*), W(MDW,*) ! EXTERNAL DSWAP ! DOUBLE PRECISION T INTEGER ITEMP ! !***FIRST EXECUTABLE STATEMENT DWNLT3 if (IMAX /= I) THEN ITEMP = IPIVOT(I) IPIVOT(I) = IPIVOT(IMAX) IPIVOT(IMAX) = ITEMP ! call DSWAP(M, W(1,IMAX), 1, W(1,I), 1) ! T = H(IMAX) H(IMAX) = H(I) H(I) = T end if return end subroutine DWNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, & IWORK, WORK) ! !! DWNNLS solves a linearly constrained least squares problem with ... ! equality constraints and nonnegativity constraints on ! selected variables. ! !***LIBRARY SLATEC !***CATEGORY K1A2A !***TYPE DOUBLE PRECISION (WNNLS-S, DWNNLS-D) !***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, ! EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, ! NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! Abstract ! ! This subprogram solves a linearly constrained least squares ! problem. Suppose there are given matrices E and A of ! respective dimensions ME by N and MA by N, and vectors F ! and B of respective lengths ME and MA. This subroutine ! solves the problem ! ! EX = F, (equations to be exactly satisfied) ! ! AX = B, (equations to be approximately satisfied, ! in the least squares sense) ! ! subject to components L+1,...,N nonnegative ! ! Any values ME >= 0, MA >= 0 and 0 <= L <= N are permitted. ! ! The problem is reposed as problem DWNNLS ! ! (WT*E)X = (WT*F) ! ( A) ( B), (least squares) ! subject to components L+1,...,N nonnegative. ! ! The subprogram chooses the heavy weight (or penalty parameter) WT. ! ! The parameters for DWNNLS are ! ! INPUT.. All TYPE REAL variables are DOUBLE PRECISION ! ! W(*,*),MDW, The array W(*,*) is double subscripted with first ! ME,MA,N,L dimensioning parameter equal to MDW. For this ! discussion let us call M = ME + MA. Then MDW ! must satisfy MDW >= M. The condition MDW < M ! is an error. ! ! The array W(*,*) contains the matrices and vectors ! ! (E F) ! (A B) ! ! in rows and columns 1,...,M and 1,...,N+1 ! respectively. Columns 1,...,L correspond to ! unconstrained variables X(1),...,X(L). The ! remaining variables are constrained to be ! nonnegative. The condition L < 0 or L > N is ! an error. ! ! PRGOPT(*) This double precision array is the option vector. ! If the user is satisfied with the nominal ! subprogram features set ! ! PRGOPT(1)=1 (or PRGOPT(1)=1.0) ! ! Otherwise PRGOPT(*) is a linked list consisting of ! groups of data of the following form ! ! LINK ! KEY ! DATA SET ! ! The parameters LINK and KEY are each one word. ! The DATA SET can be comprised of several words. ! The number of items depends on the value of KEY. ! The value of LINK points to the first ! entry of the next group of data within ! PRGOPT(*). The exception is when there are ! no more options to change. In that ! case LINK=1 and the values KEY and DATA SET ! are not referenced. The general layout of ! PRGOPT(*) is as follows. ! ! ...PRGOPT(1)=LINK1 (link to first entry of next group) ! . PRGOPT(2)=KEY1 (key to the option change) ! . PRGOPT(3)=DATA VALUE (data value for this change) ! . . ! . . ! . . ! ...PRGOPT(LINK1)=LINK2 (link to the first entry of ! . next group) ! . PRGOPT(LINK1+1)=KEY2 (key to the option change) ! . PRGOPT(LINK1+2)=DATA VALUE ! ... . ! . . ! . . ! ...PRGOPT(LINK)=1 (no more options to change) ! ! Values of LINK that are nonpositive are errors. ! A value of LINK > NLINK=100000 is also an error. ! This helps prevent using invalid but positive ! values of LINK that will probably extend ! beyond the program limits of PRGOPT(*). ! Unrecognized values of KEY are ignored. The ! order of the options is arbitrary and any number ! of options can be changed with the following ! restriction. To prevent cycling in the ! processing of the option array a count of the ! number of options changed is maintained. ! Whenever this count exceeds NOPT=1000 an error ! message is printed and the subprogram returns. ! ! OPTIONS.. ! ! KEY=6 ! Scale the nonzero columns of the ! entire data matrix ! (E) ! (A) ! to have length one. The DATA SET for ! this option is a single value. It must ! be nonzero if unit length column scaling is ! desired. ! ! KEY=7 ! Scale columns of the entire data matrix ! (E) ! (A) ! with a user-provided diagonal matrix. ! The DATA SET for this option consists ! of the N diagonal scaling factors, one for ! each matrix column. ! ! KEY=8 ! Change the rank determination tolerance from ! the nominal value of SQRT(SRELPR). This quantity ! can be no smaller than SRELPR, The arithmetic- ! storage precision. The quantity used ! here is internally restricted to be at ! least SRELPR. The DATA SET for this option ! is the new tolerance. ! ! KEY=9 ! Change the blow-up parameter from the ! nominal value of SQRT(SRELPR). The reciprocal of ! this parameter is used in rejecting solution ! components as too large when a variable is ! first brought into the active set. Too large ! means that the proposed component times the ! reciprocal of the parameter is not less than ! the ratio of the norms of the right-side ! vector and the data matrix. ! This parameter can be no smaller than SRELPR, ! the arithmetic-storage precision. ! ! For example, suppose we want to provide ! a diagonal matrix to scale the problem ! matrix and change the tolerance used for ! determining linear dependence of dropped col ! vectors. For these options the dimensions of ! PRGOPT(*) must be at least N+6. The FORTRAN ! statements defining these options would ! be as follows. ! ! PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) ! PRGOPT(2)=7 (user-provided scaling key) ! ! call DCOPY(N,D,1,PRGOPT(3),1) (copy the N ! scaling factors from a user array called D(*) ! into PRGOPT(3)-PRGOPT(N+2)) ! ! PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) ! PRGOPT(N+4)=8 (linear dependence tolerance key) ! PRGOPT(N+5)=... (new value of the tolerance) ! ! PRGOPT(N+6)=1 (no more options to change) ! ! ! IWORK(1), The amounts of working storage actually allocated ! IWORK(2) for the working arrays WORK(*) and IWORK(*), ! respectively. These quantities are compared with ! the actual amounts of storage needed for DWNNLS( ). ! Insufficient storage allocated for either WORK(*) ! or IWORK(*) is considered an error. This feature ! was included in DWNNLS( ) because miscalculating ! the storage formulas for WORK(*) and IWORK(*) ! might very well lead to subtle and hard-to-find ! execution errors. ! ! The length of WORK(*) must be at least ! ! LW = ME+MA+5*N ! This test will not be made if IWORK(1) <= 0. ! ! The length of IWORK(*) must be at least ! ! LIW = ME+MA+N ! This test will not be made if IWORK(2) <= 0. ! ! OUTPUT.. All TYPE REAL variables are DOUBLE PRECISION ! ! X(*) An array dimensioned at least N, which will ! contain the N components of the solution vector ! on output. ! ! RNORM The residual norm of the solution. The value of ! RNORM contains the residual vector length of the ! equality constraints and least squares equations. ! ! MODE The value of MODE indicates the success or failure ! of the subprogram. ! ! MODE = 0 Subprogram completed successfully. ! ! = 1 Max. number of iterations (equal to ! 3*(N-L)) exceeded. Nearly all problems ! should complete in fewer than this ! number of iterations. An approximate ! solution and its corresponding residual ! vector length are in X(*) and RNORM. ! ! = 2 Usage error occurred. The offending ! condition is noted with the error ! processing subprogram, XERMSG( ). ! ! User-designated ! Working arrays.. ! ! WORK(*) A double precision working array of length at least ! M + 5*N. ! ! IWORK(*) An integer-valued working array of length at least ! M+N. ! !***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for ! linear least squares problems with equality and ! nonnegativity constraints, Report SAND77-0552, Sandia ! Laboratories, June 1978. ! K. H. Haskell and R. J. Hanson, Selected algorithms for ! the linearly constrained least squares problem - a ! users guide, Report SAND78-1290, Sandia Laboratories, ! August 1979. ! K. H. Haskell and R. J. Hanson, An algorithm for ! linear least squares problems with equality and ! nonnegativity constraints, Mathematical Programming ! 21 (1981), pp. 98-118. ! R. J. Hanson and K. H. Haskell, Two algorithms for the ! linearly constrained least squares problem, ACM ! Transactions on Mathematical Software, September 1982. ! C. L. Lawson and R. J. Hanson, Solving Least Squares ! Problems, Prentice-Hall, Inc., 1974. !***ROUTINES CALLED DWNLSM, XERMSG !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and revised. (WRB & RWC) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls, change Prologue ! comments to agree with WNNLS. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE DWNNLS INTEGER IWORK(*), L, L1, L2, L3, L4, L5, LIW, LW, MA, MDW, ME, & MODE, N DOUBLE PRECISION PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) CHARACTER*8 XERN1 !***FIRST EXECUTABLE STATEMENT DWNNLS MODE = 0 if (MA+ME <= 0 .OR. N <= 0) RETURN ! if (IWORK(1) > 0) THEN LW = ME + MA + 5*N if (IWORK(1) < LW) THEN WRITE (XERN1, '(I8)') LW call XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // & 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) MODE = 2 return ENDIF end if ! if (IWORK(2) > 0) THEN LIW = ME + MA + N if (IWORK(2) < LIW) THEN WRITE (XERN1, '(I8)') LIW call XERMSG ('SLATEC', 'DWNNLS', 'INSUFFICIENT STORAGE ' // & 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) MODE = 2 return ENDIF end if ! if (MDW < ME+MA) THEN call XERMSG ('SLATEC', 'DWNNLS', & 'THE VALUE MDW < ME+MA IS AN ERROR', 1, 1) MODE = 2 return end if ! if (L < 0 .OR. L > N) THEN call XERMSG ('SLATEC', 'DWNNLS', & 'L >= 0 .AND. L <= N IS REQUIRED', 2, 1) MODE = 2 return end if ! ! THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS ! WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS ! REQUIRED BY THE MAIN SUBROUTINE DWNLSM( ). ! L1 = N + 1 L2 = L1 + N L3 = L2 + ME + MA L4 = L3 + N L5 = L4 + N ! call DWNLSM(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 DWRITP (IPAGE, LIST, RLIST, LPAGE, IREC) ! !! DWRITP is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SWRITP-S, DWRITP-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! WRITE RECORD NUMBER IRECN, OF LENGTH LPG, FROM STORAGE ! ARRAY LIST(*) ONTO UNIT NUMBER IPAGEF. ! WRITE RECORD NUMBER IRECN+1, OF LENGTH LPG, ONTO UNIT ! NUMBER IPAGEF FROM THE STORAGE ARRAY RLIST(*). ! ! TO CHANGE THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE ! /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/. ! !***SEE ALSO DSPLP !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890605 Corrected references to XERRWV. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE DWRITP INTEGER LIST(*) DOUBLE PRECISION RLIST(*) CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT DWRITP IPAGEF=IPAGE LPG =LPAGE IRECN =IREC WRITE(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG) WRITE(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG) return ! 100 WRITE (XERN1, '(I8)') LPG WRITE (XERN2, '(I8)') IRECN call XERMSG ('SLATEC', 'DWRITP', 'IN DSPLP, LGP = ' // XERN1 // & ' IRECN = ' // XERN2, 100, 1) return end subroutine DWUPDT (N, R, LDR, W, B, ALPHA, COS, SIN) ! !! DWUPDT is subsidiary to DNLS1 and DNLS1E. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (RWUPDT-S, DWUPDT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an N by N upper triangular matrix R, this subroutine ! computes the QR decomposition of the matrix formed when a row ! is added to R. If the row is specified by the vector W, then ! DWUPDT determines an orthogonal matrix Q such that when the ! N+1 by N matrix composed of R augmented by W is premultiplied ! by (Q TRANSPOSE), the resulting matrix is upper trapezoidal. ! The orthogonal matrix Q is the product of N transformations ! ! G(1)*G(2)* ... *G(N) ! ! where G(I) is a Givens rotation in the (I,N+1) plane which ! eliminates elements in the I-th plane. DWUPDT also ! computes the product (Q TRANSPOSE)*C where C is the ! (N+1)-vector (b,alpha). Q itself is not accumulated, rather ! the information to recover the G rotations is supplied. ! ! The subroutine statement is ! ! SUBROUTINE DWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) ! ! where ! ! N is a positive integer input variable set to the order of R. ! ! R is an N by N array. On input the upper triangular part of ! R must contain the matrix to be updated. On output R ! contains the updated triangular matrix. ! ! LDR is a positive integer input variable not less than N ! which specifies the leading dimension of the array R. ! ! W is an input array of length N which must contain the row ! vector to be added to R. ! ! B is an array of length N. On input B must contain the ! first N elements of the vector C. On output B contains ! the first N elements of the vector (Q TRANSPOSE)*C. ! ! ALPHA is a variable. On input ALPHA must contain the ! (N+1)-st element of the vector C. On output ALPHA contains ! the (N+1)-st element of the vector (Q TRANSPOSE)*C. ! ! COS is an output array of length N which contains the ! cosines of the transforming Givens rotations. ! ! SIN is an output array of length N which contains the ! sines of the transforming Givens rotations. ! ! ********** ! !***SEE ALSO DNLS1, DNLS1E !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE DWUPDT INTEGER N,LDR DOUBLE PRECISION ALPHA DOUBLE PRECISION R(LDR,*),W(*),B(*),COS(*),SIN(*) INTEGER I,J,JM1 DOUBLE PRECISION COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO SAVE ONE, P5, P25, ZERO DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/ !***FIRST EXECUTABLE STATEMENT DWUPDT DO 60 J = 1, N ROWJ = W(J) JM1 = J - 1 ! ! APPLY THE PREVIOUS TRANSFORMATIONS TO ! R(I,J), I=1,2,...,J-1, AND TO W(J). ! if (JM1 < 1) go to 20 DO 10 I = 1, JM1 TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ R(I,J) = TEMP 10 CONTINUE 20 CONTINUE ! ! DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J). ! COS(J) = ONE SIN(J) = ZERO if (ROWJ == ZERO) go to 50 if (ABS(R(J,J)) >= ABS(ROWJ)) go to 30 COTAN = R(J,J)/ROWJ SIN(J) = P5/SQRT(P25+P25*COTAN**2) COS(J) = SIN(J)*COTAN go to 40 30 CONTINUE TAN = ROWJ/R(J,J) COS(J) = P5/SQRT(P25+P25*TAN**2) SIN(J) = COS(J)*TAN 40 CONTINUE ! ! APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA. ! R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ TEMP = COS(J)*B(J) + SIN(J)*ALPHA ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA B(J) = TEMP 50 CONTINUE 60 CONTINUE return ! ! LAST CARD OF SUBROUTINE DWUPDT. ! end subroutine DX4 (U, IDMN, I, J, UXXX, UXXXX) ! !! DX4 is subsidiary to SEPX4. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (DX4-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This program computes second order finite difference ! approximations to the third and fourth X ! partial derivatives of U at the (I,J) mesh point. ! !***SEE ALSO SEPX4 !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SPL4 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE DX4 ! COMMON /SPL4/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION U(IDMN,*) !***FIRST EXECUTABLE STATEMENT DX4 if (I > 2 .AND. I < (K-1)) go to 50 if (I == 1) go to 10 if (I == 2) go to 30 if (I == K-1) go to 60 if (I == K) go to 80 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A ! 10 if (KSWX == 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)- & 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)+ & 11.0*U(5,J)-2.0*U(6,J))/DLX4 return ! ! PERIODIC AT X=A ! 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 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A+DLX ! 30 if (KSWX == 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))/ & 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)- & U(6,J))/DLX4 return ! ! PERIODIC AT X=A+DLX ! 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 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR ! 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))/ & DLX4 return ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B-DLX ! 60 if (KSWX == 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)+ & 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)- & 9.0*U(K-1,J)+2.0*U(K,J))/DLX4 return ! ! PERIODIC AT X=B-DLX ! 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))/ & DLX4 return ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B ! 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)+ & 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)- & 14.0*U(K-1,J)+3.0*U(K,J))/DLX4 return end subroutine DXADD (X, IX, Y, IY, Z, IZ, IERROR) ! !! DXADD provides double-precision floating-point arithmetic ... ! with an extended exponent range. ! !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE DOUBLE PRECISION (XADD-S, DXADD-D) !***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! DOUBLE PRECISION X, Y, Z ! INTEGER IX, IY, IZ ! ! FORMS THE EXTENDED-RANGE SUM (Z,IZ) = ! (X,IX) + (Y,IY). (Z,IZ) IS ADJUSTED ! BEFORE RETURNING. THE INPUT OPERANDS ! NEED NOT BE IN ADJUSTED FORM, BUT THEIR ! PRINCIPAL PARTS MUST SATISFY ! RADIX**(-2L) <= ABS(X) <= RADIX**(2L), ! RADIX**(-2L) <= ABS(Y) <= RADIX**(2L). ! !***SEE ALSO DXSET !***REFERENCES (NONE) !***ROUTINES CALLED DXADJ !***COMMON BLOCKS DXBLK2 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXADD DOUBLE PRECISION X, Y, Z INTEGER IX, IY, IZ DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R INTEGER L, L2, KMAX COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX SAVE /DXBLK2/ DOUBLE PRECISION S, T ! ! THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE ! ARE ! (1) 1 < L <= 0.5D0*LOGR(0.5D0*DZERO) ! ! (2) NRADPL < L <= KMAX/6 ! ! (3) KMAX <= (2**NBITS - 4*L - 1)/2 ! ! THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING ! IN SUBROUTINE DXSET. ! !***FIRST EXECUTABLE STATEMENT DXADD IERROR=0 if (X /= 0.0D0) go to 10 Z = Y IZ = IY go to 220 10 if (Y /= 0.0D0) go to 20 Z = X IZ = IX go to 220 20 CONTINUE if (IX >= 0 .AND. IY >= 0) go to 40 if (IX < 0 .AND. IY < 0) go to 40 if (ABS(IX) <= 6*L .AND. ABS(IY) <= 6*L) go to 40 if (IX >= 0) go to 30 Z = Y IZ = IY go to 220 30 CONTINUE Z = X IZ = IX go to 220 40 I = IX - IY if (I) 80, 50, 90 50 if (ABS(X) > 1.0D0 .AND. ABS(Y) > 1.0D0) go to 60 if (ABS(X) < 1.0D0 .AND. ABS(Y) < 1.0D0) go to 70 Z = X + Y IZ = IX go to 220 60 S = X/RADIXL T = Y/RADIXL Z = S + T IZ = IX + L go to 220 70 S = X*RADIXL T = Y*RADIXL Z = S + T IZ = IX - L go to 220 80 S = Y IS = IY T = X go to 100 90 S = X IS = IX T = Y 100 CONTINUE ! ! AT THIS POINT, THE ONE OF (X,IX) OR (Y,IY) THAT HAS THE ! LARGER AUXILIARY INDEX IS STORED IN (S,IS). THE PRINCIPAL ! PART OF THE OTHER INPUT IS STORED IN T. ! I1 = ABS(I)/L I2 = MOD(ABS(I),L) if (ABS(T) >= RADIXL) go to 130 if (ABS(T) >= 1.0D0) go to 120 if (RADIXL*ABS(T) >= 1.0D0) go to 110 J = I1 + 1 T = T*RADIX**(L-I2) go to 140 110 J = I1 T = T*RADIX**(-I2) go to 140 120 J = I1 - 1 if (J < 0) go to 110 T = T*RADIX**(-I2)/RADIXL go to 140 130 J = I1 - 2 if (J < 0) go to 120 T = T*RADIX**(-I2)/RAD2L 140 CONTINUE ! ! AT THIS POINT, SOME OR ALL OF THE DIFFERENCE IN THE ! AUXILIARY INDICES HAS BEEN USED TO EFFECT A LEFT SHIFT ! OF T. THE SHIFTED VALUE OF T SATISFIES ! ! RADIX**(-2*L) <= ABS(T) <= 1.0D0 ! ! AND, if J=0, NO FURTHER SHIFTING REMAINS TO BE DONE. ! if (J == 0) go to 190 if (ABS(S) >= RADIXL .OR. J > 3) go to 150 if (ABS(S) >= 1.0D0) go to (180, 150, 150), J if (RADIXL*ABS(S) >= 1.0D0) go to (180, 170, 150), J go to (180, 170, 160), J 150 Z = S IZ = IS go to 220 160 S = S*RADIXL 170 S = S*RADIXL 180 S = S*RADIXL 190 CONTINUE ! ! AT THIS POINT, THE REMAINING DIFFERENCE IN THE ! AUXILIARY INDICES HAS BEEN USED TO EFFECT A RIGHT SHIFT ! OF S. if THE SHIFTED VALUE OF S WOULD HAVE EXCEEDED ! RADIX**L, THEN (S,IS) IS RETURNED AS THE VALUE OF THE ! SUM. ! if (ABS(S) > 1.0D0 .AND. ABS(T) > 1.0D0) go to 200 if (ABS(S) < 1.0D0 .AND. ABS(T) < 1.0D0) go to 210 Z = S + T IZ = IS - J*L go to 220 200 S = S/RADIXL T = T/RADIXL Z = S + T IZ = IS - J*L + L go to 220 210 S = S*RADIXL T = T*RADIXL Z = S + T IZ = IS - J*L - L 220 call DXADJ(Z, IZ,IERROR) return end subroutine DXADJ (X, IX, IERROR) ! !! DXADJ provides double-precision floating-point arithmetic ... ! with an extended exponent range. ! !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE DOUBLE PRECISION (XADJ-S, DXADJ-D) !***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! DOUBLE PRECISION X ! INTEGER IX ! ! TRANSFORMS (X,IX) SO THAT ! RADIX**(-L) <= ABS(X) < RADIX**L. ! ON MOST COMPUTERS THIS TRANSFORMATION DOES ! NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS ! THE NUMBER BASE OF DOUBLE-PRECISION ARITHMETIC. ! !***SEE ALSO DXSET !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***COMMON BLOCKS DXBLK2 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! CALLs to XERROR changed to CALLs to XERMSG. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXADJ DOUBLE PRECISION X INTEGER IX DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R INTEGER L, L2, KMAX COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX SAVE /DXBLK2/ ! ! THE CONDITION IMPOSED ON L AND KMAX BY THIS SUBROUTINE ! IS ! 2*L <= KMAX ! ! THIS CONDITION MUST BE MET BY APPROPRIATE CODING ! IN SUBROUTINE DXSET. ! !***FIRST EXECUTABLE STATEMENT DXADJ IERROR=0 if (X == 0.0D0) go to 50 if (ABS(X) >= 1.0D0) go to 20 if (RADIXL*ABS(X) >= 1.0D0) go to 60 X = X*RAD2L if (IX < 0) go to 10 IX = IX - L2 go to 70 10 if (IX < -KMAX+L2) go to 40 IX = IX - L2 go to 70 20 if (ABS(X) < RADIXL) go to 60 X = X/RAD2L if (IX > 0) go to 30 IX = IX + L2 go to 70 30 if (IX > KMAX-L2) go to 40 IX = IX + L2 go to 70 40 call XERMSG ('SLATEC', 'DXADJ', 'overflow in auxiliary index', & 207, 1) IERROR=207 return 50 IX = 0 60 if (ABS(IX) > KMAX) go to 40 70 RETURN end subroutine DXC210 (K, Z, J, IERROR) ! !! DXC210 provides double-precision floating-point arithmetic ... ! with an extended exponent range. ! !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE DOUBLE PRECISION (XC210-S, DXC210-D) !***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! INTEGER K, J ! DOUBLE PRECISION Z ! ! GIVEN K THIS SUBROUTINE COMPUTES J AND Z ! SUCH THAT RADIX**K = Z*10**J, WHERE Z IS IN ! THE RANGE 1/10 <= Z < 1. ! THE VALUE OF Z WILL BE ACCURATE TO FULL ! DOUBLE-PRECISION PROVIDED THE NUMBER ! OF DECIMAL PLACES IN THE LARGEST ! INTEGER PLUS THE NUMBER OF DECIMAL ! PLACES CARRIED IN DOUBLE-PRECISION DOES NOT ! EXCEED 60. DXC210 IS CALLED BY SUBROUTINE ! DXCON WHEN NECESSARY. THE USER SHOULD ! NEVER NEED TO call DXC210 DIRECTLY. ! !***SEE ALSO DXSET !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***COMMON BLOCKS DXBLK3 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! CALLs to XERROR changed to CALLs to XERMSG. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXC210 DOUBLE PRECISION Z INTEGER K, J INTEGER NLG102, MLG102, LG102 COMMON /DXBLK3/ NLG102, MLG102, LG102(21) SAVE /DXBLK3/ ! ! THE CONDITIONS IMPOSED ON NLG102, MLG102, AND LG102 BY ! THIS SUBROUTINE ARE ! ! (1) NLG102 >= 2 ! ! (2) MLG102 >= 1 ! ! (3) 2*MLG102*(MLG102 - 1) <= 2**NBITS - 1 ! ! THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING ! IN SUBROUTINE DXSET. ! !***FIRST EXECUTABLE STATEMENT DXC210 IERROR=0 if (K == 0) go to 70 M = MLG102 KA = ABS(K) KA1 = KA/M KA2 = MOD(KA,M) if (KA1 >= M) go to 60 NM1 = NLG102 - 1 NP1 = NLG102 + 1 IT = KA2*LG102(NP1) IC = IT/M ID = MOD(IT,M) Z = ID if (KA1 > 0) go to 20 DO 10 II=1,NM1 I = NP1 - II IT = KA2*LG102(I) + IC IC = IT/M ID = MOD(IT,M) Z = Z/M + ID 10 CONTINUE JA = KA*LG102(1) + IC go to 40 20 CONTINUE DO 30 II=1,NM1 I = NP1 - II IT = KA2*LG102(I) + KA1*LG102(I+1) + IC IC = IT/M ID = MOD(IT,M) Z = Z/M + ID 30 CONTINUE JA = KA*LG102(1) + KA1*LG102(2) + IC 40 CONTINUE Z = Z/M if (K > 0) go to 50 J = -JA Z = 10.0D0**(-Z) go to 80 50 CONTINUE J = JA + 1 Z = 10.0D0**(Z-1.0D0) go to 80 60 CONTINUE ! THIS ERROR OCCURS if K EXCEEDS MLG102**2 - 1 IN MAGNITUDE. ! call XERMSG ('SLATEC', 'DXC210', 'K too large', 208, 1) IERROR=208 return 70 CONTINUE J = 0 Z = 1.0D0 80 RETURN end subroutine DXCON (X, IX, IERROR) ! !! DXCON provides double-precision floating-point arithmetic ... ! with an extended exponent range. ! !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE DOUBLE PRECISION (XCON-S, DXCON-D) !***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! DOUBLE PRECISION X ! INTEGER IX ! ! CONVERTS (X,IX) = X*RADIX**IX ! TO DECIMAL FORM IN PREPARATION FOR ! PRINTING, SO THAT (X,IX) = X*10**IX ! WHERE 1/10 <= ABS(X) < 1 ! IS RETURNED, EXCEPT THAT IF ! (ABS(X),IX) IS BETWEEN RADIX**(-2L) ! AND RADIX**(2L) THEN THE REDUCED ! FORM WITH IX = 0 IS RETURNED. ! !***SEE ALSO DXSET !***REFERENCES (NONE) !***ROUTINES CALLED DXADJ, DXC210, DXRED !***COMMON BLOCKS DXBLK2 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXCON DOUBLE PRECISION X INTEGER IX ! ! THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE ! ARE ! (1) 4 <= L <= 2**NBITS - 1 - KMAX ! ! (2) KMAX <= ((2**NBITS)-2)/LOG10R - L ! ! THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING ! IN SUBROUTINE DXSET. ! DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R INTEGER L, L2, KMAX COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX SAVE /DXBLK2/, ISPACE ! DOUBLE PRECISION A, B, Z ! DATA ISPACE /1/ ! THE PARAMETER ISPACE IS THE INCREMENT USED IN FORM- ! ING THE AUXILIARY INDEX OF THE DECIMAL EXTENDED-RANGE ! FORM. THE RETURNED VALUE OF IX WILL BE AN INTEGER MULT- ! IPLE OF ISPACE. ISPACE MUST SATISFY 1 <= ISPACE <= ! L/2. if A VALUE GREATER THAN 1 IS TAKEN, THE RETURNED ! VALUE OF X WILL SATISFY 10**(-ISPACE) <= ABS(X) <= 1 ! WHEN (ABS(X),IX) < RADIX**(-2L), AND 1/10 <= ABS(X) ! < 10**(ISPACE-1) WHEN (ABS(X),IX) > RADIX**(2L). ! !***FIRST EXECUTABLE STATEMENT DXCON IERROR=0 call DXRED(X, IX,IERROR) if (IERROR /= 0) RETURN if (IX == 0) go to 150 call DXADJ(X, IX,IERROR) if (IERROR /= 0) RETURN ! ! CASE 1 IS WHEN (X,IX) IS LESS THAN RADIX**(-2L) IN MAGNITUDE, ! CASE 2 IS WHEN (X,IX) IS GREATER THAN RADIX**(2L) IN MAGNITUDE. ITEMP = 1 ICASE = (3+SIGN(ITEMP,IX))/2 go to (10, 20), ICASE 10 if (ABS(X) < 1.0D0) go to 30 X = X/RADIXL IX = IX + L go to 30 20 if (ABS(X) >= 1.0D0) go to 30 X = X*RADIXL IX = IX - L 30 CONTINUE ! ! AT THIS POINT, RADIX**(-L) <= ABS(X) < 1.0D0 IN CASE 1, ! 1.0D0 <= ABS(X) < RADIX**L IN CASE 2. I = LOG10(ABS(X))/DLG10R A = RADIX**I go to (40, 60), ICASE 40 if (A <= RADIX*ABS(X)) go to 50 I = I - 1 A = A/RADIX go to 40 50 if (ABS(X) < A) go to 80 I = I + 1 A = A*RADIX go to 50 60 if (A <= ABS(X)) go to 70 I = I - 1 A = A/RADIX go to 60 70 if (ABS(X) < RADIX*A) go to 80 I = I + 1 A = A*RADIX go to 70 80 CONTINUE ! ! AT THIS POINT I IS SUCH THAT ! RADIX**(I-1) <= ABS(X) < RADIX**I IN CASE 1, ! RADIX**I <= ABS(X) < RADIX**(I+1) IN CASE 2. ITEMP = ISPACE/DLG10R A = RADIX**ITEMP B = 10.0D0**ISPACE 90 if (A <= B) go to 100 ITEMP = ITEMP - 1 A = A/RADIX go to 90 100 if (B < A*RADIX) go to 110 ITEMP = ITEMP + 1 A = A*RADIX go to 100 110 CONTINUE ! ! AT THIS POINT ITEMP IS SUCH THAT ! RADIX**ITEMP <= 10**ISPACE < RADIX**(ITEMP+1). if (ITEMP > 0) go to 120 ! ITEMP = 0 IF, AND ONLY IF, ISPACE = 1 AND RADIX = 16.0D0 X = X*RADIX**(-I) IX = IX + I call DXC210(IX, Z, J,IERROR) if (IERROR /= 0) RETURN X = X*Z IX = J go to (130, 140), ICASE 120 CONTINUE I1 = I/ITEMP X = X*RADIX**(-I1*ITEMP) IX = IX + I1*ITEMP ! ! AT THIS POINT, ! RADIX**(-ITEMP) <= ABS(X) < 1.0D0 IN CASE 1, ! 1.0D0 <= ABS(X) < RADIX**ITEMP IN CASE 2. call DXC210(IX, Z, J,IERROR) if (IERROR /= 0) RETURN J1 = J/ISPACE J2 = J - J1*ISPACE X = X*Z*10.0D0**J2 IX = J1*ISPACE ! ! AT THIS POINT, ! 10.0D0**(-2*ISPACE) <= ABS(X) < 1.0D0 IN CASE 1, ! 10.0D0**-1 <= ABS(X) < 10.0D0**(2*ISPACE-1) IN CASE 2. go to (130, 140), ICASE 130 if (B*ABS(X) >= 1.0D0) go to 150 X = X*B IX = IX - ISPACE go to 130 140 if (10.0D0*ABS(X) < B) go to 150 X = X/B IX = IX + ISPACE go to 140 150 RETURN end subroutine DX (U, IDMN, I, J, UXXX, UXXXX) ! !! DX is subsidiary to SEPELI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (DX-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This program computes second order finite difference ! approximations to the third and fourth X ! partial derivatives of U at the (I,J) mesh point. ! !***SEE ALSO SEPELI !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SPLPCM !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE DX ! COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION U(IDMN,*) !***FIRST EXECUTABLE STATEMENT DX if (I > 2 .AND. I < (K-1)) go to 50 if (I == 1) go to 10 if (I == 2) go to 30 if (I == K-1) go to 60 if (I == K) go to 80 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A ! 10 if (KSWX == 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)- & 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)+ & 11.0*U(5,J)-2.0*U(6,J))/DLX4 return ! ! PERIODIC AT X=A ! 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 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A+DLX ! 30 if (KSWX == 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))/ & 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)- & U(6,J))/DLX4 return ! ! PERIODIC AT X=A+DLX ! 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 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR ! 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))/ & DLX4 return ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B-DLX ! 60 if (KSWX == 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)+ & 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)- & 9.0*U(K-1,J)+2.0*U(K,J))/DLX4 return ! ! PERIODIC AT X=B-DLX ! 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))/ & DLX4 return ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B ! 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)+ & 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)- & 14.0*U(K-1,J)+3.0*U(K,J))/DLX4 return end subroutine DXLCAL (N, LGMR, X, XL, ZL, HES, MAXLP1, Q, V, R0NRM, & WK, SZ, JSCAL, JPRE, MSOLVE, NMSL, RPAR, IPAR, NELT, IA, JA, A, & ISYM) ! !! DXLCAL is an internal routine for DGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SXLCAL-S, DXLCAL-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine computes the solution XL, the current DGMRES ! iterate, given the V(I)'s and the QR factorization of the ! Hessenberg matrix HES. This routine is only called when ! ITOL=11. ! ! *Usage: ! INTEGER N, LGMR, MAXLP1, JSCAL, JPRE, NMSL, IPAR(USER DEFINED) ! INTEGER NELT, IA(NELT), JA(NELT), ISYM ! DOUBLE PRECISION X(N), XL(N), ZL(N), HES(MAXLP1,MAXL), Q(2*MAXL), ! $ V(N,MAXLP1), R0NRM, WK(N), SZ(N), ! $ RPAR(USER DEFINED), A(NELT) ! EXTERNAL MSOLVE ! ! call DXLCAL(N, LGMR, X, XL, ZL, HES, MAXLP1, Q, V, R0NRM, ! $ WK, SZ, JSCAL, JPRE, MSOLVE, NMSL, RPAR, IPAR, ! $ NELT, IA, JA, A, ISYM) ! ! *Arguments: ! N :IN Integer ! The order of the matrix A, and the lengths ! of the vectors SR, SZ, R0 and Z. ! LGMR :IN Integer ! The number of iterations performed and ! the current order of the upper Hessenberg ! matrix HES. ! X :IN Double Precision X(N) ! The current approximate solution as of the last restart. ! XL :OUT Double Precision XL(N) ! An array of length N used to hold the approximate ! solution X(L). ! Warning: XL and ZL are the same array in the calling routine. ! ZL :IN Double Precision ZL(N) ! An array of length N used to hold the approximate ! solution Z(L). ! HES :IN Double Precision HES(MAXLP1,MAXL) ! The upper triangular factor of the QR decomposition ! of the (LGMR+1) by LGMR upper Hessenberg matrix whose ! entries are the scaled inner-products of A*V(*,i) and V(*,k). ! MAXLP1 :IN Integer ! MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. ! MAXL is the maximum allowable order of the matrix HES. ! Q :IN Double Precision Q(2*MAXL) ! A double precision array of length 2*MAXL containing the ! components of the Givens rotations used in the QR ! decomposition of HES. It is loaded in DHEQR. ! V :IN Double Precision V(N,MAXLP1) ! The N by(LGMR+1) array containing the LGMR ! orthogonal vectors V(*,1) to V(*,LGMR). ! R0NRM :IN Double Precision ! The scaled norm of the initial residual for the ! current call to DPIGMR. ! WK :IN Double Precision WK(N) ! A double precision work array of length N. ! SZ :IN Double Precision SZ(N) ! A vector of length N containing the non-zero ! elements of the diagonal scaling matrix for Z. ! JSCAL :IN Integer ! A flag indicating whether arrays SR and SZ are used. ! JSCAL=0 means SR and SZ are not used and the ! algorithm will perform as if all ! SR(i) = 1 and SZ(i) = 1. ! JSCAL=1 means only SZ is used, and the algorithm ! performs as if all SR(i) = 1. ! JSCAL=2 means only SR is used, and the algorithm ! performs as if all SZ(i) = 1. ! JSCAL=3 means both SR and SZ are used. ! JPRE :IN Integer ! The preconditioner type flag. ! MSOLVE :EXT External. ! Name of the routine which solves a linear system Mz = r for ! z given r with the preconditioning matrix M (M is supplied via ! RPAR and IPAR arrays. The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as below. RPAR is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IPAR is an integer work array ! for the same purpose as RPAR. ! NMSL :IN Integer ! The number of calls to MSOLVE. ! RPAR :IN Double Precision RPAR(USER DEFINED) ! Double Precision workspace passed directly to the MSOLVE ! routine. ! IPAR :IN Integer IPAR(USER DEFINED) ! Integer workspace passed directly to the MSOLVE routine. ! NELT :IN Integer ! The length of arrays IA, JA and A. ! IA :IN Integer IA(NELT) ! An integer array of length NELT containing matrix data. ! It is passed directly to the MATVEC and MSOLVE routines. ! JA :IN Integer JA(NELT) ! An integer array of length NELT containing matrix data. ! It is passed directly to the MATVEC and MSOLVE routines. ! A :IN Double Precision A(NELT) ! A double precision array of length NELT containing matrix ! data. ! It is passed directly to the MATVEC and MSOLVE routines. ! ISYM :IN Integer ! A flag to indicate symmetric matrix storage. ! If ISYM=0, all non-zero entries of the matrix are ! stored. If ISYM=1, the matrix is symmetric and ! only the upper or lower triangular part is stored. ! !***SEE ALSO DGMRES !***ROUTINES CALLED DAXPY, DCOPY, DHELS !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to DGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE DXLCAL ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. DOUBLE PRECISION R0NRM INTEGER ISYM, JPRE, JSCAL, LGMR, MAXLP1, N, NELT, NMSL ! .. Array Arguments .. DOUBLE PRECISION A(NELT), HES(MAXLP1,*), Q(*), RPAR(*), SZ(*), & V(N,*), WK(N), X(N), XL(N), ZL(N) INTEGER IA(NELT), IPAR(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Local Scalars .. INTEGER I, K, LL, LLP1 ! .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DHELS !***FIRST EXECUTABLE STATEMENT DXLCAL LL = LGMR LLP1 = LL + 1 DO 10 K = 1,LLP1 WK(K) = 0 10 CONTINUE WK(1) = R0NRM call DHELS(HES, MAXLP1, LL, Q, WK) DO 20 K = 1,N ZL(K) = 0 20 CONTINUE DO 30 I = 1,LL call DAXPY(N, WK(I), V(1,I), 1, ZL, 1) 30 CONTINUE if ((JSCAL == 1) .OR.(JSCAL == 3)) THEN DO 40 K = 1,N ZL(K) = ZL(K)/SZ(K) 40 CONTINUE end if if (JPRE > 0) THEN call DCOPY(N, ZL, 1, WK, 1) call MSOLVE(N, WK, ZL, NELT, IA, JA, A, ISYM, RPAR, IPAR) NMSL = NMSL + 1 end if ! calculate XL from X and ZL. DO 50 K = 1,N XL(K) = X(K) + ZL(K) 50 CONTINUE return !------------- LAST LINE OF DXLCAL FOLLOWS ---------------------------- end subroutine DXLEGF (DNU1, NUDIFF, MU1, MU2, THETA, ID, PQA, IPQA, & IERROR) ! !! DXLEGF computes normalized Legendre polynomials and associated Legendre ... ! functions. ! !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE DOUBLE PRECISION (XLEGF-S, DXLEGF-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! ! DXLEGF: Extended-range Double-precision Legendre Functions ! ! A feature of the DXLEGF subroutine for Legendre functions is ! the use of extended-range arithmetic, a software extension of ! ordinary floating-point arithmetic that greatly increases the ! exponent range of the representable numbers. This avoids the ! need for scaling the solutions to lie within the exponent range ! of the most restrictive manufacturer's hardware. The increased ! exponent range is achieved by allocating an integer storage ! location together with each floating-point storage location. ! ! The interpretation of the pair (X,I) where X is floating-point ! and I is integer is X*(IR**I) where IR is the internal radix of ! the computer arithmetic. ! ! This subroutine computes one of the following vectors: ! ! 1. Legendre function of the first kind of negative order, either ! a. P(-MU1,NU,X), P(-MU1-1,NU,X), ..., P(-MU2,NU,X) or ! b. P(-MU,NU1,X), P(-MU,NU1+1,X), ..., P(-MU,NU2,X) ! 2. Legendre function of the second kind, either ! a. Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X) or ! b. Q(MU,NU1,X), Q(MU,NU1+1,X), ..., Q(MU,NU2,X) ! 3. Legendre function of the first kind of positive order, either ! a. P(MU1,NU,X), P(MU1+1,NU,X), ..., P(MU2,NU,X) or ! b. P(MU,NU1,X), P(MU,NU1+1,X), ..., P(MU,NU2,X) ! 4. Normalized Legendre polynomials, either ! a. PN(MU1,NU,X), PN(MU1+1,NU,X), ..., PN(MU2,NU,X) or ! b. PN(MU,NU1,X), PN(MU,NU1+1,X), ..., PN(MU,NU2,X) ! ! where X = COS(THETA). ! ! The input values to DXLEGF are DNU1, NUDIFF, MU1, MU2, THETA, ! and ID. These must satisfy ! ! DNU1 is DOUBLE PRECISION and greater than or equal to -0.5; ! NUDIFF is INTEGER and non-negative; ! MU1 is INTEGER and non-negative; ! MU2 is INTEGER and greater than or equal to MU1; ! THETA is DOUBLE PRECISION and in the half-open interval (0,PI/2]; ! ID is INTEGER and equal to 1, 2, 3 or 4; ! ! and additionally either NUDIFF = 0 or MU2 = MU1. ! ! If ID=1 and NUDIFF=0, a vector of type 1a above is computed ! with NU=DNU1. ! ! If ID=1 and MU1=MU2, a vector of type 1b above is computed ! with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. ! ! If ID=2 and NUDIFF=0, a vector of type 2a above is computed ! with NU=DNU1. ! ! If ID=2 and MU1=MU2, a vector of type 2b above is computed ! with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. ! ! If ID=3 and NUDIFF=0, a vector of type 3a above is computed ! with NU=DNU1. ! ! If ID=3 and MU1=MU2, a vector of type 3b above is computed ! with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. ! ! If ID=4 and NUDIFF=0, a vector of type 4a above is computed ! with NU=DNU1. ! ! If ID=4 and MU1=MU2, a vector of type 4b above is computed ! with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. ! ! In each case the vector of computed Legendre function values ! is returned in the extended-range vector (PQA(I),IPQA(I)). The ! length of this vector is either MU2-MU1+1 or NUDIFF+1. ! ! Where possible, DXLEGF returns IPQA(I) as zero. In this case the ! value of the Legendre function is contained entirely in PQA(I), ! so it can be used in subsequent computations without further ! consideration of extended-range arithmetic. If IPQA(I) is nonzero, ! then the value of the Legendre function is not representable in ! floating-point because of underflow or overflow. The program that ! calls DXLEGF must test IPQA(I) to ensure correct usage. ! ! IERROR is an error indicator. If no errors are detected, IERROR=0 ! when control returns to the calling routine. If an error is detected, ! IERROR is returned as nonzero. The calling routine must check the ! value of IERROR. ! ! If IERROR=210 or 211, invalid input was provided to DXLEGF. ! If IERROR=201,202,203, or 204, invalid input was provided to DXSET. ! If IERROR=205 or 206, an internal consistency error occurred in ! DXSET (probably due to a software malfunction in the library routine ! I1MACH). ! If IERROR=207, an overflow or underflow of an extended-range number ! was detected in DXADJ. ! If IERROR=208, an overflow or underflow of an extended-range number ! was detected in DXC210. ! !***SEE ALSO DXSET !***REFERENCES Olver and Smith, Associated Legendre Functions on the ! Cut, J Comp Phys, v 51, n 3, Sept 1983, pp 502--518. ! Smith, Olver and Lozier, Extended-Range Arithmetic and ! Normalized Legendre Polynomials, ACM Trans on Math ! Softw, v 7, n 1, March 1981, pp 93--105. !***ROUTINES CALLED DXPMU, DXPMUP, DXPNRM, DXPQNU, DXQMU, DXQNU, DXRED, ! DXSET, XERMSG !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! CALLs to XERROR changed to CALLs to XERMSG. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXLEGF DOUBLE PRECISION PQA,DNU1,DNU2,SX,THETA,X,PI2 DIMENSION PQA(*),IPQA(*) ! !***FIRST EXECUTABLE STATEMENT DXLEGF IERROR=0 call DXSET (0, 0, 0.0D0, 0,IERROR) if (IERROR /= 0) RETURN PI2=2.D0*ATAN(1.D0) ! ! ZERO OUTPUT ARRAYS ! L=(MU2-MU1)+NUDIFF+1 DO 290 I=1,L PQA(I)=0.D0 290 IPQA(I)=0 ! ! CHECK FOR VALID INPUT VALUES ! if ( NUDIFF < 0) go to 400 if ( DNU1 < -.5D0) go to 400 if ( MU2 < MU1) go to 400 if ( MU1 < 0) go to 400 if ( THETA <= 0.D0.OR.THETA > PI2) go to 420 if ( ID < 1.OR.ID > 4) go to 400 if ( (MU1 /= MU2).AND.(NUDIFF > 0)) go to 400 ! ! if DNU1 IS NOT AN INTEGER, NORMALIZED P(MU,DNU,X) ! CANNOT BE CALCULATED. if DNU1 IS AN INTEGER AND ! MU1 > DNU2 THEN ALL VALUES OF P(+MU,DNU,X) AND ! NORMALIZED P(MU,NU,X) WILL BE ZERO. ! DNU2=DNU1+NUDIFF if ( (ID == 3).AND.(MOD(DNU1,1.D0) /= 0.D0)) go to 295 if ( (ID == 4).AND.(MOD(DNU1,1.D0) /= 0.D0)) go to 400 if ( (ID == 3.OR.ID == 4).AND.MU1 > DNU2) RETURN 295 CONTINUE ! X=COS(THETA) SX=1.D0/SIN(THETA) if ( ID == 2) go to 300 if ( MU2-MU1 <= 0) go to 360 ! ! FIXED NU, VARIABLE MU ! call DXPMU TO CALCULATE P(-MU1,NU,X),....,P(-MU2,NU,X) ! call DXPMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN go to 380 ! 300 if ( MU2 == MU1) go to 320 ! ! FIXED NU, VARIABLE MU ! call DXQMU TO CALCULATE Q(MU1,NU,X),....,Q(MU2,NU,X) ! call DXQMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN go to 390 ! ! FIXED MU, VARIABLE NU ! call DXQNU TO CALCULATE Q(MU,DNU1,X),....,Q(MU,DNU2,X) ! 320 call DXQNU(DNU1,DNU2,MU1,THETA,X,SX,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN go to 390 ! ! FIXED MU, VARIABLE NU ! call DXPQNU TO CALCULATE P(-MU,DNU1,X),....,P(-MU,DNU2,X) ! 360 call DXPQNU(DNU1,DNU2,MU1,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN ! ! if ID = 3, TRANSFORM P(-MU,NU,X) VECTOR INTO ! P(MU,NU,X) VECTOR. ! 380 if ( ID == 3) call DXPMUP(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN ! ! if ID = 4, TRANSFORM P(-MU,NU,X) VECTOR INTO ! NORMALIZED P(MU,NU,X) VECTOR. ! if ( ID == 4) call DXPNRM(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN ! ! PLACE RESULTS IN REDUCED FORM if POSSIBLE ! AND RETURN TO MAIN PROGRAM. ! 390 DO 395 I=1,L call DXRED(PQA(I),IPQA(I),IERROR) if (IERROR /= 0) RETURN 395 CONTINUE return ! ! ***** ERROR TERMINATION ***** ! 400 call XERMSG ('SLATEC', 'DXLEGF', & 'DNU1, NUDIFF, MU1, MU2, or ID not valid', 210, 1) IERROR=210 return 420 call XERMSG ('SLATEC', 'DXLEGF', 'THETA out of range', 211, 1) IERROR=211 return end subroutine DXNRMP (NU, MU1, MU2, DARG, MODE, DPN, IPN, ISIG, & IERROR) ! !! DXNRMP computes normalized Legendre polynomials. ! !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE DOUBLE PRECISION (XNRMP-S, DXNRMP-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! ! SUBROUTINE TO CALCULATE NORMALIZED LEGENDRE POLYNOMIALS ! (XNRMP is single-precision version) ! DXNRMP calculates normalized Legendre polynomials of varying ! order and fixed argument and degree. The order MU and degree ! NU are non-negative integers and the argument is real. Because ! the algorithm requires the use of numbers outside the normal ! machine range, this subroutine employs a special arithmetic ! called extended-range arithmetic. See J.M. Smith, F.W.J. Olver, ! and D.W. Lozier, Extended-Range Arithmetic and Normalized ! Legendre Polynomials, ACM Transactions on Mathematical Soft- ! ware, 93-105, March 1981, for a complete description of the ! algorithm and special arithmetic. Also see program comments ! in DXSET. ! ! The normalized Legendre polynomials are multiples of the ! associated Legendre polynomials of the first kind where the ! normalizing coefficients are chosen so as to make the integral ! from -1 to 1 of the square of each function equal to 1. See ! E. Jahnke, F. Emde and F. Losch, Tables of Higher Functions, ! McGraw-Hill, New York, 1960, p. 121. ! ! The input values to DXNRMP are NU, MU1, MU2, DARG, and MODE. ! These must satisfy ! 1. NU >= 0 specifies the degree of the normalized Legendre ! polynomial that is wanted. ! 2. MU1 >= 0 specifies the lowest-order normalized Legendre ! polynomial that is wanted. ! 3. MU2 >= MU1 specifies the highest-order normalized Leg- ! endre polynomial that is wanted. ! 4a. MODE = 1 and -1.0D0 <= DARG <= 1.0D0 specifies that ! Normalized Legendre(NU, MU, DARG) is wanted for MU = MU1, ! MU1 + 1, ..., MU2. ! 4b. MODE = 2 and -3.14159... < DARG < 3.14159... spec- ! ifies that Normalized Legendre(NU, MU, COS(DARG)) is ! wanted for MU = MU1, MU1 + 1, ..., MU2. ! ! The output of DXNRMP consists of the two vectors DPN and IPN ! and the error estimate ISIG. The computed values are stored as ! extended-range numbers such that ! (DPN(1),IPN(1))=NORMALIZED LEGENDRE(NU,MU1,DX) ! (DPN(2),IPN(2))=NORMALIZED LEGENDRE(NU,MU1+1,DX) ! . ! . ! (DPN(K),IPN(K))=NORMALIZED LEGENDRE(NU,MU2,DX) ! where K = MU2 - MU1 + 1 and DX = DARG or COS(DARG) according ! to whether MODE = 1 or 2. Finally, ISIG is an estimate of the ! number of decimal digits lost through rounding errors in the ! computation. For example if DARG is accurate to 12 significant ! decimals, then the computed function values are accurate to ! 12 - ISIG significant decimals (except in neighborhoods of ! zeros). ! ! The interpretation of (DPN(I),IPN(I)) is DPN(I)*(IR**IPN(I)) ! where IR is the internal radix of the computer arithmetic. When ! IPN(I) = 0 the value of the normalized Legendre polynomial is ! contained entirely in DPN(I) and subsequent double-precision ! computations can be performed without further consideration of ! extended-range arithmetic. However, if IPN(I) /= 0 the corre- ! sponding value of the normalized Legendre polynomial cannot be ! represented in double-precision because of overflow or under- ! flow. THE USER MUST TEST IPN(I) IN HIS/HER PROGRAM. In the case ! that IPN(I) is nonzero, the user could rewrite his/her program ! to use extended range arithmetic. ! ! ! ! The interpretation of (DPN(I),IPN(I)) can be changed to ! DPN(I)*(10**IPN(I)) by calling the extended-range subroutine ! DXCON. This should be done before printing the computed values. ! As an example of usage, the Fortran coding ! J = K ! DO 20 I = 1, K ! call DXCON(DPN(I), IPN(I),IERROR) ! if (IERROR /= 0) RETURN ! PRINT 10, DPN(I), IPN(I) ! 10 FORMAT(1X, D30.18 , I15) ! if ((IPN(I) == 0) .OR. (J < K)) go to 20 ! J = I - 1 ! 20 CONTINUE ! will print all computed values and determine the largest J ! such that IPN(1) = IPN(2) = ... = IPN(J) = 0. Because of the ! change of representation caused by calling DXCON, (DPN(I), ! IPN(I)) for I = J+1, J+2, ... cannot be used in subsequent ! extended-range computations. ! ! IERROR is an error indicator. If no errors are detected, ! IERROR=0 when control returns to the calling routine. If ! an error is detected, IERROR is returned as nonzero. The ! calling routine must check the value of IERROR. ! ! If IERROR=212 or 213, invalid input was provided to DXNRMP. ! If IERROR=201,202,203, or 204, invalid input was provided ! to DXSET. ! If IERROR=205 or 206, an internal consistency error occurred ! in DXSET (probably due to a software malfunction in the ! library routine I1MACH). ! If IERROR=207, an overflow or underflow of an extended-range ! number was detected in DXADJ. ! If IERROR=208, an overflow or underflow of an extended-range ! number was detected in DXC210. ! !***SEE ALSO DXSET !***REFERENCES Smith, Olver and Lozier, Extended-Range Arithmetic and ! Normalized Legendre Polynomials, ACM Trans on Math ! Softw, v 7, n 1, March 1981, pp 93--105. !***ROUTINES CALLED DXADD, DXADJ, DXRED, DXSET, XERMSG !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! CALLs to XERROR changed to CALLs to XERMSG. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXNRMP INTEGER NU, MU1, MU2, MODE, IPN, ISIG DOUBLE PRECISION DARG, DPN DIMENSION DPN(*), IPN(*) DOUBLE PRECISION C1,C2,P,P1,P2,P3,S,SX,T,TX,X,DK ! call DXSET TO INITIALIZE EXTENDED-RANGE ARITHMETIC (SEE DXSET ! LISTING FOR DETAILS) !***FIRST EXECUTABLE STATEMENT DXNRMP IERROR=0 call DXSET (0, 0, 0.0D0, 0,IERROR) if (IERROR /= 0) RETURN ! ! TEST FOR PROPER INPUT VALUES. ! if (NU < 0) go to 110 if (MU1 < 0) go to 110 if (MU1 > MU2) go to 110 if (NU == 0) go to 90 if (MODE < 1 .OR. MODE > 2) go to 110 go to (10, 20), MODE 10 if (ABS(DARG) > 1.0D0) go to 120 if (ABS(DARG) == 1.0D0) go to 90 X = DARG SX = SQRT((1.0D0+ABS(X))*((0.5D0-ABS(X))+0.5D0)) TX = X/SX ISIG = LOG10(2.0D0*NU*(5.0D0+TX**2)) go to 30 20 if (ABS(DARG) > 4.0D0*ATAN(1.0D0)) go to 120 if (DARG == 0.0D0) go to 90 X = COS(DARG) SX = ABS(SIN(DARG)) TX = X/SX ISIG = LOG10(2.0D0*NU*(5.0D0+ABS(DARG*TX))) ! ! BEGIN CALCULATION ! 30 MU = MU2 I = MU2 - MU1 + 1 ! ! if MU > NU, NORMALIZED LEGENDRE(NU,MU,X)=0. ! 40 if (MU <= NU) go to 50 DPN(I) = 0.0D0 IPN(I) = 0 I = I - 1 MU = MU - 1 if (I > 0) go to 40 ISIG = 0 go to 160 50 MU = NU ! ! P1 = 0. = NORMALIZED LEGENDRE(NU,NU+1,X) ! P1 = 0.0D0 IP1 = 0 ! ! CALCULATE P2 = NORMALIZED LEGENDRE(NU,NU,X) ! P2 = 1.0D0 IP2 = 0 P3 = 0.5D0 DK = 2.0D0 DO 60 J=1,NU P3 = ((DK+1.0D0)/DK)*P3 P2 = P2*SX call DXADJ(P2, IP2,IERROR) if (IERROR /= 0) RETURN DK = DK + 2.0D0 60 CONTINUE P2 = P2*SQRT(P3) call DXADJ(P2, IP2,IERROR) if (IERROR /= 0) RETURN S = 2.0D0*TX T = 1.0D0/NU if (MU2 < NU) go to 70 DPN(I) = P2 IPN(I) = IP2 I = I - 1 if (I == 0) go to 140 ! ! RECURRENCE PROCESS ! 70 P = MU*T C1 = 1.0D0/SQRT((1.0D0-P+T)*(1.0D0+P)) C2 = S*P*C1*P2 C1 = -SQRT((1.0D0+P+T)*(1.0D0-P))*C1*P1 call DXADD(C2, IP2, C1, IP1, P, IP,IERROR) if (IERROR /= 0) RETURN MU = MU - 1 if (MU > MU2) go to 80 ! ! STORE IN ARRAY DPN FOR RETURN TO CALLING ROUTINE. ! DPN(I) = P IPN(I) = IP I = I - 1 if (I == 0) go to 140 80 P1 = P2 IP1 = IP2 P2 = P IP2 = IP if (MU <= MU1) go to 140 go to 70 ! ! SPECIAL CASE WHEN X=-1 OR +1, OR NU=0. ! 90 K = MU2 - MU1 + 1 DO 100 I=1,K DPN(I) = 0.0D0 IPN(I) = 0 100 CONTINUE ISIG = 0 if (MU1 > 0) go to 160 ISIG = 1 DPN(1) = SQRT(NU+0.5D0) IPN(1) = 0 if (MOD(NU,2) == 0) go to 160 if (MODE == 1 .AND. DARG == 1.0D0) go to 160 if (MODE == 2) go to 160 DPN(1) = -DPN(1) go to 160 ! ! ERROR PRINTOUTS AND TERMINATION. ! 110 call XERMSG ('SLATEC', 'DXNRMP', 'NU, MU1, MU2 or MODE not valid', & 212, 1) IERROR=212 return 120 call XERMSG ('SLATEC', 'DXNRMP', 'DARG out of range', 213, 1) IERROR=213 return ! ! return TO CALLING PROGRAM ! 140 K = MU2 - MU1 + 1 DO 150 I=1,K call DXRED(DPN(I),IPN(I),IERROR) if (IERROR /= 0) RETURN 150 CONTINUE 160 RETURN end subroutine DXPMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA, & IERROR) ! !! DXPMU computes the values of Legendre functions for DXLEGF. ... ! ! Method: backward mu-wise recurrence for P(-MU,NU,X) for ! fixed nu to obtain P(-MU2,NU1,X), P(-(MU2-1),NU1,X), ..., ! P(-MU1,NU1,X) and store in ascending mu order. !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE DOUBLE PRECISION (XPMU-S, DXPMU-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED DXADD, DXADJ, DXPQNU !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXPMU DOUBLE PRECISION PQA,NU1,NU2,P0,X,SX,THETA,X1,X2 DIMENSION PQA(*),IPQA(*) ! ! call DXPQNU TO OBTAIN P(-MU2,NU,X) ! !***FIRST EXECUTABLE STATEMENT DXPMU IERROR=0 call DXPQNU(NU1,NU2,MU2,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN P0=PQA(1) IP0=IPQA(1) MU=MU2-1 ! ! call DXPQNU TO OBTAIN P(-MU2-1,NU,X) ! call DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN N=MU2-MU1+1 PQA(N)=P0 IPQA(N)=IP0 if ( N == 1) go to 300 PQA(N-1)=PQA(1) IPQA(N-1)=IPQA(1) if ( N == 2) go to 300 J=N-2 290 CONTINUE ! ! BACKWARD RECURRENCE IN MU TO OBTAIN ! P(-MU2,NU1,X),P(-(MU2-1),NU1,X),....P(-MU1,NU1,X) ! USING ! (NU-MU)*(NU+MU+1.)*P(-(MU+1),NU,X)= ! 2.*MU*X*SQRT((1./(1.-X**2))*P(-MU,NU,X)-P(-(MU-1),NU,X) ! X1=2.D0*MU*X*SX*PQA(J+1) X2=-(NU1-MU)*(NU1+MU+1.D0)*PQA(J+2) call DXADD(X1,IPQA(J+1),X2,IPQA(J+2),PQA(J),IPQA(J),IERROR) if (IERROR /= 0) RETURN call DXADJ(PQA(J),IPQA(J),IERROR) if (IERROR /= 0) RETURN if ( J == 1) go to 300 J=J-1 MU=MU-1 go to 290 300 RETURN end subroutine DXPMUP (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR) ! !! DXPMUP computes the values of Legendre functions for DXLEGF. ... ! ! This subroutine transforms an array of Legendre functions ! of the first kind of negative order stored in array PQA ! into Legendre functions of the first kind of positive ! order stored in array PQA. The original array is destroyed. !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE DOUBLE PRECISION (XPMUP-S, DXPMUP-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED DXADJ !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXPMUP DOUBLE PRECISION DMU,NU,NU1,NU2,PQA,PROD DIMENSION PQA(*),IPQA(*) !***FIRST EXECUTABLE STATEMENT DXPMUP IERROR=0 NU=NU1 MU=MU1 DMU=MU N=INT(NU2-NU1+.1D0)+(MU2-MU1)+1 J=1 if ( MOD(REAL(NU),1.) /= 0.) go to 210 200 if ( DMU < NU+1.D0) go to 210 PQA(J)=0.D0 IPQA(J)=0 J=J+1 if ( J > N) RETURN ! INCREMENT EITHER MU OR NU AS APPROPRIATE. if ( NU2-NU1 > .5D0) NU=NU+1.D0 if ( MU2 > MU1) MU=MU+1 go to 200 ! ! TRANSFORM P(-MU,NU,X) TO P(MU,NU,X) USING ! P(MU,NU,X)=(NU-MU+1)*(NU-MU+2)*...*(NU+MU)*P(-MU,NU,X)*(-1)**MU ! 210 PROD=1.D0 IPROD=0 K=2*MU if ( K == 0) go to 222 DO 220 L=1,K PROD=PROD*(DMU-NU-L) 220 call DXADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN 222 CONTINUE DO 240 I=J,N if ( MU == 0) go to 225 PQA(I)=PQA(I)*PROD*(-1)**MU IPQA(I)=IPQA(I)+IPROD call DXADJ(PQA(I),IPQA(I),IERROR) if (IERROR /= 0) RETURN 225 if ( NU2-NU1 > .5D0) go to 230 PROD=(DMU-NU)*PROD*(-DMU-NU-1.D0) call DXADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN MU=MU+1 DMU=DMU+1.D0 go to 240 230 PROD=PROD*(-DMU-NU-1.D0)/(DMU-NU-1.D0) call DXADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN NU=NU+1.D0 240 CONTINUE return end subroutine DXPNRM (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR) ! !! DXPNRM computes the values of Legendre functions for DXLEGF. ! ! This subroutine transforms an array of Legendre functions ! of the first kind of negative order stored in array PQA ! into normalized Legendre polynomials stored in array PQA. ! The original array is destroyed. !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE DOUBLE PRECISION (XPNRM-S, DXPNRM-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED DXADJ !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXPNRM DOUBLE PRECISION C1,DMU,NU,NU1,NU2,PQA,PROD DIMENSION PQA(*),IPQA(*) !***FIRST EXECUTABLE STATEMENT DXPNRM IERROR=0 L=(MU2-MU1)+(NU2-NU1+1.5D0) MU=MU1 DMU=MU1 NU=NU1 ! ! if MU > NU, NORM P =0. ! J=1 500 if ( DMU <= NU) go to 505 PQA(J)=0.D0 IPQA(J)=0 J=J+1 if ( J > L) RETURN ! ! INCREMENT EITHER MU OR NU AS APPROPRIATE. ! if ( MU2 > MU1) DMU=DMU+1.D0 if ( NU2-NU1 > .5D0) NU=NU+1.D0 go to 500 ! ! TRANSFORM P(-MU,NU,X) INTO NORMALIZED P(MU,NU,X) USING ! NORM P(MU,NU,X)= ! SQRT((NU+.5)*FACTORIAL(NU+MU)/FACTORIAL(NU-MU)) ! *P(-MU,NU,X) ! 505 PROD=1.D0 IPROD=0 K=2*MU if ( K <= 0) go to 520 DO 510 I=1,K PROD=PROD*SQRT(NU+DMU+1.D0-I) 510 call DXADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN 520 DO 540 I=J,L C1=PROD*SQRT(NU+.5D0) PQA(I)=PQA(I)*C1 IPQA(I)=IPQA(I)+IPROD call DXADJ(PQA(I),IPQA(I),IERROR) if (IERROR /= 0) RETURN if ( NU2-NU1 > .5D0) go to 530 if ( DMU >= NU) go to 525 PROD=SQRT(NU+DMU+1.D0)*PROD if ( NU > DMU) PROD=PROD*SQRT(NU-DMU) call DXADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN MU=MU+1 DMU=DMU+1.D0 go to 540 525 PROD=0.D0 IPROD=0 MU=MU+1 DMU=DMU+1.D0 go to 540 530 PROD=SQRT(NU+DMU+1.D0)*PROD if ( NU /= DMU-1.D0) PROD=PROD/SQRT(NU-DMU+1.D0) call DXADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN NU=NU+1.D0 540 CONTINUE return end subroutine DXPQNU (NU1, NU2, MU, THETA, ID, PQA, IPQA, IERROR) ! !! DXPQNU computes the values of Legendre functions for DXLEGF. ! ! This subroutine calculates initial values of P or Q using ! power series, then performs forward nu-wise recurrence to ! obtain P(-MU,NU,X), Q(0,NU,X), or Q(1,NU,X). The nu-wise ! recurrence is stable for P for all mu and for Q for mu=0,1. !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE DOUBLE PRECISION (XPQNU-S, DXPQNU-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED DXADD, DXADJ, DXPSI !***COMMON BLOCKS DXBLK1 !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXPQNU DOUBLE PRECISION A,NU,NU1,NU2,PQ,PQA,DXPSI,R,THETA,W,X,X1,X2,XS, & Y,Z DOUBLE PRECISION DI,DMU,PQ1,PQ2,FACTMU,FLOK DIMENSION PQA(*),IPQA(*) COMMON /DXBLK1/ NBITSF SAVE /DXBLK1/ ! ! J0, IPSIK, AND IPSIX ARE INITIALIZED IN THIS SUBROUTINE. ! J0 IS THE NUMBER OF TERMS USED IN SERIES EXPANSION ! IN SUBROUTINE DXPQNU. ! IPSIK, IPSIX ARE VALUES OF K AND X RESPECTIVELY ! USED IN THE CALCULATION OF THE DXPSI FUNCTION. ! !***FIRST EXECUTABLE STATEMENT DXPQNU IERROR=0 J0=NBITSF IPSIK=1+(NBITSF/10) IPSIX=5*IPSIK IPQ=0 ! FIND NU IN INTERVAL [-.5,.5) if ID=2 ( CALCULATION OF Q ) NU=MOD(NU1,1.D0) if ( NU >= .5D0) NU=NU-1.D0 ! FIND NU IN INTERVAL (-1.5,-.5] if ID=1,3, OR 4 ( CALC. OF P ) if ( ID /= 2.AND.NU > -.5D0) NU=NU-1.D0 ! CALCULATE MU FACTORIAL K=MU DMU=MU if ( MU <= 0) go to 60 FACTMU=1.D0 IF=0 DO 50 I=1,K FACTMU=FACTMU*I 50 call DXADJ(FACTMU,IF,IERROR) if (IERROR /= 0) RETURN 60 if ( K == 0) FACTMU=1.D0 if ( K == 0) IF=0 ! ! X=COS(THETA) ! Y=SIN(THETA/2)**2=(1-X)/2=.5-.5*X ! R=TAN(THETA/2)=SQRT((1-X)/(1+X) ! X=COS(THETA) Y=SIN(THETA/2.D0)**2 R=TAN(THETA/2.D0) ! ! USE ASCENDING SERIES TO CALCULATE TWO VALUES OF P OR Q ! FOR USE AS STARTING VALUES IN RECURRENCE RELATION. ! PQ2=0.0D0 DO 100 J=1,2 IPQ1=0 if ( ID == 2) go to 80 ! ! SERIES FOR P ( ID = 1, 3, OR 4 ) ! P(-MU,NU,X)=1./FACTORIAL(MU)*SQRT(((1.-X)/(1.+X))**MU) ! *SUM(FROM 0 TO J0-1)A(J)*(.5-.5*X)**J ! IPQ=0 PQ=1.D0 A=1.D0 IA=0 DO 65 I=2,J0 DI=I A=A*Y*(DI-2.D0-NU)*(DI-1.D0+NU)/((DI-1.D0+DMU)*(DI-1.D0)) call DXADJ(A,IA,IERROR) if (IERROR /= 0) RETURN if ( A == 0.D0) go to 66 call DXADD(PQ,IPQ,A,IA,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN 65 CONTINUE 66 CONTINUE if ( MU <= 0) go to 90 X2=R X1=PQ K=MU DO 77 I=1,K X1=X1*X2 77 call DXADJ(X1,IPQ,IERROR) if (IERROR /= 0) RETURN PQ=X1/FACTMU IPQ=IPQ-IF call DXADJ(PQ,IPQ,IERROR) if (IERROR /= 0) RETURN go to 90 ! ! Z=-LN(R)=.5*LN((1+X)/(1-X)) ! 80 Z=-LOG(R) W=DXPSI(NU+1.D0,IPSIK,IPSIX) XS=1.D0/SIN(THETA) ! ! SERIES SUMMATION FOR Q ( ID = 2 ) ! Q(0,NU,X)=SUM(FROM 0 TO J0-1)((.5*LN((1+X)/(1-X)) ! +DXPSI(J+1,IPSIK,IPSIX)-DXPSI(NU+1,IPSIK,IPSIX)))*A(J)*(.5-.5*X)**J ! ! Q(1,NU,X)=-SQRT(1./(1.-X**2))+SQRT((1-X)/(1+X)) ! *SUM(FROM 0 T0 J0-1)(-NU*(NU+1)/2*LN((1+X)/(1-X)) ! +(J-NU)*(J+NU+1)/(2*(J+1))+NU*(NU+1)* ! (DXPSI(NU+1,IPSIK,IPSIX)-DXPSI(J+1,IPSIK,IPSIX))*A(J)*(.5-.5*X)**J ! ! NOTE, IN THIS LOOP K=J+1 ! PQ=0.D0 IPQ=0 IA=0 A=1.D0 DO 85 K=1,J0 FLOK=K if ( K == 1) go to 81 A=A*Y*(FLOK-2.D0-NU)*(FLOK-1.D0+NU)/((FLOK-1.D0+DMU)*(FLOK-1.D0)) call DXADJ(A,IA,IERROR) if (IERROR /= 0) RETURN 81 CONTINUE if ( MU >= 1) go to 83 X1=(DXPSI(FLOK,IPSIK,IPSIX)-W+Z)*A IX1=IA call DXADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN go to 85 83 X1=(NU*(NU+1.D0)*(Z-W+DXPSI(FLOK,IPSIK,IPSIX))+(NU-FLOK+1.D0) & *(NU+FLOK)/(2.D0*FLOK))*A IX1=IA call DXADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN 85 CONTINUE if ( MU >= 1) PQ=-R*PQ IXS=0 if ( MU >= 1) call DXADD(PQ,IPQ,-XS,IXS,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN if ( J == 2) MU=-MU if ( J == 2) DMU=-DMU 90 if ( J == 1) PQ2=PQ if ( J == 1) IPQ2=IPQ NU=NU+1.D0 100 CONTINUE K=0 if ( NU-1.5D0 < NU1) go to 120 K=K+1 PQA(K)=PQ2 IPQA(K)=IPQ2 if ( NU > NU2+.5D0) RETURN 120 PQ1=PQ IPQ1=IPQ if ( NU < NU1+.5D0) go to 130 K=K+1 PQA(K)=PQ IPQA(K)=IPQ if ( NU > NU2+.5D0) RETURN ! ! FORWARD NU-WISE RECURRENCE FOR F(MU,NU,X) FOR FIXED MU ! USING ! (NU+MU+1)*F(MU,NU,X)=(2.*NU+1)*F(MU,NU,X)-(NU-MU)*F(MU,NU-1,X) ! WHERE F(MU,NU,X) MAY BE P(-MU,NU,X) OR if MU IS REPLACED ! BY -MU THEN F(MU,NU,X) MAY BE Q(MU,NU,X). ! NOTE, IN THIS LOOP, NU=NU+1 ! 130 X1=(2.D0*NU-1.D0)/(NU+DMU)*X*PQ1 X2=(NU-1.D0-DMU)/(NU+DMU)*PQ2 call DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN call DXADJ(PQ,IPQ,IERROR) if (IERROR /= 0) RETURN NU=NU+1.D0 PQ2=PQ1 IPQ2=IPQ1 go to 120 ! end DOUBLE PRECISION FUNCTION DXPSI (A, IPSIK, IPSIX) ! !! DXPSI computes values of the Psi function for DXLEGF. ! !***LIBRARY SLATEC !***CATEGORY C7C !***TYPE DOUBLE PRECISION (XPSI-S, DXPSI-D) !***KEYWORDS PSI FUNCTION !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXPSI DOUBLE PRECISION A,B,C,CNUM,CDENOM DIMENSION CNUM(12),CDENOM(12) SAVE CNUM, CDENOM ! ! CNUM(I) AND CDENOM(I) ARE THE ( REDUCED ) NUMERATOR ! AND 2*I*DENOMINATOR RESPECTIVELY OF THE 2*I TH BERNOULLI ! NUMBER. ! DATA CNUM(1),CNUM(2),CNUM(3),CNUM(4),CNUM(5),CNUM(6),CNUM(7), & CNUM(8),CNUM(9),CNUM(10),CNUM(11),CNUM(12) & / 1.D0, -1.D0, 1.D0, -1.D0, 1.D0, & -691.D0, 1.D0, -3617.D0, 43867.D0, -174611.D0, 77683.D0, & -236364091.D0/ DATA CDENOM(1),CDENOM(2),CDENOM(3),CDENOM(4),CDENOM(5),CDENOM(6), & CDENOM(7),CDENOM(8),CDENOM(9),CDENOM(10),CDENOM(11),CDENOM(12) & /12.D0,120.D0, 252.D0, 240.D0,132.D0, & 32760.D0, 12.D0, 8160.D0, 14364.D0, 6600.D0, 276.D0, 65520.D0/ !***FIRST EXECUTABLE STATEMENT DXPSI N=MAX(0,IPSIX-INT(A)) B=N+A K1=IPSIK-1 ! ! SERIES EXPANSION FOR A > IPSIX USING IPSIK-1 TERMS. ! C=0.D0 DO 12 I=1,K1 K=IPSIK-I 12 C=(C+CNUM(K)/CDENOM(K))/B**2 DXPSI=LOG(B)-(C+.5D0/B) if ( N == 0) go to 20 B=0.D0 ! ! RECURRENCE FOR A <= IPSIX. ! DO 15 M=1,N 15 B=B+1.D0/(N-M+A) DXPSI=DXPSI-B 20 RETURN end subroutine DXQMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA, & IERROR) ! !! DXQMU computes the values of Legendre functions for DXLEGF. ! ! Method: forward mu-wise recurrence for Q(MU,NU,X) for fixed ! nu to obtain Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X). !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE DOUBLE PRECISION (XQMU-S, DXQMU-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED DXADD, DXADJ, DXPQNU !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXQMU DIMENSION PQA(*),IPQA(*) DOUBLE PRECISION DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2 DOUBLE PRECISION THETA !***FIRST EXECUTABLE STATEMENT DXQMU IERROR=0 MU=0 ! ! call DXPQNU TO OBTAIN Q(0.,NU1,X) ! call DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN PQ2=PQA(1) IPQ2=IPQA(1) MU=1 ! ! call DXPQNU TO OBTAIN Q(1.,NU1,X) ! call DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN NU=NU1 K=0 MU=1 DMU=1.D0 PQ1=PQA(1) IPQ1=IPQA(1) if ( MU1 > 0) go to 310 K=K+1 PQA(K)=PQ2 IPQA(K)=IPQ2 if ( MU2 < 1) go to 330 310 if ( MU1 > 1) go to 320 K=K+1 PQA(K)=PQ1 IPQA(K)=IPQ1 if ( MU2 <= 1) go to 330 320 CONTINUE ! ! FORWARD RECURRENCE IN MU TO OBTAIN ! Q(MU1,NU,X),Q(MU1+1,NU,X),....,Q(MU2,NU,X) USING ! Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X) ! -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X) ! X1=-2.D0*DMU*X*SX*PQ1 X2=(NU+DMU)*(NU-DMU+1.D0)*PQ2 call DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN call DXADJ(PQ,IPQ,IERROR) if (IERROR /= 0) RETURN PQ2=PQ1 IPQ2=IPQ1 PQ1=PQ IPQ1=IPQ MU=MU+1 DMU=DMU+1.D0 if ( MU < MU1) go to 320 K=K+1 PQA(K)=PQ IPQA(K)=IPQ if ( MU2 > MU) go to 320 330 RETURN end subroutine DXQNU (NU1, NU2, MU1, THETA, X, SX, ID, PQA, IPQA, & IERROR) ! !! DXQNU computes the values of Legendre functions for DXLEGF. ! ! Method: backward nu-wise recurrence for Q(MU,NU,X) for ! fixed mu to obtain Q(MU1,NU1,X), Q(MU1,NU1+1,X), ..., ! Q(MU1,NU2,X). !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE DOUBLE PRECISION (XQNU-S, DXQNU-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED DXADD, DXADJ, DXPQNU !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXQNU DIMENSION PQA(*),IPQA(*) DOUBLE PRECISION DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2 DOUBLE PRECISION THETA,PQL1,PQL2 !***FIRST EXECUTABLE STATEMENT DXQNU IERROR=0 K=0 PQ2=0.0D0 IPQ2=0 PQL2=0.0D0 IPQL2=0 if ( MU1 == 1) go to 290 MU=0 ! ! call DXPQNU TO OBTAIN Q(0.,NU2,X) AND Q(0.,NU2-1,X) ! call DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN if ( MU1 == 0) RETURN K=(NU2-NU1+1.5D0) PQ2=PQA(K) IPQ2=IPQA(K) PQL2=PQA(K-1) IPQL2=IPQA(K-1) 290 MU=1 ! ! call DXPQNU TO OBTAIN Q(1.,NU2,X) AND Q(1.,NU2-1,X) ! call DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN if ( MU1 == 1) RETURN NU=NU2 PQ1=PQA(K) IPQ1=IPQA(K) PQL1=PQA(K-1) IPQL1=IPQA(K-1) 300 MU=1 DMU=1.D0 320 CONTINUE ! ! FORWARD RECURRENCE IN MU TO OBTAIN Q(MU1,NU2,X) AND ! Q(MU1,NU2-1,X) USING ! Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X) ! -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X) ! ! FIRST FOR NU=NU2 ! X1=-2.D0*DMU*X*SX*PQ1 X2=(NU+DMU)*(NU-DMU+1.D0)*PQ2 call DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN call DXADJ(PQ,IPQ,IERROR) if (IERROR /= 0) RETURN PQ2=PQ1 IPQ2=IPQ1 PQ1=PQ IPQ1=IPQ MU=MU+1 DMU=DMU+1.D0 if ( MU < MU1) go to 320 PQA(K)=PQ IPQA(K)=IPQ if ( K == 1) RETURN if ( NU < NU2) go to 340 ! ! THEN FOR NU=NU2-1 ! NU=NU-1.D0 PQ2=PQL2 IPQ2=IPQL2 PQ1=PQL1 IPQ1=IPQL1 K=K-1 go to 300 ! ! BACKWARD RECURRENCE IN NU TO OBTAIN ! Q(MU1,NU1,X),Q(MU1,NU1+1,X),....,Q(MU1,NU2,X) ! USING ! (NU-MU+1.)*Q(MU,NU+1,X)= ! (2.*NU+1.)*X*Q(MU,NU,X)-(NU+MU)*Q(MU,NU-1,X) ! 340 PQ1=PQA(K) IPQ1=IPQA(K) PQ2=PQA(K+1) IPQ2=IPQA(K+1) 350 if ( NU <= NU1) RETURN K=K-1 X1=(2.D0*NU+1.D0)*X*PQ1/(NU+DMU) X2=-(NU-DMU+1.D0)*PQ2/(NU+DMU) call DXADD(X1,IPQ1,X2,IPQ2,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN call DXADJ(PQ,IPQ,IERROR) if (IERROR /= 0) RETURN PQ2=PQ1 IPQ2=IPQ1 PQ1=PQ IPQ1=IPQ PQA(K)=PQ IPQA(K)=IPQ NU=NU-1.D0 go to 350 end subroutine DXRED (X, IX, IERROR) ! !! DXRED provides double-precision floating-point arithmetic ... ! with an extended exponent range. ! !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE DOUBLE PRECISION (XRED-S, DXRED-D) !***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! DOUBLE PRECISION X ! INTEGER IX ! ! IF ! RADIX**(-2L) <= (ABS(X),IX) <= RADIX**(2L) ! THEN DXRED TRANSFORMS (X,IX) SO THAT IX=0. ! if (X,IX) IS OUTSIDE THE ABOVE RANGE, ! THEN DXRED TAKES NO ACTION. ! THIS SUBROUTINE IS USEFUL if THE ! RESULTS OF EXTENDED-RANGE CALCULATIONS ! ARE TO BE USED IN SUBSEQUENT ORDINARY ! DOUBLE-PRECISION CALCULATIONS. ! !***SEE ALSO DXSET !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DXBLK2 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXRED DOUBLE PRECISION X INTEGER IX DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R, XA INTEGER L, L2, KMAX COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX SAVE /DXBLK2/ ! !***FIRST EXECUTABLE STATEMENT DXRED IERROR=0 if (X == 0.0D0) go to 90 XA = ABS(X) if (IX == 0) go to 70 IXA = ABS(IX) IXA1 = IXA/L2 IXA2 = MOD(IXA,L2) if (IX > 0) go to 40 10 CONTINUE if (XA > 1.0D0) go to 20 XA = XA*RAD2L IXA1 = IXA1 + 1 go to 10 20 XA = XA/RADIX**IXA2 if (IXA1 == 0) go to 70 DO 30 I=1,IXA1 if (XA < 1.0D0) go to 100 XA = XA/RAD2L 30 CONTINUE go to 70 ! 40 CONTINUE if (XA < 1.0D0) go to 50 XA = XA/RAD2L IXA1 = IXA1 + 1 go to 40 50 XA = XA*RADIX**IXA2 if (IXA1 == 0) go to 70 DO 60 I=1,IXA1 if (XA > 1.0D0) go to 100 XA = XA*RAD2L 60 CONTINUE 70 if (XA > RAD2L) go to 100 if (XA > 1.0D0) go to 80 if (RAD2L*XA < 1.0D0) go to 100 80 X = SIGN(XA,X) 90 IX = 0 100 RETURN end subroutine DXSET (IRAD, NRADPL, DZERO, NBITS, IERROR) ! !! DXSET provides double-precision floating-point arithmetic ... ! with an extended exponent range. !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE DOUBLE PRECISION (XSET-S, DXSET-D) !***KEYWORDS EXTENDED-RANGE DOUBLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! ! SUBROUTINE DXSET MUST BE CALLED PRIOR TO CALLING ANY OTHER ! EXTENDED-RANGE SUBROUTINE. IT CALCULATES AND STORES SEVERAL ! MACHINE-DEPENDENT CONSTANTS IN COMMON BLOCKS. THE USER MUST ! SUPPLY FOUR CONSTANTS THAT PERTAIN TO HIS PARTICULAR COMPUTER. ! THE CONSTANTS ARE ! ! IRAD = THE INTERNAL BASE OF DOUBLE-PRECISION ! ARITHMETIC IN THE COMPUTER. ! NRADPL = THE NUMBER OF RADIX PLACES CARRIED IN ! THE DOUBLE-PRECISION REPRESENTATION. ! DZERO = THE SMALLEST OF 1/DMIN, DMAX, DMAXLN WHERE ! DMIN = THE SMALLEST POSITIVE DOUBLE-PRECISION ! NUMBER OR AN UPPER BOUND TO THIS NUMBER, ! DMAX = THE LARGEST DOUBLE-PRECISION NUMBER ! OR A LOWER BOUND TO THIS NUMBER, ! DMAXLN = THE LARGEST DOUBLE-PRECISION NUMBER ! SUCH THAT LOG10(DMAXLN) CAN BE COMPUTED BY THE ! FORTRAN SYSTEM (ON MOST SYSTEMS DMAXLN = DMAX). ! NBITS = THE NUMBER OF BITS (EXCLUSIVE OF SIGN) IN ! AN INTEGER COMPUTER WORD. ! ! ALTERNATIVELY, ANY OR ALL OF THE CONSTANTS CAN BE GIVEN ! THE VALUE 0 (0.0D0 FOR DZERO). if A CONSTANT IS ZERO, DXSET TRIES ! TO ASSIGN AN APPROPRIATE VALUE BY CALLING I1MACH ! (SEE P.A.FOX, A.D.HALL, N.L.SCHRYER, ALGORITHM 528 FRAMEWORK ! FOR A PORTABLE LIBRARY, ACM TRANSACTIONS ON MATH SOFTWARE, ! V.4, NO.2, JUNE 1978, 177-188). ! ! THIS IS THE SETTING-UP SUBROUTINE FOR A PACKAGE OF SUBROUTINES ! THAT FACILITATE THE USE OF EXTENDED-RANGE ARITHMETIC. EXTENDED-RANGE ! ARITHMETIC ON A PARTICULAR COMPUTER IS DEFINED ON THE SET OF NUMBERS ! OF THE FORM ! ! (X,IX) = X*RADIX**IX ! ! WHERE X IS A DOUBLE-PRECISION NUMBER CALLED THE PRINCIPAL PART, ! IX IS AN INTEGER CALLED THE AUXILIARY INDEX, AND RADIX IS THE ! INTERNAL BASE OF THE DOUBLE-PRECISION ARITHMETIC. OBVIOUSLY, ! EACH REAL NUMBER IS REPRESENTABLE WITHOUT ERROR BY MORE THAN ONE ! EXTENDED-RANGE FORM. CONVERSIONS BETWEEN DIFFERENT FORMS ARE ! ESSENTIAL IN CARRYING OUT ARITHMETIC OPERATIONS. WITH THE CHOICE ! OF RADIX WE HAVE MADE, AND THE SUBROUTINES WE HAVE WRITTEN, THESE ! CONVERSIONS ARE PERFORMED WITHOUT ERROR (AT LEAST ON MOST COMPUTERS). ! (SEE SMITH, J.M., OLVER, F.W.J., AND LOZIER, D.W., EXTENDED-RANGE ! ARITHMETIC AND NORMALIZED LEGENDRE POLYNOMIALS, ACM TRANSACTIONS ON ! MATHEMATICAL SOFTWARE, MARCH 1981). ! ! AN EXTENDED-RANGE NUMBER (X,IX) IS SAID TO BE IN ADJUSTED FORM IF ! X AND IX ARE ZERO OR ! ! RADIX**(-L) <= ABS(X) < RADIX**L ! ! IS SATISFIED, WHERE L IS A COMPUTER-DEPENDENT INTEGER DEFINED IN THIS ! SUBROUTINE. TWO EXTENDED-RANGE NUMBERS IN ADJUSTED FORM CAN BE ADDED, ! SUBTRACTED, MULTIPLIED OR DIVIDED (IF THE DIVISOR IS NONZERO) WITHOUT ! CAUSING OVERFLOW OR UNDERFLOW IN THE PRINCIPAL PART OF THE RESULT. ! WITH PROPER USE OF THE EXTENDED-RANGE SUBROUTINES, THE ONLY OVERFLOW ! THAT CAN OCCUR IS INTEGER OVERFLOW IN THE AUXILIARY INDEX. if THIS ! IS DETECTED, THE SOFTWARE CALLS XERROR (A GENERAL ERROR-HANDLING ! FORTRAN SUBROUTINE PACKAGE). ! ! MULTIPLICATION AND DIVISION IS PERFORMED BY SETTING ! ! (X,IX)*(Y,IY) = (X*Y,IX+IY) ! OR ! (X,IX)/(Y,IY) = (X/Y,IX-IY). ! ! PRE-ADJUSTMENT OF THE OPERANDS IS ESSENTIAL TO AVOID ! OVERFLOW OR UNDERFLOW OF THE PRINCIPAL PART. SUBROUTINE ! DXADJ (SEE BELOW) MAY BE CALLED TO TRANSFORM ANY EXTENDED- ! RANGE NUMBER INTO ADJUSTED FORM. ! ! ADDITION AND SUBTRACTION REQUIRE THE USE OF SUBROUTINE DXADD ! (SEE BELOW). THE INPUT OPERANDS NEED NOT BE IN ADJUSTED FORM. ! HOWEVER, THE RESULT OF ADDITION OR SUBTRACTION IS RETURNED ! IN ADJUSTED FORM. THUS, FOR EXAMPLE, if (X,IX),(Y,IY), ! (U,IU), AND (V,IV) ARE IN ADJUSTED FORM, THEN ! ! (X,IX)*(Y,IY) + (U,IU)*(V,IV) ! ! CAN BE COMPUTED AND STORED IN ADJUSTED FORM WITH NO EXPLICIT ! CALLS TO DXADJ. ! ! WHEN AN EXTENDED-RANGE NUMBER IS TO BE PRINTED, IT MUST BE ! CONVERTED TO AN EXTENDED-RANGE FORM WITH DECIMAL RADIX. SUBROUTINE ! DXCON IS PROVIDED FOR THIS PURPOSE. ! ! THE SUBROUTINES CONTAINED IN THIS PACKAGE ARE ! ! SUBROUTINE DXADD ! USAGE ! call DXADD(X,IX,Y,IY,Z,IZ,IERROR) ! if (IERROR /= 0) RETURN ! DESCRIPTION ! FORMS THE EXTENDED-RANGE SUM (Z,IZ) = ! (X,IX) + (Y,IY). (Z,IZ) IS ADJUSTED ! BEFORE RETURNING. THE INPUT OPERANDS ! NEED NOT BE IN ADJUSTED FORM, BUT THEIR ! PRINCIPAL PARTS MUST SATISFY ! RADIX**(-2L) <= ABS(X) <= RADIX**(2L), ! RADIX**(-2L) <= ABS(Y) <= RADIX**(2L). ! ! SUBROUTINE DXADJ ! USAGE ! call DXADJ(X,IX,IERROR) ! if (IERROR /= 0) RETURN ! DESCRIPTION ! TRANSFORMS (X,IX) SO THAT ! RADIX**(-L) <= ABS(X) < RADIX**L. ! ON MOST COMPUTERS THIS TRANSFORMATION DOES ! NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS ! THE NUMBER BASE OF DOUBLE-PRECISION ARITHMETIC. ! ! SUBROUTINE DXC210 ! USAGE ! call DXC210(K,Z,J,IERROR) ! if (IERROR /= 0) RETURN ! DESCRIPTION ! GIVEN K THIS SUBROUTINE COMPUTES J AND Z ! SUCH THAT RADIX**K = Z*10**J, WHERE Z IS IN ! THE RANGE 1/10 <= Z < 1. ! THE VALUE OF Z WILL BE ACCURATE TO FULL ! DOUBLE-PRECISION PROVIDED THE NUMBER ! OF DECIMAL PLACES IN THE LARGEST ! INTEGER PLUS THE NUMBER OF DECIMAL ! PLACES CARRIED IN DOUBLE-PRECISION DOES NOT ! EXCEED 60. DXC210 IS CALLED BY SUBROUTINE ! DXCON WHEN NECESSARY. THE USER SHOULD ! NEVER NEED TO call DXC210 DIRECTLY. ! ! SUBROUTINE DXCON ! USAGE ! call DXCON(X,IX,IERROR) ! if (IERROR /= 0) RETURN ! DESCRIPTION ! CONVERTS (X,IX) = X*RADIX**IX ! TO DECIMAL FORM IN PREPARATION FOR ! PRINTING, SO THAT (X,IX) = X*10**IX ! WHERE 1/10 <= ABS(X) < 1 ! IS RETURNED, EXCEPT THAT IF ! (ABS(X),IX) IS BETWEEN RADIX**(-2L) ! AND RADIX**(2L) THEN THE REDUCED ! FORM WITH IX = 0 IS RETURNED. ! ! SUBROUTINE DXRED ! USAGE ! call DXRED(X,IX,IERROR) ! if (IERROR /= 0) RETURN ! DESCRIPTION ! IF ! RADIX**(-2L) <= (ABS(X),IX) <= RADIX**(2L) ! THEN DXRED TRANSFORMS (X,IX) SO THAT IX=0. ! if (X,IX) IS OUTSIDE THE ABOVE RANGE, ! THEN DXRED TAKES NO ACTION. ! THIS SUBROUTINE IS USEFUL if THE ! RESULTS OF EXTENDED-RANGE CALCULATIONS ! ARE TO BE USED IN SUBSEQUENT ORDINARY ! DOUBLE-PRECISION CALCULATIONS. ! !***REFERENCES Smith, Olver and Lozier, Extended-Range Arithmetic and ! Normalized Legendre Polynomials, ACM Trans on Math ! Softw, v 7, n 1, March 1981, pp 93--105. !***ROUTINES CALLED I1MACH, XERMSG !***COMMON BLOCKS DXBLK1, DXBLK2, DXBLK3 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! CALLs to XERROR changed to CALLs to XERMSG. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE DXSET INTEGER IRAD, NRADPL, NBITS DOUBLE PRECISION DZERO, DZEROX COMMON /DXBLK1/ NBITSF SAVE /DXBLK1/ DOUBLE PRECISION RADIX, RADIXL, RAD2L, DLG10R INTEGER L, L2, KMAX COMMON /DXBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX SAVE /DXBLK2/ INTEGER NLG102, MLG102, LG102 COMMON /DXBLK3/ NLG102, MLG102, LG102(21) SAVE /DXBLK3/ INTEGER IFLAG SAVE IFLAG ! DIMENSION LOG102(20), LGTEMP(20) SAVE LOG102 ! ! LOG102 CONTAINS THE FIRST 60 DIGITS OF LOG10(2) FOR USE IN ! CONVERSION OF EXTENDED-RANGE NUMBERS TO BASE 10 . DATA LOG102 /301,029,995,663,981,195,213,738,894,724,493,026,768, & 189,881,462,108,541,310,428/ ! ! FOLLOWING CODING PREVENTS DXSET FROM BEING EXECUTED MORE THAN ONCE. ! THIS IS IMPORTANT BECAUSE SOME SUBROUTINES (SUCH AS DXNRMP AND ! DXLEGF) call DXSET TO MAKE SURE EXTENDED-RANGE ARITHMETIC HAS ! BEEN INITIALIZED. THE USER MAY WANT TO PRE-EMPT THIS CALL, FOR ! EXAMPLE WHEN I1MACH IS NOT AVAILABLE. SEE CODING BELOW. DATA IFLAG /0/ !***FIRST EXECUTABLE STATEMENT DXSET IERROR=0 if (IFLAG /= 0) RETURN IRADX = IRAD NRDPLC = NRADPL DZEROX = DZERO IMINEX = 0 IMAXEX = 0 NBITSX = NBITS ! FOLLOWING 5 STATEMENTS SHOULD BE DELETED if I1MACH IS ! NOT AVAILABLE OR NOT CONFIGURED TO RETURN THE CORRECT ! MACHINE-DEPENDENT VALUES. if (IRADX == 0) IRADX = I1MACH (10) if (NRDPLC == 0) NRDPLC = I1MACH (14) if (DZEROX == 0.0D0) IMINEX = I1MACH (15) if (DZEROX == 0.0D0) IMAXEX = I1MACH (16) if (NBITSX == 0) NBITSX = I1MACH (8) if (IRADX == 2) go to 10 if (IRADX == 4) go to 10 if (IRADX == 8) go to 10 if (IRADX == 16) go to 10 call XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF IRAD', 201, 1) IERROR=201 return 10 CONTINUE LOG2R=0 if (IRADX == 2) LOG2R = 1 if (IRADX == 4) LOG2R = 2 if (IRADX == 8) LOG2R = 3 if (IRADX == 16) LOG2R = 4 NBITSF=LOG2R*NRDPLC RADIX = IRADX DLG10R = LOG10(RADIX) if (DZEROX /= 0.0D0) go to 14 LX = MIN ((1-IMINEX)/2, (IMAXEX-1)/2) go to 16 14 LX = 0.5D0*LOG10(DZEROX)/DLG10R ! RADIX**(2*L) SHOULD NOT OVERFLOW, BUT REDUCE L BY 1 FOR FURTHER ! PROTECTION. LX=LX-1 16 L2 = 2*LX if (LX >= 4) go to 20 call XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF DZERO', 202, 1) IERROR=202 return 20 L = LX RADIXL = RADIX**L RAD2L = RADIXL**2 ! IT IS NECESSARY TO RESTRICT NBITS (OR NBITSX) TO BE LESS THAN SOME ! UPPER LIMIT BECAUSE OF BINARY-TO-DECIMAL CONVERSION. SUCH CONVERSION ! IS DONE BY DXC210 AND REQUIRES A CONSTANT THAT IS STORED TO SOME FIXED ! PRECISION. THE STORED CONSTANT (LOG102 IN THIS ROUTINE) PROVIDES ! FOR CONVERSIONS ACCURATE TO THE LAST DECIMAL DIGIT WHEN THE INTEGER ! WORD LENGTH DOES NOT EXCEED 63. A LOWER LIMIT OF 15 BITS IS IMPOSED ! BECAUSE THE SOFTWARE IS DESIGNED TO RUN ON COMPUTERS WITH INTEGER WORD ! LENGTH OF AT LEAST 16 BITS. if (15 <= NBITSX .AND. NBITSX <= 63) go to 30 call XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF NBITS', 203, 1) IERROR=203 return 30 CONTINUE KMAX = 2**(NBITSX-1) - L2 NB = (NBITSX-1)/2 MLG102 = 2**NB if (1 <= NRDPLC*LOG2R .AND. NRDPLC*LOG2R <= 120) go to 40 call XERMSG ('SLATEC', 'DXSET', 'IMPROPER VALUE OF NRADPL', 204, & 1) IERROR=204 return 40 CONTINUE NLG102 = NRDPLC*LOG2R/NB + 3 NP1 = NLG102 + 1 ! ! AFTER COMPLETION OF THE FOLLOWING LOOP, IC CONTAINS ! THE INTEGER PART AND LGTEMP CONTAINS THE FRACTIONAL PART ! OF LOG10(IRADX) IN RADIX 1000. IC = 0 DO 50 II=1,20 I = 21 - II IT = LOG2R*LOG102(I) + IC IC = IT/1000 LGTEMP(I) = MOD(IT,1000) 50 CONTINUE ! ! AFTER COMPLETION OF THE FOLLOWING LOOP, LG102 CONTAINS ! LOG10(IRADX) IN RADIX MLG102. THE RADIX POINT IS ! BETWEEN LG102(1) AND LG102(2). LG102(1) = IC DO 80 I=2,NP1 LG102X = 0 DO 70 J=1,NB IC = 0 DO 60 KK=1,20 K = 21 - KK IT = 2*LGTEMP(K) + IC IC = IT/1000 LGTEMP(K) = MOD(IT,1000) 60 CONTINUE LG102X = 2*LG102X + IC 70 CONTINUE LG102(I) = LG102X 80 CONTINUE ! ! CHECK SPECIAL CONDITIONS REQUIRED BY SUBROUTINES... if (NRDPLC < L) go to 90 call XERMSG ('SLATEC', 'DXSET', 'NRADPL >= L', 205, 1) IERROR=205 return 90 if (6*L <= KMAX) go to 100 call XERMSG ('SLATEC', 'DXSET', '6*L > KMAX', 206, 1) IERROR=206 return 100 CONTINUE IFLAG = 1 return end subroutine DY4 (U, IDMN, I, J, UYYY, UYYYY) ! !! DY4 is subsidiary to SEPX4. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (DY4-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This program computes second order finite difference ! approximations to the third and fourth Y ! partial derivatives of U at the (I,J) mesh point. ! !***SEE ALSO SEPX4 !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SPL4 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE DY4 ! COMMON /SPL4/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION U(IDMN,*) !***FIRST EXECUTABLE STATEMENT DY4 if (J > 2 .AND. J < (L-1)) go to 50 if (J == 1) go to 10 if (J == 2) go to 30 if (J == L-1) go to 60 if (J == L) go to 80 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C ! 10 if (KSWY == 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)- & 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)+ & 11.0*U(I,5)-2.0*U(I,6))/DLY4 return ! ! PERIODIC AT X=A ! 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 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C+DLY ! 30 if (KSWY == 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))/ & 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)- & U(I,6))/DLY4 return ! ! PERIODIC AT Y=C+DLY ! 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 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR ! 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))/ & DLY4 return ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D-DLY ! 60 if (KSWY == 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)+ & 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)- & 9.0*U(I,L-1)+2.0*U(I,L))/DLY4 return ! ! PERIODIC AT Y=D-DLY ! 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))/ & DLY4 return ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D ! 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)+ & 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)- & 14.0*U(I,L-1)+3.0*U(I,L))/DLY4 return end subroutine DYAIRY (X, RX, C, BI, DBI) ! !! DYAIRY is subsidiary to DBESJ and DBESY. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (YAIRY-S, DYAIRY-D) !***AUTHOR Amos, D. E., (SNLA) ! Daniel, S. L., (SNLA) !***DESCRIPTION ! ! DYAIRY computes the Airy function BI(X) ! and its derivative DBI(X) for DASYJY ! ! INPUT ! ! X - Argument, computed by DASYJY, X unrestricted ! RX - RX=SQRT(ABS(X)), computed by DASYJY ! C - C=2.*(ABS(X)**1.5)/3., computed by DASYJY ! ! OUTPUT ! BI - Value of function BI(X) ! DBI - Value of the derivative DBI(X) ! !***SEE ALSO DBESJ, DBESY !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE DYAIRY ! INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4D, N1, N1D, N2, N2D, & N3, N3D, N4D DOUBLE PRECISION AA,AX,BB,BI,BJN,BJP,BK1,BK2,BK3,BK4,C,CON1,CON2, & CON3, CV, DAA, DBB, DBI, DBJN, DBJP, DBK1, DBK2, DBK3, DBK4, D1, & D2, EX, E1, E2, FPI12, F1, F2, RTRX, RX, SPI12, S1, S2, T, TC, & TEMP1, TEMP2, TT, X DIMENSION BK1(20), BK2(20), BK3(20), BK4(14) DIMENSION BJP(19), BJN(19), AA(14), BB(14) DIMENSION DBK1(21), DBK2(20), DBK3(20), DBK4(14) DIMENSION DBJP(19), DBJN(19), DAA(14), DBB(14) SAVE N1, N2, N3, M1, M2, M3, N1D, N2D, N3D, N4D, & M1D, M2D, M3D, M4D, FPI12, SPI12, CON1, CON2, CON3, & BK1, BK2, BK3, BK4, BJN, BJP, AA, BB, DBK1, DBK2, DBK3, DBK4, & DBJP, DBJN, DAA, DBB DATA N1,N2,N3/20,19,14/ DATA M1,M2,M3/18,17,12/ DATA N1D,N2D,N3D,N4D/21,20,19,14/ DATA M1D,M2D,M3D,M4D/19,18,17,12/ DATA FPI12,SPI12,CON1,CON2,CON3/ & 1.30899693899575D+00, 1.83259571459405D+00, 6.66666666666667D-01, & 7.74148278841779D+00, 3.64766105490356D-01/ DATA BK1(1), BK1(2), BK1(3), BK1(4), BK1(5), BK1(6), & BK1(7), BK1(8), BK1(9), BK1(10), BK1(11), BK1(12), & BK1(13), BK1(14), BK1(15), BK1(16), BK1(17), BK1(18), & BK1(19), BK1(20)/ 2.43202846447449D+00, 2.57132009754685D+00, & 1.02802341258616D+00, 3.41958178205872D-01, 8.41978629889284D-02, & 1.93877282587962D-02, 3.92687837130335D-03, 6.83302689948043D-04, & 1.14611403991141D-04, 1.74195138337086D-05, 2.41223620956355D-06, & 3.24525591983273D-07, 4.03509798540183D-08, 4.70875059642296D-09, & 5.35367432585889D-10, 5.70606721846334D-11, 5.80526363709933D-12, & 5.76338988616388D-13, 5.42103834518071D-14, 4.91857330301677D-15/ DATA BK2(1), BK2(2), BK2(3), BK2(4), BK2(5), BK2(6), & BK2(7), BK2(8), BK2(9), BK2(10), BK2(11), BK2(12), & BK2(13), BK2(14), BK2(15), BK2(16), BK2(17), BK2(18), & BK2(19), BK2(20)/ 5.74830555784088D-01,-6.91648648376891D-03, & 1.97460263052093D-03,-5.24043043868823D-04, 1.22965147239661D-04, & -2.27059514462173D-05, 2.23575555008526D-06, 4.15174955023899D-07, & -2.84985752198231D-07, 8.50187174775435D-08,-1.70400826891326D-08, & 2.25479746746889D-09,-1.09524166577443D-10,-3.41063845099711D-11, & 1.11262893886662D-11,-1.75542944241734D-12, 1.36298600401767D-13, & 8.76342105755664D-15,-4.64063099157041D-15, 7.78772758732960D-16/ DATA BK3(1), BK3(2), BK3(3), BK3(4), BK3(5), BK3(6), & BK3(7), BK3(8), BK3(9), BK3(10), BK3(11), BK3(12), & BK3(13), BK3(14), BK3(15), BK3(16), BK3(17), BK3(18), & BK3(19), BK3(20)/ 5.66777053506912D-01, 2.63672828349579D-03, & 5.12303351473130D-05, 2.10229231564492D-06, 1.42217095113890D-07, & 1.28534295891264D-08, 7.28556219407507D-10,-3.45236157301011D-10, & -2.11919115912724D-10,-6.56803892922376D-11,-8.14873160315074D-12, & 3.03177845632183D-12, 1.73447220554115D-12, 1.67935548701554D-13, & -1.49622868806719D-13,-5.15470458953407D-14, 8.75741841857830D-15, & 7.96735553525720D-15,-1.29566137861742D-16,-1.11878794417520D-15/ DATA BK4(1), BK4(2), BK4(3), BK4(4), BK4(5), BK4(6), & BK4(7), BK4(8), BK4(9), BK4(10), BK4(11), BK4(12), & BK4(13), BK4(14)/ 4.85444386705114D-01,-3.08525088408463D-03, & 6.98748404837928D-05,-2.82757234179768D-06, 1.59553313064138D-07, & -1.12980692144601D-08, 9.47671515498754D-10,-9.08301736026423D-11, & 9.70776206450724D-12,-1.13687527254574D-12, 1.43982917533415D-13, & -1.95211019558815D-14, 2.81056379909357D-15,-4.26916444775176D-16/ DATA BJP(1), BJP(2), BJP(3), BJP(4), BJP(5), BJP(6), & BJP(7), BJP(8), BJP(9), BJP(10), BJP(11), BJP(12), & BJP(13), BJP(14), BJP(15), BJP(16), BJP(17), BJP(18), & BJP(19) / 1.34918611457638D-01,-3.19314588205813D-01, & 5.22061946276114D-02, 5.28869112170312D-02,-8.58100756077350D-03, & -2.99211002025555D-03, 4.21126741969759D-04, 8.73931830369273D-05, & -1.06749163477533D-05,-1.56575097259349D-06, 1.68051151983999D-07, & 1.89901103638691D-08,-1.81374004961922D-09,-1.66339134593739D-10, & 1.42956335780810D-11, 1.10179811626595D-12,-8.60187724192263D-14, & -5.71248177285064D-15, 4.08414552853803D-16/ DATA BJN(1), BJN(2), BJN(3), BJN(4), BJN(5), BJN(6), & BJN(7), BJN(8), BJN(9), BJN(10), BJN(11), BJN(12), & BJN(13), BJN(14), BJN(15), BJN(16), BJN(17), BJN(18), & BJN(19) / 6.59041673525697D-02,-4.24905910566004D-01, & 2.87209745195830D-01, 1.29787771099606D-01,-4.56354317590358D-02, & -1.02630175982540D-02, 2.50704671521101D-03, 3.78127183743483D-04, & -7.11287583284084D-05,-8.08651210688923D-06, 1.23879531273285D-06, & 1.13096815867279D-07,-1.46234283176310D-08,-1.11576315688077D-09, & 1.24846618243897D-10, 8.18334132555274D-12,-8.07174877048484D-13, & -4.63778618766425D-14, 4.09043399081631D-15/ DATA AA(1), AA(2), AA(3), AA(4), AA(5), AA(6), & AA(7), AA(8), AA(9), AA(10), AA(11), AA(12), & AA(13), AA(14) /-2.78593552803079D-01, 3.52915691882584D-03, & 2.31149677384994D-05,-4.71317842263560D-06, 1.12415907931333D-07, & 2.00100301184339D-08,-2.60948075302193D-09, 3.55098136101216D-11, & 3.50849978423875D-11,-5.83007187954202D-12, 2.04644828753326D-13, & 1.10529179476742D-13,-2.87724778038775D-14, 2.88205111009939D-15/ DATA BB(1), BB(2), BB(3), BB(4), BB(5), BB(6), & BB(7), BB(8), BB(9), BB(10), BB(11), BB(12), & BB(13), BB(14) /-4.90275424742791D-01,-1.57647277946204D-03, & 9.66195963140306D-05,-1.35916080268815D-07,-2.98157342654859D-07, & 1.86824767559979D-08, 1.03685737667141D-09,-3.28660818434328D-10, & 2.57091410632780D-11, 2.32357655300677D-12,-9.57523279048255D-13, & 1.20340828049719D-13, 2.90907716770715D-15,-4.55656454580149D-15/ DATA DBK1(1), DBK1(2), DBK1(3), DBK1(4), DBK1(5), DBK1(6), & DBK1(7), DBK1(8), DBK1(9), DBK1(10),DBK1(11),DBK1(12), & DBK1(13),DBK1(14),DBK1(15),DBK1(16),DBK1(17),DBK1(18), & DBK1(19),DBK1(20), & DBK1(21) / 2.95926143981893D+00, 3.86774568440103D+00, & 1.80441072356289D+00, 5.78070764125328D-01, 1.63011468174708D-01, & 3.92044409961855D-02, 7.90964210433812D-03, 1.50640863167338D-03, & 2.56651976920042D-04, 3.93826605867715D-05, 5.81097771463818D-06, & 7.86881233754659D-07, 9.93272957325739D-08, 1.21424205575107D-08, & 1.38528332697707D-09, 1.50190067586758D-10, 1.58271945457594D-11, & 1.57531847699042D-12, 1.50774055398181D-13, 1.40594335806564D-14, & 1.24942698777218D-15/ DATA DBK2(1), DBK2(2), DBK2(3), DBK2(4), DBK2(5), DBK2(6), & DBK2(7), DBK2(8), DBK2(9), DBK2(10),DBK2(11),DBK2(12), & DBK2(13),DBK2(14),DBK2(15),DBK2(16),DBK2(17),DBK2(18), & DBK2(19),DBK2(20)/ 5.49756809432471D-01, 9.13556983276901D-03, & -2.53635048605507D-03, 6.60423795342054D-04,-1.55217243135416D-04, & 3.00090325448633D-05,-3.76454339467348D-06,-1.33291331611616D-07, & 2.42587371049013D-07,-8.07861075240228D-08, 1.71092818861193D-08, & -2.41087357570599D-09, 1.53910848162371D-10, 2.56465373190630D-11, & -9.88581911653212D-12, 1.60877986412631D-12,-1.20952524741739D-13, & -1.06978278410820D-14, 5.02478557067561D-15,-8.68986130935886D-16/ DATA DBK3(1), DBK3(2), DBK3(3), DBK3(4), DBK3(5), DBK3(6), & DBK3(7), DBK3(8), DBK3(9), DBK3(10),DBK3(11),DBK3(12), & DBK3(13),DBK3(14),DBK3(15),DBK3(16),DBK3(17),DBK3(18), & DBK3(19),DBK3(20)/ 5.60598509354302D-01,-3.64870013248135D-03, & -5.98147152307417D-05,-2.33611595253625D-06,-1.64571516521436D-07, & -2.06333012920569D-08,-4.27745431573110D-09,-1.08494137799276D-09, & -2.37207188872763D-10,-2.22132920864966D-11, 1.07238008032138D-11, & 5.71954845245808D-12, 7.51102737777835D-13,-3.81912369483793D-13, & -1.75870057119257D-13, 6.69641694419084D-15, 2.26866724792055D-14, & 2.69898141356743D-15,-2.67133612397359D-15,-6.54121403165269D-16/ DATA DBK4(1), DBK4(2), DBK4(3), DBK4(4), DBK4(5), DBK4(6), & DBK4(7), DBK4(8), DBK4(9), DBK4(10),DBK4(11),DBK4(12), & DBK4(13),DBK4(14)/ 4.93072999188036D-01, 4.38335419803815D-03, & -8.37413882246205D-05, 3.20268810484632D-06,-1.75661979548270D-07, & 1.22269906524508D-08,-1.01381314366052D-09, 9.63639784237475D-11, & -1.02344993379648D-11, 1.19264576554355D-12,-1.50443899103287D-13, & 2.03299052379349D-14,-2.91890652008292D-15, 4.42322081975475D-16/ DATA DBJP(1), DBJP(2), DBJP(3), DBJP(4), DBJP(5), DBJP(6), & DBJP(7), DBJP(8), DBJP(9), DBJP(10),DBJP(11),DBJP(12), & DBJP(13),DBJP(14),DBJP(15),DBJP(16),DBJP(17),DBJP(18), & DBJP(19) / 1.13140872390745D-01,-2.08301511416328D-01, & 1.69396341953138D-02, 2.90895212478621D-02,-3.41467131311549D-03, & -1.46455339197417D-03, 1.63313272898517D-04, 3.91145328922162D-05, & -3.96757190808119D-06,-6.51846913772395D-07, 5.98707495269280D-08, & 7.44108654536549D-09,-6.21241056522632D-10,-6.18768017313526D-11, & 4.72323484752324D-12, 3.91652459802532D-13,-2.74985937845226D-14, & -1.95036497762750D-15, 1.26669643809444D-16/ DATA DBJN(1), DBJN(2), DBJN(3), DBJN(4), DBJN(5), DBJN(6), & DBJN(7), DBJN(8), DBJN(9), DBJN(10),DBJN(11),DBJN(12), & DBJN(13),DBJN(14),DBJN(15),DBJN(16),DBJN(17),DBJN(18), & DBJN(19) /-1.88091260068850D-02,-1.47798180826140D-01, & 5.46075900433171D-01, 1.52146932663116D-01,-9.58260412266886D-02, & -1.63102731696130D-02, 5.75364806680105D-03, 7.12145408252655D-04, & -1.75452116846724D-04,-1.71063171685128D-05, 3.24435580631680D-06, & 2.61190663932884D-07,-4.03026865912779D-08,-2.76435165853895D-09, & 3.59687929062312D-10, 2.14953308456051D-11,-2.41849311903901D-12, & -1.28068004920751D-13, 1.26939834401773D-14/ DATA DAA(1), DAA(2), DAA(3), DAA(4), DAA(5), DAA(6), & DAA(7), DAA(8), DAA(9), DAA(10), DAA(11), DAA(12), & DAA(13), DAA(14)/ 2.77571356944231D-01,-4.44212833419920D-03, & 8.42328522190089D-05, 2.58040318418710D-06,-3.42389720217621D-07, & 6.24286894709776D-09, 2.36377836844577D-09,-3.16991042656673D-10, & 4.40995691658191D-12, 5.18674221093575D-12,-9.64874015137022D-13, & 4.90190576608710D-14, 1.77253430678112D-14,-5.55950610442662D-15/ DATA DBB(1), DBB(2), DBB(3), DBB(4), DBB(5), DBB(6), & DBB(7), DBB(8), DBB(9), DBB(10), DBB(11), DBB(12), & DBB(13), DBB(14)/ 4.91627321104601D-01, 3.11164930427489D-03, & 8.23140762854081D-05,-4.61769776172142D-06,-6.13158880534626D-08, & 2.87295804656520D-08,-1.81959715372117D-09,-1.44752826642035D-10, & 4.53724043420422D-11,-3.99655065847223D-12,-3.24089119830323D-13, & 1.62098952568741D-13,-2.40765247974057D-14, 1.69384811284491D-16/ !***FIRST EXECUTABLE STATEMENT DYAIRY AX = ABS(X) RX = SQRT(AX) C = CON1*AX*RX if (X < 0.0D0) go to 120 if (C > 8.0D0) go to 60 if (X > 2.5D0) go to 30 T = (X+X-2.5D0)*0.4D0 TT = T + T J = N1 F1 = BK1(J) F2 = 0.0D0 DO 10 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + BK1(J) F2 = TEMP1 10 CONTINUE BI = T*F1 - F2 + BK1(1) J = N1D F1 = DBK1(J) F2 = 0.0D0 DO 20 I=1,M1D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DBK1(J) F2 = TEMP1 20 CONTINUE DBI = T*F1 - F2 + DBK1(1) return 30 CONTINUE RTRX = SQRT(RX) T = (X+X-CON2)*CON3 TT = T + T J = N1 F1 = BK2(J) F2 = 0.0D0 DO 40 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + BK2(J) F2 = TEMP1 40 CONTINUE BI = (T*F1-F2+BK2(1))/RTRX EX = EXP(C) BI = BI*EX J = N2D F1 = DBK2(J) F2 = 0.0D0 DO 50 I=1,M2D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DBK2(J) F2 = TEMP1 50 CONTINUE DBI = (T*F1-F2+DBK2(1))*RTRX DBI = DBI*EX return ! 60 CONTINUE RTRX = SQRT(RX) T = 16.0D0/C - 1.0D0 TT = T + T J = N1 F1 = BK3(J) F2 = 0.0D0 DO 70 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + BK3(J) F2 = TEMP1 70 CONTINUE S1 = T*F1 - F2 + BK3(1) J = N2D F1 = DBK3(J) F2 = 0.0D0 DO 80 I=1,M2D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DBK3(J) F2 = TEMP1 80 CONTINUE D1 = T*F1 - F2 + DBK3(1) TC = C + C EX = EXP(C) if (TC > 35.0D0) go to 110 T = 10.0D0/C - 1.0D0 TT = T + T J = N3 F1 = BK4(J) F2 = 0.0D0 DO 90 I=1,M3 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + BK4(J) F2 = TEMP1 90 CONTINUE S2 = T*F1 - F2 + BK4(1) BI = (S1+EXP(-TC)*S2)/RTRX BI = BI*EX J = N4D F1 = DBK4(J) F2 = 0.0D0 DO 100 I=1,M4D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DBK4(J) F2 = TEMP1 100 CONTINUE D2 = T*F1 - F2 + DBK4(1) DBI = RTRX*(D1+EXP(-TC)*D2) DBI = DBI*EX return 110 BI = EX*S1/RTRX DBI = EX*RTRX*D1 return ! 120 CONTINUE if (C > 5.0D0) go to 150 T = 0.4D0*C - 1.0D0 TT = T + T J = N2 F1 = BJP(J) E1 = BJN(J) F2 = 0.0D0 E2 = 0.0D0 DO 130 I=1,M2 J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + BJP(J) E1 = TT*E1 - E2 + BJN(J) F2 = TEMP1 E2 = TEMP2 130 CONTINUE BI = (T*E1-E2+BJN(1)) - AX*(T*F1-F2+BJP(1)) J = N3D F1 = DBJP(J) E1 = DBJN(J) F2 = 0.0D0 E2 = 0.0D0 DO 140 I=1,M3D J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + DBJP(J) E1 = TT*E1 - E2 + DBJN(J) F2 = TEMP1 E2 = TEMP2 140 CONTINUE DBI = X*X*(T*F1-F2+DBJP(1)) + (T*E1-E2+DBJN(1)) return ! 150 CONTINUE RTRX = SQRT(RX) T = 10.0D0/C - 1.0D0 TT = T + T J = N3 F1 = AA(J) E1 = BB(J) F2 = 0.0D0 E2 = 0.0D0 DO 160 I=1,M3 J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + AA(J) E1 = TT*E1 - E2 + BB(J) F2 = TEMP1 E2 = TEMP2 160 CONTINUE TEMP1 = T*F1 - F2 + AA(1) TEMP2 = T*E1 - E2 + BB(1) CV = C - FPI12 BI = (TEMP1*COS(CV)+TEMP2*SIN(CV))/RTRX J = N4D F1 = DAA(J) E1 = DBB(J) F2 = 0.0D0 E2 = 0.0D0 DO 170 I=1,M4D J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + DAA(J) E1 = TT*E1 - E2 + DBB(J) F2 = TEMP1 E2 = TEMP2 170 CONTINUE TEMP1 = T*F1 - F2 + DAA(1) TEMP2 = T*E1 - E2 + DBB(1) CV = C - SPI12 DBI = (TEMP1*COS(CV)-TEMP2*SIN(CV))*RTRX return end subroutine DY (U, IDMN, I, J, UYYY, UYYYY) ! !! DY is subsidiary to SEPELI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (DY-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This program computes second order finite difference ! approximations to the third and fourth Y ! partial derivatives of U at the (I,J) mesh point. ! !***SEE ALSO SEPELI !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SPLPCM !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE DY ! COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION U(IDMN,*) !***FIRST EXECUTABLE STATEMENT DY if (J > 2 .AND. J < (L-1)) go to 50 if (J == 1) go to 10 if (J == 2) go to 30 if (J == L-1) go to 60 if (J == L) go to 80 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C ! 10 if (KSWY == 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)- & 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)+ & 11.0*U(I,5)-2.0*U(I,6))/DLY4 return ! ! PERIODIC AT X=A ! 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 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C+DLY ! 30 if (KSWY == 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))/ & 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)- & U(I,6))/DLY4 return ! ! PERIODIC AT Y=C+DLY ! 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 ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR ! 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))/ & DLY4 return ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D-DLY ! 60 if (KSWY == 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)+ & 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)- & 9.0*U(I,L-1)+2.0*U(I,L))/DLY4 return ! ! PERIODIC AT Y=D-DLY ! 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))/ & DLY4 return ! ! COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D ! 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)+ & 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)- & 14.0*U(I,L-1)+3.0*U(I,L))/DLY4 return end function E1 (X) ! !! E1 computes the exponential integral E1(X). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C5 !***TYPE SINGLE PRECISION (E1-S, DE1-D) !***KEYWORDS E1 FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! E1 calculates the single precision exponential integral, E1(X), for ! positive single precision argument X and the Cauchy principal value ! for negative X. If principal values are used everywhere, then, for ! all X, ! ! E1(X) = -Ei(-X) ! or ! Ei(X) = -E1(-X). ! ! ! Series for AE11 on the interval -1.00000D-01 to 0. ! with weighted error 1.76E-17 ! log weighted error 16.75 ! significant figures required 15.70 ! decimal places required 17.55 ! ! ! Series for AE12 on the interval -2.50000D-01 to -1.00000D-01 ! with weighted error 5.83E-17 ! log weighted error 16.23 ! significant figures required 15.76 ! decimal places required 16.93 ! ! ! Series for E11 on the interval -4.00000D+00 to -1.00000D+00 ! with weighted error 1.08E-18 ! log weighted error 17.97 ! significant figures required 19.02 ! decimal places required 18.61 ! ! ! Series for E12 on the interval -1.00000D+00 to 1.00000D+00 ! with weighted error 3.15E-18 ! log weighted error 17.50 ! approx significant figures required 15.8 ! decimal places required 18.10 ! ! ! Series for AE13 on the interval 2.50000D-01 to 1.00000D+00 ! with weighted error 2.34E-17 ! log weighted error 16.63 ! significant figures required 16.14 ! decimal places required 17.33 ! ! ! Series for AE14 on the interval 0. to 2.50000D-01 ! with weighted error 5.41E-17 ! log weighted error 16.27 ! significant figures required 15.38 ! decimal places required 16.97 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891115 Modified prologue description. (WRB) ! 891115 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE E1 DIMENSION AE11CS(39), AE12CS(25), E11CS(19), E12CS(16), & AE13CS(25), AE14CS(26) LOGICAL FIRST SAVE AE11CS, AE12CS, E11CS, E12CS, AE13CS, AE14CS, & NTAE11, NTAE12, NTE11, NTE12, NTAE13, NTAE14, XMAX, FIRST DATA AE11CS( 1) / .12150323971606579E0 / DATA AE11CS( 2) / -.065088778513550150E0 / DATA AE11CS( 3) / .004897651357459670E0 / DATA AE11CS( 4) / -.000649237843027216E0 / DATA AE11CS( 5) / .000093840434587471E0 / DATA AE11CS( 6) / .000000420236380882E0 / DATA AE11CS( 7) / -.000008113374735904E0 / DATA AE11CS( 8) / .000002804247688663E0 / DATA AE11CS( 9) / .000000056487164441E0 / DATA AE11CS(10) / -.000000344809174450E0 / DATA AE11CS(11) / .000000058209273578E0 / DATA AE11CS(12) / .000000038711426349E0 / DATA AE11CS(13) / -.000000012453235014E0 / DATA AE11CS(14) / -.000000005118504888E0 / DATA AE11CS(15) / .000000002148771527E0 / DATA AE11CS(16) / .000000000868459898E0 / DATA AE11CS(17) / -.000000000343650105E0 / DATA AE11CS(18) / -.000000000179796603E0 / DATA AE11CS(19) / .000000000047442060E0 / DATA AE11CS(20) / .000000000040423282E0 / DATA AE11CS(21) / -.000000000003543928E0 / DATA AE11CS(22) / -.000000000008853444E0 / DATA AE11CS(23) / -.000000000000960151E0 / DATA AE11CS(24) / .000000000001692921E0 / DATA AE11CS(25) / .000000000000607990E0 / DATA AE11CS(26) / -.000000000000224338E0 / DATA AE11CS(27) / -.000000000000200327E0 / DATA AE11CS(28) / -.000000000000006246E0 / DATA AE11CS(29) / .000000000000045571E0 / DATA AE11CS(30) / .000000000000016383E0 / DATA AE11CS(31) / -.000000000000005561E0 / DATA AE11CS(32) / -.000000000000006074E0 / DATA AE11CS(33) / -.000000000000000862E0 / DATA AE11CS(34) / .000000000000001223E0 / DATA AE11CS(35) / .000000000000000716E0 / DATA AE11CS(36) / -.000000000000000024E0 / DATA AE11CS(37) / -.000000000000000201E0 / DATA AE11CS(38) / -.000000000000000082E0 / DATA AE11CS(39) / .000000000000000017E0 / DATA AE12CS( 1) / .58241749513472674E0 / DATA AE12CS( 2) / -.15834885090578275E0 / DATA AE12CS( 3) / -.006764275590323141E0 / DATA AE12CS( 4) / .005125843950185725E0 / DATA AE12CS( 5) / .000435232492169391E0 / DATA AE12CS( 6) / -.000143613366305483E0 / DATA AE12CS( 7) / -.000041801320556301E0 / DATA AE12CS( 8) / -.000002713395758640E0 / DATA AE12CS( 9) / .000001151381913647E0 / DATA AE12CS(10) / .000000420650022012E0 / DATA AE12CS(11) / .000000066581901391E0 / DATA AE12CS(12) / .000000000662143777E0 / DATA AE12CS(13) / -.000000002844104870E0 / DATA AE12CS(14) / -.000000000940724197E0 / DATA AE12CS(15) / -.000000000177476602E0 / DATA AE12CS(16) / -.000000000015830222E0 / DATA AE12CS(17) / .000000000002905732E0 / DATA AE12CS(18) / .000000000001769356E0 / DATA AE12CS(19) / .000000000000492735E0 / DATA AE12CS(20) / .000000000000093709E0 / DATA AE12CS(21) / .000000000000010707E0 / DATA AE12CS(22) / -.000000000000000537E0 / DATA AE12CS(23) / -.000000000000000716E0 / DATA AE12CS(24) / -.000000000000000244E0 / DATA AE12CS(25) / -.000000000000000058E0 / DATA E11CS( 1) / -16.113461655571494026E0 / DATA E11CS( 2) / 7.7940727787426802769E0 / DATA E11CS( 3) / -1.9554058188631419507E0 / DATA E11CS( 4) / .37337293866277945612E0 / DATA E11CS( 5) / -.05692503191092901938E0 / DATA E11CS( 6) / .00721107776966009185E0 / DATA E11CS( 7) / -.00078104901449841593E0 / DATA E11CS( 8) / .00007388093356262168E0 / DATA E11CS( 9) / -.00000620286187580820E0 / DATA E11CS(10) / .00000046816002303176E0 / DATA E11CS(11) / -.00000003209288853329E0 / DATA E11CS(12) / .00000000201519974874E0 / DATA E11CS(13) / -.00000000011673686816E0 / DATA E11CS(14) / .00000000000627627066E0 / DATA E11CS(15) / -.00000000000031481541E0 / DATA E11CS(16) / .00000000000001479904E0 / DATA E11CS(17) / -.00000000000000065457E0 / DATA E11CS(18) / .00000000000000002733E0 / DATA E11CS(19) / -.00000000000000000108E0 / DATA E12CS( 1) / -0.037390214792202795E0 / DATA E12CS( 2) / 0.042723986062209577E0 / DATA E12CS( 3) / -.1303182079849700544E0 / DATA E12CS( 4) / .01441912402469889073E0 / DATA E12CS( 5) / -.00134617078051068022E0 / DATA E12CS( 6) / .00010731029253063780E0 / DATA E12CS( 7) / -.00000742999951611943E0 / DATA E12CS( 8) / .00000045377325690753E0 / DATA E12CS( 9) / -.00000002476417211390E0 / DATA E12CS(10) / .00000000122076581374E0 / DATA E12CS(11) / -.00000000005485141480E0 / DATA E12CS(12) / .00000000000226362142E0 / DATA E12CS(13) / -.00000000000008635897E0 / DATA E12CS(14) / .00000000000000306291E0 / DATA E12CS(15) / -.00000000000000010148E0 / DATA E12CS(16) / .00000000000000000315E0 / DATA AE13CS( 1) / -.60577324664060346E0 / DATA AE13CS( 2) / -.11253524348366090E0 / DATA AE13CS( 3) / .013432266247902779E0 / DATA AE13CS( 4) / -.001926845187381145E0 / DATA AE13CS( 5) / .000309118337720603E0 / DATA AE13CS( 6) / -.000053564132129618E0 / DATA AE13CS( 7) / .000009827812880247E0 / DATA AE13CS( 8) / -.000001885368984916E0 / DATA AE13CS( 9) / .000000374943193568E0 / DATA AE13CS(10) / -.000000076823455870E0 / DATA AE13CS(11) / .000000016143270567E0 / DATA AE13CS(12) / -.000000003466802211E0 / DATA AE13CS(13) / .000000000758754209E0 / DATA AE13CS(14) / -.000000000168864333E0 / DATA AE13CS(15) / .000000000038145706E0 / DATA AE13CS(16) / -.000000000008733026E0 / DATA AE13CS(17) / .000000000002023672E0 / DATA AE13CS(18) / -.000000000000474132E0 / DATA AE13CS(19) / .000000000000112211E0 / DATA AE13CS(20) / -.000000000000026804E0 / DATA AE13CS(21) / .000000000000006457E0 / DATA AE13CS(22) / -.000000000000001568E0 / DATA AE13CS(23) / .000000000000000383E0 / DATA AE13CS(24) / -.000000000000000094E0 / DATA AE13CS(25) / .000000000000000023E0 / DATA AE14CS( 1) / -.1892918000753017E0 / DATA AE14CS( 2) / -.08648117855259871E0 / DATA AE14CS( 3) / .00722410154374659E0 / DATA AE14CS( 4) / -.00080975594575573E0 / DATA AE14CS( 5) / .00010999134432661E0 / DATA AE14CS( 6) / -.00001717332998937E0 / DATA AE14CS( 7) / .00000298562751447E0 / DATA AE14CS( 8) / -.00000056596491457E0 / DATA AE14CS( 9) / .00000011526808397E0 / DATA AE14CS(10) / -.00000002495030440E0 / DATA AE14CS(11) / .00000000569232420E0 / DATA AE14CS(12) / -.00000000135995766E0 / DATA AE14CS(13) / .00000000033846628E0 / DATA AE14CS(14) / -.00000000008737853E0 / DATA AE14CS(15) / .00000000002331588E0 / DATA AE14CS(16) / -.00000000000641148E0 / DATA AE14CS(17) / .00000000000181224E0 / DATA AE14CS(18) / -.00000000000052538E0 / DATA AE14CS(19) / .00000000000015592E0 / DATA AE14CS(20) / -.00000000000004729E0 / DATA AE14CS(21) / .00000000000001463E0 / DATA AE14CS(22) / -.00000000000000461E0 / DATA AE14CS(23) / .00000000000000148E0 / DATA AE14CS(24) / -.00000000000000048E0 / DATA AE14CS(25) / .00000000000000016E0 / DATA AE14CS(26) / -.00000000000000005E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT E1 if (FIRST) THEN ETA = 0.1*R1MACH(3) NTAE11 = INITS (AE11CS, 39, ETA) NTAE12 = INITS (AE12CS, 25, ETA) NTE11 = INITS (E11CS, 19, ETA) NTE12 = INITS (E12CS, 16, ETA) NTAE13 = INITS (AE13CS, 25, ETA) NTAE14 = INITS (AE14CS, 26, ETA) ! XMAXT = -LOG (R1MACH(1)) XMAX = XMAXT - LOG(XMAXT) end if FIRST = .FALSE. ! if (X > (-10.)) go to 20 ! ! E1(X) = -EI(-X) FOR X <= -10. ! E1 = EXP(-X)/X * (1.+CSEVL (20./X+1., AE11CS, NTAE11)) return ! 20 if (X > (-4.0)) go to 30 ! ! E1(X) = -EI(-X) FOR -10. < X <= -4. ! E1 = EXP(-X)/X * (1.+CSEVL ((40./X+7.)/3., AE12CS, NTAE12)) return ! 30 if (X > (-1.0)) go to 40 ! ! E1(X) = -EI(-X) FOR -4. < X <= -1. ! E1 = -LOG(ABS(X)) + CSEVL ((2.*X+5.)/3., E11CS, NTE11) return ! 40 if (X > 1.) go to 50 if (X == 0.) call XERMSG ('SLATEC', 'E1', 'X IS 0', 2, 2) ! ! E1(X) = -EI(-X) FOR -1. < X <= 1., X /= 0. ! E1 = (-LOG(ABS(X)) - 0.6875 + X) + CSEVL (X, E12CS, NTE12) return ! 50 if (X > 4.) go to 60 ! ! E1(X) = -EI(-X) FOR 1. < X <= 4. ! E1 = EXP(-X)/X * (1.+CSEVL ((8./X-5.)/3., AE13CS, NTAE13)) return ! 60 if (X > XMAX) go to 70 ! ! E1(X) = -EI(-X) FOR 4. < X <= XMAX ! E1 = EXP(-X)/X * (1. + CSEVL (8./X-1., AE14CS, NTAE14)) return ! ! E1(X) = -EI(-X) FOR X > XMAX ! 70 call XERMSG ('SLATEC', 'E1', 'X SO BIG E1 UNDERFLOWS', 1, 1) E1 = 0. return ! end subroutine EFC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, & MDEIN, MDEOUT, COEFF, LW, W) ! !! EFC fits a piecewise polynomial curve to discrete data. ! ! The piecewise polynomials are represented as B-splines. ! The fitting is done in a weighted least squares sense. !***LIBRARY SLATEC !***CATEGORY K1A1A1, K1A2A, L8A3 !***TYPE SINGLE PRECISION (EFC-S, DEFC-D) !***KEYWORDS B-SPLINE, CURVE FITTING, WEIGHTED LEAST SQUARES !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! This subprogram fits a piecewise polynomial curve ! to discrete data. The piecewise polynomials are ! represented as B-splines. ! The fitting is done in a weighted least squares sense. ! ! The data can be processed in groups of modest size. ! The size of the group is chosen by the user. This feature ! may be necessary for purposes of using constrained curve fitting ! with subprogram FC( ) on a very large data set. ! ! For a description of the B-splines and usage instructions to ! evaluate them, see ! ! C. W. de Boor, Package for Calculating with B-Splines. ! SIAM J. Numer. Anal., p. 441, (June, 1977). ! ! For further discussion of (constrained) curve fitting using ! B-splines, see ! ! R. J. Hanson, Constrained Least Squares Curve Fitting ! to Discrete Data Using B-Splines, a User's ! Guide. Sandia Labs. Tech. Rept. SAND-78-1291, ! December, (1978). ! ! Input.. ! NDATA,XDATA(*), ! YDATA(*), ! SDDATA(*) ! The NDATA discrete (X,Y) pairs and the Y value ! standard deviation or uncertainty, SD, are in ! the respective arrays XDATA(*), YDATA(*), and ! SDDATA(*). No sorting of XDATA(*) is ! required. Any non-negative value of NDATA is ! allowed. A negative value of NDATA is an ! error. A zero value for any entry of ! SDDATA(*) will weight that data point as 1. ! Otherwise the weight of that data point is ! the reciprocal of this entry. ! ! NORD,NBKPT, ! BKPT(*) ! The NBKPT knots of the B-spline of order NORD ! are in the array BKPT(*). Normally the ! problem data interval will be included between ! the limits BKPT(NORD) and BKPT(NBKPT-NORD+1). ! The additional end knots BKPT(I),I=1,..., ! NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are ! required to compute the functions used to fit ! the data. No sorting of BKPT(*) is required. ! Internal to EFC( ) the extreme end knots may ! be reduced and increased respectively to ! accommodate any data values that are exterior ! to the given knot values. The contents of ! BKPT(*) is not changed. ! ! NORD must be in the range 1 <= NORD <= 20. ! The value of NBKPT must satisfy the condition ! NBKPT >= 2*NORD. ! Other values are considered errors. ! ! (The order of the spline is one more than the ! degree of the piecewise polynomial defined on ! each interval. This is consistent with the ! B-spline package convention. For example, ! NORD=4 when we are using piecewise cubics.) ! ! MDEIN ! An integer flag, with one of two possible ! values (1 or 2), that directs the subprogram ! action with regard to new data points provided ! by the user. ! ! =1 The first time that EFC( ) has been ! entered. There are NDATA points to process. ! ! =2 This is another entry to EFC( ). The sub- ! program EFC( ) has been entered with MDEIN=1 ! exactly once before for this problem. There ! are NDATA new additional points to merge and ! process with any previous points. ! (When using EFC( ) with MDEIN=2 it is import- ! ant that the set of knots remain fixed at the ! same values for all entries to EFC( ).) ! LW ! The amount of working storage actually ! allocated for the working array W(*). ! This quantity is compared with the ! actual amount of storage needed in EFC( ). ! Insufficient storage allocated for W(*) is ! an error. This feature was included in EFC( ) ! because misreading the storage formula ! for W(*) might very well lead to subtle ! and hard-to-find programming bugs. ! ! The length of the array W(*) must satisfy ! ! LW >= (NBKPT-NORD+3)*(NORD+1)+ ! (NBKPT+1)*(NORD+1)+ ! 2*MAX(NDATA,NBKPT)+NBKPT+NORD**2 ! ! Output.. ! MDEOUT ! An output flag that indicates the status ! of the curve fit. ! ! =-1 A usage error of EFC( ) occurred. The ! offending condition is noted with the SLATEC ! library error processor, XERMSG( ). In case ! the working array W(*) is not long enough, the ! minimal acceptable length is printed. ! ! =1 The B-spline coefficients for the fitted ! curve have been returned in array COEFF(*). ! ! =2 Not enough data has been processed to ! determine the B-spline coefficients. ! The user has one of two options. Continue ! to process more data until a unique set ! of coefficients is obtained, or use the ! subprogram FC( ) to obtain a specific ! set of coefficients. The user should read ! the usage instructions for FC( ) for further ! details if this second option is chosen. ! COEFF(*) ! If the output value of MDEOUT=1, this array ! contains the unknowns obtained from the least ! squares fitting process. These N=NBKPT-NORD ! parameters are the B-spline coefficients. ! For MDEOUT=2, not enough data was processed to ! uniquely determine the B-spline coefficients. ! In this case, and also when MDEOUT=-1, all ! values of COEFF(*) are set to zero. ! ! If the user is not satisfied with the fitted ! curve returned by EFC( ), the constrained ! least squares curve fitting subprogram FC( ) ! may be required. The work done within EFC( ) ! to accumulate the data can be utilized by ! the user, if so desired. This involves ! saving the first (NBKPT-NORD+3)*(NORD+1) ! entries of W(*) and providing this data ! to FC( ) with the "old problem" designation. ! The user should read the usage instructions ! for subprogram FC( ) for further details. ! ! Working Array.. ! W(*) ! This array is typed REAL. ! Its length is specified as an input parameter ! in LW as noted above. The contents of W(*) ! must not be modified by the user between calls ! to EFC( ) with values of MDEIN=1,2,2,... . ! The first (NBKPT-NORD+3)*(NORD+1) entries of ! W(*) are acceptable as direct input to FC( ) ! for an "old problem" only when MDEOUT=1 or 2. ! ! Evaluating the ! Fitted Curve.. ! To evaluate derivative number IDER at XVAL, ! use the function subprogram BVALU( ). ! ! F = BVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER, ! XVAL,INBV,WORKB) ! ! The output of this subprogram will not be ! defined unless an output value of MDEOUT=1 ! was obtained from EFC( ), XVAL is in the data ! interval, and IDER is nonnegative and < ! NORD. ! ! The first time BVALU( ) is called, INBV=1 ! must be specified. This value of INBV is the ! overwritten by BVALU( ). The array WORKB(*) ! must be of length at least 3*NORD, and must ! not be the same as the W(*) array used in the ! call to EFC( ). ! ! BVALU( ) expects the breakpoint array BKPT(*) ! to be sorted. ! !***REFERENCES R. J. Hanson, Constrained least squares curve fitting ! to discrete data using B-splines, a users guide, ! Report SAND78-1291, Sandia Laboratories, December ! 1978. !***ROUTINES CALLED EFCMN !***REVISION HISTORY (YYMMDD) ! 800801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Change Prologue comments to refer to XERMSG. (RWC) ! 900607 Editorial changes to Prologue to make Prologues for EFC, ! DEFC, FC, and DFC look as much the same as possible. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE EFC ! ! SUBROUTINE FUNCTION/REMARKS ! ! BSPLVN( ) COMPUTE FUNCTION VALUES OF B-SPLINES. FROM ! THE B-SPLINE PACKAGE OF DE BOOR NOTED ABOVE. ! ! BNDACC( ), BANDED LEAST SQUARES MATRIX PROCESSORS. ! BNDSOL( ) FROM LAWSON-HANSON, SOLVING LEAST ! SQUARES PROBLEMS. ! ! SSORT( ) DATA SORTING SUBROUTINE, FROM THE ! SANDIA MATH. LIBRARY, SAND77-1441. ! ! XERMSG( ) ERROR HANDLING ROUTINE ! FOR THE SLATEC MATH. LIBRARY. ! SEE SAND78-1189, BY R. E. JONES. ! ! SCOPY( ),SSCAL( ) SUBROUTINES FROM THE BLAS PACKAGE. ! ! WRITTEN BY R. HANSON, SANDIA NATL. LABS., ! ALB., N. M., AUGUST-SEPTEMBER, 1980. ! REAL BKPT(*),COEFF(*),SDDATA(*),W(*),XDATA(*),YDATA(*) INTEGER LW, MDEIN, MDEOUT, NBKPT, NDATA, NORD ! EXTERNAL EFCMN ! INTEGER LBF, LBKPT, LG, LPTEMP, LWW, LXTEMP, MDG, MDW ! !***FIRST EXECUTABLE STATEMENT EFC ! LWW=1 USAGE IN EFCMN( ) OF W(*).. ! LWW,...,LG-1 W(*,*) ! ! LG,...,LXTEMP-1 G(*,*) ! ! LXTEMP,...,LPTEMP-1 XTEMP(*) ! ! LPTEMP,...,LBKPT-1 PTEMP(*) ! ! LBKPT,...,LBF BKPT(*) (LOCAL TO EFCMN( )) ! ! LBF,...,LBF+NORD**2 BF(*,*) ! MDG = NBKPT+1 MDW = NBKPT-NORD+3 LWW = 1 LG = LWW + MDW*(NORD+1) LXTEMP = LG + MDG*(NORD+1) LPTEMP = LXTEMP + MAX(NDATA,NBKPT) LBKPT = LPTEMP + MAX(NDATA,NBKPT) LBF = LBKPT + NBKPT call EFCMN(NDATA,XDATA,YDATA,SDDATA, & NORD,NBKPT,BKPT, & MDEIN,MDEOUT, & COEFF, & W(LBF),W(LXTEMP),W(LPTEMP),W(LBKPT), & W(LG),MDG,W(LWW),MDW,LW) return end subroutine EFCMN (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, & BKPTIN, MDEIN, MDEOUT, COEFF, BF, XTEMP, PTEMP, BKPT, G, MDG, & W, MDW, LW) ! !! EFCMN is subsidiary to EFC. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (EFCMN-S, DEFCMN-D) !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! This is a companion subprogram to EFC( ). ! This subprogram does weighted least squares fitting of data by ! B-spline curves. ! The documentation for EFC( ) has complete usage instructions. ! !***SEE ALSO EFC !***ROUTINES CALLED BNDACC, BNDSOL, BSPLVN, SCOPY, SSCAL, SSORT, XERMSG !***REVISION HISTORY (YYMMDD) ! 800801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and extensively revised (WRB & RWC) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE EFCMN INTEGER LW, MDEIN, MDEOUT, MDG, MDW, NBKPT, NDATA, NORD REAL BF(NORD,*), BKPT(*), BKPTIN(*), COEFF(*), & G(MDG,*), PTEMP(*), SDDATA(*), W(MDW,*), XDATA(*), XTEMP(*), & YDATA(*) ! EXTERNAL BNDACC, BNDSOL, BSPLVN, SCOPY, SSCAL, SSORT, XERMSG ! REAL DUMMY, RNORM, XMAX, XMIN, XVAL INTEGER I, IDATA, ILEFT, INTSEQ, IP, IR, IROW, L, MT, N, NB, & NORDM1, NORDP1, NP1 CHARACTER*8 XERN1, XERN2 ! !***FIRST EXECUTABLE STATEMENT EFCMN ! ! Initialize variables and analyze input. ! N = NBKPT - NORD NP1 = N + 1 ! ! Initially set all output coefficients to zero. ! call SCOPY (N, 0.E0, 0, COEFF, 1) MDEOUT = -1 if (NORD < 1 .OR. NORD > 20) THEN call XERMSG ('SLATEC', 'EFCMN', & 'IN EFC, THE ORDER OF THE B-SPLINE MUST BE 1 THRU 20.', & 3, 1) return end if ! if (NBKPT < 2*NORD) THEN call XERMSG ('SLATEC', 'EFCMN', & 'IN EFC, THE NUMBER OF KNOTS MUST BE AT LEAST TWICE ' // & 'THE B-SPLINE ORDER.', 4, 1) return end if ! if (NDATA < 0) THEN call XERMSG ('SLATEC', 'EFCMN', & 'IN EFC, THE NUMBER OF DATA POINTS MUST BE NONNEGATIVE.', & 5, 1) return end if ! NB = (NBKPT-NORD+3)*(NORD+1) + (NBKPT+1)*(NORD+1) + & 2*MAX(NBKPT,NDATA) + NBKPT + NORD**2 if (LW < NB) THEN WRITE (XERN1, '(I8)') NB WRITE (XERN2, '(I8)') LW call XERMSG ('SLATEC', 'EFCMN', & 'IN EFC, INSUFFICIENT STORAGE FOR W(*). CHECK FORMULA ' // & 'THAT READS LW >= ... . NEED = ' // XERN1 // & ' GIVEN = ' // XERN2, 6, 1) MDEOUT = -1 return end if ! if (MDEIN /= 1 .AND. MDEIN /= 2) THEN call XERMSG ('SLATEC', 'EFCMN', & 'IN EFC, INPUT VALUE OF MDEIN MUST BE 1-2.', 7, 1) return end if ! ! Sort the breakpoints. ! call SCOPY (NBKPT, BKPTIN, 1, BKPT, 1) call SSORT (BKPT, DUMMY, NBKPT, 1) ! ! Save interval containing knots. ! XMIN = BKPT(NORD) XMAX = BKPT(NP1) NORDM1 = NORD - 1 NORDP1 = NORD + 1 ! ! Process least squares equations. ! ! Sort data and an array of pointers. ! call SCOPY (NDATA, XDATA, 1, XTEMP, 1) DO 100 I = 1,NDATA PTEMP(I) = I 100 CONTINUE ! if (NDATA > 0) THEN call SSORT (XTEMP, PTEMP, NDATA, 2) XMIN = MIN(XMIN,XTEMP(1)) XMAX = MAX(XMAX,XTEMP(NDATA)) end if ! ! Fix breakpoint array if needed. This should only involve very ! minor differences with the input array of breakpoints. ! DO 110 I = 1,NORD BKPT(I) = MIN(BKPT(I),XMIN) 110 CONTINUE ! DO 120 I = NP1,NBKPT BKPT(I) = MAX(BKPT(I),XMAX) 120 CONTINUE ! ! Initialize parameters of banded matrix processor, BNDACC( ). ! MT = 0 IP = 1 IR = 1 ILEFT = NORD INTSEQ = 1 DO 150 IDATA = 1,NDATA ! ! Sorted indices are in PTEMP(*). ! L = PTEMP(IDATA) XVAL = XDATA(L) ! ! When interval changes, process equations in the last block. ! if (XVAL >= BKPT(ILEFT+1)) THEN call BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) MT = 0 ! ! Move pointer up to have BKPT(ILEFT) <= XVAL, ILEFT <= N. ! DO 130 ILEFT = ILEFT,N if (XVAL < BKPT(ILEFT+1)) go to 140 if (MDEIN == 2) THEN ! ! Data is being sequentially accumulated. ! Transfer previously accumulated rows from W(*,*) to ! G(*,*) and process them. ! call SCOPY (NORDP1, W(INTSEQ,1), MDW, G(IR,1), MDG) call BNDACC (G, MDG, NORD, IP, IR, 1, INTSEQ) INTSEQ = INTSEQ + 1 ENDIF 130 CONTINUE ENDIF ! ! Obtain B-spline function value. ! 140 call BSPLVN (BKPT, NORD, 1, XVAL, ILEFT, BF) ! ! Move row into place. ! IROW = IR + MT MT = MT + 1 call SCOPY (NORD, BF, 1, G(IROW,1), MDG) G(IROW,NORDP1) = YDATA(L) ! ! Scale data if uncertainty is nonzero. ! if (SDDATA(L) /= 0.E0) call SSCAL (NORDP1, 1.E0/SDDATA(L), & G(IROW,1), MDG) ! ! When staging work area is exhausted, process rows. ! if (IROW == MDG-1) THEN call BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) MT = 0 ENDIF 150 CONTINUE ! ! Process last block of equations. ! call BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) ! ! Finish processing any previously accumulated rows from W(*,*) ! to G(*,*). ! if (MDEIN == 2) THEN DO 160 I = INTSEQ,NP1 call SCOPY (NORDP1, W(I,1), MDW, G(IR,1), MDG) call BNDACC (G, MDG, NORD, IP, IR, 1, MIN(N,I)) 160 CONTINUE end if ! ! Last call to adjust block positioning. ! call SCOPY (NORDP1, 0.E0, 0, G(IR,1), MDG) call BNDACC (G, MDG, NORD, IP, IR, 1, NP1) ! ! Transfer accumulated rows from G(*,*) to W(*,*) for ! possible later sequential accumulation. ! DO 170 I = 1,NP1 call SCOPY (NORDP1, G(I,1), MDG, W(I,1), MDW) 170 CONTINUE ! ! Solve for coefficients when possible. ! DO 180 I = 1,N if (G(I,1) == 0.E0) THEN MDEOUT = 2 return ENDIF 180 CONTINUE ! ! All the diagonal terms in the accumulated triangular ! matrix are nonzero. The solution can be computed but ! it may be unsuitable for further use due to poor ! conditioning or the lack of constraints. No checking ! for either of these is done here. ! call BNDSOL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM) MDEOUT = 1 return end function EI (X) ! !! EI computes the exponential integral Ei(X). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C5 !***TYPE SINGLE PRECISION (EI-S, DEI-D) !***KEYWORDS EI FUNCTION, EXPONENTIAL INTEGRAL, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! EI calculates the single precision exponential integral, Ei(X), for ! positive single precision argument X and the Cauchy principal value ! for negative X. If principal values are used everywhere, then, for ! all X, ! ! Ei(X) = -E1(-X) ! or ! E1(X) = -Ei(-X). ! !***REFERENCES (NONE) !***ROUTINES CALLED E1 !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 891115 Modified prologue description. (WRB) ! 891115 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE EI !***FIRST EXECUTABLE STATEMENT EI EI = -E1(-X) ! return end subroutine EISDOC ! !! EISDOC contains documentation for EISPACK, a collection of subprograms ... ! for solving matrix eigen-problems. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4, Z !***TYPE ALL (EISDOC-A) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Vandevender, W. H., (SNLA) !***DESCRIPTION ! ! **********EISPACK Routines********** ! ! single double complx ! ------ ------ ------ ! ! RS - CH Computes eigenvalues and, optionally, ! eigenvectors of real symmetric ! (complex Hermitian) matrix. ! ! RSP - - Compute eigenvalues and, optionally, ! eigenvectors of real symmetric matrix ! packed into a one dimensional array. ! ! RG - CG Computes eigenvalues and, optionally, ! eigenvectors of a real (complex) general ! matrix. ! ! BISECT - - Compute eigenvalues of symmetric tridiagonal ! matrix given interval using Sturm sequencing. ! ! IMTQL1 - - Computes eigenvalues of symmetric tridiagonal ! matrix implicit QL method. ! ! IMTQL2 - - Computes eigenvalues and eigenvectors of ! symmetric tridiagonal matrix using ! implicit QL method. ! ! IMTQLV - - Computes eigenvalues of symmetric tridiagonal ! matrix by the implicit QL method. ! Eigenvectors may be computed later. ! ! RATQR - - Computes largest or smallest eigenvalues ! of symmetric tridiagonal matrix using ! rational QR method with Newton correction. ! ! RST - - Compute eigenvalues and, optionally, ! eigenvectors of real symmetric tridiagonal ! matrix. ! ! RT - - Compute eigenvalues and eigenvectors of ! a special real tridiagonal matrix. ! ! TQL1 - - Compute eigenvalues of symmetric tridiagonal ! matrix by QL method. ! ! TQL2 - - Compute eigenvalues and eigenvectors ! of symmetric tridiagonal matrix. ! ! TQLRAT - - Computes eigenvalues of symmetric ! tridiagonal matrix a rational variant ! of the QL method. ! ! TRIDIB - - Computes eigenvalues of symmetric ! tridiagonal matrix given interval using ! Sturm sequencing. ! ! TSTURM - - Computes eigenvalues of symmetric tridiagonal ! matrix given interval and eigenvectors ! by Sturm sequencing. This subroutine ! is a translation of the ALGOL procedure ! TRISTURM by Peters and Wilkinson. HANDBOOK ! FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, ! 418-439(1971). ! ! BQR - - Computes some of the eigenvalues of a real ! symmetric matrix using the QR method with ! shifts of origin. ! ! RSB - - Computes eigenvalues and, optionally, ! eigenvectors of symmetric band matrix. ! ! RSG - - Computes eigenvalues and, optionally, ! eigenvectors of symmetric generalized ! eigenproblem: A*X=(LAMBDA)*B*X ! ! RSGAB - - Computes eigenvalues and, optionally, ! eigenvectors of symmetric generalized ! eigenproblem: A*B*X=(LAMBDA)*X ! ! RSGBA - - Computes eigenvalues and, optionally, ! eigenvectors of symmetric generalized ! eigenproblem: B*A*X=(LAMBDA)*X ! ! RGG - - Computes eigenvalues and eigenvectors ! for real generalized eigenproblem: ! A*X=(LAMBDA)*B*X. ! ! BALANC - CBAL Balances a general real (complex) ! matrix and isolates eigenvalues whenever ! possible. ! ! BANDR - - Reduces real symmetric band matrix ! to symmetric tridiagonal matrix and, ! optionally, accumulates orthogonal similarity ! transformations. ! ! HTRID3 - - Reduces complex Hermitian (packed) matrix ! to real symmetric tridiagonal matrix by unitary ! similarity transformations. ! ! HTRIDI - - Reduces complex Hermitian matrix to real ! symmetric tridiagonal matrix using unitary ! similarity transformations. ! ! TRED1 - - Reduce real symmetric matrix to symmetric ! tridiagonal matrix using orthogonal ! similarity transformations. ! ! TRED2 - - Reduce real symmetric matrix to symmetric ! tridiagonal matrix using and accumulating ! orthogonal transformations. ! ! TRED3 - - Reduce symmetric matrix stored in packed ! form to symmetric tridiagonal matrix using ! orthogonal transformations. ! ! ELMHES - COMHES Reduces real (complex) general matrix to ! upper Hessenberg form using stabilized ! elementary similarity transformations. ! ! ORTHES - CORTH Reduces real (complex) general matrix to upper ! Hessenberg form orthogonal (unitary) ! similarity transformations. ! ! QZHES - - The first step of the QZ algorithm for solving ! generalized matrix eigenproblems. Accepts ! a pair of real general matrices and reduces ! one of them to upper Hessenberg and the other ! to upper triangular form using orthogonal ! transformations. Usually followed by QZIT, ! QZVAL, QZ ! ! QZIT - - The second step of the QZ algorithm for ! generalized eigenproblems. Accepts an upper ! Hessenberg and an upper triangular matrix ! and reduces the former to quasi-triangular ! form while preserving the form of the latter. ! Usually preceded by QZHES and followed by QZVAL ! and QZVEC. ! ! FIGI - - Transforms certain real non-symmetric ! tridiagonal matrix to symmetric tridiagonal ! matrix. ! ! FIGI2 - - Transforms certain real non-symmetric ! tridiagonal matrix to symmetric tridiagonal ! matrix. ! ! REDUC - - Reduces generalized symmetric eigenproblem ! A*X=(LAMBDA)*B*X, to standard symmetric ! eigenproblem using Cholesky factorization. ! ! REDUC2 - - Reduces certain generalized symmetric ! eigenproblems standard symmetric eigenproblem, ! using Cholesky factorization. ! ! - - COMLR Computes eigenvalues of a complex upper ! Hessenberg matrix using the modified LR method. ! ! - - COMLR2 Computes eigenvalues and eigenvectors of ! complex upper Hessenberg matrix using ! modified LR method. ! ! HQR - COMQR Computes eigenvalues of a real (complex) ! upper Hessenberg matrix using the QR method. ! ! HQR2 - COMQR2 Computes eigenvalues and eigenvectors of ! real (complex) upper Hessenberg matrix ! using QR method. ! ! INVIT - CINVIT Computes eigenvectors of real (complex) ! Hessenberg matrix associated with specified ! eigenvalues by inverse iteration. ! ! QZVAL - - The third step of the QZ algorithm for ! generalized eigenproblems. Accepts a pair ! of real matrices, one quasi-triangular form ! and the other in upper triangular form and ! computes the eigenvalues of the associated ! eigenproblem. Usually preceded by QZHES, ! QZIT, and followed by QZVEC. ! ! BANDV - - Forms eigenvectors of real symmetric band ! matrix associated with a set of ordered ! approximate eigenvalue by inverse iteration. ! ! QZVEC - - The optional fourth step of the QZ algorithm ! for generalized eigenproblems. Accepts ! a matrix in quasi-triangular form and another ! in upper triangular and computes the ! eigenvectors of the triangular problem ! and transforms them back to the original ! coordinates Usually preceded by QZHES, QZIT, ! QZVAL. ! ! TINVIT - - Eigenvectors of symmetric tridiagonal ! matrix corresponding to some specified ! eigenvalues, using inverse iteration. ! ! BAKVEC - - Forms eigenvectors of certain real ! non-symmetric tridiagonal matrix from ! symmetric tridiagonal matrix output from FIGI. ! ! BALBAK - CBABK2 Forms eigenvectors of real (complex) general ! matrix from eigenvectors of matrix output ! from BALANC (CBAL). ! ! ELMBAK - COMBAK Forms eigenvectors of real (complex) general ! matrix from eigenvectors of upper Hessenberg ! matrix output from ELMHES (COMHES). ! ! ELTRAN - - Accumulates the stabilized elementary ! similarity transformations used in the ! reduction of a real general matrix to upper ! Hessenberg form by ELMHES. ! ! HTRIB3 - - Computes eigenvectors of complex Hermitian ! matrix from eigenvectors of real symmetric ! tridiagonal matrix output from HTRID3. ! ! HTRIBK - - Forms eigenvectors of complex Hermitian ! matrix from eigenvectors of real symmetric ! tridiagonal matrix output from HTRIDI. ! ! ORTBAK - CORTB Forms eigenvectors of general real (complex) ! matrix from eigenvectors of upper Hessenberg ! matrix output from ORTHES (CORTH). ! ! ORTRAN - - Accumulates orthogonal similarity ! transformations in reduction of real general ! matrix by ORTHES. ! ! REBAK - - Forms eigenvectors of generalized symmetric ! eigensystem from eigenvectors of derived ! matrix output from REDUC or REDUC2. ! ! REBAKB - - Forms eigenvectors of generalized symmetric ! eigensystem from eigenvectors of derived ! matrix output from REDUC2 ! ! TRBAK1 - - Forms the eigenvectors of real symmetric ! matrix from eigenvectors of symmetric ! tridiagonal matrix formed by TRED1. ! ! TRBAK3 - - Forms eigenvectors of real symmetric matrix ! from the eigenvectors of symmetric tridiagonal ! matrix formed by TRED3. ! ! MINFIT - - Compute Singular Value Decomposition ! of rectangular matrix and solve related ! Linear Least Squares problem. ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811101 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900723 PURPOSE section revised. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE EISDOC !***FIRST EXECUTABLE STATEMENT EISDOC return end subroutine ELMBAK (NM, LOW, IGH, A, INT, M, Z) ! !! ELMBAK forms the eigenvectors of a real general matrix from the ... ! eigenvectors of the upper Hessenberg matrix output from ELMHES. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (ELMBAK-S, COMBAK-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure ELMBAK, ! NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). ! ! This subroutine forms the eigenvectors of a REAL GENERAL ! matrix by back transforming those of the corresponding ! upper Hessenberg matrix determined by ELMHES. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine BALANC. If BALANC has not been ! used, set LOW=1 and IGH equal to the order of the matrix. ! ! A contains the multipliers which were used in the reduction ! by ELMHES in its lower triangle below the subdiagonal. ! A is a two-dimensional REAL array, dimensioned A(NM,IGH). ! ! INT contains information on the rows and columns interchanged ! in the reduction by ELMHES. Only elements LOW through IGH ! are used. INT is a one-dimensional INTEGER array, ! dimensioned INT(IGH). ! ! M is the number of columns of Z to be back transformed. ! M is an INTEGER variable. ! ! Z contains the real and imaginary parts of the eigenvectors ! to be back transformed in its first M columns. Z is a ! two-dimensional REAL array, dimensioned Z(NM,M). ! ! On OUTPUT ! ! Z contains the real and imaginary parts of the transformed ! eigenvectors in its first M columns. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ELMBAK ! INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 REAL A(NM,*),Z(NM,*) REAL X INTEGER INT(*) ! !***FIRST EXECUTABLE STATEMENT ELMBAK if (M == 0) go to 200 LA = IGH - 1 KP1 = LOW + 1 if (LA < KP1) go to 200 ! .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = KP1, LA MP = LOW + IGH - MM MP1 = MP + 1 ! DO 110 I = MP1, IGH X = A(I,MP-1) if (X == 0.0E0) go to 110 ! DO 100 J = 1, M 100 Z(I,J) = Z(I,J) + X * Z(MP,J) ! 110 CONTINUE ! I = INT(MP) if (I == MP) go to 140 ! DO 130 J = 1, M X = Z(I,J) Z(I,J) = Z(MP,J) Z(MP,J) = X 130 CONTINUE ! 140 CONTINUE ! 200 RETURN end subroutine ELMHES (NM, N, LOW, IGH, A, INT) ! !! ELMHES reduces a real general matrix to upper Hessenberg form ... ! using stabilized elementary similarity transformations. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B2 !***TYPE SINGLE PRECISION (ELMHES-S, COMHES-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure ELMHES, ! NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). ! ! Given a REAL GENERAL matrix, this subroutine ! reduces a submatrix situated in rows and columns ! LOW through IGH to upper Hessenberg form by ! stabilized elementary similarity transformations. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, A, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix, A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine BALANC. If BALANC has not been ! used, set LOW=1 and IGH equal to the order of the matrix, N. ! ! A contains the input matrix. A is a two-dimensional REAL ! array, dimensioned A(NM,N). ! ! On OUTPUT ! ! A contains the upper Hessenberg matrix. The multipliers which ! were used in the reduction are stored in the remaining ! triangle under the Hessenberg matrix. ! ! INT contains information on the rows and columns interchanged ! in the reduction. Only elements LOW through IGH are used. ! INT is a one-dimensional INTEGER array, dimensioned INT(IGH). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ELMHES ! INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 REAL A(NM,*) REAL X,Y INTEGER INT(*) ! !***FIRST EXECUTABLE STATEMENT ELMHES LA = IGH - 1 KP1 = LOW + 1 if (LA < KP1) go to 200 ! DO 180 M = KP1, LA MM1 = M - 1 X = 0.0E0 I = M ! DO 100 J = M, IGH if (ABS(A(J,MM1)) <= ABS(X)) go to 100 X = A(J,MM1) I = J 100 CONTINUE ! INT(M) = I if (I == M) go to 130 ! .......... 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 ! DO 120 J = 1, IGH Y = A(J,I) A(J,I) = A(J,M) A(J,M) = Y 120 CONTINUE ! .......... END INTERCHANGE .......... 130 if (X == 0.0E0) go to 180 MP1 = M + 1 ! DO 160 I = MP1, IGH Y = A(I,MM1) if (Y == 0.0E0) go to 160 Y = Y / X A(I,MM1) = Y ! DO 140 J = M, N 140 A(I,J) = A(I,J) - Y * A(M,J) ! DO 150 J = 1, IGH 150 A(J,M) = A(J,M) + Y * A(J,I) ! 160 CONTINUE ! 180 CONTINUE ! 200 RETURN end subroutine ELTRAN (NM, N, LOW, IGH, A, INT, Z) ! !! ELTRAN accumulates the stabilized elementary similarity ... ! transformations used in the reduction of a real general ! matrix to upper Hessenberg form by ELMHES. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (ELTRAN-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure ELMTRANS, ! NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). ! ! This subroutine accumulates the stabilized elementary ! similarity transformations used in the reduction of a ! REAL GENERAL matrix to upper Hessenberg form by ELMHES. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine BALANC. If BALANC has not been ! used, set LOW=1 and IGH equal to the order of the matrix, N. ! ! A contains the multipliers which were used in the reduction ! by ELMHES in its lower triangle below the subdiagonal. ! A is a two-dimensional REAL array, dimensioned A(NM,IGH). ! ! INT contains information on the rows and columns interchanged ! in the reduction by ELMHES. Only elements LOW through IGH ! are used. INT is a one-dimensional INTEGER array, ! dimensioned INT(IGH). ! ! On OUTPUT ! ! Z contains the transformation matrix produced in the reduction ! by ELMHES. Z is a two-dimensional REAL array, dimensioned ! Z(NM,N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ELTRAN ! INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 REAL A(NM,*),Z(NM,*) INTEGER INT(*) ! !***FIRST EXECUTABLE STATEMENT ELTRAN DO 80 I = 1, N ! DO 60 J = 1, N 60 Z(I,J) = 0.0E0 ! Z(I,I) = 1.0E0 80 CONTINUE ! KL = IGH - LOW - 1 if (KL < 1) go to 200 ! .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = 1, KL MP = IGH - MM MP1 = MP + 1 ! DO 100 I = MP1, IGH 100 Z(I,MP) = A(I,MP-1) ! I = INT(MP) if (I == MP) go to 140 ! DO 130 J = MP, IGH Z(MP,J) = Z(I,J) Z(I,J) = 0.0E0 130 CONTINUE ! Z(I,MP) = 1.0E0 140 CONTINUE ! 200 RETURN end FUNCTION ENORM (N, X) ! !! ENORM is subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (ENORM-S, DENORM-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an N-vector X, this function calculates the ! Euclidean norm of X. ! ! The Euclidean norm is computed by accumulating the sum of ! squares in three different sums. The sums of squares for the ! small and large components are scaled so that no overflows ! occur. Non-destructive underflows are permitted. Underflows ! and overflows do not occur in the computation of the unscaled ! sum of squares for the intermediate components. ! The definitions of small, intermediate and large components ! depend on two constants, RDWARF and RGIANT. The main ! restrictions on these constants are that RDWARF**2 not ! underflow and RGIANT**2 not overflow. The constants ! given here are suitable for every known computer. ! ! The function statement is ! ! REAL FUNCTION ENORM(N,X) ! ! where ! ! N is a positive integer input variable. ! ! X is an input array of length N. ! !***SEE ALSO SNLS1, SNLS1E, SNSQ, SNSQE !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE ENORM INTEGER N REAL ENORM REAL X(*) INTEGER I REAL AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX, & ZERO SAVE ONE, ZERO, RDWARF, RGIANT DATA ONE,ZERO,RDWARF,RGIANT /1.0E0,0.0E0,3.834E-20,1.304E19/ !***FIRST EXECUTABLE STATEMENT ENORM S1 = ZERO S2 = ZERO S3 = ZERO X1MAX = ZERO X3MAX = ZERO FLOATN = N AGIANT = RGIANT/FLOATN DO 90 I = 1, N XABS = ABS(X(I)) if (XABS > RDWARF .AND. XABS < AGIANT) go to 70 if (XABS <= RDWARF) go to 30 ! ! SUM FOR LARGE COMPONENTS. ! if (XABS <= X1MAX) go to 10 S1 = ONE + S1*(X1MAX/XABS)**2 X1MAX = XABS go to 20 10 CONTINUE S1 = S1 + (XABS/X1MAX)**2 20 CONTINUE go to 60 30 CONTINUE ! ! SUM FOR SMALL COMPONENTS. ! if (XABS <= X3MAX) go to 40 S3 = ONE + S3*(X3MAX/XABS)**2 X3MAX = XABS go to 50 40 CONTINUE if (XABS /= ZERO) S3 = S3 + (XABS/X3MAX)**2 50 CONTINUE 60 CONTINUE go to 80 70 CONTINUE ! ! SUM FOR INTERMEDIATE COMPONENTS. ! S2 = S2 + XABS**2 80 CONTINUE 90 CONTINUE ! ! CALCULATION OF NORM. ! if (S1 == ZERO) go to 100 ENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX) go to 130 100 CONTINUE if (S2 == ZERO) go to 110 if (S2 >= X3MAX) & ENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) if (S2 < X3MAX) & ENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) go to 120 110 CONTINUE ENORM = X3MAX*SQRT(S3) 120 CONTINUE 130 CONTINUE return end function ERFC (X) ! !! ERFC computes the complementary error function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C8A, L5A1E !***TYPE SINGLE PRECISION (ERFC-S, DERFC-D) !***KEYWORDS COMPLEMENTARY ERROR FUNCTION, ERFC, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! ERFC(X) calculates the single precision complementary error ! function for single precision argument X. ! ! Series for ERF on the interval 0. to 1.00000D+00 ! with weighted error 7.10E-18 ! log weighted error 17.15 ! significant figures required 16.31 ! decimal places required 17.71 ! ! Series for ERFC on the interval 0. to 2.50000D-01 ! with weighted error 4.81E-17 ! log weighted error 16.32 ! approx significant figures required 15.0 ! ! ! Series for ERC2 on the interval 2.50000D-01 to 1.00000D+00 ! with weighted error 5.22E-17 ! log weighted error 16.28 ! approx significant figures required 15.0 ! decimal places required 16.96 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE ERFC DIMENSION ERFCS(13), ERFCCS(24), ERC2CS(23) LOGICAL FIRST SAVE ERFCS, ERC2CS, ERFCCS, SQRTPI, NTERF, NTERFC, & NTERC2, XSML, XMAX, SQEPS, FIRST DATA ERFCS( 1) / -.049046121234691808E0 / DATA ERFCS( 2) / -.14226120510371364E0 / DATA ERFCS( 3) / .010035582187599796E0 / DATA ERFCS( 4) / -.000576876469976748E0 / DATA ERFCS( 5) / .000027419931252196E0 / DATA ERFCS( 6) / -.000001104317550734E0 / DATA ERFCS( 7) / .000000038488755420E0 / DATA ERFCS( 8) / -.000000001180858253E0 / DATA ERFCS( 9) / .000000000032334215E0 / DATA ERFCS(10) / -.000000000000799101E0 / DATA ERFCS(11) / .000000000000017990E0 / DATA ERFCS(12) / -.000000000000000371E0 / DATA ERFCS(13) / .000000000000000007E0 / DATA ERC2CS( 1) / -.069601346602309501E0 / DATA ERC2CS( 2) / -.041101339362620893E0 / DATA ERC2CS( 3) / .003914495866689626E0 / DATA ERC2CS( 4) / -.000490639565054897E0 / DATA ERC2CS( 5) / .000071574790013770E0 / DATA ERC2CS( 6) / -.000011530716341312E0 / DATA ERC2CS( 7) / .000001994670590201E0 / DATA ERC2CS( 8) / -.000000364266647159E0 / DATA ERC2CS( 9) / .000000069443726100E0 / DATA ERC2CS(10) / -.000000013712209021E0 / DATA ERC2CS(11) / .000000002788389661E0 / DATA ERC2CS(12) / -.000000000581416472E0 / DATA ERC2CS(13) / .000000000123892049E0 / DATA ERC2CS(14) / -.000000000026906391E0 / DATA ERC2CS(15) / .000000000005942614E0 / DATA ERC2CS(16) / -.000000000001332386E0 / DATA ERC2CS(17) / .000000000000302804E0 / DATA ERC2CS(18) / -.000000000000069666E0 / DATA ERC2CS(19) / .000000000000016208E0 / DATA ERC2CS(20) / -.000000000000003809E0 / DATA ERC2CS(21) / .000000000000000904E0 / DATA ERC2CS(22) / -.000000000000000216E0 / DATA ERC2CS(23) / .000000000000000052E0 / DATA ERFCCS( 1) / 0.0715179310202925E0 / DATA ERFCCS( 2) / -.026532434337606719E0 / DATA ERFCCS( 3) / .001711153977920853E0 / DATA ERFCCS( 4) / -.000163751663458512E0 / DATA ERFCCS( 5) / .000019871293500549E0 / DATA ERFCCS( 6) / -.000002843712412769E0 / DATA ERFCCS( 7) / .000000460616130901E0 / DATA ERFCCS( 8) / -.000000082277530261E0 / DATA ERFCCS( 9) / .000000015921418724E0 / DATA ERFCCS(10) / -.000000003295071356E0 / DATA ERFCCS(11) / .000000000722343973E0 / DATA ERFCCS(12) / -.000000000166485584E0 / DATA ERFCCS(13) / .000000000040103931E0 / DATA ERFCCS(14) / -.000000000010048164E0 / DATA ERFCCS(15) / .000000000002608272E0 / DATA ERFCCS(16) / -.000000000000699105E0 / DATA ERFCCS(17) / .000000000000192946E0 / DATA ERFCCS(18) / -.000000000000054704E0 / DATA ERFCCS(19) / .000000000000015901E0 / DATA ERFCCS(20) / -.000000000000004729E0 / DATA ERFCCS(21) / .000000000000001432E0 / DATA ERFCCS(22) / -.000000000000000439E0 / DATA ERFCCS(23) / .000000000000000138E0 / DATA ERFCCS(24) / -.000000000000000048E0 / DATA SQRTPI /1.7724538509055160E0/ DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT ERFC if (FIRST) THEN ETA = 0.1*R1MACH(3) NTERF = INITS (ERFCS, 13, ETA) NTERFC = INITS (ERFCCS, 24, ETA) NTERC2 = INITS (ERC2CS, 23, ETA) ! XSML = -SQRT (-LOG(SQRTPI*R1MACH(3))) TXMAX = SQRT (-LOG(SQRTPI*R1MACH(1))) XMAX = TXMAX - 0.5*LOG(TXMAX)/TXMAX - 0.01 SQEPS = SQRT (2.0*R1MACH(3)) end if FIRST = .FALSE. ! if (X > XSML) go to 20 ! ! ERFC(X) = 1.0 - ERF(X) FOR X < XSML ! ERFC = 2. return ! 20 if (X > XMAX) go to 40 Y = ABS(X) if (Y > 1.0) go to 30 ! ! ERFC(X) = 1.0 - ERF(X) FOR -1. <= X <= 1. ! if (Y < SQEPS) ERFC = 1.0 - 2.0*X/SQRTPI if (Y >= SQEPS) ERFC = 1.0 - & X*(1.0 + CSEVL (2.*X*X-1., ERFCS, NTERF) ) return ! ! ERFC(X) = 1.0 - ERF(X) FOR 1. < ABS(X) <= XMAX ! 30 Y = Y*Y if (Y <= 4.) ERFC = EXP(-Y)/ABS(X) * (0.5 + CSEVL ((8./Y-5.)/3., & ERC2CS, NTERC2) ) if (Y > 4.) ERFC = EXP(-Y)/ABS(X) * (0.5 + CSEVL (8./Y-1., & ERFCCS, NTERFC) ) if (X < 0.) ERFC = 2.0 - ERFC return ! 40 call XERMSG ('SLATEC', 'ERFC', 'X SO BIG ERFC UNDERFLOWS', 1, 1) ERFC = 0. return ! end function ERF (X) ! !! ERF computes the error function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C8A, L5A1E !***TYPE SINGLE PRECISION (ERF-S, DERF-D) !***KEYWORDS ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! ERF(X) calculates the single precision error function for ! single precision argument X. ! ! Series for ERF on the interval 0. to 1.00000D+00 ! with weighted error 7.10E-18 ! log weighted error 17.15 ! significant figures required 16.31 ! decimal places required 17.71 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, ERFC, INITS, R1MACH !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900727 Added EXTERNAL statement. (WRB) ! 920618 Removed space from variable name. (RWC, WRB) !***END PROLOGUE ERF DIMENSION ERFCS(13) LOGICAL FIRST EXTERNAL ERFC SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST DATA ERFCS( 1) / -.049046121234691808E0 / DATA ERFCS( 2) / -.14226120510371364E0 / DATA ERFCS( 3) / .010035582187599796E0 / DATA ERFCS( 4) / -.000576876469976748E0 / DATA ERFCS( 5) / .000027419931252196E0 / DATA ERFCS( 6) / -.000001104317550734E0 / DATA ERFCS( 7) / .000000038488755420E0 / DATA ERFCS( 8) / -.000000001180858253E0 / DATA ERFCS( 9) / .000000000032334215E0 / DATA ERFCS(10) / -.000000000000799101E0 / DATA ERFCS(11) / .000000000000017990E0 / DATA ERFCS(12) / -.000000000000000371E0 / DATA ERFCS(13) / .000000000000000007E0 / DATA SQRTPI /1.7724538509055160E0/ DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT ERF if (FIRST) THEN NTERF = INITS (ERFCS, 13, 0.1*R1MACH(3)) XBIG = SQRT(-LOG(SQRTPI*R1MACH(3))) SQEPS = SQRT(2.0*R1MACH(3)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 1.) go to 20 ! ! ERF(X) = 1. - ERFC(X) FOR -1. <= X <= 1. ! if (Y <= SQEPS) ERF = 2.0*X/SQRTPI if (Y > SQEPS) ERF = X*(1.0 + CSEVL(2.*X**2-1., ERFCS, NTERF)) return ! ! ERF(X) = 1. - ERFC(X) FOR ABS(X) > 1. ! 20 if (Y <= XBIG) ERF = SIGN (1.0-ERFC(Y), X) if (Y > XBIG) ERF = SIGN (1.0, X) ! return end subroutine EXBVP (Y, NROWY, XPTS, A, NROWA, ALPHA, B, NROWB, BETA, & IFLAG, WORK, IWORK) ! !! EXBVP is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (EXBVP-S, DEXBVP-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This subroutine is used to execute the basic technique for solving ! the two-point boundary value problem ! !***SEE ALSO BVSUP !***ROUTINES CALLED BVPOR, XERMSG !***COMMON BLOCKS ML15TO, ML17BW, ML18JR, ML5MCO, ML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE EXBVP ! DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*),BETA(*), & WORK(*),IWORK(*),XPTS(*) CHARACTER*8 XERN1, XERN2 ! ! **************************************************************** ! COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, & ICOCO COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, & K10,K11,L1,L2,KKKINT,LLLINT ! COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR ! !***FIRST EXECUTABLE STATEMENT EXBVP KOTC = 1 IEXP = 0 if (IWORK(7) == -1) IEXP = IWORK(8) ! ! COMPUTE ORTHONORMALIZATION TOLERANCES. ! 10 TOL = 10.0**((-LPAR-IEXP)*2) ! IWORK(8) = IEXP MXNON = IWORK(2) ! ! ********************************************************************** ! ********************************************************************** ! call BVPOR(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B, & NROWB,BETA,NFC,IFLAG,WORK(1),MXNON,WORK(K1),NTP, & IWORK(18),WORK(K2),IWORK(16),WORK(K3),WORK(K4), & WORK(K5),WORK(K6),WORK(K7),WORK(K8),WORK(K9), & WORK(K10),IWORK(L1),NFCC) ! ! ********************************************************************** ! ********************************************************************** ! if MGSBV RETURNS WITH MESSAGE OF DEPENDENT VECTORS, WE REDUCE ! ORTHONORMALIZATION TOLERANCE AND TRY AGAIN. THIS IS DONE ! A MAXIMUM OF 2 TIMES. ! if (IFLAG /= 30) go to 20 if (KOTC == 3 .OR. NOPG == 1) go to 30 KOTC = KOTC + 1 IEXP = IEXP - 2 go to 10 ! ! ********************************************************************** ! if BVPOR RETURNS MESSAGE THAT THE MAXIMUM NUMBER OF ! ORTHONORMALIZATIONS HAS BEEN ATTAINED AND WE CANNOT CONTINUE, THEN ! WE ESTIMATE THE NEW STORAGE REQUIREMENTS IN ORDER TO SOLVE PROBLEM ! 20 if (IFLAG /= 13) go to 30 XL = ABS(XEND-XBEG) ZQUIT = ABS(X-XBEG) INC = 1.5 * XL/ZQUIT * (MXNON+1) if (NDISK /= 1) THEN NSAFW = INC*KKKZPW + NEEDW NSAFIW = INC*NFCC + NEEDIW ELSE NSAFW = NEEDW + INC NSAFIW = NEEDIW end if ! WRITE (XERN1, '(I8)') NSAFW WRITE (XERN2, '(I8)') NSAFIW call XERMSG ('SLATEC', 'EXBVP', & 'IN BVSUP, PREDICTED STORAGE ALLOCATION FOR WORK ARRAY IS ' // & XERN1 // ', PREDICTED STORAGE ALLOCATION FOR IWORK ARRAY IS ' & // XERN2, 1, 0) ! 30 IWORK(1) = MXNON return end subroutine EXINT (X, N, KODE, M, TOL, EN, NZ, IERR) ! !! EXINT computes an M member sequence of exponential integrals ... ! E(N+K,X), K=0,1,...,M-1 for N >= 1 and X >= 0. !***LIBRARY SLATEC !***CATEGORY C5 !***TYPE SINGLE PRECISION (EXINT-S, DEXINT-D) !***KEYWORDS EXPONENTIAL INTEGRAL, SPECIAL FUNCTIONS !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! EXINT computes M member sequences of exponential integrals ! E(N+K,X), K=0,1,...,M-1 for N >= 1 and X >= 0. The ! exponential integral is defined by ! ! E(N,X)=integral on (1,infinity) of EXP(-XT)/T**N ! ! where X=0.0 and N=1 cannot occur simultaneously. Formulas ! and notation are found in the NBS Handbook of Mathematical ! Functions (ref. 1). ! ! The power series is implemented for X <= XCUT and the ! confluent hypergeometric representation ! ! E(A,X) = EXP(-X)*(X**(A-1))*U(A,A,X) ! ! is computed for X > XCUT. Since sequences are computed in ! a stable fashion by recurring away from X, A is selected as ! the integer closest to X within the constraint N <= A <= ! N+M-1. For the U computation, A is further modified to be the ! nearest even integer. Indices are carried forward or ! backward by the two term recursion relation ! ! K*E(K+1,X) + X*E(K,X) = EXP(-X) ! ! once E(A,X) is computed. The U function is computed by means ! of the backward recursive Miller algorithm applied to the ! three term contiguous relation for U(A+K,A,X), K=0,1,... ! This produces accurate ratios and determines U(A+K,A,X), and ! hence E(A,X), to within a multiplicative constant C. ! Another contiguous relation applied to C*U(A,A,X) and ! C*U(A+1,A,X) gets C*U(A+1,A+1,X), a quantity proportional to ! E(A+1,X). The normalizing constant C is obtained from the ! two term recursion relation above with K=A. ! ! Description of Arguments ! ! Input ! X X > 0.0 for N=1 and X >= 0.0 for N >= 2 ! N order of the first member of the sequence, N >= 1 ! (X=0.0 and N=1 is an error) ! KODE a selection parameter for scaled values ! KODE=1 returns E(N+K,X), K=0,1,...,M-1. ! =2 returns EXP(X)*E(N+K,X), K=0,1,...,M-1. ! M number of exponential integrals in the sequence, ! M >= 1 ! TOL relative accuracy wanted, ETOL <= TOL <= 0.1 ! ETOL = single precision unit roundoff = R1MACH(4) ! ! Output ! EN a vector of dimension at least M containing values ! EN(K) = E(N+K-1,X) or EXP(X)*E(N+K-1,X), K=1,M ! depending on KODE ! NZ underflow indicator ! NZ=0 a normal return ! NZ=M X exceeds XLIM and an underflow occurs. ! EN(K)=0.0E0 , K=1,M returned on KODE=1 ! IERR error flag ! IERR=0, normal return, computation completed ! IERR=1, input error, no computation ! IERR=2, error, no computation ! algorithm termination condition not met ! !***REFERENCES M. Abramowitz and I. A. Stegun, Handbook of ! Mathematical Functions, NBS AMS Series 55, U.S. Dept. ! of Commerce, 1955. ! D. E. Amos, Computation of exponential integrals, ACM ! Transactions on Mathematical Software 6, (1980), ! pp. 365-377 and pp. 420-428. !***ROUTINES CALLED I1MACH, PSIXN, R1MACH !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 910408 Updated the REFERENCES section. (WRB) ! 920207 Updated with code with a revision date of 880811 from ! D. Amos. Included correction of argument list. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE EXINT REAL A,AA,AAMS,AH,AK,AT,B,BK,BT,CC,CNORM,CT,EM,EMX,EN, & ETOL,FNM,FX,PT,P1,P2,S,TOL,TX,X,XCUT,XLIM,XTOL,Y, & YT,Y1,Y2 REAL R1MACH,PSIXN INTEGER I,IC,ICASE,ICT,IERR,IK,IND,IX,I1M,JSET,K,KK,KN,KODE,KS,M, & ML,MU,N,ND,NM,NZ INTEGER I1MACH DIMENSION EN(*), A(99), B(99), Y(2) !***FIRST EXECUTABLE STATEMENT EXINT IERR = 0 NZ = 0 ETOL = MAX(R1MACH(4),0.5E-18) if (X < 0.0E0) IERR = 1 if (N < 1) IERR = 1 if (KODE < 1 .OR. KODE > 2) IERR = 1 if (M < 1) IERR = 1 if (TOL < ETOL .OR. TOL > 0.1E0) IERR = 1 if (X == 0.0E0 .AND. N == 1) IERR = 1 if (IERR /= 0) RETURN I1M = -I1MACH(12) PT = 2.3026E0*R1MACH(5)*I1M XLIM = PT - 6.907755E0 BT = PT + (N+M-1) if (BT > 1000.0E0) XLIM = PT - LOG(BT) ! XCUT = 2.0E0 if (ETOL > 2.0E-7) XCUT = 1.0E0 if (X > XCUT) go to 100 if (X == 0.0E0 .AND. N > 1) go to 80 !----------------------------------------------------------------------- ! SERIES FOR E(N,X) FOR X <= XCUT !----------------------------------------------------------------------- TX = X + 0.5E0 IX = TX !----------------------------------------------------------------------- ! ICASE=1 MEANS INTEGER CLOSEST TO X IS 2 AND N=1 ! ICASE=2 MEANS INTEGER CLOSEST TO X IS 0,1, OR 2 AND N >= 2 !----------------------------------------------------------------------- ICASE = 2 if (IX > N) ICASE = 1 NM = N - ICASE + 1 ND = NM + 1 IND = 3 - ICASE MU = M - IND ML = 1 KS = ND FNM = NM S = 0.0E0 XTOL = 3.0E0*TOL if (ND == 1) go to 10 XTOL = 0.3333E0*TOL S = 1.0E0/FNM 10 CONTINUE AA = 1.0E0 AK = 1.0E0 IC = 35 if (X < ETOL) IC = 1 DO 50 I=1,IC AA = -AA*X/AK if (I == NM) go to 30 S = S - AA/(AK-FNM) if (ABS(AA) <= XTOL*ABS(S)) go to 20 AK = AK + 1.0E0 go to 50 20 CONTINUE if (I < 2) go to 40 if (ND-2 > I .OR. I > ND-1) go to 60 AK = AK + 1.0E0 go to 50 30 S = S + AA*(-LOG(X)+PSIXN(ND)) XTOL = 3.0E0*TOL 40 AK = AK + 1.0E0 50 CONTINUE if (IC /= 1) go to 340 60 if (ND == 1) S = S + (-LOG(X)+PSIXN(1)) if (KODE == 2) S = S*EXP(X) EN(1) = S EMX = 1.0E0 if (M == 1) go to 70 EN(IND) = S AA = KS if (KODE == 1) EMX = EXP(-X) go to (220, 240), ICASE 70 if (ICASE == 2) RETURN if (KODE == 1) EMX = EXP(-X) EN(1) = (EMX-S)/X return 80 CONTINUE DO 90 I=1,M EN(I) = 1.0E0/(N+I-2) 90 CONTINUE return !----------------------------------------------------------------------- ! BACKWARD RECURSIVE MILLER ALGORITHM FOR ! E(N,X)=EXP(-X)*(X**(N-1))*U(N,N,X) ! WITH RECURSION AWAY FROM N=INTEGER CLOSEST TO X. ! U(A,B,X) IS THE SECOND CONFLUENT HYPERGEOMETRIC FUNCTION !----------------------------------------------------------------------- 100 CONTINUE EMX = 1.0E0 if (KODE == 2) go to 130 if (X <= XLIM) go to 120 NZ = M DO 110 I=1,M EN(I) = 0.0E0 110 CONTINUE return 120 EMX = EXP(-X) 130 CONTINUE IX = X+0.5E0 KN = N + M - 1 if (KN <= IX) go to 140 if (N < IX .AND. IX < KN) go to 170 if (N >= IX) go to 160 go to 340 140 ICASE = 1 KS = KN ML = M - 1 MU = -1 IND = M if (KN > 1) go to 180 150 KS = 2 ICASE = 3 go to 180 160 ICASE = 2 IND = 1 KS = N MU = M - 1 if (N > 1) go to 180 if (KN == 1) go to 150 IX = 2 170 ICASE = 1 KS = IX ML = IX - N IND = ML + 1 MU = KN - IX 180 CONTINUE IK = KS/2 AH = IK JSET = 1 + KS - (IK+IK) !----------------------------------------------------------------------- ! START COMPUTATION FOR ! EN(IND) = C*U( A , A ,X) JSET=1 ! EN(IND) = C*U(A+1,A+1,X) JSET=2 ! FOR AN EVEN INTEGER A. !----------------------------------------------------------------------- IC = 0 AA = AH + AH AAMS = AA - 1.0E0 AAMS = AAMS*AAMS TX = X + X FX = TX + TX AK = AH XTOL = TOL if (TOL <= 1.0E-3) XTOL = 20.0E0*TOL CT = AAMS + FX*AH EM = (AH+1.0E0)/((X+AA)*XTOL*SQRT(CT)) BK = AA CC = AH*AH !----------------------------------------------------------------------- ! FORWARD RECURSION FOR P(IC),P(IC+1) AND INDEX IC FOR BACKWARD ! RECURSION !----------------------------------------------------------------------- P1 = 0.0E0 P2 = 1.0E0 190 CONTINUE if (IC == 99) go to 340 IC = IC + 1 AK = AK + 1.0E0 AT = BK/(BK+AK+CC+IC) BK = BK + AK + AK A(IC) = AT BT = (AK+AK+X)/(AK+1.0E0) B(IC) = BT PT = P2 P2 = BT*P2 - AT*P1 P1 = PT CT = CT + FX EM = EM*AT*(1.0E0-TX/CT) if (EM*(AK+1.0E0) > P1*P1) go to 190 ICT = IC KK = IC + 1 BT = TX/(CT+FX) Y2 = (BK/(BK+CC+KK))*(P1/P2)*(1.0E0-BT+0.375E0*BT*BT) Y1 = 1.0E0 !----------------------------------------------------------------------- ! BACKWARD RECURRENCE FOR ! Y1= C*U( A ,A,X) ! Y2= C*(A/(1+A/2))*U(A+1,A,X) !----------------------------------------------------------------------- DO 200 K=1,ICT KK = KK - 1 YT = Y1 Y1 = (B(KK)*Y1-Y2)/A(KK) Y2 = YT 200 CONTINUE !----------------------------------------------------------------------- ! THE CONTIGUOUS RELATION ! X*U(B,C+1,X)=(C-B)*U(B,C,X)+U(B-1,C,X) ! WITH B=A+1 , C=A IS USED FOR ! Y(2) = C * U(A+1,A+1,X) ! X IS INCORPORATED INTO THE NORMALIZING RELATION !----------------------------------------------------------------------- PT = Y2/Y1 CNORM = 1.0E0 - PT*(AH+1.0E0)/AA Y(1) = 1.0E0/(CNORM*AA+X) Y(2) = CNORM*Y(1) if (ICASE == 3) go to 210 EN(IND) = EMX*Y(JSET) if (M == 1) RETURN AA = KS go to (220, 240), ICASE !----------------------------------------------------------------------- ! RECURSION SECTION N*E(N+1,X) + X*E(N,X)=EMX !----------------------------------------------------------------------- 210 EN(1) = EMX*(1.0E0-Y(1))/X return 220 K = IND - 1 DO 230 I=1,ML AA = AA - 1.0E0 EN(K) = (EMX-AA*EN(K+1))/X K = K - 1 230 CONTINUE if (MU <= 0) RETURN AA = KS 240 K = IND DO 250 I=1,MU EN(K+1) = (EMX-X*EN(K))/AA AA = AA + 1.0E0 K = K + 1 250 CONTINUE return 340 CONTINUE IERR = 2 return end function EXPREL (X) ! !! EXPREL calculates the relative error exponential (EXP(X)-1)/X. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4B !***TYPE SINGLE PRECISION (EXPREL-S, DEXPRL-D, CEXPRL-C) !***KEYWORDS ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate EXPREL(X) = (EXP(X) - 1.0) / X. For small ABS(X) the ! Taylor series is used. If X is negative, the reflection formula ! EXPREL(X) = EXP(X) * EXPREL(ABS(X)) ! may be used. This reflection formula will be of use when the ! evaluation for small ABS(X) is done by Chebyshev series rather than ! Taylor series. EXPREL and X are single precision. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE EXPREL LOGICAL FIRST SAVE NTERMS, XBND, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT EXPREL if (FIRST) THEN ALNEPS = LOG(R1MACH(3)) XN = 3.72 - 0.3*ALNEPS XLN = LOG((XN+1.0)/1.36) NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36) + 1.5 XBND = R1MACH(3) end if FIRST = .FALSE. ! ABSX = ABS(X) if (ABSX > 0.5) EXPREL = (EXP(X) - 1.0) / X if (ABSX > 0.5) RETURN ! EXPREL = 1.0 if (ABSX < XBND) RETURN ! EXPREL = 0.0 DO 20 I=1,NTERMS EXPREL = 1.0 + EXPREL*X/(NTERMS+2-I) 20 CONTINUE ! return end subroutine EZFFT1 (N, WA, IFAC) ! !! EZFFT1 calls EZFFT1 with appropriate work array partitioning. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (EZFFT1-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing references to intrinsic function FLOAT ! to REAL, and ! (c) changing definition of variable TPI by using ! FORTRAN intrinsic function ATAN instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE EZFFT1 DIMENSION WA(*), IFAC(*), NTRYH(4) SAVE NTRYH DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ !***FIRST EXECUTABLE STATEMENT EZFFT1 TPI = 8.*ATAN(1.) 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 /= 2) go to 107 if (NF == 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 /= 1) go to 104 IFAC(1) = N IFAC(2) = NF ARGH = TPI/N IS = 0 NFM1 = NF-1 L1 = 1 if (NFM1 == 0) RETURN DO 111 K1=1,NFM1 IP = IFAC(K1+2) L2 = L1*IP IDO = N/L2 IPM = IP-1 ARG1 = L1*ARGH CH1 = 1. SH1 = 0. DCH1 = COS(ARG1) DSH1 = SIN(ARG1) DO 110 J=1,IPM CH1H = DCH1*CH1-DSH1*SH1 SH1 = DCH1*SH1+DSH1*CH1 CH1 = CH1H I = IS+2 WA(I-1) = CH1 WA(I) = SH1 if (IDO < 5) go to 109 DO 108 II=5,IDO,2 I = I+2 WA(I-1) = CH1*WA(I-3)-SH1*WA(I-2) WA(I) = CH1*WA(I-2)+SH1*WA(I-3) 108 CONTINUE 109 IS = IS+IDO 110 CONTINUE L1 = L2 111 CONTINUE return end subroutine EZFFTB (N, R, AZERO, A, B, WSAVE) ! !! EZFFTB is a simplified real, periodic, backward fast Fourier transform. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A1 !***TYPE SINGLE PRECISION (EZFFTB-S) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine EZFFTB computes a real periodic sequence from its ! Fourier coefficients (Fourier synthesis). The transform is ! defined below at Output Parameter R. EZFFTB is a simplified ! but slower version of RFFTB. ! ! Input Parameters ! ! N the length of the output array R. The method is most ! efficient when N is the product of small primes. ! ! AZERO the constant Fourier coefficient ! ! A,B arrays which contain the remaining Fourier coefficients. ! These arrays are not destroyed. ! ! The length of these arrays depends on whether N is even or ! odd. ! ! If N is even, N/2 locations are required. ! If N is odd, (N-1)/2 locations are required ! ! WSAVE a work array which must be dimensioned at least 3*N+15 ! in the program that calls EZFFTB. The WSAVE array must be ! initialized by calling subroutine EZFFTI(N,WSAVE), and a ! different WSAVE array must be used for each different ! value of N. This initialization does not have to be ! repeated so long as N remains unchanged. Thus subsequent ! transforms can be obtained faster than the first. ! The same WSAVE array can be used by EZFFTF and EZFFTB. ! ! Output Parameters ! ! R if N is even, define KMAX=N/2 ! if N is odd, define KMAX=(N-1)/2 ! ! Then for I=1,...,N ! ! R(I)=AZERO plus the sum from K=1 to K=KMAX of ! ! A(K)*COS(K*(I-1)*2*PI/N)+B(K)*SIN(K*(I-1)*2*PI/N) ! ! ********************* Complex Notation ************************** ! ! For J=1,...,N ! ! R(J) equals the sum from K=-KMAX to K=KMAX of ! ! C(K)*EXP(I*K*(J-1)*2*PI/N) ! ! where ! ! C(K) = .5*CMPLX(A(K),-B(K)) for K=1,...,KMAX ! ! C(-K) = CONJG(C(K)) ! ! C(0) = AZERO ! ! and I=SQRT(-1) ! ! *************** Amplitude - Phase Notation *********************** ! ! For I=1,...,N ! ! R(I) equals AZERO plus the sum from K=1 to K=KMAX of ! ! ALPHA(K)*COS(K*(I-1)*2*PI/N+BETA(K)) ! ! where ! ! ALPHA(K) = SQRT(A(K)*A(K)+B(K)*B(K)) ! ! COS(BETA(K))=A(K)/ALPHA(K) ! ! SIN(BETA(K))=-B(K)/ALPHA(K) ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTB !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*) ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE EZFFTB DIMENSION R(*), A(*), B(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT EZFFTB if (N-2) 101,102,103 101 R(1) = AZERO return 102 R(1) = AZERO+A(1) R(2) = AZERO-A(1) return 103 NS2 = (N-1)/2 DO 104 I=1,NS2 R(2*I) = .5*A(I) R(2*I+1) = -.5*B(I) 104 CONTINUE R(1) = AZERO if (MOD(N,2) == 0) R(N) = A(NS2+1) call RFFTB (N,R,WSAVE(N+1)) return end subroutine EZFFTF (N, R, AZERO, A, B, WSAVE) ! !! EZFFTF computes a simplified real, periodic, fast Fourier forward transform. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A1 !***TYPE SINGLE PRECISION (EZFFTF-S) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine EZFFTF computes the Fourier coefficients of a real ! periodic sequence (Fourier analysis). The transform is defined ! below at Output Parameters AZERO, A and B. EZFFTF is a simplified ! but slower version of RFFTF. ! ! Input Parameters ! ! N the length of the array R to be transformed. The method ! is most efficient when N is the product of small primes. ! ! R a real array of length N which contains the sequence ! to be transformed. R is not destroyed. ! ! ! WSAVE a work array which must be dimensioned at least 3*N+15 ! in the program that calls EZFFTF. The WSAVE array must be ! initialized by calling subroutine EZFFTI(N,WSAVE), and a ! different WSAVE array must be used for each different ! value of N. This initialization does not have to be ! repeated so long as N remains unchanged. Thus subsequent ! transforms can be obtained faster than the first. ! The same WSAVE array can be used by EZFFTF and EZFFTB. ! ! Output Parameters ! ! AZERO the sum from I=1 to I=N of R(I)/N ! ! A,B for N even B(N/2)=0. and A(N/2) is the sum from I=1 to ! I=N of (-1)**(I-1)*R(I)/N ! ! for N even define KMAX=N/2-1 ! for N odd define KMAX=(N-1)/2 ! ! then for K=1,...,KMAX ! ! A(K) equals the sum from I=1 to I=N of ! ! 2./N*R(I)*COS(K*(I-1)*2*PI/N) ! ! B(K) equals the sum from I=1 to I=N of ! ! 2./N*R(I)*SIN(K*(I-1)*2*PI/N) ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTF !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing references to intrinsic function FLOAT ! to REAL. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE EZFFTF DIMENSION R(*), A(*), B(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT EZFFTF if (N-2) 101,102,103 101 AZERO = R(1) return 102 AZERO = .5*(R(1)+R(2)) A(1) = .5*(R(1)-R(2)) return 103 DO 104 I=1,N WSAVE(I) = R(I) 104 CONTINUE call RFFTF (N,WSAVE,WSAVE(N+1)) CF = 2./N CFM = -CF AZERO = .5*CF*WSAVE(1) NS2 = (N+1)/2 NS2M = NS2-1 DO 105 I=1,NS2M A(I) = CF*WSAVE(2*I) B(I) = CFM*WSAVE(2*I+1) 105 CONTINUE if (MOD(N,2) == 0) A(NS2) = .5*CF*WSAVE(N) return end subroutine EZFFTI (N, WSAVE) ! !! EZFFTI initializes a work array for EZFFTF and EZFFTB. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A1 !***TYPE SINGLE PRECISION (EZFFTI-S) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine EZFFTI initializes the work array WSAVE which is used in ! both EZFFTF and EZFFTB. The prime factorization of N together with ! a tabulation of the trigonometric functions are computed and ! stored in WSAVE. ! ! Input Parameter ! ! N the length of the sequence to be transformed. ! ! Output Parameter ! ! WSAVE a work array which must be dimensioned at least 3*N+15. ! The same work array can be used for both EZFFTF and EZFFTB ! as long as N remains unchanged. Different WSAVE arrays ! are required for different values of N. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED EZFFT1 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE EZFFTI DIMENSION WSAVE(*) !***FIRST EXECUTABLE STATEMENT EZFFTI if (N == 1) RETURN call EZFFT1 (N,WSAVE(2*N+1),WSAVE(3*N+1)) return end function FAC (N) ! !! FAC computes the factorial function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C1 !***TYPE SINGLE PRECISION (FAC-S, DFAC-D) !***KEYWORDS FACTORIAL, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! FAC(N) evaluates the factorial function of N. FAC is single ! precision. N must be an integer between 0 and 25 inclusive. ! !***REFERENCES (NONE) !***ROUTINES CALLED GAMLIM, R9LGMC, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE FAC DIMENSION FACN(26) SAVE FACN, SQ2PIL, NMAX DATA FACN( 1) / 1.0E0 / DATA FACN( 2) / 1.0E0 / DATA FACN( 3) / 2.0E0 / DATA FACN( 4) / 6.0E0 / DATA FACN( 5) / 24.0E0 / DATA FACN( 6) / 120.0E0 / DATA FACN( 7) / 720.0E0 / DATA FACN( 8) / 5040.0E0 / DATA FACN( 9) / 40320.0E0 / DATA FACN(10) / 362880.0E0 / DATA FACN(11) / 3628800.0E0 / DATA FACN(12) / 39916800.0E0 / DATA FACN(13) / 479001600.0E0 / DATA FACN(14) / 6227020800.0E0 / DATA FACN(15) / 87178291200.0E0 / DATA FACN(16) / 1307674368000.0E0 / DATA FACN(17) / 20922789888000.0E0 / DATA FACN(18) / 355687428096000.0E0 / DATA FACN(19) / 6402373705728000.0E0 / DATA FACN(20) / .12164510040883200E18 / DATA FACN(21) / .24329020081766400E19 / DATA FACN(22) / .51090942171709440E20 / DATA FACN(23) / .11240007277776077E22 / DATA FACN(24) / .25852016738884977E23 / DATA FACN(25) / .62044840173323944E24 / DATA FACN(26) / .15511210043330986E26 / DATA SQ2PIL / 0.91893853320467274E0/ DATA NMAX / 0 / !***FIRST EXECUTABLE STATEMENT FAC if (NMAX /= 0) go to 10 call GAMLIM (XMIN, XMAX) NMAX = XMAX - 1. ! 10 if (N < 0) call XERMSG ('SLATEC', 'FAC', & 'FACTORIAL OF NEGATIVE INTEGER UNDEFINED', 1, 2) ! if (N <= 25) FAC = FACN(N+1) if (N <= 25) RETURN ! if (N > NMAX) call XERMSG ('SLATEC', 'FAC', & 'N SO BIG FACTORIAL(N) OVERFLOWS', 2, 2) ! X = N + 1 FAC = EXP ( (X-0.5)*LOG(X) - X + SQ2PIL + R9LGMC(X) ) ! return end subroutine FC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, & NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, W, IW) ! !! FC fits a piecewise polynomial curve to discrete data. ! ! The piecewise polynomials are represented as B-splines. ! The fitting is done in a weighted least squares sense. ! Equality and inequality constraints can be imposed on the ! fitted curve. !***LIBRARY SLATEC !***CATEGORY K1A1A1, K1A2A, L8A3 !***TYPE SINGLE PRECISION (FC-S, DFC-D) !***KEYWORDS B-SPLINE, CONSTRAINED LEAST SQUARES, CURVE FITTING, ! WEIGHTED LEAST SQUARES !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! This subprogram fits a piecewise polynomial curve ! to discrete data. The piecewise polynomials are ! represented as B-splines. ! The fitting is done in a weighted least squares sense. ! Equality and inequality constraints can be imposed on the ! fitted curve. ! ! For a description of the B-splines and usage instructions to ! evaluate them, see ! ! C. W. de Boor, Package for Calculating with B-Splines. ! SIAM J. Numer. Anal., p. 441, (June, 1977). ! ! For further documentation and discussion of constrained ! curve fitting using B-splines, see ! ! R. J. Hanson, Constrained Least Squares Curve Fitting ! to Discrete Data Using B-Splines, a User's ! Guide. Sandia Labs. Tech. Rept. SAND-78-1291, ! December, (1978). ! ! Input.. ! NDATA,XDATA(*), ! YDATA(*), ! SDDATA(*) ! The NDATA discrete (X,Y) pairs and the Y value ! standard deviation or uncertainty, SD, are in ! the respective arrays XDATA(*), YDATA(*), and ! SDDATA(*). No sorting of XDATA(*) is ! required. Any non-negative value of NDATA is ! allowed. A negative value of NDATA is an ! error. A zero value for any entry of ! SDDATA(*) will weight that data point as 1. ! Otherwise the weight of that data point is ! the reciprocal of this entry. ! ! NORD,NBKPT, ! BKPT(*) ! The NBKPT knots of the B-spline of order NORD ! are in the array BKPT(*). Normally the ! problem data interval will be included between ! the limits BKPT(NORD) and BKPT(NBKPT-NORD+1). ! The additional end knots BKPT(I),I=1,..., ! NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are ! required to compute the functions used to fit ! the data. No sorting of BKPT(*) is required. ! Internal to FC( ) the extreme end knots may ! be reduced and increased respectively to ! accommodate any data values that are exterior ! to the given knot values. The contents of ! BKPT(*) is not changed. ! ! NORD must be in the range 1 <= NORD <= 20. ! The value of NBKPT must satisfy the condition ! NBKPT >= 2*NORD. ! Other values are considered errors. ! ! (The order of the spline is one more than the ! degree of the piecewise polynomial defined on ! each interval. This is consistent with the ! B-spline package convention. For example, ! NORD=4 when we are using piecewise cubics.) ! ! NCONST,XCONST(*), ! YCONST(*),NDERIV(*) ! The number of conditions that constrain the ! B-spline is NCONST. A constraint is specified ! by an (X,Y) pair in the arrays XCONST(*) and ! YCONST(*), and by the type of constraint and ! derivative value encoded in the array ! NDERIV(*). No sorting of XCONST(*) is ! required. The value of NDERIV(*) is ! determined as follows. Suppose the I-th ! constraint applies to the J-th derivative ! of the B-spline. (Any non-negative value of ! J < NORD is permitted. In particular the ! value J=0 refers to the B-spline itself.) ! For this I-th constraint, set ! XCONST(I)=X, ! YCONST(I)=Y, and ! NDERIV(I)=ITYPE+4*J, where ! ! ITYPE = 0, if (J-th deriv. at X) <= Y. ! = 1, if (J-th deriv. at X) >= Y. ! = 2, if (J-th deriv. at X) == Y. ! = 3, if (J-th deriv. at X) == ! (J-th deriv. at Y). ! (A value of NDERIV(I)=-1 will cause this ! constraint to be ignored. This subprogram ! feature is often useful when temporarily ! suppressing a constraint while still ! retaining the source code of the calling ! program.) ! ! MODE ! An input flag that directs the least squares ! solution method used by FC( ). ! ! The variance function, referred to below, ! defines the square of the probable error of ! the fitted curve at any point, XVAL. ! This feature of FC( ) allows one to use the ! square root of this variance function to ! determine a probable error band around the ! fitted curve. ! ! =1 a new problem. No variance function. ! ! =2 a new problem. Want variance function. ! ! =3 an old problem. No variance function. ! ! =4 an old problem. Want variance function. ! ! Any value of MODE other than 1-4 is an error. ! ! The user with a new problem can skip directly ! to the description of the input parameters ! IW(1), IW(2). ! ! If the user correctly specifies the new or old ! problem status, the subprogram FC( ) will ! perform more efficiently. ! By an old problem it is meant that subprogram ! FC( ) was last called with this same set of ! knots, data points and weights. ! ! Another often useful deployment of this old ! problem designation can occur when one has ! previously obtained a Q-R orthogonal ! decomposition of the matrix resulting from ! B-spline fitting of data (without constraints) ! at the breakpoints BKPT(I), I=1,...,NBKPT. ! For example, this matrix could be the result ! of sequential accumulation of the least ! squares equations for a very large data set. ! The user writes this code in a manner ! convenient for the application. For the ! discussion here let ! ! N=NBKPT-NORD, and K=N+3 ! ! Let us assume that an equivalent least squares ! system ! ! RC=D ! ! has been obtained. Here R is an N+1 by N ! matrix and D is a vector with N+1 components. ! The last row of R is zero. The matrix R is ! upper triangular and banded. At most NORD of ! the diagonals are nonzero. ! The contents of R and D can be copied to the ! working array W(*) as follows. ! ! The I-th diagonal of R, which has N-I+1 ! elements, is copied to W(*) starting at ! ! W((I-1)*K+1), ! ! for I=1,...,NORD. ! The vector D is copied to W(*) starting at ! ! W(NORD*K+1) ! ! The input value used for NDATA is arbitrary ! when an old problem is designated. Because ! of the feature of FC( ) that checks the ! working storage array lengths, a value not ! exceeding NBKPT should be used. For example, ! use NDATA=0. ! ! (The constraints or variance function request ! can change in each call to FC( ).) A new ! problem is anything other than an old problem. ! ! IW(1),IW(2) ! The amounts of working storage actually ! allocated for the working arrays W(*) and ! IW(*). These quantities are compared with the ! actual amounts of storage needed in FC( ). ! Insufficient storage allocated for either ! W(*) or IW(*) is an error. This feature was ! included in FC( ) because misreading the ! storage formulas for W(*) and IW(*) might very ! well lead to subtle and hard-to-find ! programming bugs. ! ! The length of W(*) must be at least ! ! NB=(NBKPT-NORD+3)*(NORD+1)+ ! 2*MAX(NDATA,NBKPT)+NBKPT+NORD**2 ! ! Whenever possible the code uses banded matrix ! processors BNDACC( ) and BNDSOL( ). These ! are utilized if there are no constraints, ! no variance function is required, and there ! is sufficient data to uniquely determine the ! B-spline coefficients. If the band processors ! cannot be used to determine the solution, ! then the constrained least squares code LSEI ! is used. In this case the subprogram requires ! an additional block of storage in W(*). For ! the discussion here define the integers NEQCON ! and NINCON respectively as the number of ! equality (ITYPE=2,3) and inequality ! (ITYPE=0,1) constraints imposed on the fitted ! curve. Define ! ! L=NBKPT-NORD+1 ! ! and note that ! ! NCONST=NEQCON+NINCON. ! ! When the subprogram FC( ) uses LSEI( ) the ! length of the working array W(*) must be at ! least ! ! LW=NB+(L+NCONST)*L+ ! 2*(NEQCON+L)+(NINCON+L)+(NINCON+2)*(L+6) ! ! The length of the array IW(*) must be at least ! ! IW1=NINCON+2*L ! ! in any case. ! ! Output.. ! MODE ! An output flag that indicates the status ! of the constrained curve fit. ! ! =-1 a usage error of FC( ) occurred. The ! offending condition is noted with the ! SLATEC library error processor, XERMSG. ! In case the working arrays W(*) or IW(*) ! are not long enough, the minimal ! acceptable length is printed. ! ! = 0 successful constrained curve fit. ! ! = 1 the requested equality constraints ! are contradictory. ! ! = 2 the requested inequality constraints ! are contradictory. ! ! = 3 both equality and inequality constraints ! are contradictory. ! ! COEFF(*) ! If the output value of MODE=0 or 1, this array ! contains the unknowns obtained from the least ! squares fitting process. These N=NBKPT-NORD ! parameters are the B-spline coefficients. ! For MODE=1, the equality constraints are ! contradictory. To make the fitting process ! more robust, the equality constraints are ! satisfied in a least squares sense. In this ! case the array COEFF(*) contains B-spline ! coefficients for this extended concept of a ! solution. If MODE=-1,2 or 3 on output, the ! array COEFF(*) is undefined. ! ! Working Arrays.. ! W(*),IW(*) ! These arrays are respectively typed REAL and ! INTEGER. ! Their required lengths are specified as input ! parameters in IW(1), IW(2) noted above. The ! contents of W(*) must not be modified by the ! user if the variance function is desired. ! ! Evaluating the ! Variance Function.. ! To evaluate the variance function (assuming ! that the uncertainties of the Y values were ! provided to FC( ) and an input value of ! MODE=2 or 4 was used), use the function ! subprogram CV( ) ! ! VAR=CV(XVAL,NDATA,NCONST,NORD,NBKPT, ! BKPT,W) ! ! Here XVAL is the point where the variance is ! desired. The other arguments have the same ! meaning as in the usage of FC( ). ! ! For those users employing the old problem ! designation, let MDATA be the number of data ! points in the problem. (This may be different ! from NDATA if the old problem designation ! feature was used.) The value, VAR, should be ! multiplied by the quantity ! ! REAL(MAX(NDATA-N,1))/MAX(MDATA-N,1) ! ! The output of this subprogram is not defined ! if an input value of MODE=1 or 3 was used in ! FC( ) or if an output value of MODE=-1, 2, or ! 3 was obtained. The variance function, except ! for the scaling factor noted above, is given ! by ! ! VAR=(transpose of B(XVAL))*C*B(XVAL) ! ! The vector B(XVAL) is the B-spline basis ! function values at X=XVAL. ! The covariance matrix, C, of the solution ! coefficients accounts only for the least ! squares equations and the explicitly stated ! equality constraints. This fact must be ! considered when interpreting the variance ! function from a data fitting problem that has ! inequality constraints on the fitted curve. ! ! Evaluating the ! Fitted Curve.. ! To evaluate derivative number IDER at XVAL, ! use the function subprogram BVALU( ). ! ! F = BVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER, ! XVAL,INBV,WORKB) ! ! The output of this subprogram will not be ! defined unless an output value of MODE=0 or 1 ! was obtained from FC( ), XVAL is in the data ! interval, and IDER is nonnegative and < ! NORD. ! ! The first time BVALU( ) is called, INBV=1 ! must be specified. This value of INBV is the ! overwritten by BVALU( ). The array WORKB(*) ! must be of length at least 3*NORD, and must ! not be the same as the W(*) array used in ! the call to FC( ). ! ! BVALU( ) expects the breakpoint array BKPT(*) ! to be sorted. ! !***REFERENCES R. J. Hanson, Constrained least squares curve fitting ! to discrete data using B-splines, a users guide, ! Report SAND78-1291, Sandia Laboratories, December ! 1978. !***ROUTINES CALLED FCMN !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert references to XERRWV to references to XERMSG. (RWC) ! 900607 Editorial changes to Prologue to make Prologues for EFC, ! DEFC, FC, and DFC look as much the same as possible. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE FC REAL BKPT(*), COEFF(*), SDDATA(*), W(*), XCONST(*), & XDATA(*), YCONST(*), YDATA(*) INTEGER IW(*), MODE, NBKPT, NCONST, NDATA, NDERIV(*), NORD ! EXTERNAL FCMN ! INTEGER I1, I2, I3, I4, I5, I6, I7, MDG, MDW ! !***FIRST EXECUTABLE STATEMENT FC MDG = NBKPT - NORD + 3 MDW = NBKPT - NORD + 1 + NCONST ! USAGE IN FCMN( ) OF W(*).. ! I1,...,I2-1 G(*,*) ! ! I2,...,I3-1 XTEMP(*) ! ! I3,...,I4-1 PTEMP(*) ! ! I4,...,I5-1 BKPT(*) (LOCAL TO FCMN( )) ! ! I5,...,I6-1 BF(*,*) ! ! I6,...,I7-1 W(*,*) ! ! I7,... WORK(*) FOR LSEI( ) ! I1 = 1 I2 = I1 + MDG*(NORD+1) I3 = I2 + MAX(NDATA,NBKPT) I4 = I3 + MAX(NDATA,NBKPT) I5 = I4 + NBKPT I6 = I5 + NORD*NORD I7 = I6 + MDW*(NBKPT-NORD+1) call FCMN(NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT, NCONST, & XCONST, YCONST, NDERIV, MODE, COEFF, W(I5), W(I2), W(I3), & W(I4), W(I1), MDG, W(I6), MDW, W(I7), IW) return end subroutine FCMN (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPTIN, & NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, BF, XTEMP, PTEMP, & BKPT, G, MDG, W, MDW, WORK, IWORK) ! !! FCMN is subsidiary to FC. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (FCMN-S, DFCMN-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This is a companion subprogram to FC( ). ! The documentation for FC( ) has complete usage instructions. ! !***SEE ALSO FC !***ROUTINES CALLED BNDACC, BNDSOL, BSPLVD, BSPLVN, LSEI, SAXPY, SCOPY, ! SSCAL, SSORT, XERMSG !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and extensively revised (WRB & RWC) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE FCMN INTEGER IWORK(*), MDG, MDW, MODE, NBKPT, NCONST, NDATA, NDERIV(*), & NORD REAL BF(NORD,*), BKPT(*), BKPTIN(*), COEFF(*), & G(MDG,*), PTEMP(*), SDDATA(*), W(MDW,*), WORK(*), & XCONST(*), XDATA(*), XTEMP(*), YCONST(*), YDATA(*) ! EXTERNAL BNDACC, BNDSOL, BSPLVD, BSPLVN, LSEI, SAXPY, SCOPY, & SSCAL, SSORT, XERMSG ! REAL DUMMY, PRGOPT(10), RNORM, RNORME, RNORML, XMAX, & XMIN, XVAL, YVAL INTEGER I, IDATA, IDERIV, ILEFT, INTRVL, INTW1, IP, IR, IROW, & ITYPE, IW1, IW2, L, LW, MT, N, NB, NEQCON, NINCON, NORDM1, & NORDP1, NP1 LOGICAL BAND, NEW, VAR CHARACTER*8 XERN1 ! !***FIRST EXECUTABLE STATEMENT FCMN ! ! Analyze input. ! if (NORD < 1 .OR. NORD > 20) THEN call XERMSG ('SLATEC', 'FCMN', & 'IN FC, THE ORDER OF THE B-SPLINE MUST BE 1 THRU 20.', & 2, 1) MODE = -1 return ! ELSEIF (NBKPT < 2*NORD) THEN call XERMSG ('SLATEC', 'FCMN', & 'IN FC, THE NUMBER OF KNOTS MUST BE AT LEAST TWICE ' // & 'THE B-SPLINE ORDER.', 2, 1) MODE = -1 return end if ! if (NDATA < 0) THEN call XERMSG ('SLATEC', 'FCMN', & 'IN FC, THE NUMBER OF DATA POINTS MUST BE NONNEGATIVE.', & 2, 1) MODE = -1 return end if ! ! Amount of storage allocated for W(*), IW(*). ! IW1 = IWORK(1) IW2 = IWORK(2) NB = (NBKPT-NORD+3)*(NORD+1) + 2*MAX(NDATA,NBKPT) + NBKPT + & NORD**2 ! ! See if sufficient storage has been allocated. ! if (IW1 < NB) THEN WRITE (XERN1, '(I8)') NB call XERMSG ('SLATEC', 'FCMN', & 'IN FC, INSUFFICIENT STORAGE FOR W(*). CHECK NB = ' // & XERN1, 2, 1) MODE = -1 return end if ! if (MODE == 1) THEN BAND = .TRUE. VAR = .FALSE. NEW = .TRUE. ELSEIF (MODE == 2) THEN BAND = .FALSE. VAR = .TRUE. NEW = .TRUE. ELSEIF (MODE == 3) THEN BAND = .TRUE. VAR = .FALSE. NEW = .FALSE. ELSEIF (MODE == 4) THEN BAND = .FALSE. VAR = .TRUE. NEW = .FALSE. ELSE call XERMSG ('SLATEC', 'FCMN', & 'IN FC, INPUT VALUE OF MODE MUST BE 1-4.', 2, 1) MODE = -1 return end if MODE = 0 ! ! Sort the breakpoints. ! call SCOPY (NBKPT, BKPTIN, 1, BKPT, 1) call SSORT (BKPT, DUMMY, NBKPT, 1) ! ! Initialize variables. ! NEQCON = 0 NINCON = 0 DO 100 I = 1,NCONST L = NDERIV(I) ITYPE = MOD(L,4) if (ITYPE < 2) THEN NINCON = NINCON + 1 ELSE NEQCON = NEQCON + 1 ENDIF 100 CONTINUE ! ! Compute the number of variables. ! N = NBKPT - NORD NP1 = N + 1 LW = NB + (NP1+NCONST)*NP1 + 2*(NEQCON+NP1) + (NINCON+NP1) + & (NINCON+2)*(NP1+6) INTW1 = NINCON + 2*NP1 ! ! Save interval containing knots. ! XMIN = BKPT(NORD) XMAX = BKPT(NP1) ! ! Find the smallest referenced independent variable value in any ! constraint. ! DO 110 I = 1,NCONST XMIN = MIN(XMIN,XCONST(I)) XMAX = MAX(XMAX,XCONST(I)) 110 CONTINUE NORDM1 = NORD - 1 NORDP1 = NORD + 1 ! ! Define the option vector PRGOPT(1-10) for use in LSEI( ). ! PRGOPT(1) = 4 ! ! Set the covariance matrix computation flag. ! PRGOPT(2) = 1 if (VAR) THEN PRGOPT(3) = 1 ELSE PRGOPT(3) = 0 end if ! ! Increase the rank determination tolerances for both equality ! constraint equations and least squares equations. ! PRGOPT(4) = 7 PRGOPT(5) = 4 PRGOPT(6) = 1.E-4 ! PRGOPT(7) = 10 PRGOPT(8) = 5 PRGOPT(9) = 1.E-4 ! PRGOPT(10) = 1 ! ! Turn off work array length checking in LSEI( ). ! IWORK(1) = 0 IWORK(2) = 0 ! ! Initialize variables and analyze input. ! if (NEW) THEN ! ! To process least squares equations sort data and an array of ! pointers. ! call SCOPY (NDATA, XDATA, 1, XTEMP, 1) DO 120 I = 1,NDATA PTEMP(I) = I 120 CONTINUE ! if (NDATA > 0) THEN call SSORT (XTEMP, PTEMP, NDATA, 2) XMIN = MIN(XMIN,XTEMP(1)) XMAX = MAX(XMAX,XTEMP(NDATA)) ENDIF ! ! Fix breakpoint array if needed. ! DO 130 I = 1,NORD BKPT(I) = MIN(BKPT(I),XMIN) 130 CONTINUE ! DO 140 I = NP1,NBKPT BKPT(I) = MAX(BKPT(I),XMAX) 140 CONTINUE ! ! Initialize parameters of banded matrix processor, BNDACC( ). ! MT = 0 IP = 1 IR = 1 ILEFT = NORD DO 160 IDATA = 1,NDATA ! ! Sorted indices are in PTEMP(*). ! L = PTEMP(IDATA) XVAL = XDATA(L) ! ! When interval changes, process equations in the last block. ! if (XVAL >= BKPT(ILEFT+1)) THEN call BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) MT = 0 ! ! Move pointer up to have BKPT(ILEFT) <= XVAL, ! ILEFT < NP1. ! 150 if (XVAL >= BKPT(ILEFT+1) .AND. ILEFT < N) THEN ILEFT = ILEFT + 1 go to 150 ENDIF ENDIF ! ! Obtain B-spline function value. ! call BSPLVN (BKPT, NORD, 1, XVAL, ILEFT, BF) ! ! Move row into place. ! IROW = IR + MT MT = MT + 1 call SCOPY (NORD, BF, 1, G(IROW,1), MDG) G(IROW,NORDP1) = YDATA(L) ! ! Scale data if uncertainty is nonzero. ! if (SDDATA(L) /= 0.E0) call SSCAL (NORDP1, 1.E0/SDDATA(L), & G(IROW,1), MDG) ! ! When staging work area is exhausted, process rows. ! if (IROW == MDG-1) THEN call BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) MT = 0 ENDIF 160 CONTINUE ! ! Process last block of equations. ! call BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1) ! ! Last call to adjust block positioning. ! call SCOPY (NORDP1, 0.E0, 0, G(IR,1), MDG) call BNDACC (G, MDG, NORD, IP, IR, 1, NP1) end if ! BAND = BAND .AND. NCONST == 0 DO 170 I = 1,N BAND = BAND .AND. G(I,1) /= 0.E0 170 CONTINUE ! ! Process banded least squares equations. ! if (BAND) THEN call BNDSOL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM) return end if ! ! Check further for sufficient storage in working arrays. ! if (IW1 < LW) THEN WRITE (XERN1, '(I8)') LW call XERMSG ('SLATEC', 'FCMN', & 'IN FC, INSUFFICIENT STORAGE FOR W(*). CHECK LW = ' // & XERN1, 2, 1) MODE = -1 return end if ! if (IW2 < INTW1) THEN WRITE (XERN1, '(I8)') INTW1 call XERMSG ('SLATEC', 'FCMN', & 'IN FC, INSUFFICIENT STORAGE FOR IW(*). CHECK IW1 = ' // & XERN1, 2, 1) MODE = -1 return end if ! ! Write equality constraints. ! Analyze constraint indicators for an equality constraint. ! NEQCON = 0 DO 220 IDATA = 1,NCONST L = NDERIV(IDATA) ITYPE = MOD(L,4) if (ITYPE > 1) THEN IDERIV = L/4 NEQCON = NEQCON + 1 ILEFT = NORD XVAL = XCONST(IDATA) ! 180 if (XVAL < BKPT(ILEFT+1) .OR. ILEFT >= N) go to 190 ILEFT = ILEFT + 1 go to 180 ! 190 call BSPLVD (BKPT, NORD, XVAL, ILEFT, BF, IDERIV+1) call SCOPY (NP1, 0.E0, 0, W(NEQCON,1), MDW) call SCOPY (NORD, BF(1,IDERIV+1), 1, W(NEQCON,ILEFT-NORDM1), & MDW) ! if (ITYPE == 2) THEN W(NEQCON,NP1) = YCONST(IDATA) ELSE ILEFT = NORD YVAL = YCONST(IDATA) ! 200 if (YVAL < BKPT(ILEFT+1) .OR. ILEFT >= N) go to 210 ILEFT = ILEFT + 1 go to 200 ! 210 call BSPLVD (BKPT, NORD, YVAL, ILEFT, BF, IDERIV+1) call SAXPY (NORD, -1.E0, BF(1, IDERIV+1), 1, & W(NEQCON, ILEFT-NORDM1), MDW) ENDIF ENDIF 220 CONTINUE ! ! Transfer least squares data. ! DO 230 I = 1,NP1 IROW = I + NEQCON call SCOPY (N, 0.E0, 0, W(IROW,1), MDW) call SCOPY (MIN(NP1-I, NORD), G(I,1), MDG, W(IROW,I), MDW) W(IROW,NP1) = G(I,NORDP1) 230 CONTINUE ! ! Write inequality constraints. ! Analyze constraint indicators for inequality constraints. ! NINCON = 0 DO 260 IDATA = 1,NCONST L = NDERIV(IDATA) ITYPE = MOD(L,4) if (ITYPE < 2) THEN IDERIV = L/4 NINCON = NINCON + 1 ILEFT = NORD XVAL = XCONST(IDATA) ! 240 if (XVAL < BKPT(ILEFT+1) .OR. ILEFT >= N) go to 250 ILEFT = ILEFT + 1 go to 240 ! 250 call BSPLVD (BKPT, NORD, XVAL, ILEFT, BF, IDERIV+1) IROW = NEQCON + NP1 + NINCON call SCOPY (N, 0.E0, 0, W(IROW,1), MDW) INTRVL = ILEFT - NORDM1 call SCOPY (NORD, BF(1, IDERIV+1), 1, W(IROW, INTRVL), MDW) ! if (ITYPE == 1) THEN W(IROW,NP1) = YCONST(IDATA) ELSE W(IROW,NP1) = -YCONST(IDATA) call SSCAL (NORD, -1.E0, W(IROW, INTRVL), MDW) ENDIF ENDIF 260 CONTINUE ! ! Solve constrained least squares equations. ! call LSEI(W, MDW, NEQCON, NP1, NINCON, N, PRGOPT, COEFF, RNORME, & RNORML, MODE, WORK, IWORK) return end subroutine FDJAC1 (FCN, N, X, FVEC, FJAC, LDFJAC, IFLAG, ML, MU, & EPSFCN, WA1, WA2) ! !! FDJAC1 is subsidiary to SNSQ and SNSQE. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (FDJAC1-S, DFDJC1-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine computes a forward-difference approximation ! to the N by N Jacobian matrix associated with a specified ! problem of N functions in N VARIABLES. If the Jacobian has ! a banded form, then function evaluations are saved by only ! approximating the nonzero terms. ! ! The subroutine statement is ! ! SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, ! WA1,WA2) ! ! where ! ! FCN is the name of the user-supplied subroutine which ! calculates the functions. FCN must be declared ! in an external statement in the user calling ! program, and should be written as follows. ! ! SUBROUTINE FCN(N,X,FVEC,IFLAG) ! INTEGER N,IFLAG ! REAL X(N),FVEC(N) ! ---------- ! Calculate the functions at X and ! return this vector in FVEC. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by FCN unless ! the user wants to terminate execution of FDJAC1. ! In this case set IFLAG to a negative integer. ! ! N Is a positive integer input variable set to the number ! of functions and variables. ! ! X is an input array of length N. ! ! FVEC is an input array of length N which must contain the ! functions evaluated at X. ! ! FJAC is an output N by N array which contains the ! approximation to the Jacobian matrix evaluated at X. ! ! LDFJAC is a positive integer input variable not less than N ! which specifies the leading dimension of the array FJAC. ! ! IFLAG is an integer variable which can be used to terminate ! the execution of FDJAC1. See description of FCN. ! ! ML is a nonnegative integer input variable which specifies ! the number of subdiagonals within the band of the ! Jacobian matrix. If the Jacobian is not banded, set ! ML to at least N - 1. ! ! EPSFCN is an input variable used in determining a suitable ! step length for the forward-difference approximation. This ! approximation assumes that the relative errors in the ! functions are of the order of EPSFCN. If EPSFCN is less ! than the machine precision, it is assumed that the relative ! errors in the functions are of the order of the machine ! precision. ! ! MU is a nonnegative integer input variable which specifies ! the number of superdiagonals within the band of the ! Jacobian matrix. If the Jacobian is not banded, set ! MU to at least N - 1. ! ! WA1 and WA2 are work arrays of length N. If ML + MU + 1 is at ! least N, then the Jacobian is considered dense, and WA2 is ! not referenced. ! !***SEE ALSO SNSQ, SNSQE !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE FDJAC1 INTEGER N,LDFJAC,IFLAG,ML,MU REAL EPSFCN REAL X(*),FVEC(*),FJAC(LDFJAC,*),WA1(*),WA2(*) INTEGER I,J,K,MSUM REAL EPS,EPSMCH,H,TEMP,ZERO REAL R1MACH SAVE ZERO DATA ZERO /0.0E0/ !***FIRST EXECUTABLE STATEMENT FDJAC1 EPSMCH = R1MACH(4) ! EPS = SQRT(MAX(EPSFCN,EPSMCH)) MSUM = ML + MU + 1 if (MSUM < N) go to 40 ! ! COMPUTATION OF DENSE APPROXIMATE JACOBIAN. ! DO 20 J = 1, N TEMP = X(J) H = EPS*ABS(TEMP) if (H == ZERO) H = EPS X(J) = TEMP + H call FCN(N,X,WA1,IFLAG) if (IFLAG < 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 ! ! COMPUTATION OF BANDED APPROXIMATE JACOBIAN. ! DO 90 K = 1, MSUM DO 60 J = K, N, MSUM WA2(J) = X(J) H = EPS*ABS(WA2(J)) if (H == ZERO) H = EPS X(J) = WA2(J) + H 60 CONTINUE call FCN(N,X,WA1,IFLAG) if (IFLAG < 0) go to 100 DO 80 J = K, N, MSUM X(J) = WA2(J) H = EPS*ABS(WA2(J)) if (H == ZERO) H = EPS DO 70 I = 1, N FJAC(I,J) = ZERO if (I >= J - MU .AND. I <= J + ML) & FJAC(I,J) = (WA1(I) - FVEC(I))/H 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE 110 CONTINUE return ! ! LAST CARD OF SUBROUTINE FDJAC1. ! end subroutine FDJAC3 (FCN, M, N, X, FVEC, FJAC, LDFJAC, IFLAG, & EPSFCN, WA) ! !! FDJAC3 is subsidiary to SNLS1 and SNLS1E. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (FDJAC3-S, DFDJC3-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine computes a forward-difference approximation ! to the M by N Jacobian matrix associated with a specified ! problem of M functions in N variables. ! ! The subroutine statement is ! ! SUBROUTINE FDJAC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) ! ! where ! ! FCN is the name of the user-supplied subroutine which ! calculates the functions. FCN must be declared ! in an external statement in the user calling ! program, and should be written as follows. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! INTEGER LDFJAC,M,N,IFLAG ! REAL X(N),FVEC(M),FJAC(LDFJAC,N) ! ---------- ! When IFLAG == 1 calculate the functions at X and ! return this vector in FVEC. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by FCN unless ! the user wants to terminate execution of FDJAC3. ! In this case set IFLAG to a negative integer. ! ! M is a positive integer input variable set to the number ! of functions. ! ! N is a positive integer input variable set to the number ! of variables. N must not exceed M. ! ! X is an input array of length N. ! ! FVEC is an input array of length M which must contain the ! functions evaluated at X. ! ! FJAC is an output M by N array which contains the ! approximation to the Jacobian matrix evaluated at X. ! ! LDFJAC is a positive integer input variable not less than M ! which specifies the leading dimension of the array FJAC. ! ! IFLAG is an integer variable which can be used to terminate ! THE EXECUTION OF FDJAC3. See description of FCN. ! ! EPSFCN is an input variable used in determining a suitable ! step length for the forward-difference approximation. This ! approximation assumes that the relative errors in the ! functions are of the order of EPSFCN. If EPSFCN is less ! than the machine precision, it is assumed that the relative ! errors in the functions are of the order of the machine ! precision. ! ! WA is a work array of length M. ! !***SEE ALSO SNLS1, SNLS1E !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE FDJAC3 INTEGER M,N,LDFJAC,IFLAG REAL EPSFCN REAL X(*),FVEC(*),FJAC(LDFJAC,*),WA(*) INTEGER I,J REAL EPS,EPSMCH,H,TEMP,ZERO REAL R1MACH SAVE ZERO DATA ZERO /0.0E0/ !***FIRST EXECUTABLE STATEMENT FDJAC3 EPSMCH = R1MACH(4) ! EPS = SQRT(MAX(EPSFCN,EPSMCH)) ! SET IFLAG=1 TO INDICATE THAT FUNCTION VALUES ! ARE TO BE RETURNED BY FCN. IFLAG = 1 DO 20 J = 1, N TEMP = X(J) H = EPS*ABS(TEMP) if (H == ZERO) H = EPS X(J) = TEMP + H call FCN(IFLAG,M,N,X,WA,FJAC,LDFJAC) if (IFLAG < 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 ! ! LAST CARD OF SUBROUTINE FDJAC3. ! end subroutine FDUMP ! !! FDUMP makes a symbolic dump (should be locally written). ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3 !***TYPE ALL (FDUMP-A) !***KEYWORDS ERROR, XERMSG !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! ***Note*** Machine Dependent Routine ! FDUMP is intended to be replaced by a locally written ! version which produces a symbolic dump. Failing this, ! it should be replaced by a version which prints the ! subprogram nesting list. Note that this dump must be ! printed on each of up to five files, as indicated by the ! XGETUA routine. See XSETUA and XGETUA for details. ! ! Written by Ron Jones, with SLATEC Common Math Library Subcommittee ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE FDUMP !***FIRST EXECUTABLE STATEMENT FDUMP return end subroutine FFTDOC ! !! FFTDOC is documentation for FFTPACK, a collection of Fast Fourier ... ! Transform routines. !***LIBRARY SLATEC !***CATEGORY J1, Z !***TYPE ALL (FFTDOC-A) !***KEYWORDS DOCUMENTATION, FAST FOURIER TRANSFORM, FFT !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! Version 3 June 1979 ! ! A Package of Fortran Subprograms for The Fast Fourier ! Transform of Periodic and Other Symmetric Sequences ! By ! Paul N Swarztrauber ! ! National Center For Atmospheric Research, Boulder, Colorado 80307 ! which is sponsored by the National Science Foundation ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! This package consists of programs which perform Fast Fourier ! Transforms for both complex and real periodic sequences and ! certain other symmetric sequences that are listed below. ! ! 1. RFFTI Initialize RFFTF and RFFTB ! 2. RFFTF Forward transform of a real periodic sequence ! 3. RFFTB Backward transform of a real coefficient array ! ! 4. EZFFTI Initialize EZFFTF and EZFFTB ! 5. EZFFTF A simplified real periodic forward transform ! 6. EZFFTB A simplified real periodic backward transform ! ! 7. SINTI Initialize SINT ! 8. SINT Sine transform of a real odd sequence ! ! 9. COSTI Initialize COST ! 10. COST Cosine transform of a real even sequence ! ! 11. SINQI Initialize SINQF and SINQB ! 12. SINQF Forward sine transform with odd wave numbers ! 13. SINQB Unnormalized inverse of SINQF ! ! 14. COSQI Initialize COSQF and COSQB ! 15. COSQF Forward cosine transform with odd wave numbers ! 16. COSQB Unnormalized inverse of COSQF ! ! 17. CFFTI Initialize CFFTF and CFFTB ! 18. CFFTF Forward transform of a complex periodic sequence ! 19. CFFTB Unnormalized inverse of CFFTF ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780201 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900723 PURPOSE section revised. (WRB) !***END PROLOGUE FFTDOC !***FIRST EXECUTABLE STATEMENT FFTDOC return end subroutine FIGI2 (NM, N, T, D, E, Z, IERR) ! !! FIGI2 transforms certain real non-symmetric tridiagonal matrix ... ! to symmetric tridiagonal matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1C !***TYPE SINGLE PRECISION (FIGI2-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! Given a NONSYMMETRIC TRIDIAGONAL matrix such that the products ! of corresponding pairs of off-diagonal elements are all ! non-negative, and zero only when both factors are zero, this ! subroutine reduces it to a SYMMETRIC TRIDIAGONAL matrix ! using and accumulating diagonal similarity transformations. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, T and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix T. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! T contains the nonsymmetric matrix. Its subdiagonal is ! stored in the last N-1 positions of the first column, ! its diagonal in the N positions of the second column, ! and its superdiagonal in the first N-1 positions of ! the third column. T(1,1) and T(N,3) are arbitrary. ! T is a two-dimensional REAL array, dimensioned T(NM,3). ! ! On OUTPUT ! ! T is unaltered. ! ! D contains the diagonal elements of the tridiagonal symmetric ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the tridiagonal ! symmetric matrix in its last N-1 positions. E(1) is not set. ! E is a one-dimensional REAL array, dimensioned E(N). ! ! Z contains the diagonal transformation matrix produced in the ! symmetrization. Z is a two-dimensional REAL array, ! dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! N+I if T(I,1)*T(I-1,3) is negative, ! 2*N+I if T(I,1)*T(I-1,3) is zero with one factor ! non-zero. In these cases, there does not exist ! a symmetrizing similarity transformation which ! is essential for the validity of the later ! eigenvector computation. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE FIGI2 ! INTEGER I,J,N,NM,IERR REAL T(NM,3),D(*),E(*),Z(NM,*) REAL H ! !***FIRST EXECUTABLE STATEMENT FIGI2 IERR = 0 ! DO 100 I = 1, N ! DO 50 J = 1, N 50 Z(I,J) = 0.0E0 ! if (I == 1) go to 70 H = T(I,1) * T(I-1,3) if (H) 900, 60, 80 60 if (T(I,1) /= 0.0E0 .OR. T(I-1,3) /= 0.0E0) go to 1000 E(I) = 0.0E0 70 Z(I,I) = 1.0E0 go to 90 80 E(I) = SQRT(H) Z(I,I) = Z(I-1,I-1) * E(I) / T(I-1,3) 90 D(I) = T(I,2) 100 CONTINUE ! go to 1001 ! .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL ! ELEMENTS IS NEGATIVE .......... 900 IERR = N + I go to 1001 ! .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL ! ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... 1000 IERR = 2 * N + I 1001 RETURN end subroutine FIGI (NM, N, T, D, E, E2, IERR) ! !! FIGI transforms certain real non-symmetric tridiagonal matrix ... ! to symmetric tridiagonal matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1C !***TYPE SINGLE PRECISION (FIGI-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! Given a NONSYMMETRIC TRIDIAGONAL matrix such that the products ! of corresponding pairs of off-diagonal elements are all ! non-negative, this subroutine reduces it to a symmetric ! tridiagonal matrix with the same eigenvalues. If, further, ! a zero product only occurs when both factors are zero, ! the reduced matrix is similar to the original matrix. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, T, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix T. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! T contains the nonsymmetric matrix. Its subdiagonal is ! stored in the last N-1 positions of the first column, ! its diagonal in the N positions of the second column, ! and its superdiagonal in the first N-1 positions of ! the third column. T(1,1) and T(N,3) are arbitrary. ! T is a two-dimensional REAL array, dimensioned T(NM,3). ! ! On OUTPUT ! ! T is unaltered. ! ! D contains the diagonal elements of the tridiagonal symmetric ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the tridiagonal ! symmetric matrix in its last N-1 positions. E(1) is not set. ! E is a one-dimensional REAL array, dimensioned E(N). ! ! E2 contains the squares of the corresponding elements of E. ! E2 may coincide with E if the squares are not needed. ! E2 is a one-dimensional REAL array, dimensioned E2(N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! N+I if T(I,1)*T(I-1,3) is negative and a symmetric ! matrix cannot be produced with FIGI, ! -(3*N+I) if T(I,1)*T(I-1,3) is zero with one factor ! non-zero. In this case, the eigenvectors of ! the symmetric matrix are not simply related ! to those of T and should not be sought. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE FIGI ! INTEGER I,N,NM,IERR REAL T(NM,3),D(*),E(*),E2(*) ! !***FIRST EXECUTABLE STATEMENT FIGI IERR = 0 ! DO 100 I = 1, N if (I == 1) go to 90 E2(I) = T(I,1) * T(I-1,3) if (E2(I)) 1000, 60, 80 60 if (T(I,1) == 0.0E0 .AND. T(I-1,3) == 0.0E0) go to 80 ! .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL ! ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... IERR = -(3 * N + I) 80 E(I) = SQRT(E2(I)) 90 D(I) = T(I,2) 100 CONTINUE ! go to 1001 ! .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL ! ELEMENTS IS NEGATIVE .......... 1000 IERR = N + I 1001 RETURN end subroutine FULMAT (I, J, AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) ! !! FULMAT is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (FULMAT-S, DFULMT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DECODES A STANDARD TWO-DIMENSIONAL FORTRAN ARRAY PASSED ! IN THE ARRAY DATTRV(IA,*). THE ROW DIMENSION IA AND THE ! MATRIX DIMENSIONS MRELAS AND NVARS MUST SIMULTANEOUSLY BE ! PASSED USING THE OPTION ARRAY, PRGOPT(*). IT IS AN ERROR ! if THIS DATA IS NOT PASSED TO FULMAT( ). ! EXAMPLE-- (FOR USE TOGETHER WITH SPLP().) ! EXTERNAL USRMAT ! DIMENSION DATTRV(IA,*) ! PRGOPT(01)=7 ! PRGOPT(02)=68 ! PRGOPT(03)=1 ! PRGOPT(04)=IA ! PRGOPT(05)=MRELAS ! PRGOPT(06)=NVARS ! PRGOPT(07)=1 ! call SPLP( ... FULMAT INSTEAD OF USRMAT...) ! !***SEE ALSO SPLP !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE FULMAT REAL AIJ,ZERO,DATTRV(*),PRGOPT(*) INTEGER IFLAG(10) SAVE ZERO !***FIRST EXECUTABLE STATEMENT FULMAT if (.NOT.(IFLAG(1) == 1)) go to 50 ! INITIALIZE POINTERS TO PROCESS FULL TWO-DIMENSIONAL FORTRAN ! ARRAYS. ZERO = 0. LP = 1 10 NEXT = PRGOPT(LP) if (.NOT.(NEXT <= 1)) go to 20 NERR = 29 LEVEL = 1 call XERMSG ('SLATEC', 'FULMAT', & 'IN SPLP PACKAGE, ROW DIM., MRELAS, NVARS ARE MISSING FROM ' // & 'PRGOPT.', NERR, LEVEL) IFLAG(1) = 3 go to 110 20 KEY = PRGOPT(LP+1) if (.NOT.(KEY /= 68)) go to 30 LP = NEXT go to 10 30 if (.NOT.(PRGOPT(LP+2) == ZERO)) go to 40 LP = NEXT go to 10 40 IFLAG(2) = 1 IFLAG(3) = 1 IFLAG(4) = PRGOPT(LP+3) IFLAG(5) = PRGOPT(LP+4) IFLAG(6) = PRGOPT(LP+5) go to 110 50 if (.NOT.(IFLAG(1) == 2)) go to 100 60 I = IFLAG(2) J = IFLAG(3) if (.NOT.(J > IFLAG(6))) go to 70 IFLAG(1) = 3 go to 110 70 if (.NOT.(I > IFLAG(5))) go to 80 IFLAG(2) = 1 IFLAG(3) = J + 1 go to 60 80 AIJ = DATTRV(IFLAG(4)*(J-1)+I) IFLAG(2) = I + 1 if (.NOT.(AIJ == ZERO)) go to 90 go to 60 90 INDCAT = 0 go to 110 100 CONTINUE 110 RETURN end subroutine FUNDOC ! !! FUNDOC is documentation for FNLIB, a collection of routines for ... ! evaluating elementary and special functions. ! !***LIBRARY SLATEC !***CATEGORY C, Z !***TYPE ALL (FUNDOC-A) !***KEYWORDS DOCUMENTATION, ELEMENTARY FUNCTIONS, SPECIAL FUNCTIONS !***AUTHOR Kahaner, D. K., (NBS) !***DESCRIPTION ! ! The SLATEC Library -- Elementary And Special Functions ! ! This describes the elementary and special function routines available ! in the SLATEC library. Most of the these routines were written by ! Wayne Fullerton while at LANL. Some were written by Don Amos of SNLA. ! There are approximately 63 single precision, 63 double precision and ! 25 complex user callable elementary and special function routines. ! ! The table below gives a breakdown of routines according to their ! function. Unless otherwise indicated all routines are function ! subprograms. ! Sngl. Dble. ! Description Notation Prec. Prec. Complex ! ! ***Intrinsic Functions and Fundamental Functions*** ! Unpack floating point Call R9UPAK(X,Y,N) D9UPAK -- ! number ! Pack floating point R9PAK(Y,N) D9PAK -- ! number ! Initialize orthogonal INITS(OS,NOS,ETA) INITDS -- ! polynomial series ! Evaluate Chebyshev summation for CSEVL(X,CS,N) DCSEVL -- ! series i = 1 to n of ! cs(i)*(2*x)**(i-1) ! ! ***Elementary Functions*** ! Argument = theta in z = \ z \ * -- -- CARG(Z) ! radians e**(i * theta) ! Cube root CBRT(X) DCBRT CCBRT ! Relative error exponen- ((e**x) -1) / x EXPREL(X) DEXPRL CEXPRL ! tial from first order ! Common logarithm log to the base 10 -- -- CLOG10(Z) ! of z ! Relative error logarithm ln(1 + x) ALNREL(X) DLNREL CLNREL ! Relative error logarithm (ln(1 + x) - x R9LN2R(X) D9LN2R C9LN2R ! from second order + x**2/2) / x**3 ! ***Trigonometric and Hyperbolic Functions*** ! Tangent tan z -- -- CTAN(Z) ! Cotangent cot x COT(X) DCOT CCOT ! Sine x in degrees sin((2*pi*x)/360) SINDG(X) DSINDG -- ! Cosine x in degrees cos((2*pi*x)/360) COSDG(X) DCOSDG -- ! Arc sine arcsin (z) -- -- CASIN(Z) ! Arc cosine arccos (z) -- -- CACOS(Z) ! Arc tangent arctan (z) -- -- CATAN(Z) ! Quadrant correct arctan (z1/z2) -- -- CATAN2(Z1, ! arc tangent Z2) ! Hyperbolic sine sinh z -- -- CSINH(Z) ! Hyperbolic cosine cosh z -- -- CCOSH(Z) ! Hyperbolic tangent tanh z -- -- CTANH(Z) ! Arc hyperbolic sine arcsinh (x) ASINH(X) DASINH CASINH ! Arc hyperbolic cosine arccosh (x) ACOSH(X) DACOSH CACOSH ! Arc hyperbolic tangent arctanh (x) ATANH(X) DATANH CATANH ! Relative error arc (arctan (x) - x) R9ATN1(X) D9ATN1 -- ! tangent from first order / x**3 ! ***Exponential Integrals and Related Functions*** ! Exponential integral Ei(x) = (minus) EI(X) DEI -- ! the integral from ! -x to infinity of ! (e**-t / t)dt ! Exponential integral E sub 1 (x) = E1(X) DE1 -- ! the integral from x ! to infinity of ! (e**-t / t) dt ! Logarithmic integral li(x) = the ALI(X) DLI -- ! integral from 0 to ! x of (1 / ln t) dt ! Sequences of exponential integrals. ! M values are computed where ! k=0,1,...M-1 and n>=1 ! Exponential integral E sub n+k (x) Call EXINT(X, DEXINT -- ! =the integral from N,KODE,M,TOL, ! 1 to infinity of EN,IERR) ! (e**(-x*t)/t**(n+k))dt ! ***Gamma Functions and Related Functions*** ! Factorial n! FAC(N) DFAC -- ! Binomial n!/(m!*(n-m)!) BINOM(N,M) DBINOM -- ! Gamma gamma(x) GAMMA(X) DGAMMA CGAMMA ! Gamma(x) under and Call GAMLIM( DGAMLM -- ! overflow limits XMIN,XMAX) ! Reciprocal gamma 1 / gamma(x) GAMR(X) DGAMR CGAMR ! Log abs gamma ln \gamma(x)\ ALNGAM(X) DLNGAM -- ! Log gamma ln gamma(z) -- -- CLNGAM ! Log abs gamma g = ln \gamma(x)\ Call ALGAMS(X, DLGAMS -- ! with sign s = sign gamma(x) G,S) ! Incomplete gamma gamma(a,x) = GAMI(A,X) DGAMI -- ! the integral from ! 0 to x of ! (t**(a-1) * e**-t)dt ! Complementary gamma(a,x) = GAMIC(A,X) DGAMIC -- ! incomplete gamma the integral from ! x to infinity of ! (t**(a-1) * e**-t)dt ! Tricomi's gamma super star(a,x) GAMIT(A,X) DGAMIT -- ! incomplete gamma = x**-a * ! incomplete gamma(a,x) ! / gamma(a) ! Psi (Digamma) psi(x) = gamma'(x) PSI(X) DPSI CPSI ! / gamma(x) ! Pochhammer's (a) sub x = gamma(a+x) POCH(A,X) DPOCH -- ! generalized symbol / gamma(a) ! Pochhammer's symbol ((a) sub x -1) / x POCH1(A,X) DPOCH1 -- ! from first order ! Beta b(a,b) = (gamma(a) BETA(A,B) DBETA CBETA ! * gamma(b)) ! / gamma(a+b) ! = the integral ! from 0 to 1 of ! (t**(a-1) * ! (1-t)**(b-1))dt ! Log beta ln b(a,b) ALBETA(A,B) DLBETA CLBETA ! Incomplete beta i sub x (a,b) = BETAI(X,A,B) DBETAI __ ! b sub x (a,b) / b(a,b) ! = 1 / b(a,b) * ! the integral ! from 0 to x of ! (t**(a-1) * ! (1-t)**(b-1))dt ! Log gamma correction ln gamma(x) - R9LGMC(X) D9LGMC C9LGMC ! term when Stirling's (ln(2 * pi))/2 - ! approximation is valid (x - 1/2) * ln(x) + x ! ***Error Functions and Fresnel Integrals*** ! Error function erf x = (2 / ERF(X) DERF -- ! square root of pi) * ! the integral from ! 0 to x of ! e**(-t**2)dt ! Complementary erfc x = (2 / ERFC(X) DERFC -- ! error function square root of pi) * ! the integral from ! x to infinity of ! e**(-t**2)dt ! Dawson's function F(x) = e**(-x**2) DAWS(X) DDAWS -- ! * the integral from ! from 0 to x of ! e**(t**2)dt ! ***Bessel Functions*** ! Bessel functions of special integer order ! First kind, order zero J sub 0 (x) BESJ0(X) DBESJ0 -- ! First kind, order one J sub 1 (x) BESJ1(X) DBESJ1 -- ! Second kind, order zero Y sub 0 (x) BESY0(X) DBESY0 -- ! Second kind, order one Y sub 1 (x) BESY1(X) DBESY1 -- ! Modified (hyperbolic) Bessel functions of special integer order ! First kind, order zero I sub 0 (x) BESI0(X) DBESI0 -- ! First kind, order one I sub 1 (x) BESI1(X) DBESI1 -- ! Third kind, order zero K sub 0 (x) BESK0(X) DBESK0 -- ! Third kind, order one K sub 1 (x) BESK1(X) DBESK1 -- ! Modified (hyperbolic) Bessel functions of special integer order ! scaled by an exponential ! First kind, order zero e**-\x\ * I sub 0(x) BESI0E(X) DBSI0E -- ! First kind, order one e**-\x\ * I sub 1(x) BESI1E(X) DBSI1E -- ! Third kind, order zero e**x * K sub 0 (x) BESK0E(X) DBSK0E -- ! Third kind, order one e**x * K sub 1 (x) BESK1E(X) DBSK1E -- ! Sequences of Bessel functions of general order. ! N values are computed where k = 1,2,...N and v .ge. 0. ! Modified first kind I sub v+k-1 (x) Call BESI(X, DBESI -- ! optional scaling ALPHA,KODE,N, ! by e**(-x) Y,NZ) ! First kind J sub v+k-1 (x) Call BESJ(X, DBESJ -- ! ALPHA,N,Y,NZ) ! Second kind Y sub v+k-1 (x) Call BESY(X, DBESY -- ! FNU,N,Y) ! Modified third kind K sub v+k-1 (x) Call BESK(X, DBESK -- ! optional scaling FNU,KODE,N,Y, ! by e**(x) NZ) ! Sequences of Bessel functions. \N\ values are computed where ! I = 0, 1, 2, ..., N-1 for N > 0 or I = 0, -1, -2, ..., N+1 ! for N < 0. ! Modified third kind K sub v+i (x) Call BESKS( DBESKS -- ! XNU,X,N,BK) ! Sequences of Bessel functions scaled by an exponential. ! \N\ values are computed where I = 0, 1, 2, ..., N-1 ! for N > 0 or I = 0, -1, -2, ..., N+1 for N < 0. ! Modified third kind e**x * Call BESKES( DBSKES -- ! K sub v+i (x) XNU,X,N,BK) ! ***Bessel Functions of Fractional Order*** ! Airy functions ! Airy Ai(x) AI(X) DAI -- ! Bairy Bi(x) BI(X) DBI -- ! Exponentially scaled Airy functions ! Airy Ai(x), x <= 0 AIE(X) DAIE -- ! exp(2/3 * x**(3/2)) ! * Ai(x), x >= 0 ! Bairy Bi(x), x <= 0 BIE(X) DBIE -- ! exp(-2/3 * x**(3/2)) ! * Bi(x), x >= 0 ! ***Confluent Hypergeometric Functions*** ! Confluent U(a,b,x) CHU(A,B,X) DCHU -- ! hypergeometric ! ***Miscellaneous Functions*** ! Spence s(x) = - the SPENC(X) DSPENC -- ! dilogarithm integral from ! 0 to x of ! ((ln \1-y\) / y)dy ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801015 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Routine name changed from FNLIBD to FUNDOC. (WRB) ! 900723 PURPOSE section revised. (WRB) !***END PROLOGUE FUNDOC !***FIRST EXECUTABLE STATEMENT FUNDOC return end subroutine FZERO (F, B, C, R, RE, AE, IFLAG) ! !! FZERO searches for a zero of a function F(X) in a given interval ... ! (B,C). It is designed primarily for problems where F(B) ! and F(C) have opposite signs. ! !***LIBRARY SLATEC !***CATEGORY F1B !***TYPE SINGLE PRECISION (FZERO-S, DFZERO-D) !***KEYWORDS BISECTION, NONLINEAR EQUATIONS, ROOTS, ZEROS !***AUTHOR Shampine, L. F., (SNLA) ! Watts, H. A., (SNLA) !***DESCRIPTION ! ! FZERO searches for a zero of a REAL function F(X) between the ! given REAL values B and C until the width of the interval (B,C) ! has collapsed to within a tolerance specified by the stopping ! criterion, ! ABS(B-C) <= 2.*(RW*ABS(B)+AE). ! The method used is an efficient combination of bisection and the ! secant rule and is due to T. J. Dekker. ! ! Description Of Arguments ! ! F :EXT - Name of the REAL external function. This name must ! be in an EXTERNAL statement in the calling program. ! F must be a function of one REAL argument. ! ! B :INOUT - One end of the REAL interval (B,C). The value ! returned for B usually is the better approximation ! to a zero of F. ! ! C :INOUT - The other end of the REAL interval (B,C) ! ! R :OUT - A (better) REAL guess of a zero of F which could help ! in speeding up convergence. If F(B) and F(R) have ! opposite signs, a root will be found in the interval ! (B,R); if not, but F(R) and F(C) have opposite signs, ! a root will be found in the interval (R,C); ! otherwise, the interval (B,C) will be searched for a ! possible root. When no better guess is known, it is ! recommended that r be set to B or C, since if R is ! not interior to the interval (B,C), it will be ! ignored. ! ! RE :IN - Relative error used for RW in the stopping criterion. ! If the requested RE is less than machine precision, ! then RW is set to approximately machine precision. ! ! AE :IN - Absolute error used in the stopping criterion. If ! the given interval (B,C) contains the origin, then a ! nonzero value should be chosen for AE. ! ! IFLAG :OUT - A status code. User must check IFLAG after each ! call. Control returns to the user from FZERO in all ! cases. ! ! 1 B is within the requested tolerance of a zero. ! The interval (B,C) collapsed to the requested ! tolerance, the function changes sign in (B,C), and ! F(X) decreased in magnitude as (B,C) collapsed. ! ! 2 F(B) = 0. However, the interval (B,C) may not have ! collapsed to the requested tolerance. ! ! 3 B may be near a singular point of F(X). ! The interval (B,C) collapsed to the requested tol- ! erance and the function changes sign in (B,C), but ! F(X) increased in magnitude as (B,C) collapsed, i.e. ! ABS(F(B out)) > MAX(ABS(F(B in)),ABS(F(C in))) ! ! 4 No change in sign of F(X) was found although the ! interval (B,C) collapsed to the requested tolerance. ! The user must examine this case and decide whether ! B is near a local minimum of F(X), or B is near a ! zero of even multiplicity, or neither of these. ! ! 5 Too many ( > 500) function evaluations used. ! !***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving ! code, Report SC-TM-70-631, Sandia Laboratories, ! September 1970. ! T. J. Dekker, Finding a zero by means of successive ! linear interpolation, Constructive Aspects of the ! Fundamental Theorem of Algebra, edited by B. Dejon ! and P. Henrici, Wiley-Interscience, 1969. !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 700901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE FZERO REAL A,ACBS,ACMB,AE,AW,B,C,CMB,ER,FA,FB,FC,FX,FZ,P,Q,R, & RE,RW,T,TOL,Z INTEGER IC,IFLAG,KOUNT !***FIRST EXECUTABLE STATEMENT FZERO ! ! ER is two times the computer unit roundoff value which is defined ! here by the function R1MACH. ! ER = 2.0E0 * R1MACH(4) ! ! Initialize. ! Z = R if (R <= MIN(B,C) .OR. R >= MAX(B,C)) Z = C RW = MAX(RE,ER) AW = MAX(AE,0.E0) IC = 0 T = Z FZ = F(T) FC = FZ T = B FB = F(T) KOUNT = 2 if (SIGN(1.0E0,FZ) == SIGN(1.0E0,FB)) go to 1 C = Z go to 2 1 if (Z == C) go to 2 T = C FC = F(T) KOUNT = 3 if (SIGN(1.0E0,FZ) == SIGN(1.0E0,FC)) go to 2 B = Z FB = FZ 2 A = C FA = FC ACBS = ABS(B-C) FX = MAX(ABS(FB),ABS(FC)) ! 3 if (ABS(FC) >= ABS(FB)) go to 4 ! ! Perform interchange. ! A = B FA = FB B = C FB = FC C = A FC = FA ! 4 CMB = 0.5E0*(C-B) ACMB = ABS(CMB) TOL = RW*ABS(B) + AW ! ! Test stopping criterion and function count. ! if (ACMB <= TOL) go to 10 if (FB == 0.E0) go to 11 if (KOUNT >= 500) go to 14 ! ! Calculate new iterate implicitly as B+P/Q, where we arrange ! P >= 0. The implicit form is used to prevent overflow. ! P = (B-A)*FB Q = FA - FB if (P >= 0.E0) go to 5 P = -P Q = -Q ! ! Update A and check for satisfactory reduction in the size of the ! bracketing interval. If not, perform bisection. ! 5 A = B FA = FB IC = IC + 1 if (IC < 4) go to 6 if (8.0E0*ACMB >= ACBS) go to 8 IC = 0 ACBS = ACMB ! ! Test for too small a change. ! 6 if (P > ABS(Q)*TOL) go to 7 ! ! Increment by TOLerance. ! B = B + SIGN(TOL,CMB) go to 9 ! ! Root ought to be between B and (C+B)/2. ! 7 if (P >= CMB*Q) go to 8 ! ! Use secant rule. ! B = B + P/Q go to 9 ! ! Use bisection (C+B)/2. ! 8 B = B + CMB ! ! Have completed computation for new iterate B. ! 9 T = B FB = F(T) KOUNT = KOUNT + 1 ! ! Decide whether next step is interpolation or extrapolation. ! if (SIGN(1.0E0,FB) /= SIGN(1.0E0,FC)) go to 3 C = A FC = FA go to 3 ! ! Finished. Process results for proper setting of IFLAG. ! 10 if (SIGN(1.0E0,FB) == SIGN(1.0E0,FC)) go to 13 if (ABS(FB) > FX) go to 12 IFLAG = 1 return 11 IFLAG = 2 return 12 IFLAG = 3 return 13 IFLAG = 4 return 14 IFLAG = 5 return end FUNCTION GAMIC (A, X) ! !! GAMIC calculates the complementary incomplete Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE SINGLE PRECISION (GAMIC-S, DGAMIC-D) !***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate the complementary incomplete gamma function ! ! GAMIC = integral from X to infinity of EXP(-T) * T**(A-1.) . ! ! GAMIC is evaluated for arbitrary real values of A and for non- ! negative values of X (even though GAMIC is defined for X < ! 0.0), except that for X = 0 and A <= 0.0, GAMIC is undefined. ! ! GAMIC, A, and X are REAL. ! ! A slight deterioration of 2 or 3 digits accuracy will occur when ! GAMIC is very large or very small in absolute value, because log- ! arithmic variables are used. Also, if the parameter A is very close ! to a negative integer (but not a negative integer), there is a loss ! of accuracy, which is reported if the result is less than half ! machine precision. ! !***REFERENCES W. Gautschi, A computational procedure for incomplete ! gamma functions, ACM Transactions on Mathematical ! Software 5, 4 (December 1979), pp. 466-481. ! W. Gautschi, Incomplete gamma functions, Algorithm 542, ! ACM Transactions on Mathematical Software 5, 4 ! (December 1979), pp. 482-489. !***ROUTINES CALLED ALGAMS, ALNGAM, R1MACH, R9GMIC, R9GMIT, R9LGIC, ! R9LGIT, XERCLR, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920528 DESCRIPTION and REFERENCES sections revised. (WRB) !***END PROLOGUE GAMIC LOGICAL FIRST REAL GAMIC SAVE EPS, SQEPS, ALNEPS, BOT, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT GAMIC if (FIRST) THEN EPS = 0.5*R1MACH(3) SQEPS = SQRT(R1MACH(4)) ALNEPS = -LOG(R1MACH(3)) BOT = LOG(R1MACH(1)) end if FIRST = .FALSE. ! if (X < 0.0) call XERMSG ('SLATEC', 'GAMIC', 'X IS NEGATIVE', & 2, 2) ! if (X > 0.0) go to 20 if (A <= 0.0) call XERMSG ('SLATEC', 'GAMIC', & 'X = 0 AND A LE 0 SO GAMIC IS UNDEFINED', 3, 2) ! GAMIC = EXP (ALNGAM(A+1.0) - LOG(A)) return ! 20 ALX = LOG(X) SGA = 1.0 if (A /= 0.0) SGA = SIGN (1.0, A) MA = A + 0.5*SGA AEPS = A - MA ! IZERO = 0 if (X >= 1.0) go to 60 ! if (A > 0.5 .OR. ABS(AEPS) > 0.001) go to 50 FM = -MA E = 2.0 if (FM > 1.0) E = 2.0*(FM+2.0)/(FM*FM-1.0) E = E - ALX*X**(-0.001) if (E*ABS(AEPS) > EPS) go to 50 ! GAMIC = R9GMIC (A, X, ALX) return ! 50 call ALGAMS (A+1.0, ALGAP1, SGNGAM) GSTAR = R9GMIT (A, X, ALGAP1, SGNGAM, ALX) if (GSTAR == 0.0) IZERO = 1 if (GSTAR /= 0.0) ALNGS = LOG (ABS(GSTAR)) if (GSTAR /= 0.0) SGNGS = SIGN (1.0, GSTAR) go to 70 ! 60 if (A < X) GAMIC = EXP (R9LGIC(A, X, ALX)) if (A < X) RETURN ! SGNGAM = 1.0 ALGAP1 = ALNGAM (A+1.0) SGNGS = 1.0 ALNGS = R9LGIT (A, X, ALGAP1) ! ! EVALUATION OF GAMIC(A,X) IN TERMS OF TRICOMI-S INCOMPLETE GAMMA FN. ! 70 H = 1.0 if (IZERO == 1) go to 80 ! T = A*ALX + ALNGS if (T > ALNEPS) go to 90 if (T > (-ALNEPS)) H = 1.0 - SGNGS*EXP(T) ! if (ABS(H) < SQEPS) call XERCLR if (ABS(H) < SQEPS) call XERMSG ('SLATEC', 'GAMIC', & 'RESULT LT HALF PRECISION', 1, 1) ! 80 SGNG = SIGN (1.0, H) * SGA * SGNGAM T = LOG(ABS(H)) + ALGAP1 - LOG(ABS(A)) if (T < BOT) call XERCLR GAMIC = SGNG * EXP(T) return ! 90 SGNG = -SGNGS * SGA * SGNGAM T = T + ALGAP1 - LOG(ABS(A)) if (T < BOT) call XERCLR GAMIC = SGNG * EXP(T) return ! end function GAMI (A, X) ! !! GAMI evaluates the incomplete Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE SINGLE PRECISION (GAMI-S, DGAMI-D) !***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate the incomplete gamma function defined by ! ! GAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . ! ! GAMI is evaluated for positive values of A and non-negative values ! of X. A slight deterioration of 2 or 3 digits accuracy will occur ! when GAMI is very large or very small, because logarithmic variables ! are used. GAMI, A, and X are single precision. ! !***REFERENCES (NONE) !***ROUTINES CALLED ALNGAM, GAMIT, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE GAMI !***FIRST EXECUTABLE STATEMENT GAMI if (A <= 0.0) call XERMSG ('SLATEC', 'GAMI', & 'A MUST BE GT ZERO', 1, 2) if (X < 0.0) call XERMSG ('SLATEC', 'GAMI', & 'X MUST BE GE ZERO', 2, 2) ! GAMI = 0.0 if (X == 0.0) RETURN ! ! THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. FACTOR = EXP (ALNGAM(A) + A*LOG(X) ) ! GAMI = FACTOR * GAMIT(A, X) ! return end FUNCTION GAMIT (A, X) ! !! GAMIT calculates Tricomi's form of the incomplete Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE SINGLE PRECISION (GAMIT-S, DGAMIT-D) !***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, ! SPECIAL FUNCTIONS, TRICOMI !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate Tricomi's incomplete gamma function defined by ! ! GAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) * ! T**(A-1.) ! ! for A > 0.0 and by analytic continuation for A <= 0.0. ! GAMMA(X) is the complete gamma function of X. ! ! GAMIT is evaluated for arbitrary real values of A and for non- ! negative values of X (even though GAMIT is defined for X < ! 0.0), except that for X = 0 and A <= 0.0, GAMIT is infinite, ! which is a fatal error. ! ! The function and both arguments are REAL. ! ! A slight deterioration of 2 or 3 digits accuracy will occur when ! GAMIT is very large or very small in absolute value, because log- ! arithmic variables are used. Also, if the parameter A is very ! close to a negative integer (but not a negative integer), there is ! a loss of accuracy, which is reported if the result is less than ! half machine precision. ! !***REFERENCES W. Gautschi, A computational procedure for incomplete ! gamma functions, ACM Transactions on Mathematical ! Software 5, 4 (December 1979), pp. 466-481. ! W. Gautschi, Incomplete gamma functions, Algorithm 542, ! ACM Transactions on Mathematical Software 5, 4 ! (December 1979), pp. 482-489. !***ROUTINES CALLED ALGAMS, ALNGAM, GAMR, R1MACH, R9GMIT, R9LGIC, ! R9LGIT, XERCLR, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920528 DESCRIPTION and REFERENCES sections revised. (WRB) !***END PROLOGUE GAMIT LOGICAL FIRST REAL GAMIT SAVE ALNEPS, SQEPS, BOT, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT GAMIT if (FIRST) THEN ALNEPS = -LOG(R1MACH(3)) SQEPS = SQRT(R1MACH(4)) BOT = LOG(R1MACH(1)) end if FIRST = .FALSE. ! if (X < 0.0) call XERMSG ('SLATEC', 'GAMIT', 'X IS NEGATIVE', & 2, 2) ! if (X /= 0.0) ALX = LOG(X) SGA = 1.0 if (A /= 0.0) SGA = SIGN (1.0, A) AINTA = AINT (A+0.5*SGA) AEPS = A - AINTA ! if (X > 0.0) go to 20 GAMIT = 0.0 if (AINTA > 0.0 .OR. AEPS /= 0.0) GAMIT = GAMR(A+1.0) return ! 20 if (X > 1.0) go to 40 if (A >= (-0.5) .OR. AEPS /= 0.0) call ALGAMS (A+1.0, ALGAP1, & SGNGAM) GAMIT = R9GMIT (A, X, ALGAP1, SGNGAM, ALX) return ! 40 if (A < X) go to 50 T = R9LGIT (A, X, ALNGAM(A+1.0)) if (T < BOT) call XERCLR GAMIT = EXP(T) return ! 50 ALNG = R9LGIC (A, X, ALX) ! ! EVALUATE GAMIT IN TERMS OF LOG(GAMIC(A,X)) ! H = 1.0 if (AEPS == 0.0 .AND. AINTA <= 0.0) go to 60 call ALGAMS (A+1.0, ALGAP1, SGNGAM) T = LOG(ABS(A)) + ALNG - ALGAP1 if (T > ALNEPS) go to 70 if (T > (-ALNEPS)) H = 1.0 - SGA*SGNGAM*EXP(T) if (ABS(H) > SQEPS) go to 60 call XERCLR call XERMSG ('SLATEC', 'GAMIT', 'RESULT LT HALF PRECISION', 1, 1) ! 60 T = -A*ALX + LOG(ABS(H)) if (T < BOT) call XERCLR GAMIT = SIGN (EXP(T), H) return ! 70 T = T - A*ALX if (T < BOT) call XERCLR GAMIT = -SGA*SGNGAM*EXP(T) return ! end subroutine GAMLIM (XMIN, XMAX) ! !! GAMLIM computes minimum and maximum argument bounds for the Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A, R2 !***TYPE SINGLE PRECISION (GAMLIM-S, DGAMLM-D) !***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Calculate the minimum and maximum legal bounds for X in GAMMA(X). ! XMIN and XMAX are not the only bounds, but they are the only non- ! trivial ones to calculate. ! ! Output Arguments -- ! XMIN minimum legal value of X in GAMMA(X). Any smaller value of ! X might result in underflow. ! XMAX maximum legal value of X in GAMMA(X). Any larger value will ! cause overflow. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE GAMLIM !***FIRST EXECUTABLE STATEMENT GAMLIM ALNSML = LOG(R1MACH(1)) XMIN = -ALNSML DO 10 I=1,10 XOLD = XMIN XLN = LOG(XMIN) XMIN = XMIN - XMIN*((XMIN+0.5)*XLN - XMIN - 0.2258 + ALNSML) & / (XMIN*XLN + 0.5) if (ABS(XMIN-XOLD) < 0.005) go to 20 10 CONTINUE call XERMSG ('SLATEC', 'GAMLIM', 'UNABLE TO FIND XMIN', 1, 2) ! 20 XMIN = -XMIN + 0.01 ! ALNBIG = LOG(R1MACH(2)) XMAX = ALNBIG DO 30 I=1,10 XOLD = XMAX XLN = LOG(XMAX) XMAX = XMAX - XMAX*((XMAX-0.5)*XLN - XMAX + 0.9189 - ALNBIG) & / (XMAX*XLN - 0.5) if (ABS(XMAX-XOLD) < 0.005) go to 40 30 CONTINUE call XERMSG ('SLATEC', 'GAMLIM', 'UNABLE TO FIND XMAX', 2, 2) ! 40 XMAX = XMAX - 0.01 XMIN = MAX (XMIN, -XMAX+1.) ! return end FUNCTION GAMLN (Z, IERR) ! !! GAMLN computes the logarithm of the Gamma function. ! !***LIBRARY SLATEC !***CATEGORY C7A !***TYPE SINGLE PRECISION (GAMLN-S, DGAMLN-D) !***KEYWORDS LOGARITHM OF GAMMA FUNCTION !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! GAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR ! Z > 0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES ! GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION ! G(Z+1)=Z*G(Z) FOR Z <= ZMIN. THE FUNCTION WAS MADE AS ! PORTABLE AS POSSIBLE BY COMPUTING ZMIN FROM THE NUMBER OF BASE ! 10 DIGITS IN A WORD, RLN=MAX(-ALOG10(R1MACH(4)),0.5E-18) ! LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. ! ! SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 ! VALUES IS USED FOR SPEED OF EXECUTION. ! ! DESCRIPTION OF ARGUMENTS ! ! INPUT ! Z - REAL ARGUMENT, Z > 0.0E0 ! ! OUTPUT ! GAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z ! IERR - ERROR FLAG ! IERR=0, NORMAL RETURN, COMPUTATION COMPLETED ! IERR=1, Z <= 0.0E0, NO COMPUTATION ! !***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT ! BY D. E. AMOS, SAND83-0083, MAY, 1983. !***ROUTINES CALLED I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 830501 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 921215 GAMLN defined for Z negative. (WRB) !***END PROLOGUE GAMLN ! REAL GAMLN INTEGER I, I1M, K, MZ, NZ, IERR, I1MACH REAL CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, T1, WDTOL, Z, & ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ REAL R1MACH DIMENSION CF(22), GLN(100) ! LNGAMMA(N), N=1,100 DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), & GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), & GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), & GLN(21), GLN(22)/ & 0.00000000000000000E+00, 0.00000000000000000E+00, & 6.93147180559945309E-01, 1.79175946922805500E+00, & 3.17805383034794562E+00, 4.78749174278204599E+00, & 6.57925121201010100E+00, 8.52516136106541430E+00, & 1.06046029027452502E+01, 1.28018274800814696E+01, & 1.51044125730755153E+01, 1.75023078458738858E+01, & 1.99872144956618861E+01, 2.25521638531234229E+01, & 2.51912211827386815E+01, 2.78992713838408916E+01, & 3.06718601060806728E+01, 3.35050734501368889E+01, & 3.63954452080330536E+01, 3.93398841871994940E+01, & 4.23356164607534850E+01, 4.53801388984769080E+01/ DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), & GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), & GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), & GLN(41), GLN(42), GLN(43), GLN(44)/ & 4.84711813518352239E+01, 5.16066755677643736E+01, & 5.47847293981123192E+01, 5.80036052229805199E+01, & 6.12617017610020020E+01, 6.45575386270063311E+01, & 6.78897431371815350E+01, 7.12570389671680090E+01, & 7.46582363488301644E+01, 7.80922235533153106E+01, & 8.15579594561150372E+01, 8.50544670175815174E+01, & 8.85808275421976788E+01, 9.21361756036870925E+01, & 9.57196945421432025E+01, 9.93306124547874269E+01, & 1.02968198614513813E+02, 1.06631760260643459E+02, & 1.10320639714757395E+02, 1.14034211781461703E+02, & 1.17771881399745072E+02, 1.21533081515438634E+02/ DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), & GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), & GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), & GLN(63), GLN(64), GLN(65), GLN(66)/ & 1.25317271149356895E+02, 1.29123933639127215E+02, & 1.32952575035616310E+02, 1.36802722637326368E+02, & 1.40673923648234259E+02, 1.44565743946344886E+02, & 1.48477766951773032E+02, 1.52409592584497358E+02, & 1.56360836303078785E+02, 1.60331128216630907E+02, & 1.64320112263195181E+02, 1.68327445448427652E+02, & 1.72352797139162802E+02, 1.76395848406997352E+02, & 1.80456291417543771E+02, 1.84533828861449491E+02, & 1.88628173423671591E+02, 1.92739047287844902E+02, & 1.96866181672889994E+02, 2.01009316399281527E+02, & 2.05168199482641199E+02, 2.09342586752536836E+02/ DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), & GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), & GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), & GLN(85), GLN(86), GLN(87), GLN(88)/ & 2.13532241494563261E+02, 2.17736934113954227E+02, & 2.21956441819130334E+02, 2.26190548323727593E+02, & 2.30439043565776952E+02, 2.34701723442818268E+02, & 2.38978389561834323E+02, 2.43268849002982714E+02, & 2.47572914096186884E+02, 2.51890402209723194E+02, & 2.56221135550009525E+02, 2.60564940971863209E+02, & 2.64921649798552801E+02, 2.69291097651019823E+02, & 2.73673124285693704E+02, 2.78067573440366143E+02, & 2.82474292687630396E+02, 2.86893133295426994E+02, & 2.91323950094270308E+02, 2.95766601350760624E+02, & 3.00220948647014132E+02, 3.04686856765668715E+02/ DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), & GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ & 3.09164193580146922E+02, 3.13652829949879062E+02, & 3.18152639620209327E+02, 3.22663499126726177E+02, & 3.27185287703775217E+02, 3.31717887196928473E+02, & 3.36261181979198477E+02, 3.40815058870799018E+02, & 3.45379407062266854E+02, 3.49954118040770237E+02, & 3.54539085519440809E+02, 3.59134205369575399E+02/ ! COEFFICIENTS OF ASYMPTOTIC EXPANSION DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), & CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), & CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ & 8.33333333333333333E-02, -2.77777777777777778E-03, & 7.93650793650793651E-04, -5.95238095238095238E-04, & 8.41750841750841751E-04, -1.91752691752691753E-03, & 6.41025641025641026E-03, -2.95506535947712418E-02, & 1.79644372368830573E-01, -1.39243221690590112E+00, & 1.34028640441683920E+01, -1.56848284626002017E+02, & 2.19310333333333333E+03, -3.61087712537249894E+04, & 6.91472268851313067E+05, -1.52382215394074162E+07, & 3.82900751391414141E+08, -1.08822660357843911E+10, & 3.47320283765002252E+11, -1.23696021422692745E+13, & 4.88788064793079335E+14, -2.13203339609193739E+16/ ! ! LN(2*PI) DATA CON / 1.83787706640934548E+00/ ! !***FIRST EXECUTABLE STATEMENT GAMLN IERR=0 if (Z <= 0.0E0) go to 70 if (Z > 101.0E0) go to 10 NZ = Z FZ = Z - NZ if (FZ > 0.0E0) go to 10 if (NZ > 100) go to 10 GAMLN = GLN(NZ) return 10 CONTINUE WDTOL = R1MACH(4) WDTOL = MAX(WDTOL,0.5E-18) I1M = I1MACH(11) RLN = R1MACH(5)*I1M FLN = MIN(RLN,20.0E0) FLN = MAX(FLN,3.0E0) FLN = FLN - 3.0E0 ZM = 1.8000E0 + 0.3875E0*FLN MZ = ZM + 1 ZMIN = MZ ZDMY = Z ZINC = 0.0E0 if (Z >= ZMIN) go to 20 ZINC = ZMIN - NZ ZDMY = Z + ZINC 20 CONTINUE ZP = 1.0E0/ZDMY T1 = CF(1)*ZP S = T1 if (ZP < WDTOL) go to 40 ZSQ = ZP*ZP TST = T1*WDTOL DO 30 K=2,22 ZP = ZP*ZSQ TRM = CF(K)*ZP if (ABS(TRM) < TST) go to 40 S = S + TRM 30 CONTINUE 40 CONTINUE if (ZINC /= 0.0E0) go to 50 TLG = ALOG(Z) GAMLN = Z*(TLG-1.0E0) + 0.5E0*(CON-TLG) + S return 50 CONTINUE ZP = 1.0E0 NZ = ZINC DO 60 I=1,NZ ZP = ZP*(Z+(I-1)) 60 CONTINUE TLG = ALOG(ZDMY) GAMLN = ZDMY*(TLG-1.0E0) - ALOG(ZP) + 0.5E0*(CON-TLG) + S return ! ! 70 CONTINUE GAMLN = R1MACH(2) IERR=1 return end function GAMMA (X) ! !! GAMMA computes the complete Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE SINGLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) !***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! GAMMA computes the gamma function at X, where X is not 0, -1, -2, .... ! GAMMA and X are single precision. ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, GAMLIM, INITS, R1MACH, R9LGMC, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE GAMMA DIMENSION GCS(23) LOGICAL FIRST SAVE GCS, PI, SQ2PIL, NGCS, XMIN, XMAX, DXREL, FIRST DATA GCS ( 1) / .008571195590989331E0/ DATA GCS ( 2) / .004415381324841007E0/ DATA GCS ( 3) / .05685043681599363E0/ DATA GCS ( 4) /-.004219835396418561E0/ DATA GCS ( 5) / .001326808181212460E0/ DATA GCS ( 6) /-.0001893024529798880E0/ DATA GCS ( 7) / .0000360692532744124E0/ DATA GCS ( 8) /-.0000060567619044608E0/ DATA GCS ( 9) / .0000010558295463022E0/ DATA GCS (10) /-.0000001811967365542E0/ DATA GCS (11) / .0000000311772496471E0/ DATA GCS (12) /-.0000000053542196390E0/ DATA GCS (13) / .0000000009193275519E0/ DATA GCS (14) /-.0000000001577941280E0/ DATA GCS (15) / .0000000000270798062E0/ DATA GCS (16) /-.0000000000046468186E0/ DATA GCS (17) / .0000000000007973350E0/ DATA GCS (18) /-.0000000000001368078E0/ DATA GCS (19) / .0000000000000234731E0/ DATA GCS (20) /-.0000000000000040274E0/ DATA GCS (21) / .0000000000000006910E0/ DATA GCS (22) /-.0000000000000001185E0/ DATA GCS (23) / .0000000000000000203E0/ DATA PI /3.14159265358979324E0/ ! SQ2PIL IS LOG (SQRT (2.*PI) ) DATA SQ2PIL /0.91893853320467274E0/ DATA FIRST /.TRUE./ ! ! LANL DEPENDENT CODE REMOVED 81.02.04 ! !***FIRST EXECUTABLE STATEMENT GAMMA if (FIRST) THEN ! ! --------------------------------------------------------------------- ! INITIALIZE. FIND LEGAL BOUNDS FOR X, AND DETERMINE THE NUMBER OF ! TERMS IN THE SERIES REQUIRED TO ATTAIN AN ACCURACY TEN TIMES BETTER ! THAN MACHINE PRECISION. ! NGCS = INITS (GCS, 23, 0.1*R1MACH(3)) ! call GAMLIM (XMIN, XMAX) DXREL = SQRT (R1MACH(4)) ! ! --------------------------------------------------------------------- ! FINISH INITIALIZATION. START EVALUATING GAMMA(X). ! end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 10.0) go to 50 ! ! COMPUTE GAMMA(X) FOR ABS(X) <= 10.0. REDUCE INTERVAL AND ! FIND GAMMA(1+Y) FOR 0. <= Y < 1. FIRST OF ALL. ! N = X if (X < 0.) N = N - 1 Y = X - N N = N - 1 GAMMA = 0.9375 + CSEVL(2.*Y-1., GCS, NGCS) if (N == 0) RETURN ! if (N > 0) go to 30 ! ! COMPUTE GAMMA(X) FOR X < 1. ! N = -N if (X == 0.) call XERMSG ('SLATEC', 'GAMMA', 'X IS 0', 4, 2) if (X < 0. .AND. X+N-2 == 0.) call XERMSG ('SLATEC', 'GAMMA' & , 'X IS A NEGATIVE INTEGER', 4, 2) if (X < (-0.5) .AND. ABS((X-AINT(X-0.5))/X) < DXREL) call & XERMSG ( 'SLATEC', 'GAMMA', & 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER' & , 1, 1) ! DO 20 I=1,N GAMMA = GAMMA / (X+I-1) 20 CONTINUE return ! ! GAMMA(X) FOR X >= 2. ! 30 DO 40 I=1,N GAMMA = (Y+I)*GAMMA 40 CONTINUE return ! ! COMPUTE GAMMA(X) FOR ABS(X) > 10.0. RECALL Y = ABS(X). ! 50 if (X > XMAX) call XERMSG ('SLATEC', 'GAMMA', & 'X SO BIG GAMMA OVERFLOWS', 3, 2) ! GAMMA = 0. if (X < XMIN) call XERMSG ('SLATEC', 'GAMMA', & 'X SO SMALL GAMMA UNDERFLOWS', 2, 1) if (X < XMIN) RETURN ! GAMMA = EXP((Y-0.5)*LOG(Y) - Y + SQ2PIL + R9LGMC(Y) ) if (X > 0.) RETURN ! if (ABS((X-AINT(X-0.5))/X) < DXREL) call XERMSG ('SLATEC', & 'GAMMA', & 'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1) ! SINPIY = SIN (PI*Y) if (SINPIY == 0.) call XERMSG ('SLATEC', 'GAMMA', & 'X IS A NEGATIVE INTEGER', 4, 2) ! GAMMA = -PI / (Y*SINPIY*GAMMA) ! return end function GAMR (X) ! !! GAMR computes the reciprocal of the Gamma function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7A !***TYPE SINGLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) !***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! GAMR is a single precision function that evaluates the reciprocal ! of the gamma function for single precision argument X. ! !***REFERENCES (NONE) !***ROUTINES CALLED ALGAMS, GAMMA, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE GAMR EXTERNAL GAMMA !***FIRST EXECUTABLE STATEMENT GAMR GAMR = 0.0 if (X <= 0.0 .AND. AINT(X) == X) RETURN ! call XGETF (IROLD) call XSETF (1) if (ABS(X) > 10.0) go to 10 GAMR = 1.0/GAMMA(X) call XERCLR call XSETF (IROLD) return ! 10 call ALGAMS (X, ALNGX, SGNGX) call XERCLR call XSETF (IROLD) GAMR = SGNGX * EXP(-ALNGX) return ! end FUNCTION GAMRN (X) ! !! GAMRN is subsidiary to BSKIN. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (GAMRN-S, DGAMRN-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! GAMRN computes the GAMMA function ratio GAMMA(X)/GAMMA(X+0.5) ! for real X.gt.0. If X.ge.XMIN, an asymptotic expansion is ! evaluated. If X.lt.XMIN, an integer is added to X to form a ! new value of X.ge.XMIN and the asymptotic expansion is eval- ! uated for this new value of X. Successive application of the ! recurrence relation ! ! W(X)=W(X+1)*(1+0.5/X) ! ! reduces the argument to its original value. XMIN and comp- ! utational tolerances are computed as a function of the number ! of digits carried in a word by calls to I1MACH and R1MACH. ! However, the computational accuracy is limited to the max- ! imum of unit roundoff (=R1MACH(4)) and 1.0E-18 since critical ! constants are given to only 18 digits. ! ! Input ! X - Argument, X.gt.0.0 ! ! OUTPUT ! GAMRN - Ratio GAMMA(X)/GAMMA(X+0.5) ! !***SEE ALSO BSKIN !***REFERENCES Y. L. Luke, The Special Functions and Their ! Approximations, Vol. 1, Math In Sci. And ! Eng. Series 53, Academic Press, New York, 1969, ! pp. 34-35. !***ROUTINES CALLED I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920520 Added REFERENCES section. (WRB) !***END PROLOGUE GAMRN REAL GAMRN INTEGER I, I1M11, K, MX, NX INTEGER I1MACH REAL FLN, GR, RLN, S, TOL, TRM, X, XDMY, XINC, XM, XMIN, XP, XSQ REAL R1MACH DIMENSION GR(12) SAVE GR ! DATA GR(1), GR(2), GR(3), GR(4), GR(5), GR(6), GR(7), GR(8), & GR(9), GR(10), GR(11), GR(12) /1.00000000000000000E+00, & -1.56250000000000000E-02,2.56347656250000000E-03, & -1.27983093261718750E-03,1.34351104497909546E-03, & -2.43289663922041655E-03,6.75423753364157164E-03, & -2.66369606131178216E-02,1.41527455519564332E-01, & -9.74384543032201613E-01,8.43686251229783675E+00, & -8.97258321640552515E+01/ ! !***FIRST EXECUTABLE STATEMENT GAMRN NX = INT(X) TOL = MAX(R1MACH(4),1.0E-18) I1M11 = I1MACH(11) RLN = R1MACH(5)*I1M11 FLN = MIN(RLN,20.0E0) FLN = MAX(FLN,3.0E0) FLN = FLN - 3.0E0 XM = 2.0E0 + FLN*(0.2366E0+0.01723E0*FLN) MX = INT(XM) + 1 XMIN = MX XDMY = X - 0.25E0 XINC = 0.0E0 if (X >= XMIN) go to 10 XINC = XMIN - NX XDMY = XDMY + XINC 10 CONTINUE S = 1.0E0 if (XDMY*TOL > 1.0E0) go to 30 XSQ = 1.0E0/(XDMY*XDMY) XP = XSQ DO 20 K=2,12 TRM = GR(K)*XP if (ABS(TRM) < TOL) go to 30 S = S + TRM XP = XP*XSQ 20 CONTINUE 30 CONTINUE S = S/SQRT(XDMY) if (XINC /= 0.0E0) go to 40 GAMRN = S return 40 CONTINUE NX = INT(XINC) XP = 0.0E0 DO 50 I=1,NX S = S*(1.0E0+0.5E0/(X+XP)) XP = XP + 1.0E0 50 CONTINUE GAMRN = S return end subroutine GAUS8 (FUN, A, B, ERR, ANS, IERR) ! !! GAUS8 integrates a real function of one variable over a finite interval ... ! using an adaptive 8-point Legendre-Gauss algorithm. Intended primarily ! for high accuracy integration or integration of smooth functions. ! !***LIBRARY SLATEC !***CATEGORY H2A1A1 !***TYPE SINGLE PRECISION (GAUS8-S, DGAUS8-D) !***KEYWORDS ADAPTIVE QUADRATURE, AUTOMATIC INTEGRATOR, ! GAUSS QUADRATURE, NUMERICAL INTEGRATION !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! GAUS8 integrates real functions of one variable over finite ! intervals using an adaptive 8-point Legendre-Gauss algorithm. ! GAUS8 is intended primarily for high accuracy integration ! or integration of smooth functions. ! ! Description of Arguments ! ! Input-- ! FUN - name of external function to be integrated. This name ! must be in an EXTERNAL statement in the calling program. ! FUN must be a REAL function of one REAL argument. The ! value of the argument to FUN is the variable of ! integration which ranges from A to B. ! A - lower limit of integration ! B - upper limit of integration (may be less than A) ! ERR - is a requested pseudorelative error tolerance. Normally ! pick a value of ABS(ERR) so that STOL < ABS(ERR) <= ! 1.0E-3 where STOL is the single precision unit roundoff ! R1MACH(4). ANS will normally have no more error than ! ABS(ERR) times the integral of the absolute value of ! FUN(X). Usually, smaller values for ERR yield more ! accuracy and require more function evaluations. ! ! A negative value for ERR causes an estimate of the ! absolute error in ANS to be returned in ERR. Note that ! ERR must be a variable (not a constant) in this case. ! Note also that the user must reset the value of ERR ! before making any more calls that use the variable ERR. ! ! Output-- ! ERR - will be an estimate of the absolute error in ANS if the ! input value of ERR was negative. (ERR is unchanged if ! the input value of ERR was non-negative.) The estimated ! error is solely for information to the user and should ! not be used as a correction to the computed integral. ! ANS - computed value of integral ! IERR- a status code ! --Normal codes ! 1 ANS most likely meets requested error tolerance, ! or A=B. ! -1 A and B are too nearly equal to allow normal ! integration. ANS is set to zero. ! --Abnormal code ! 2 ANS probably does not meet requested error tolerance. ! !***REFERENCES (NONE) !***ROUTINES CALLED I1MACH, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 810223 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE GAUS8 INTEGER IERR, K, KML, KMX, L, LMN, LMX, LR, MXL, NBITS, & NIB, NLMN, NLMX INTEGER I1MACH REAL A, AA, AE, ANIB, ANS, AREA, B, C, CE, EE, EF, EPS, ERR, EST, & GL, GLR, GR, HH, SQ2, TOL, VL, VR, W1, W2, W3, W4, X1, X2, X3, & X4, X, H REAL R1MACH, G8, FUN DIMENSION AA(30), HH(30), LR(30), VL(30), GR(30) SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, & NLMN, KMX, KML DATA X1, X2, X3, X4/ & 1.83434642495649805E-01, 5.25532409916328986E-01, & 7.96666477413626740E-01, 9.60289856497536232E-01/ DATA W1, W2, W3, W4/ & 3.62683783378361983E-01, 3.13706645877887287E-01, & 2.22381034453374471E-01, 1.01228536290376259E-01/ DATA SQ2/1.41421356E0/ DATA NLMN/1/,KMX/5000/,KML/6/ G8(X,H)=H*((W1*(FUN(X-X1*H) + FUN(X+X1*H)) & +W2*(FUN(X-X2*H) + FUN(X+X2*H))) & +(W3*(FUN(X-X3*H) + FUN(X+X3*H)) & +W4*(FUN(X-X4*H) + FUN(X+X4*H)))) !***FIRST EXECUTABLE STATEMENT GAUS8 ! ! Initialize ! K = I1MACH(11) ANIB = R1MACH(5)*K/0.30102000E0 NBITS = ANIB NLMX = MIN(30,(NBITS*5)/8) ANS = 0.0E0 IERR = 1 CE = 0.0E0 if (A == B) go to 140 LMX = NLMX LMN = NLMN if (B == 0.0E0) go to 10 if (SIGN(1.0E0,B)*A <= 0.0E0) go to 10 C = ABS(1.0E0-A/B) if (C > 0.1E0) go to 10 if (C <= 0.0E0) go to 140 ANIB = 0.5E0 - LOG(C)/0.69314718E0 NIB = ANIB LMX = MIN(NLMX,NBITS-NIB-7) if (LMX < 1) go to 130 LMN = MIN(LMN,LMX) 10 TOL = MAX(ABS(ERR),2.0E0**(5-NBITS))/2.0E0 if (ERR == 0.0E0) TOL = SQRT(R1MACH(4)) EPS = TOL HH(1) = (B-A)/4.0E0 AA(1) = A LR(1) = 1 L = 1 EST = G8(AA(L)+2.0E0*HH(L),2.0E0*HH(L)) K = 8 AREA = ABS(EST) EF = 0.5E0 MXL = 0 ! ! Compute refined estimates, estimate the error, etc. ! 20 GL = G8(AA(L)+HH(L),HH(L)) GR(L) = G8(AA(L)+3.0E0*HH(L),HH(L)) K = K + 16 AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) ! if (L < LMN) go to 11 GLR = GL + GR(L) EE = ABS(EST-GLR)*EF AE = MAX(EPS*AREA,TOL*ABS(GLR)) if (EE-AE) 40, 40, 50 30 MXL = 1 40 CE = CE + (EST-GLR) if (LR(L)) 60, 60, 80 ! ! Consider the left half of this level ! 50 if (K > KMX) LMX = KML if (L >= LMX) go to 30 L = L + 1 EPS = EPS*0.5E0 EF = EF/SQ2 HH(L) = HH(L-1)*0.5E0 LR(L) = -1 AA(L) = AA(L-1) EST = GL go to 20 ! ! Proceed to right half at this level ! 60 VL(L) = GLR 70 EST = GR(L-1) LR(L) = 1 AA(L) = AA(L) + 4.0E0*HH(L) go to 20 ! ! Return one level ! 80 VR = GLR 90 if (L <= 1) go to 120 L = L - 1 EPS = EPS*2.0E0 EF = EF*SQ2 if (LR(L)) 100, 100, 110 100 VL(L) = VL(L+1) + VR go to 70 110 VR = VL(L+1) + VR go to 90 ! ! Exit ! 120 ANS = VR if ((MXL == 0) .OR. (ABS(CE) <= 2.0E0*TOL*AREA)) go to 140 IERR = 2 call XERMSG ('SLATEC', 'GAUS8', & 'ANS is probably insufficiently accurate.', 3, 1) go to 140 130 IERR = -1 call XERMSG ('SLATEC', 'GAUS8', & 'A and B are too nearly equal to allow normal integration. $$' & // 'ANS is set to zero and IERR to -1.', 1, -1) 140 if (ERR < 0.0E0) ERR = CE return end subroutine GENBUN (NPEROD, N, MPEROD, M, A, B, C, IDIMY, Y, & IERROR, W) ! !! GENBUN solves by a cyclic reduction algorithm the linear system ... ! of equations that results from a finite difference approximation to ! certain 2-d elliptic PDE's on a centered grid. ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B4B !***TYPE SINGLE PRECISION (GENBUN-S, CMGNBN-C) !***KEYWORDS ELLIPTIC, FISHPACK, PDE, TRIDIAGONAL !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine GENBUN solves the linear system of equations ! ! A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J) ! ! + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J) ! ! for I = 1,2,...,M and J = 1,2,...,N. ! ! The indices I+1 and I-1 are evaluated modulo M, i.e., ! X(0,J) = X(M,J) and X(M+1,J) = X(1,J), and X(I,0) may be equal to ! 0, X(I,2), or X(I,N) and X(I,N+1) may be equal to 0, X(I,N-1), or ! X(I,1) depending on an input parameter. ! ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! NPEROD ! Indicates the values that X(I,0) and X(I,N+1) are assumed to ! have. ! ! = 0 If X(I,0) = X(I,N) and X(I,N+1) = X(I,1). ! = 1 If X(I,0) = X(I,N+1) = 0 . ! = 2 If X(I,0) = 0 and X(I,N+1) = X(I,N-1). ! = 3 If X(I,0) = X(I,2) and X(I,N+1) = X(I,N-1). ! = 4 If X(I,0) = X(I,2) and X(I,N+1) = 0. ! ! N ! The number of unknowns in the J-direction. N must be greater ! than 2. ! ! MPEROD ! = 0 if A(1) and C(M) are not zero. ! = 1 if A(1) = C(M) = 0. ! ! M ! The number of unknowns in the I-direction. M must be greater ! than 2. ! ! A,B,C ! One-dimensional arrays of length M that specify the ! coefficients in the linear equations given above. If MPEROD = 0 ! the array elements must not depend upon the index I, but must be ! constant. Specifically, the subroutine checks the following ! condition ! ! A(I) = C(1) ! C(I) = C(1) ! B(I) = B(1) ! ! for I=1,2,...,M. ! ! IDIMY ! The row (or first) dimension of the two-dimensional array Y as ! it appears in the program calling GENBUN. This parameter is ! used to specify the variable dimension of Y. IDIMY must be at ! least M. ! ! Y ! A two-dimensional array that specifies the values of the right ! side of the linear system of equations given above. Y must be ! dimensioned at least M*N. ! ! W ! A one-dimensional array that must be provided by the user for ! work space. W may require up to 4*N + (10 + INT(log2(N)))*M ! locations. The actual number of locations used is computed by ! GENBUN and is returned in location W(1). ! ! ! * * * * * * On Output * * * * * * ! ! Y ! Contains the solution X. ! ! IERROR ! An error flag that indicates invalid input parameters. Except ! for number zero, a solution is not attempted. ! ! = 0 No error. ! = 1 M <= 2 ! = 2 N <= 2 ! = 3 IDIMY < M ! = 4 NPEROD < 0 or NPEROD > 4 ! = 5 MPEROD < 0 or MPEROD > 1 ! = 6 A(I) /= C(1) or C(I) /= C(1) or B(I) /= B(1) for ! some I=1,2,...,M. ! = 7 A(1) /= 0 or C(M) /= 0 and MPEROD = 1 ! ! W ! W(1) contains the required length of W. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of A(M),B(M),C(M),Y(IDIMY,N),W(see parameter list) ! Arguments ! ! Latest June 1, 1976 ! Revision ! ! Subprograms GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE,TRIX,TRI3, ! Required PIMACH ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Standardized April 1, 1973 ! Revised August 20,1973 ! Revised January 1, 1976 ! ! Algorithm The linear system is solved by a cyclic reduction ! algorithm described in the reference. ! ! Space 4944(decimal) = 11520(octal) locations on the NCAR ! Required Control Data 7600. ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine GENBUN is roughly proportional ! to M*N*log2(N), but also depends on the input ! parameter NPEROD. Some typical values are listed ! in the table below. More comprehensive timing ! charts may be found in the reference. ! To measure the accuracy of the algorithm a ! uniform random number generator was used to create ! a solution array X for the system given in the ! 'PURPOSE' with ! ! A(I) = C(I) = -0.5*B(I) = 1, I=1,2,...,M ! ! and, when MPEROD = 1 ! ! A(1) = C(M) = 0 ! A(M) = C(1) = 2. ! ! The solution X was substituted into the given sys- ! tem and, using double precision, a right side Y was ! computed. Using this array Y subroutine GENBUN was ! called to produce an approximate solution Z. Then ! the relative error, defined as ! ! E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J))) ! ! where the two maxima are taken over all I=1,2,...,M ! and J=1,2,...,N, was computed. The value of E is ! given in the table below for some typical values of ! M and N. ! ! ! M (=N) MPEROD NPEROD T(MSECS) E ! ------ ------ ------ -------- ------ ! ! 31 0 0 36 6.E-14 ! 31 1 1 21 4.E-13 ! 31 1 3 41 3.E-13 ! 32 0 0 29 9.E-14 ! 32 1 1 32 3.E-13 ! 32 1 3 48 1.E-13 ! 33 0 0 36 9.E-14 ! 33 1 1 30 4.E-13 ! 33 1 3 34 1.E-13 ! 63 0 0 150 1.E-13 ! 63 1 1 91 1.E-12 ! 63 1 3 173 2.E-13 ! 64 0 0 122 1.E-13 ! 64 1 1 128 1.E-12 ! 64 1 3 199 6.E-13 ! 65 0 0 143 2.E-13 ! 65 1 1 120 1.E-12 ! 65 1 3 138 4.E-13 ! ! Portability American National Standards Institute Fortran. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS ! Resident ! Routines ! ! Reference Sweet, R., 'A Cyclic Reduction Algorithm For ! Solving Block Tridiagonal Systems Of Arbitrary ! Dimensions,' SIAM J. on Numer. Anal., ! 14(Sept., 1977), PP. 706-720. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES R. Sweet, A cyclic reduction algorithm for solving ! block tridiagonal systems of arbitrary dimensions, ! SIAM Journal on Numerical Analysis 14, (September ! 1977), pp. 706-720. !***ROUTINES CALLED POISD2, POISN2, POISP2 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE GENBUN ! ! DIMENSION Y(IDIMY,*) DIMENSION W(*) ,B(*) ,A(*) ,C(*) !***FIRST EXECUTABLE STATEMENT GENBUN IERROR = 0 if (M <= 2) IERROR = 1 if (N <= 2) IERROR = 2 if (IDIMY < M) IERROR = 3 if (NPEROD < 0 .OR. NPEROD > 4) IERROR = 4 if (MPEROD < 0 .OR. MPEROD > 1) IERROR = 5 if (MPEROD == 1) go to 102 DO I=2,M if (A(I) /= C(1)) go to 103 if (C(I) /= C(1)) go to 103 if (B(I) /= B(1)) go to 103 end do go to 104 102 if (A(1) /= 0. .OR. C(M) /= 0.) IERROR = 7 go to 104 103 IERROR = 6 104 if (IERROR /= 0) RETURN MP1 = M+1 IWBA = MP1 IWBB = IWBA+M IWBC = IWBB+M IWB2 = IWBC+M IWB3 = IWB2+M IWW1 = IWB3+M IWW2 = IWW1+M IWW3 = IWW2+M IWD = IWW3+M IWTCOS = IWD+M IWP = IWTCOS+4*N DO 106 I=1,M K = IWBA+I-1 W(K) = -A(I) K = IWBC+I-1 W(K) = -C(I) K = IWBB+I-1 W(K) = 2.-B(I) DO 105 J=1,N Y(I,J) = -Y(I,J) 105 CONTINUE 106 CONTINUE MP = MPEROD+1 NP = NPEROD+1 go to (114,107),MP 107 go to (108,109,110,111,123),NP 108 call POISP2 (M,N,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), & W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), & W(IWP)) go to 112 109 call POISD2 (M,N,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWW1), & W(IWD),W(IWTCOS),W(IWP)) go to 112 110 call POISN2 (M,N,1,2,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), & W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), & W(IWP)) go to 112 111 call POISN2 (M,N,1,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), & W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), & W(IWP)) 112 IPSTOR = W(IWW1) IREV = 2 if (NPEROD == 4) go to 124 113 go to (127,133),MP 114 CONTINUE ! ! REORDER UNKNOWNS WHEN MP =0 ! MH = (M+1)/2 MHM1 = MH-1 MODD = 1 if (MH*2 == M) MODD = 2 DO 119 J=1,N DO 115 I=1,MHM1 MHPI = MH+I MHMI = MH-I W(I) = Y(MHMI,J)-Y(MHPI,J) W(MHPI) = Y(MHMI,J)+Y(MHPI,J) 115 CONTINUE W(MH) = 2.*Y(MH,J) go to (117,116),MODD 116 W(M) = 2.*Y(M,J) 117 CONTINUE DO 118 I=1,M Y(I,J) = W(I) 118 CONTINUE 119 CONTINUE K = IWBC+MHM1-1 I = IWBA+MHM1 W(K) = 0. W(I) = 0. W(K+1) = 2.*W(K+1) go to (120,121),MODD 120 CONTINUE K = IWBB+MHM1-1 W(K) = W(K)-W(I-1) W(IWBC-1) = W(IWBC-1)+W(IWBB-1) go to 122 121 W(IWBB-1) = W(K+1) 122 CONTINUE go to 107 ! ! REVERSE COLUMNS WHEN NPEROD = 4. ! 123 IREV = 1 NBY2 = N/2 124 DO 126 J=1,NBY2 MSKIP = N+1-J DO 125 I=1,M A1 = Y(I,J) Y(I,J) = Y(I,MSKIP) Y(I,MSKIP) = A1 125 CONTINUE 126 CONTINUE go to (110,113),IREV 127 CONTINUE DO 132 J=1,N DO 128 I=1,MHM1 MHMI = MH-I MHPI = MH+I W(MHMI) = .5*(Y(MHPI,J)+Y(I,J)) W(MHPI) = .5*(Y(MHPI,J)-Y(I,J)) 128 CONTINUE W(MH) = .5*Y(MH,J) go to (130,129),MODD 129 W(M) = .5*Y(M,J) 130 CONTINUE DO 131 I=1,M Y(I,J) = W(I) 131 CONTINUE 132 CONTINUE 133 CONTINUE ! ! return STORAGE REQUIREMENTS FOR W ARRAY. ! W(1) = IPSTOR+IWP-1 return end subroutine H12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV, NCV) ! !! H12 is subsidiary to HFTI, LSEI and WNNLS. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (H12-S, DH12-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12 ! to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974 ! ! Construction and/or application of a single ! Householder transformation.. Q = I + U*(U**T)/B ! ! MODE = 1 or 2 to select algorithm H1 or H2 . ! LPIVOT is the index of the pivot element. ! L1,M If L1 <= M the transformation will be constructed to ! zero elements indexed from L1 through M. If L1 GT. M ! THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. ! U(),IUE,UP On entry to H1 U() contains the pivot vector. ! IUE is the storage increment between elements. ! On exit from H1 U() and UP ! contain quantities defining the vector U of the ! Householder transformation. On entry to H2 U() ! and UP should contain quantities previously computed ! by H1. These will not be modified by H2. ! C() On entry to H1 or H2 C() contains a matrix which will be ! regarded as a set of vectors to which the Householder ! transformation is to be applied. On exit C() contains the ! set of transformed vectors. ! ICE Storage increment between elements of vectors in C(). ! ICV Storage increment between vectors in C(). ! NCV Number of vectors in C() to be transformed. If NCV <= 0 ! no operations will be done on C(). ! !***SEE ALSO HFTI, LSEI, WNNLS !***ROUTINES CALLED SAXPY, SDOT, SSWAP !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE H12 DIMENSION U(IUE,*), C(*) !***FIRST EXECUTABLE STATEMENT H12 ONE=1. ! if (0 >= LPIVOT.OR.LPIVOT >= L1.OR.L1 > M) RETURN CL=ABS(U(1,LPIVOT)) if (MODE == 2) go to 60 ! ****** CONSTRUCT THE TRANSFORMATION. ****** DO 10 J=L1,M 10 CL=MAX(ABS(U(1,J)),CL) if (CL) 130,130,20 20 CLINV=ONE/CL SM=(U(1,LPIVOT)*CLINV)**2 DO 30 J=L1,M 30 SM=SM+(U(1,J)*CLINV)**2 CL=CL*SQRT(SM) if (U(1,LPIVOT)) 50,50,40 40 CL=-CL 50 UP=U(1,LPIVOT)-CL U(1,LPIVOT)=CL go to 70 ! ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** ! 60 if (CL) 130,130,70 70 if (NCV <= 0) RETURN B=UP*U(1,LPIVOT) ! B MUST BE NONPOSITIVE HERE. if B = 0., RETURN. ! if (B) 80,130,130 80 B=ONE/B MML1P2=M-L1+2 if (MML1P2 > 20) go to 140 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) 100,120,100 100 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 140 CONTINUE L1M1=L1-1 KL1=1+(L1M1-1)*ICE KL2=KL1 KLP=1+(LPIVOT-1)*ICE UL1M1=U(1,L1M1) U(1,L1M1)=UP if (LPIVOT == L1M1) go to 150 call SSWAP(NCV,C(KL1),ICV,C(KLP),ICV) 150 CONTINUE DO 160 J=1,NCV SM=SDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE) SM=SM*B call SAXPY (MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE) KL1=KL1+ICV 160 CONTINUE U(1,L1M1)=UL1M1 if (LPIVOT == L1M1) RETURN KL1=KL2 call SSWAP(NCV,C(KL1),ICV,C(KLP),ICV) return end subroutine HFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H, & G, IP) ! !! HFTI solves a linear least squares problems by performing a QR ... ! factorization of the matrix using Householder transformations. ! !***LIBRARY SLATEC !***CATEGORY D9 !***TYPE SINGLE PRECISION (HFTI-S, DHFTI-D) !***KEYWORDS CURVE FITTING, LINEAR LEAST SQUARES, QR FACTORIZATION !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N) ! ! This subroutine solves a linear least squares problem or a set of ! linear least squares problems having the same matrix but different ! right-side vectors. The problem data consists of an M by N matrix ! A, an M by NB matrix B, and an absolute tolerance parameter TAU ! whose usage is described below. The NB column vectors of B ! represent right-side vectors for NB distinct linear least squares ! problems. ! ! This set of problems can also be written as the matrix least ! squares problem ! ! AX = B, ! ! where X is the N by NB solution matrix. ! ! Note that if B is the M by M identity matrix, then X will be the ! pseudo-inverse of A. ! ! This subroutine first transforms the augmented matrix (A B) to a ! matrix (R C) using premultiplying Householder transformations with ! column interchanges. All subdiagonal elements in the matrix R are ! zero and its diagonal elements satisfy ! ! ABS(R(I,I)) >= ABS(R(I+1,I+1)), ! ! I = 1,...,L-1, where ! ! L = MIN(M,N). ! ! The subroutine will compute an integer, KRANK, equal to the number ! of diagonal terms of R that exceed TAU in magnitude. Then a ! solution of minimum Euclidean length is computed using the first ! KRANK rows of (R C). ! ! To be specific we suggest that the user consider an easily ! computable matrix norm, such as, the maximum of all column sums of ! magnitudes. ! ! Now if the relative uncertainty of B is EPS, (norm of uncertainty/ ! norm of B), it is suggested that TAU be set approximately equal to ! EPS*(norm of A). ! ! The user must dimension all arrays appearing in the call list.. ! A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N). This ! permits the solution of a range of problems in the same array ! space. ! ! The entire set of parameters for HFTI are ! ! INPUT.. ! ! A(*,*),MDA,M,N The array A(*,*) initially contains the M by N ! matrix A of the least squares problem AX = B. ! The first dimensioning parameter of the array ! A(*,*) is MDA, which must satisfy MDA >= M ! Either M >= N or M < N is permitted. There ! is no restriction on the rank of A. The ! condition MDA < M is considered an error. ! ! B(*),MDB,NB If NB = 0 the subroutine will perform the ! orthogonal decomposition but will make no ! references to the array B(*). If NB > 0 ! the array B(*) must initially contain the M by ! NB matrix B of the least squares problem AX = ! B. If NB >= 2 the array B(*) must be doubly ! subscripted with first dimensioning parameter ! MDB >= MAX(M,N). If NB = 1 the array B(*) may ! be either doubly or singly subscripted. In ! the latter case the value of MDB is arbitrary ! but it should be set to some valid integer ! value such as MDB = M. ! ! The condition of NB > 1.AND.MDB < MAX(M,N) ! is considered an error. ! ! TAU Absolute tolerance parameter provided by user ! for pseudorank determination. ! ! H(*),G(*),IP(*) Arrays of working space used by HFTI. ! ! OUTPUT.. ! ! A(*,*) The contents of the array A(*,*) will be ! modified by the subroutine. These contents ! are not generally required by the user. ! ! B(*) On return the array B(*) will contain the N by ! NB solution matrix X. ! ! KRANK Set by the subroutine to indicate the ! pseudorank of A. ! ! RNORM(*) On return, RNORM(J) will contain the Euclidean ! norm of the residual vector for the problem ! defined by the J-th column vector of the array ! B(*,*) for J = 1,...,NB. ! ! H(*),G(*) On return these arrays respectively contain ! elements of the pre- and post-multiplying ! Householder transformations used to compute ! the minimum Euclidean length solution. ! ! IP(*) Array in which the subroutine records indices ! describing the permutation of column vectors. ! The contents of arrays H(*),G(*) and IP(*) ! are not generally required by the user. ! !***REFERENCES C. L. Lawson and R. J. Hanson, Solving Least Squares ! Problems, Prentice-Hall, Inc., 1974, Chapter 14. !***ROUTINES CALLED H12, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891006 Cosmetic changes to prologue. (WRB) ! 891006 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 901005 Replace usage of DIFF with usage of R1MACH. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HFTI DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*) INTEGER IP(*) DOUBLE PRECISION SM,DZERO SAVE RELEPS DATA RELEPS /0.E0/ !***FIRST EXECUTABLE STATEMENT HFTI if (RELEPS == 0) RELEPS = R1MACH(4) SZERO=0. DZERO=0.D0 FACTOR=0.001 ! K=0 LDIAG=MIN(M,N) if (LDIAG <= 0) go to 270 if (.NOT.MDA < M) go to 5 NERR=1 IOPT=2 call XERMSG ('SLATEC', 'HFTI', 'MDA < M, PROBABLE ERROR.', & NERR, IOPT) return 5 CONTINUE ! if (.NOT.(NB > 1.AND.MAX(M,N) > MDB)) go to 6 NERR=2 IOPT=2 call XERMSG ('SLATEC', 'HFTI', & 'MDB < MAX(M,N).AND.NB > 1. PROBABLE ERROR.', NERR, IOPT) return 6 CONTINUE ! DO 80 J=1,LDIAG if (J == 1) go to 20 ! ! UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX ! .. LMAX=J DO 10 L=J,N H(L)=H(L)-A(J-1,L)**2 if (H(L) > H(LMAX)) LMAX=L 10 CONTINUE if (FACTOR*H(LMAX) > HMAX*RELEPS) go to 50 ! ! COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX ! .. 20 LMAX=J DO 40 L=J,N H(L)=0. DO 30 I=J,M 30 H(L)=H(L)+A(I,L)**2 if (H(L) > H(LMAX)) LMAX=L 40 CONTINUE HMAX=H(LMAX) ! .. ! LMAX HAS BEEN DETERMINED ! ! DO COLUMN INTERCHANGES if NEEDED. ! .. 50 CONTINUE IP(J)=LMAX if (IP(J) == 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) ! ! COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B. ! .. 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) ! ! DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU. ! .. DO 90 J=1,LDIAG if (ABS(A(J,J)) <= TAU) go to 100 90 CONTINUE K=LDIAG go to 110 100 K=J-1 110 KP1=K+1 ! ! COMPUTE THE NORMS OF THE RESIDUAL VECTORS. ! if (NB <= 0) go to 140 DO 130 JB=1,NB TMP=SZERO if (KP1 > M) go to 130 DO 120 I=KP1,M 120 TMP=TMP+B(I,JB)**2 130 RNORM(JB)=SQRT(TMP) 140 CONTINUE ! SPECIAL FOR PSEUDORANK = 0 if (K > 0) go to 160 if (NB <= 0) go to 270 DO 150 JB=1,NB DO 150 I=1,N 150 B(I,JB)=SZERO go to 270 ! ! if THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER ! DECOMPOSITION OF FIRST K ROWS. ! .. 160 if (K == 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 ! ! if (NB <= 0) go to 270 DO 260 JB=1,NB ! ! SOLVE THE K BY K TRIANGULAR SYSTEM. ! .. DO 210 L=1,K SM=DZERO I=KP1-L if (I == K) go to 200 IP1=I+1 DO 190 J=IP1,K 190 SM=SM+A(I,J)*DBLE(B(J,JB)) 200 SM1=SM 210 B(I,JB)=(B(I,JB)-SM1)/A(I,I) ! ! COMPLETE COMPUTATION OF SOLUTION VECTOR. ! .. if (K == N) go to 240 DO 220 J=KP1,N 220 B(J,JB)=SZERO DO 230 I=1,K 230 call H12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1) ! ! RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE ! COLUMN INTERCHANGES. ! .. 240 DO 250 JJ=1,LDIAG J=LDIAG+1-JJ if (IP(J) == 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 ! .. ! THE SOLUTION VECTORS, X, ARE NOW ! IN THE FIRST N ROWS OF THE ARRAY B(,). ! 270 KRANK=K return end subroutine HKSEQ (X, M, H, IERR) ! !! HKSEQ is subsidiary to BSKIN. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (HKSEQ-S, DHKSEQ-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! HKSEQ is an adaptation of subroutine PSIFN described in the ! reference below. HKSEQ generates the sequence ! H(K,X) = (-X)**(K+1)*(PSI(K,X) PSI(K,X+0.5))/GAMMA(K+1), for ! K=0,...,M. ! !***SEE ALSO BSKIN !***REFERENCES D. E. Amos, A portable Fortran subroutine for ! derivatives of the Psi function, Algorithm 610, ACM ! Transactions on Mathematical Software 9, 4 (1983), ! pp. 494-502. !***ROUTINES CALLED I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920528 DESCRIPTION and REFERENCES sections revised. (WRB) !***END PROLOGUE HKSEQ INTEGER I, IERR, J, K, M, MX, NX INTEGER I1MACH REAL B, FK, FLN, FN, FNP, H, HRX, RLN, RXSQ, R1M5, S, SLOPE, T, & TK, TRM, TRMH, TRMR, TST, U, V, WDTOL, X, XDMY, XH, XINC, XM, & XMIN, YINT REAL R1MACH DIMENSION B(22), TRM(22), TRMR(25), TRMH(25), U(25), V(25), H(*) SAVE B !----------------------------------------------------------------------- ! SCALED BERNOULLI NUMBERS 2.0*B(2K)*(1-2**(-2K)) !----------------------------------------------------------------------- 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.00000000000000000E+00, & -5.00000000000000000E-01,2.50000000000000000E-01, & -6.25000000000000000E-02,4.68750000000000000E-02, & -6.64062500000000000E-02,1.51367187500000000E-01, & -5.06103515625000000E-01,2.33319091796875000E+00, & -1.41840972900390625E+01,1.09941936492919922E+02, & -1.05824747562408447E+03,1.23842434241771698E+04, & -1.73160495905935764E+05,2.85103429084961116E+06, & -5.45964619322445132E+07,1.20316174668075304E+09, & -3.02326315271452307E+10,8.59229286072319606E+11, & -2.74233104097776039E+13,9.76664637943633248E+14, & -3.85931586838450360E+16/ ! !***FIRST EXECUTABLE STATEMENT HKSEQ IERR=0 WDTOL = MAX(R1MACH(4),1.0E-18) FN = M - 1 FNP = FN + 1.0E0 !----------------------------------------------------------------------- ! COMPUTE XMIN !----------------------------------------------------------------------- R1M5 = R1MACH(5) RLN = R1M5*I1MACH(11) RLN = MIN(RLN,18.06E0) FLN = MAX(RLN,3.0E0) - 3.0E0 YINT = 3.50E0 + 0.40E0*FLN SLOPE = 0.21E0 + FLN*(0.0006038E0*FLN+0.008677E0) XM = YINT + SLOPE*FN MX = INT(XM) + 1 XMIN = MX !----------------------------------------------------------------------- ! GENERATE H(M-1,XDMY)*XDMY**(M) BY THE ASYMPTOTIC EXPANSION !----------------------------------------------------------------------- XDMY = X XINC = 0.0E0 if (X >= XMIN) go to 10 NX = INT(X) XINC = XMIN - NX XDMY = X + XINC 10 CONTINUE RXSQ = 1.0E0/(XDMY*XDMY) HRX = 0.5E0/XDMY TST = 0.5E0*WDTOL T = FNP*HRX !----------------------------------------------------------------------- ! INITIALIZE COEFFICIENT ARRAY !----------------------------------------------------------------------- S = T*B(3) if (ABS(S) < TST) go to 30 TK = 2.0E0 DO 20 K=4,22 T = T*((TK+FN+1.0E0)/(TK+1.0E0))*((TK+FN)/(TK+2.0E0))*RXSQ TRM(K) = T*B(K) if (ABS(TRM(K)) < TST) go to 30 S = S + TRM(K) TK = TK + 2.0E0 20 CONTINUE go to 110 30 CONTINUE H(M) = S + 0.5E0 if (M == 1) go to 70 !----------------------------------------------------------------------- ! GENERATE LOWER DERIVATIVES, I < M-1 !----------------------------------------------------------------------- DO 60 I=2,M FNP = FN FN = FN - 1.0E0 S = FNP*HRX*B(3) if (ABS(S) < TST) go to 50 FK = FNP + 3.0E0 DO 40 K=4,22 TRM(K) = TRM(K)*FNP/FK if (ABS(TRM(K)) < TST) go to 50 S = S + TRM(K) FK = FK + 2.0E0 40 CONTINUE go to 110 50 CONTINUE MX = M - I + 1 H(MX) = S + 0.5E0 60 CONTINUE 70 CONTINUE if (XINC == 0.0E0) RETURN !----------------------------------------------------------------------- ! RECUR BACKWARD FROM XDMY TO X !----------------------------------------------------------------------- XH = X + 0.5E0 S = 0.0E0 NX = INT(XINC) DO 80 I=1,NX TRMR(I) = X/(X+NX-I) U(I) = TRMR(I) TRMH(I) = X/(XH+NX-I) V(I) = TRMH(I) S = S + U(I) - V(I) 80 CONTINUE MX = NX + 1 TRMR(MX) = X/XDMY U(MX) = TRMR(MX) H(1) = H(1)*TRMR(MX) + S if (M == 1) RETURN DO 100 J=2,M S = 0.0E0 DO 90 I=1,NX TRMR(I) = TRMR(I)*U(I) TRMH(I) = TRMH(I)*V(I) S = S + TRMR(I) - TRMH(I) 90 CONTINUE TRMR(MX) = TRMR(MX)*U(MX) H(J) = H(J)*TRMR(MX) + S 100 CONTINUE return 110 CONTINUE IERR=2 return end subroutine HPPERM (HX, N, IPERM, WORK, IER) ! !! HPPERM rearranges an array according to a permutation vector. ! !***LIBRARY SLATEC !***CATEGORY N8 !***TYPE CHARACTER (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H) !***KEYWORDS APPLICATION OF PERMUTATION TO DATA VECTOR !***AUTHOR McClain, M. A., (NIST) ! Rhoads, G. S., (NBS) !***DESCRIPTION ! ! HPPERM rearranges the data vector HX according to the ! permutation IPERM: HX(I) <--- HX(IPERM(I)). IPERM could come ! from one of the sorting routines IPSORT, SPSORT, DPSORT or ! HPSORT. ! ! Description of Parameters ! HX - input/output -- character array of values to be ! rearranged. ! N - input -- number of values in character array HX. ! IPERM - input -- permutation vector. ! WORK - character variable which must have a length ! specification at least as great as that of HX. ! IER - output -- error indicator: ! = 0 if no error, ! = 1 if N is zero or negative, ! = 2 if work array is not long enough, ! = 3 if IPERM is not a valid permutation. ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 901004 DATE WRITTEN ! 920507 Modified by M. McClain to revise prologue text and to add ! check for length of work array. !***END PROLOGUE HPPERM INTEGER N, IPERM(*), I, IER, INDX, INDX0, ISTRT CHARACTER*(*) HX(*), WORK !***FIRST EXECUTABLE STATEMENT HPPERM IER=0 if ( N < 1)THEN IER=1 call XERMSG ('SLATEC', 'HPPERM', & 'The number of values to be rearranged, N, is not positive.', & IER, 1) return end if if ( LEN(WORK) < LEN(HX(1)))THEN IER=2 call XERMSG ('SLATEC', 'HPPERM', & 'The length of the work variable, WORK, is too short.',IER,1) return end if ! ! CHECK WHETHER IPERM IS A VALID PERMUTATION ! DO 100 I=1,N INDX=ABS(IPERM(I)) if ( (INDX >= 1).AND.(INDX <= N))THEN if ( IPERM(INDX) > 0)THEN IPERM(INDX)=-IPERM(INDX) GOTO 100 ENDIF ENDIF IER=3 call XERMSG ('SLATEC', 'HPPERM', & 'The permutation vector, IPERM, is not valid.', IER, 1) return 100 CONTINUE ! ! REARRANGE THE VALUES OF HX ! ! USE THE IPERM VECTOR AS A FLAG. ! if IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION ! DO 330 ISTRT = 1 , N if (IPERM(ISTRT) > 0) GOTO 330 INDX = ISTRT INDX0 = INDX WORK = HX(ISTRT) 320 CONTINUE if (IPERM(INDX) >= 0) GOTO 325 HX(INDX) = HX(-IPERM(INDX)) INDX0 = INDX IPERM(INDX) = -IPERM(INDX) INDX = IPERM(INDX) GOTO 320 325 CONTINUE HX(INDX0) = WORK 330 CONTINUE ! return end subroutine HPSORT (HX, N, STRBEG, STREND, IPERM, KFLAG, WORK, IER) ! !! HPSORT returns the permutation vector generated by sorting a ... ! substring within a character array and, optionally, ! rearrange the elements of the array. The array may be ! sorted in forward or reverse lexicographical order. A ! slightly modified quicksort algorithm is used. !***LIBRARY SLATEC !***CATEGORY N6A1C, N6A2C !***TYPE CHARACTER (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H) !***KEYWORDS PASSIVE SORTING, SINGLETON QUICKSORT, SORT, STRING SORTING !***AUTHOR Jones, R. E., (SNLA) ! Rhoads, G. S., (NBS) ! Sullivan, F. E., (NBS) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! HPSORT returns the permutation vector IPERM generated by sorting ! the substrings beginning with the character STRBEG and ending with ! the character STREND within the strings in array HX and, optionally, ! rearranges the strings in HX. HX may be sorted in increasing or ! decreasing lexicographical order. A slightly modified quicksort ! algorithm is used. ! ! IPERM is such that HX(IPERM(I)) is the Ith value in the ! rearrangement of HX. IPERM may be applied to another array by ! calling IPPERM, SPPERM, DPPERM or HPPERM. ! ! An active sort of numerical data is expected to execute somewhat ! more quickly than a passive sort because there is no need to use ! indirect references. But for the character data in HPSORT, integers ! in the IPERM vector are manipulated rather than the strings in HX. ! Moving integers may be enough faster than moving character strings ! to more than offset the penalty of indirect referencing. ! ! Description of Parameters ! HX - input/output -- array of type character to be sorted. ! For example, to sort a 80 element array of names, ! each of length 6, declare HX as character HX(100)*6. ! If ABS(KFLAG) = 2, then the values in HX will be ! rearranged on output; otherwise, they are unchanged. ! N - input -- number of values in array HX to be sorted. ! STRBEG - input -- the index of the initial character in ! the string HX that is to be sorted. ! STREND - input -- the index of the final character in ! the string HX that is to be sorted. ! IPERM - output -- permutation array such that IPERM(I) is the ! index of the string in the original order of the ! HX array that is in the Ith location in the sorted ! order. ! KFLAG - input -- control parameter: ! = 2 means return the permutation vector resulting from ! sorting HX in lexicographical order and sort HX also. ! = 1 means return the permutation vector resulting from ! sorting HX in lexicographical order and do not sort ! HX. ! = -1 means return the permutation vector resulting from ! sorting HX in reverse lexicographical order and do ! not sort HX. ! = -2 means return the permutation vector resulting from ! sorting HX in reverse lexicographical order and sort ! HX also. ! WORK - character variable which must have a length specification ! at least as great as that of HX. ! IER - output -- error indicator: ! = 0 if no error, ! = 1 if N is zero or negative, ! = 2 if KFLAG is not 2, 1, -1, or -2, ! = 3 if work array is not long enough, ! = 4 if string beginning is beyond its end, ! = 5 if string beginning is out-of-range, ! = 6 if string end is out-of-range. ! ! E X A M P L E O F U S E ! ! CHARACTER*2 HX, W ! INTEGER STRBEG, STREND ! DIMENSION HX(10), IPERM(10) ! DATA (HX(I),I=1,10)/ '05','I ',' I',' ','Rs','9R','R9','89', ! 1 ',*','N"'/ ! DATA STRBEG, STREND / 1, 2 / ! call HPSORT (HX,10,STRBEG,STREND,IPERM,1,W) ! PRINT 100, (HX(IPERM(I)),I=1,10) ! 100 FORMAT (2X, A2) ! STOP ! END ! !***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm ! for sorting with minimal storage, Communications of ! the ACM, 12, 3 (1969), pp. 185-187. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 761101 DATE WRITTEN ! 761118 Modified by John A. Wisniewski to use the Singleton ! quicksort algorithm. ! 811001 Modified by Francis Sullivan for string data. ! 850326 Documentation slightly modified by D. Kahaner. ! 870423 Modified by Gregory S. Rhoads for passive sorting with the ! option for the rearrangement of the original data. ! 890620 Algorithm for rearranging the data vector corrected by R. ! Boisvert. ! 890622 Prologue upgraded to Version 4.0 style by D. Lozier. ! 920507 Modified by M. McClain to revise prologue text. ! 920818 Declarations section rebuilt and code restructured to use ! IF-THEN-ELSE-ENDIF. (SMR, WRB) !***END PROLOGUE HPSORT ! .. Scalar Arguments .. INTEGER IER, KFLAG, N, STRBEG, STREND CHARACTER * (*) WORK ! .. Array Arguments .. INTEGER IPERM(*) CHARACTER * (*) HX(*) ! .. Local Scalars .. REAL R INTEGER I, IJ, INDX, INDX0, IR, ISTRT, J, K, KK, L, LM, LMT, M, & NN, NN2 ! .. Local Arrays .. INTEGER IL(21), IU(21) ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, INT, LEN !***FIRST EXECUTABLE STATEMENT HPSORT IER = 0 NN = N if (NN < 1) THEN IER = 1 call XERMSG ('SLATEC', 'HPSORT', & 'The number of values to be sorted, N, is not positive.', & IER, 1) return end if KK = ABS(KFLAG) if (KK /= 1 .AND. KK /= 2) THEN IER = 2 call XERMSG ('SLATEC', 'HPSORT', & 'The sort control parameter, KFLAG, is not 2, 1, -1, or -2.', & IER, 1) return end if ! if ( LEN(WORK) < LEN(HX(1))) THEN IER = 3 call XERMSG ('SLATEC',' HPSORT', & 'The length of the work variable, WORK, is too short.', & IER, 1) return end if if (STRBEG > STREND) THEN IER = 4 call XERMSG ('SLATEC', 'HPSORT', & 'The string beginning, STRBEG, is beyond its end, STREND.', & IER, 1) return end if if (STRBEG < 1 .OR. STRBEG > LEN(HX(1))) THEN IER = 5 call XERMSG ('SLATEC', 'HPSORT', & 'The string beginning, STRBEG, is out-of-range.', & IER, 1) return end if if (STREND < 1 .OR. STREND > LEN(HX(1))) THEN IER = 6 call XERMSG ('SLATEC', 'HPSORT', & 'The string end, STREND, is out-of-range.', & IER, 1) return end if ! ! Initialize permutation vector ! DO 10 I=1,NN IPERM(I) = I 10 CONTINUE ! ! Return if only one value is to be sorted ! if (NN == 1) RETURN ! ! Sort HX only ! M = 1 I = 1 J = NN R = .375E0 ! 20 if (I == J) go to 70 if (R <= 0.5898437E0) THEN R = R+3.90625E-2 ELSE R = R-0.21875E0 end if ! 30 K = I ! ! Select a central element of the array and save it in location L ! IJ = I + INT((J-I)*R) LM = IPERM(IJ) ! ! If first element of array is greater than LM, interchange with LM ! if (HX(IPERM(I))(STRBEG:STREND) > HX(LM)(STRBEG:STREND)) THEN IPERM(IJ) = IPERM(I) IPERM(I) = LM LM = IPERM(IJ) end if L = J ! ! If last element of array is less than LM, interchange with LM ! if (HX(IPERM(J))(STRBEG:STREND) < HX(LM)(STRBEG:STREND)) THEN IPERM(IJ) = IPERM(J) IPERM(J) = LM LM = IPERM(IJ) ! ! If first element of array is greater than LM, interchange ! with LM ! if (HX(IPERM(I))(STRBEG:STREND) > HX(LM)(STRBEG:STREND)) & THEN IPERM(IJ) = IPERM(I) IPERM(I) = LM LM = IPERM(IJ) ENDIF end if go to 50 40 LMT = IPERM(L) IPERM(L) = IPERM(K) IPERM(K) = LMT ! ! Find an element in the second half of the array which is smaller ! than LM ! 50 L = L-1 if (HX(IPERM(L))(STRBEG:STREND) > HX(LM)(STRBEG:STREND)) & go to 50 ! ! Find an element in the first half of the array which is greater ! than LM ! 60 K = K+1 if (HX(IPERM(K))(STRBEG:STREND) < HX(LM)(STRBEG:STREND)) & go to 60 ! ! Interchange these elements ! if (K <= L) go to 40 ! ! Save upper and lower subscripts of the array yet to be sorted ! if (L-I > J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 80 ! ! Begin again on another portion of the unsorted array ! 70 M = M-1 if (M == 0) go to 110 I = IL(M) J = IU(M) ! 80 if (J-I >= 1) go to 30 if (I == 1) go to 20 I = I-1 ! 90 I = I+1 if (I == J) go to 70 LM = IPERM(I+1) if (HX(IPERM(I))(STRBEG:STREND) <= HX(LM)(STRBEG:STREND)) & go to 90 K = I ! 100 IPERM(K+1) = IPERM(K) K = K-1 ! if (HX(LM)(STRBEG:STREND) < HX(IPERM(K))(STRBEG:STREND)) & go to 100 IPERM(K+1) = LM go to 90 ! ! Clean up ! 110 if (KFLAG <= -1) THEN ! ! Alter array to get reverse order, if necessary ! NN2 = NN/2 DO 120 I=1,NN2 IR = NN-I+1 LM = IPERM(I) IPERM(I) = IPERM(IR) IPERM(IR) = LM 120 CONTINUE end if ! ! Rearrange the values of HX if desired ! if (KK == 2) THEN ! ! Use the IPERM vector as a flag. ! If IPERM(I) < 0, then the I-th value is in correct location ! DO 140 ISTRT=1,NN if (IPERM(ISTRT) >= 0) THEN INDX = ISTRT INDX0 = INDX WORK = HX(ISTRT) 130 if (IPERM(INDX) > 0) THEN HX(INDX) = HX(IPERM(INDX)) INDX0 = INDX IPERM(INDX) = -IPERM(INDX) INDX = ABS(IPERM(INDX)) go to 130 ENDIF HX(INDX0) = WORK ENDIF 140 CONTINUE ! ! Revert the signs of the IPERM values ! DO 150 I=1,NN IPERM(I) = -IPERM(I) 150 CONTINUE ! end if ! return end subroutine HQR2 (NM, N, LOW, IGH, H, WR, WI, Z, IERR) ! !! HQR2 computes the eigenvalues and eigenvectors of a real upper ... ! Hessenberg matrix using QR method. !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C2B !***TYPE SINGLE PRECISION (HQR2-S, COMQR2-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure HQR2, ! NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). ! ! This subroutine finds the eigenvalues and eigenvectors ! of a REAL UPPER Hessenberg matrix by the QR method. The ! eigenvectors of a REAL GENERAL matrix can also be found ! if ELMHES and ELTRAN or ORTHES and ORTRAN have ! been used to reduce this general matrix to Hessenberg form ! and to accumulate the similarity transformations. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, H and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix H. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine BALANC. If BALANC has not been ! used, set LOW=1 and IGH equal to the order of the matrix, N. ! ! H contains the upper Hessenberg matrix. H is a two-dimensional ! REAL array, dimensioned H(NM,N). ! ! Z contains the transformation matrix produced by ELTRAN ! after the reduction by ELMHES, or by ORTRAN after the ! reduction by ORTHES, if performed. If the eigenvectors ! of the Hessenberg matrix are desired, Z must contain the ! identity matrix. Z is a two-dimensional REAL array, ! dimensioned Z(NM,M). ! ! On OUTPUT ! ! H has been destroyed. ! ! WR and WI contain the real and imaginary parts, respectively, ! of the eigenvalues. The eigenvalues are unordered except ! that complex conjugate pairs of values appear consecutively ! with the eigenvalue having the positive imaginary part first. ! If an error exit is made, the eigenvalues should be correct ! for indices IERR+1, IERR+2, ..., N. WR and WI are one- ! dimensional REAL arrays, dimensioned WR(N) and WI(N). ! ! Z contains the real and imaginary parts of the eigenvectors. ! If the J-th eigenvalue is real, the J-th column of Z ! contains its eigenvector. If the J-th eigenvalue is complex ! with positive imaginary part, the J-th and (J+1)-th ! columns of Z contain the real and imaginary parts of its ! eigenvector. The eigenvectors are unnormalized. If an ! error exit is made, none of the eigenvectors has been found. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after a total of 30*N iterations. ! The eigenvalues should be correct for indices ! IERR+1, IERR+2, ..., N, but no eigenvectors are ! computed. ! ! Calls CDIV for complex division. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED CDIV !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HQR2 ! INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN INTEGER IGH,ITN,ITS,LOW,MP2,ENM2,IERR REAL H(NM,*),WR(*),WI(*),Z(NM,*) REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,S1,S2 LOGICAL NOTLAS ! !***FIRST EXECUTABLE STATEMENT HQR2 IERR = 0 NORM = 0.0E0 K = 1 ! .......... STORE ROOTS ISOLATED BY BALANC ! AND COMPUTE MATRIX NORM .......... DO 50 I = 1, N ! DO 40 J = K, N 40 NORM = NORM + ABS(H(I,J)) ! K = I if (I >= LOW .AND. I <= IGH) go to 50 WR(I) = H(I,I) WI(I) = 0.0E0 50 CONTINUE ! EN = IGH T = 0.0E0 ITN = 30*N ! .......... SEARCH FOR NEXT EIGENVALUES .......... 60 if (EN < LOW) go to 340 ITS = 0 NA = EN - 1 ENM2 = NA - 1 ! .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT ! FOR L=EN STEP -1 UNTIL LOW DO -- .......... 70 DO 80 LL = LOW, EN L = EN + LOW - LL if (L == LOW) go to 100 S = ABS(H(L-1,L-1)) + ABS(H(L,L)) if (S == 0.0E0) S = NORM S2 = S + ABS(H(L,L-1)) if (S2 == S) go to 100 80 CONTINUE ! .......... FORM SHIFT .......... 100 X = H(EN,EN) if (L == EN) go to 270 Y = H(NA,NA) W = H(EN,NA) * H(NA,EN) if (L == NA) go to 280 if (ITN == 0) go to 1000 if (ITS /= 10 .AND. ITS /= 20) go to 130 ! .......... FORM EXCEPTIONAL SHIFT .......... T = T + X ! DO 120 I = LOW, EN 120 H(I,I) = H(I,I) - X ! S = ABS(H(EN,NA)) + ABS(H(NA,ENM2)) X = 0.75E0 * S Y = X W = -0.4375E0 * S * S 130 ITS = ITS + 1 ITN = ITN - 1 ! .......... LOOK FOR TWO CONSECUTIVE SMALL ! SUB-DIAGONAL ELEMENTS. ! 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 == L) go to 150 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 (S2 == S1) go to 150 140 CONTINUE ! 150 MP2 = M + 2 ! DO 160 I = MP2, EN H(I,I-2) = 0.0E0 if (I == MP2) go to 160 H(I,I-3) = 0.0E0 160 CONTINUE ! .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND ! COLUMNS M TO EN .......... DO 260 K = M, NA NOTLAS = K /= NA if (K == M) go to 170 P = H(K,K-1) Q = H(K+1,K-1) R = 0.0E0 if (NOTLAS) R = H(K+2,K-1) X = ABS(P) + ABS(Q) + ABS(R) if (X == 0.0E0) go to 260 P = P / X Q = Q / X R = R / X 170 S = SIGN(SQRT(P*P+Q*Q+R*R),P) if (K == M) go to 180 H(K,K-1) = -S * X go to 190 180 if (L /= 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 ! .......... 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 ! J = MIN(EN,K+3) ! .......... 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 ! .......... 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 ! 260 CONTINUE ! go to 70 ! .......... ONE ROOT FOUND .......... 270 H(EN,EN) = X + T WR(EN) = H(EN,EN) WI(EN) = 0.0E0 EN = NA go to 60 ! .......... TWO ROOTS FOUND .......... 280 P = (Y - X) / 2.0E0 Q = P * P + W ZZ = SQRT(ABS(Q)) H(EN,EN) = X + T X = H(EN,EN) H(NA,NA) = Y + T if (Q < 0.0E0) go to 320 ! .......... REAL PAIR .......... ZZ = P + SIGN(ZZ,P) WR(NA) = X + ZZ WR(EN) = WR(NA) if (ZZ /= 0.0E0) WR(EN) = X - W / ZZ WI(NA) = 0.0E0 WI(EN) = 0.0E0 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 ! .......... 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 ! .......... 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 ! .......... 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 ! go to 330 ! .......... COMPLEX PAIR .......... 320 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 330 EN = ENM2 go to 60 ! .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND ! VECTORS OF UPPER TRIANGULAR FORM .......... 340 if (NORM == 0.0E0) go to 1001 ! .......... 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 ! .......... REAL VECTOR .......... 600 M = EN H(EN,EN) = 1.0E0 if (NA == 0) go to 800 ! .......... 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 > NA) go to 620 ! DO 610 J = M, NA 610 R = R + H(I,J) * H(J,EN) ! 620 if (WI(I) >= 0.0E0) go to 630 ZZ = W S = R go to 700 630 M = I if (WI(I) /= 0.0E0) go to 640 T = W if (T /= 0.0E0) go to 635 T = NORM 632 T = 0.5E0*T if (NORM + T > NORM) go to 632 T = 2.0E0*T 635 H(I,EN) = -R / T go to 700 ! .......... 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) <= 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 ! .......... END REAL VECTOR .......... go to 800 ! .......... COMPLEX VECTOR .......... 710 M = NA ! .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT ! EIGENVECTOR MATRIX IS TRIANGULAR .......... if (ABS(H(EN,NA)) <= 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 call CDIV(0.0E0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN)) 730 H(EN,NA) = 0.0E0 H(EN,EN) = 1.0E0 ENM2 = NA - 1 if (ENM2 == 0) go to 800 ! .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... DO 790 II = 1, ENM2 I = NA - II W = H(I,I) - P RA = 0.0E0 SA = H(I,EN) ! DO 760 J = M, NA RA = RA + H(I,J) * H(J,NA) SA = SA + H(I,J) * H(J,EN) 760 CONTINUE ! if (WI(I) >= 0.0E0) go to 770 ZZ = W R = RA S = SA go to 790 770 M = I if (WI(I) /= 0.0E0) go to 780 call CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN)) go to 790 ! .......... 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.0E0 * Q if (VR /= 0.0E0 .OR. VI /= 0.0E0) go to 783 S1 = NORM * (ABS(W)+ABS(Q)+ABS(X)+ABS(Y)+ABS(ZZ)) VR = S1 782 VR = 0.5E0*VR if (S1 + VR > S1) go to 782 VR = 2.0E0*VR 783 call CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI, & H(I,NA),H(I,EN)) if (ABS(X) <= 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 call CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q, & H(I+1,NA),H(I+1,EN)) 790 CONTINUE ! .......... END COMPLEX VECTOR .......... 800 CONTINUE ! .......... END BACK SUBSTITUTION. ! VECTORS OF ISOLATED ROOTS .......... DO 840 I = 1, N if (I >= LOW .AND. I <= IGH) go to 840 ! DO 820 J = I, N 820 Z(I,J) = H(I,J) ! 840 CONTINUE ! .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE ! VECTORS OF ORIGINAL FULL MATRIX. ! FOR J=N STEP -1 UNTIL LOW DO -- .......... DO 880 JJ = LOW, N J = N + LOW - JJ M = MIN(J,IGH) ! DO 880 I = LOW, IGH ZZ = 0.0E0 ! DO 860 K = LOW, M 860 ZZ = ZZ + Z(I,K) * H(K,J) ! Z(I,J) = ZZ 880 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN end subroutine HQR (NM, N, LOW, IGH, H, WR, WI, IERR) ! !! HQR computes the eigenvalues of a real upper Hessenberg matrix ... ! using the QR method. !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C2B !***TYPE SINGLE PRECISION (HQR-S, COMQR-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure HQR, ! NUM. MATH. 14, 219-231(1970) by Martin, Peters, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). ! ! This subroutine finds the eigenvalues of a REAL ! UPPER Hessenberg matrix by the QR method. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, H, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix H. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine BALANC. If BALANC has not been ! used, set LOW=1 and IGH equal to the order of the matrix, N. ! ! H contains the upper Hessenberg matrix. Information about ! the transformations used in the reduction to Hessenberg ! form by ELMHES or ORTHES, if performed, is stored ! in the remaining triangle under the Hessenberg matrix. ! H is a two-dimensional REAL array, dimensioned H(NM,N). ! ! On OUTPUT ! ! H has been destroyed. Therefore, it must be saved before ! calling HQR if subsequent calculation and back ! transformation of eigenvectors is to be performed. ! ! WR and WI contain the real and imaginary parts, respectively, ! of the eigenvalues. The eigenvalues are unordered except ! that complex conjugate pairs of values appear consecutively ! with the eigenvalue having the positive imaginary part first. ! If an error exit is made, the eigenvalues should be correct ! for indices IERR+1, IERR+2, ..., N. WR and WI are one- ! dimensional REAL arrays, dimensioned WR(N) and WI(N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after a total of 30*N iterations. ! The eigenvalues should be correct for indices ! IERR+1, IERR+2, ..., N. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HQR ! INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR REAL H(NM,*),WR(*),WI(*) REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,S1,S2 LOGICAL NOTLAS ! !***FIRST EXECUTABLE STATEMENT HQR IERR = 0 NORM = 0.0E0 K = 1 ! .......... STORE ROOTS ISOLATED BY BALANC ! AND COMPUTE MATRIX NORM .......... DO 50 I = 1, N ! DO 40 J = K, N 40 NORM = NORM + ABS(H(I,J)) ! K = I if (I >= LOW .AND. I <= IGH) go to 50 WR(I) = H(I,I) WI(I) = 0.0E0 50 CONTINUE ! EN = IGH T = 0.0E0 ITN = 30*N ! .......... SEARCH FOR NEXT EIGENVALUES .......... 60 if (EN < LOW) go to 1001 ITS = 0 NA = EN - 1 ENM2 = NA - 1 ! .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT ! FOR L=EN STEP -1 UNTIL LOW DO -- .......... 70 DO 80 LL = LOW, EN L = EN + LOW - LL if (L == LOW) go to 100 S = ABS(H(L-1,L-1)) + ABS(H(L,L)) if (S == 0.0E0) S = NORM S2 = S + ABS(H(L,L-1)) if (S2 == S) go to 100 80 CONTINUE ! .......... FORM SHIFT .......... 100 X = H(EN,EN) if (L == EN) go to 270 Y = H(NA,NA) W = H(EN,NA) * H(NA,EN) if (L == NA) go to 280 if (ITN == 0) go to 1000 if (ITS /= 10 .AND. ITS /= 20) go to 130 ! .......... FORM EXCEPTIONAL SHIFT .......... T = T + X ! DO 120 I = LOW, EN 120 H(I,I) = H(I,I) - X ! S = ABS(H(EN,NA)) + ABS(H(NA,ENM2)) X = 0.75E0 * S Y = X W = -0.4375E0 * S * S 130 ITS = ITS + 1 ITN = ITN - 1 ! .......... LOOK FOR TWO CONSECUTIVE SMALL ! SUB-DIAGONAL ELEMENTS. ! 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 == L) go to 150 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 (S2 == S1) go to 150 140 CONTINUE ! 150 MP2 = M + 2 ! DO 160 I = MP2, EN H(I,I-2) = 0.0E0 if (I == MP2) go to 160 H(I,I-3) = 0.0E0 160 CONTINUE ! .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND ! COLUMNS M TO EN .......... DO 260 K = M, NA NOTLAS = K /= NA if (K == M) go to 170 P = H(K,K-1) Q = H(K+1,K-1) R = 0.0E0 if (NOTLAS) R = H(K+2,K-1) X = ABS(P) + ABS(Q) + ABS(R) if (X == 0.0E0) go to 260 P = P / X Q = Q / X R = R / X 170 S = SIGN(SQRT(P*P+Q*Q+R*R),P) if (K == M) go to 180 H(K,K-1) = -S * X go to 190 180 if (L /= 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 ! .......... 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 ! J = MIN(EN,K+3) ! .......... 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 ! 260 CONTINUE ! go to 70 ! .......... ONE ROOT FOUND .......... 270 WR(EN) = X + T WI(EN) = 0.0E0 EN = NA go to 60 ! .......... TWO ROOTS FOUND .......... 280 P = (Y - X) / 2.0E0 Q = P * P + W ZZ = SQRT(ABS(Q)) X = X + T if (Q < 0.0E0) go to 320 ! .......... REAL PAIR .......... ZZ = P + SIGN(ZZ,P) WR(NA) = X + ZZ WR(EN) = WR(NA) if (ZZ /= 0.0E0) WR(EN) = X - W / ZZ WI(NA) = 0.0E0 WI(EN) = 0.0E0 go to 330 ! .......... COMPLEX PAIR .......... 320 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 330 EN = ENM2 go to 60 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN end subroutine HSTART (F, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, & BIG, SPY, PV, YP, SF, RPAR, IPAR, H) ! !! HSTART is subsidiary to DEABM, DEBDF and DERKF. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (HSTART-S, DHSTRT-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! HSTART computes a starting step size to be used in solving initial ! value problems in ordinary differential equations. ! ********************************************************************** ! Abstract ! ! Subroutine HSTART computes a starting step size to be used by an ! initial value method in solving ordinary differential equations. ! It is based on an estimate of the local Lipschitz constant for the ! differential equation (lower bound on a norm of the Jacobian), ! a bound on the differential equation (first derivative), and ! a bound on the partial derivative of the equation with respect to ! the independent variable. ! (All approximated near the initial point A.) ! ! Subroutine HSTART uses a function subprogram HVNRM for computing ! a vector norm. The maximum norm is presently utilized though it ! can easily be replaced by any other vector norm. It is presumed ! that any replacement norm routine would be carefully coded to ! prevent unnecessary underflows or overflows from occurring, and ! also, would not alter the vector or number of components. ! ! ********************************************************************** ! On Input you must provide the following ! ! F -- This is a subroutine of the form ! F(X,U,UPRIME,RPAR,IPAR) ! which defines the system of first order differential ! equations to be solved. For the given values of X and the ! vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must ! evaluate the NEQ components of the system of differential ! equations dU/DX=F(X,U) and store the derivatives in the ! array UPRIME(*), that is, UPRIME(I) = * dU(I)/DX * for ! equations I=1,...,NEQ. ! ! Subroutine F must not alter X or U(*). You must declare ! the name F in an EXTERNAL statement in your program that ! calls HSTART. You must dimension U and UPRIME in F. ! ! RPAR and IPAR are real and integer parameter arrays which ! you can use for communication between your program and ! subroutine F. They are not used or altered by HSTART. If ! you do not need RPAR or IPAR, ignore these parameters by ! treating them as dummy arguments. If you do choose to use ! them, dimension them in your program and in F as arrays ! of appropriate length. ! ! NEQ -- This is the number of (first order) differential equations ! to be integrated. ! ! A -- This is the initial point of integration. ! ! B -- This is a value of the independent variable used to define ! the direction of integration. A reasonable choice is to ! set B to the first point at which a solution is desired. ! You can also use B, if necessary, to restrict the length ! of the first integration step because the algorithm will ! not compute a starting step length which is bigger than ! ABS(B-A), unless B has been chosen too close to A. ! (It is presumed that HSTART has been called with B ! different from A on the machine being used. Also see ! the discussion about the parameter SMALL.) ! ! Y(*) -- This is the vector of initial values of the NEQ solution ! components at the initial point A. ! ! YPRIME(*) -- This is the vector of derivatives of the NEQ ! solution components at the initial point A. ! (defined by the differential equations in subroutine F) ! ! ETOL -- This is the vector of error tolerances corresponding to ! the NEQ solution components. It is assumed that all ! elements are positive. Following the first integration ! step, the tolerances are expected to be used by the ! integrator in an error test which roughly requires that ! ABS(local error) <= ETOL ! for each vector component. ! ! MORDER -- This is the order of the formula which will be used by ! the initial value method for taking the first integration ! step. ! ! SMALL -- This is a small positive machine dependent constant ! which is used for protecting against computations with ! numbers which are too small relative to the precision of ! floating point arithmetic. SMALL should be set to ! (approximately) the smallest positive real number such ! that (1.+SMALL) > 1. on the machine being used. the ! quantity SMALL**(3/8) is used in computing increments of ! variables for approximating derivatives by differences. ! also the algorithm will not compute a starting step length ! which is smaller than 100*SMALL*ABS(A). ! ! BIG -- This is a large positive machine dependent constant which ! is used for preventing machine overflows. A reasonable ! choice is to set big to (approximately) the square root of ! the largest real number which can be held in the machine. ! ! SPY(*),PV(*),YP(*),SF(*) -- These are real work arrays of length ! NEQ which provide the routine with needed storage space. ! ! RPAR,IPAR -- These are parameter arrays, of real and integer ! type, respectively, which can be used for communication ! between your program and the F subroutine. They are not ! used or altered by HSTART. ! ! ********************************************************************** ! On Output (after the return from HSTART), ! ! H -- Is an appropriate starting step size to be attempted by the ! differential equation method. ! ! All parameters in the call list remain unchanged except for ! the working arrays SPY(*),PV(*),YP(*) and SF(*). ! ! ********************************************************************** ! !***SEE ALSO DEABM, DEBDF, DERKF !***ROUTINES CALLED HVNRM !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891024 Changed references from VNORM to HVNRM. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE HSTART ! DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*),SF(*), & RPAR(*),IPAR(*) EXTERNAL F ! !....................................................................... ! !***FIRST EXECUTABLE STATEMENT HSTART DX = B - A ABSDX = ABS(DX) RELPER = SMALL**0.375 YNORM = HVNRM(Y,NEQ) ! !....................................................................... ! ! COMPUTE A WEIGHTED APPROXIMATE BOUND (DFDXB) ON THE PARTIAL ! DERIVATIVE OF THE EQUATION WITH RESPECT TO THE ! INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. ALSO ! COMPUTE A WEIGHTED BOUND (FBND) ON THE FIRST DERIVATIVE LOCALLY. ! DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX),100.*SMALL*ABS(A)),DX) if (DA == 0.) DA = RELPER*DX call F(A+DA,Y,SF,RPAR,IPAR) ! if (MORDER == 1) go to 20 POWER = 2./(MORDER+1) DO 10 J=1,NEQ WTJ = ETOL(J)**POWER SPY(J) = SF(J)/WTJ YP(J) = YPRIME(J)/WTJ 10 PV(J) = SPY(J) - YP(J) go to 40 ! 20 DO 30 J=1,NEQ SPY(J) = SF(J)/ETOL(J) YP(J) = YPRIME(J)/ETOL(J) 30 PV(J) = SPY(J) - YP(J) ! 40 DELF = HVNRM(PV,NEQ) DFDXB = BIG if (DELF < BIG*ABS(DA)) DFDXB = DELF/ABS(DA) YPNORM = HVNRM(YP,NEQ) FBND = MAX(HVNRM(SPY,NEQ),YPNORM) ! !....................................................................... ! ! COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ CONSTANT FOR ! THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS ALSO REPRESENTS AN ! ESTIMATE OF THE NORM OF THE JACOBIAN LOCALLY. ! THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO ESTIMATE THE ! LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. THE FIRST ! PERTURBATION VECTOR IS BASED ON THE INITIAL DERIVATIVES AND ! DIRECTION OF INTEGRATION. THE SECOND PERTURBATION VECTOR IS ! FORMED USING ANOTHER EVALUATION OF THE DIFFERENTIAL EQUATION. ! THE THIRD PERTURBATION VECTOR IS FORMED USING PERTURBATIONS BASED ! ONLY ON THE INITIAL VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS ! CHANGED TO NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN ! INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT COMPONENTS ! OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE CONSISTENT WITH ! THE SLOPES OF LOCAL SOLUTION CURVES. ! ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST DERIVATIVE. ! NO ATTEMPT IS MADE TO KEEP THE PERTURBATION VECTOR SIZE CONSTANT. ! if (YPNORM == 0.) go to 60 ! USE INITIAL DERIVATIVES FOR FIRST PERTURBATION ICASE = 1 DO 50 J=1,NEQ SPY(J) = YPRIME(J) 50 YP(J) = YPRIME(J) go to 80 ! CANNOT HAVE A NULL PERTURBATION VECTOR 60 ICASE = 2 DO 70 J=1,NEQ SPY(J) = YPRIME(J) 70 YP(J) = ETOL(J) ! 80 DFDUB = 0. LK = MIN(NEQ+1,3) DO 260 K=1,LK ! SET YPNORM AND DELX YPNORM = HVNRM(YP,NEQ) if (ICASE == 1 .OR. ICASE == 3) go to 90 DELX = SIGN(1.0,DX) go to 120 ! TRY TO ENFORCE MEANINGFUL PERTURBATION VALUES 90 DELX = DX if (ABS(DELX)*YPNORM >= RELPER*YNORM) go to 100 DELXB = BIG if (RELPER*YNORM < BIG*YPNORM) DELXB = RELPER*YNORM/YPNORM DELX = SIGN(DELXB,DX) 100 DO 110 J=1,NEQ if (ABS(DELX*YP(J)) > ETOL(J)) DELX=SIGN(ETOL(J)/YP(J),DX) 110 CONTINUE ! DEFINE PERTURBED VECTOR OF INITIAL VALUES 120 DO 130 J=1,NEQ 130 PV(J) = Y(J) + DELX*YP(J) if (K == 2) go to 150 ! EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED ! VECTOR AND COMPUTE CORRESPONDING DIFFERENCES call F(A,PV,YP,RPAR,IPAR) DO 140 J=1,NEQ 140 PV(J) = YP(J) - YPRIME(J) go to 170 ! USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE ! IN COMPUTING ONE ESTIMATE 150 call F(A+DA,PV,YP,RPAR,IPAR) DO 160 J=1,NEQ 160 PV(J) = YP(J) - SF(J) ! CHOOSE LARGEST BOUND ON THE WEIGHTED FIRST ! DERIVATIVE 170 if (MORDER == 1) go to 190 DO 180 J=1,NEQ 180 YP(J) = YP(J)/ETOL(J)**POWER go to 210 190 DO 200 J=1,NEQ 200 YP(J) = YP(J)/ETOL(J) 210 FBND = MAX(FBND,HVNRM(YP,NEQ)) ! COMPUTE BOUND ON A LOCAL LIPSCHITZ CONSTANT DELF = HVNRM(PV,NEQ) if (DELF == 0.) go to 220 DELY = ABS(DELX)*YPNORM if (DELF >= BIG*DELY) go to 270 DFDUB = MAX(DFDUB,DELF/DELY) ! 220 if (K == LK) go to 280 ! CHOOSE NEXT PERTURBATION VECTOR DO 250 J=1,NEQ if (K == LK-1) go to 230 ICASE = 3 DY = ABS(PV(J)) if (DY == 0.) DY = MAX(DELF,ETOL(J)) go to 240 230 ICASE = 4 DY = MAX(RELPER*ABS(Y(J)),ETOL(J)) 240 if (SPY(J) == 0.) SPY(J) = YP(J) if (SPY(J) /= 0.) DY = SIGN(DY,SPY(J)) 250 YP(J) = DY 260 CONTINUE ! ! PROTECT AGAINST AN OVERFLOW 270 DFDUB = BIG ! !....................................................................... ! ! COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE ! 280 YDPB = DFDXB + DFDUB*FBND ! !....................................................................... ! ! COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND SECOND ! DERIVATIVE INFORMATION ! ! RESTRICT THE STEP LENGTH TO BE NOT BIGGER THAN ! ABS(B-A). (UNLESS B IS TOO CLOSE TO A) H = ABSDX ! if (YDPB /= 0. .OR. FBND /= 0.) go to 290 ! ! BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND ! DERIVATIVE TERM (YDPB) ARE ZERO go to 310 ! 290 if (YDPB /= 0.) go to 300 ! ! ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO if (1.0 < FBND*ABSDX) H = 1./FBND go to 310 ! ! SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO 300 SRYDPB = SQRT(0.5*YDPB) if (1.0 < SRYDPB*ABSDX) H = 1./SRYDPB ! ! FURTHER RESTRICT THE STEP LENGTH TO BE NOT ! BIGGER THAN 1/DFDUB 310 if (H*DFDUB > 1.) H = 1./DFDUB ! ! FINALLY, RESTRICT THE STEP LENGTH TO BE NOT ! SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF ! A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, ! THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE ! STEP LENGTH. H = MAX(H,100.*SMALL*ABS(A)) if (H == 0.) H = SMALL*ABS(B) ! ! NOW SET DIRECTION OF INTEGRATION H = SIGN(H,DX) ! return end subroutine HSTCRT (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, & BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) ! !! HSTCRT solves the standard five-point finite difference ... ! approximation on a staggered grid to the Helmholtz equation ! in Cartesian coordinates. !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HSTCRT-S) !***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! HSTCRT solves the standard five-point finite difference ! approximation on a staggered grid to the Helmholtz equation in ! Cartesian coordinates ! ! (d/dX)(dU/dX) + (d/dY)(dU/dY) + LAMBDA*U = F(X,Y) ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! A,B ! The range of X, i.e. A <= X <= B. A must be less than B. ! ! M ! The number of grid points in the interval (A,B). The grid points ! in the X-direction are given by X(I) = A + (I-0.5)dX for ! I=1,2,...,M where dX =(B-A)/M. M must be greater than 2. ! ! MBDCND ! Indicates the type of boundary conditions at X = A and X = B. ! ! = 0 If the solution is periodic in X, ! U(M+I,J) = U(I,J). ! ! = 1 If the solution is specified at X = A and X = B. ! ! = 2 If the solution is specified at X = A and the derivative ! of the solution with respect to X is specified at X = B. ! ! = 3 If the derivative of the solution with respect to X is ! specified at X = A and X = B. ! ! = 4 If the derivative of the solution with respect to X is ! specified at X = A and the solution is specified at X = B. ! ! BDA ! A one-dimensional array of length N that specifies the boundary ! values (if any) of the solution at X = A. When MBDCND = 1 or 2, ! ! BDA(J) = U(A,Y(J)) , J=1,2,...,N. ! ! When MBDCND = 3 or 4, ! ! BDA(J) = (d/dX)U(A,Y(J)) , J=1,2,...,N. ! ! BDB ! A one-dimensional array of length N that specifies the boundary ! values of the solution at X = B. When MBDCND = 1 or 4 ! ! BDB(J) = U(B,Y(J)) , J=1,2,...,N. ! ! When MBDCND = 2 or 3 ! ! BDB(J) = (d/dX)U(B,Y(J)) , J=1,2,...,N. ! ! C,D ! The range of Y, i.e. C <= Y <= D. C must be less ! than D. ! ! N ! The number of unknowns in the interval (C,D). The unknowns in ! the Y-direction are given by Y(J) = C + (J-0.5)DY, ! J=1,2,...,N, where DY = (D-C)/N. N must be greater than 2. ! ! NBDCND ! Indicates the type of boundary conditions at Y = C ! and Y = D. ! ! = 0 If the solution is periodic in Y, i.e. ! U(I,J) = U(I,N+J). ! ! = 1 If the solution is specified at Y = C and Y = D. ! ! = 2 If the solution is specified at Y = C and the derivative ! of the solution with respect to Y is specified at Y = D. ! ! = 3 If the derivative of the solution with respect to Y is ! specified at Y = C and Y = D. ! ! = 4 If the derivative of the solution with respect to Y is ! specified at Y = C and the solution is specified at Y = D. ! ! BDC ! A one dimensional array of length M that specifies the boundary ! values of the solution at Y = C. When NBDCND = 1 or 2, ! ! BDC(I) = U(X(I),C) , I=1,2,...,M. ! ! When NBDCND = 3 or 4, ! ! BDC(I) = (d/dY)U(X(I),C), I=1,2,...,M. ! ! When NBDCND = 0, BDC is a dummy variable. ! ! BDD ! A one-dimensional array of length M that specifies the boundary ! values of the solution at Y = D. When NBDCND = 1 or 4, ! ! BDD(I) = U(X(I),D) , I=1,2,...,M. ! ! When NBDCND = 2 or 3, ! ! BDD(I) = (d/dY)U(X(I),D) , I=1,2,...,M. ! ! When NBDCND = 0, BDD is a dummy variable. ! ! ELMBDA ! The constant LAMBDA in the Helmholtz equation. If LAMBDA is ! greater than 0, a solution may not exist. However, HSTCRT will ! attempt to find a solution. ! ! F ! A two-dimensional array that specifies the values of the right ! side of the Helmholtz equation. For I=1,2,...,M and J=1,2,...,N ! ! F(I,J) = F(X(I),Y(J)) . ! ! F must be dimensioned at least M X N. ! ! IDIMF ! The row (or first) dimension of the array F as it appears in the ! program calling HSTCRT. This parameter is used to specify the ! variable dimension of F. IDIMF must be at least M. ! ! W ! A one-dimensional array that must be provided by the user for ! work space. W may require up to 13M + 4N + M*INT(log2(N)) ! locations. The actual number of locations used is computed by ! HSTCRT and is returned in the location W(1). ! ! ! * * * * * * On Output * * * * * * ! ! F ! Contains the solution U(I,J) of the finite difference ! approximation for the grid point (X(I),Y(J)) for ! I=1,2,...,M, J=1,2,...,N. ! ! PERTRB ! If a combination of periodic or derivative boundary conditions is ! specified for a Poisson equation (LAMBDA = 0), a solution may not ! exist. PERTRB is a constant, calculated and subtracted from F, ! which ensures that a solution exists. HSTCRT then computes this ! solution, which is a least squares solution to the original ! approximation. This solution plus any constant is also a ! solution; hence, the solution is not unique. The value of PERTRB ! should be small compared to the right side F. Otherwise, a ! solution is obtained to an essentially different problem. This ! comparison should always be made to insure that a meaningful ! solution has been obtained. ! ! IERROR ! An error flag that indicates invalid input parameters. ! Except for numbers 0 and 6, a solution is not attempted. ! ! = 0 No error ! ! = 1 A >= B ! ! = 2 MBDCND < 0 or MBDCND > 4 ! ! = 3 C >= D ! ! = 4 N <= 2 ! ! = 5 NBDCND < 0 or NBDCND > 4 ! ! = 6 LAMBDA > 0 ! ! = 7 IDIMF < M ! ! = 8 M <= 2 ! ! Since this is the only means of indicating a possibly ! incorrect call to HSTCRT, the user should test IERROR after ! the call. ! ! W ! W(1) contains the required length of W. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N), ! Arguments W(See argument list) ! ! Latest June 1, 1977 ! Revision ! ! Subprograms HSTCRT,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2, ! Required COSGEN,MERGE,TRIX,TRI3,PIMACH ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Written by Roland Sweet at NCAR in January , 1977 ! ! Algorithm This subroutine defines the finite-difference ! equations, incorporates boundary data, adjusts the ! right side when the system is singular and calls ! either POISTG or GENBUN which solves the linear ! system of equations. ! ! Space 8131(decimal) = 17703(octal) locations on the ! Required NCAR Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine HSTCRT is roughly proportional ! to M*N*log2(N). Some typical values are listed in ! the table below. ! The solution process employed results in a loss ! of no more than FOUR significant digits for N and M ! as large as 64. More detailed information about ! accuracy can be found in the documentation for ! subroutine POISTG which is the routine that ! actually solves the finite difference equations. ! ! ! M(=N) MBDCND NBDCND T(MSECS) ! ----- ------ ------ -------- ! ! 32 1-4 1-4 56 ! 64 1-4 1-4 230 ! ! Portability American National Standards Institute Fortran. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS ! Resident ! Routines ! ! Reference Schumann, U. and R. Sweet,'A Direct Method For ! The Solution Of Poisson's Equation With Neumann ! Boundary Conditions On A Staggered Grid Of ! Arbitrary Size,' J. COMP. PHYS. 20(1976), ! PP. 171-182. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES U. Schumann and R. Sweet, A direct method for the ! solution of Poisson's equation with Neumann boundary ! conditions on a staggered grid of arbitrary size, ! Journal of Computational Physics 20, (1976), ! pp. 171-182. !***ROUTINES CALLED GENBUN, POISTG !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HSTCRT ! ! DIMENSION F(IDIMF,*) ,BDA(*) ,BDB(*) ,BDC(*) , & BDD(*) ,W(*) !***FIRST EXECUTABLE STATEMENT HSTCRT IERROR = 0 if (A >= B) IERROR = 1 if (MBDCND < 0 .OR. MBDCND > 4) IERROR = 2 if (C >= D) IERROR = 3 if (N <= 2) IERROR = 4 if (NBDCND < 0 .OR. NBDCND > 4) IERROR = 5 if (IDIMF < M) IERROR = 7 if (M <= 2) IERROR = 8 if (IERROR /= 0) RETURN NPEROD = NBDCND MPEROD = 0 if (MBDCND > 0) MPEROD = 1 DELTAX = (B-A)/M TWDELX = 1./DELTAX DELXSQ = 2./DELTAX**2 DELTAY = (D-C)/N TWDELY = 1./DELTAY DELYSQ = DELTAY**2 TWDYSQ = 2./DELYSQ NP = NBDCND+1 MP = MBDCND+1 ! ! DEFINE THE A,B,C COEFFICIENTS IN W-ARRAY. ! ID2 = M ID3 = ID2+M ID4 = ID3+M S = (DELTAY/DELTAX)**2 ST2 = 2.*S DO 101 I=1,M W(I) = S J = ID2+I W(J) = -ST2+ELMBDA*DELYSQ J = ID3+I W(J) = S 101 CONTINUE ! ! ENTER BOUNDARY DATA FOR X-BOUNDARIES. ! go to (111,102,102,104,104),MP 102 DO 103 J=1,N F(1,J) = F(1,J)-BDA(J)*DELXSQ 103 CONTINUE W(ID2+1) = W(ID2+1)-W(1) go to 106 104 DO 105 J=1,N F(1,J) = F(1,J)+BDA(J)*TWDELX 105 CONTINUE W(ID2+1) = W(ID2+1)+W(1) 106 go to (111,107,109,109,107),MP 107 DO 108 J=1,N F(M,J) = F(M,J)-BDB(J)*DELXSQ 108 CONTINUE W(ID3) = W(ID3)-W(1) go to 111 109 DO 110 J=1,N F(M,J) = F(M,J)-BDB(J)*TWDELX 110 CONTINUE W(ID3) = W(ID3)+W(1) 111 CONTINUE ! ! ENTER BOUNDARY DATA FOR Y-BOUNDARIES. ! go to (121,112,112,114,114),NP 112 DO 113 I=1,M F(I,1) = F(I,1)-BDC(I)*TWDYSQ 113 CONTINUE go to 116 114 DO 115 I=1,M F(I,1) = F(I,1)+BDC(I)*TWDELY 115 CONTINUE 116 go to (121,117,119,119,117),NP 117 DO 118 I=1,M F(I,N) = F(I,N)-BDD(I)*TWDYSQ 118 CONTINUE go to 121 119 DO 120 I=1,M F(I,N) = F(I,N)-BDD(I)*TWDELY 120 CONTINUE 121 CONTINUE DO 123 I=1,M DO 122 J=1,N F(I,J) = F(I,J)*DELYSQ 122 CONTINUE 123 CONTINUE if (MPEROD == 0) go to 124 W(1) = 0. W(ID4) = 0. 124 CONTINUE PERTRB = 0. if (ELMBDA) 133,126,125 125 IERROR = 6 go to 133 126 go to (127,133,133,127,133),MP 127 go to (128,133,133,128,133),NP ! ! FOR SINGULAR PROBLEMS MUST ADJUST DATA TO INSURE THAT A SOLUTION ! WILL EXIST. ! 128 CONTINUE S = 0. DO 130 J=1,N DO 129 I=1,M S = S+F(I,J) 129 CONTINUE 130 CONTINUE PERTRB = S/(M*N) DO 132 J=1,N DO 131 I=1,M F(I,J) = F(I,J)-PERTRB 131 CONTINUE 132 CONTINUE PERTRB = PERTRB/DELYSQ ! ! SOLVE THE EQUATION. ! 133 CONTINUE if (NPEROD == 0) go to 134 call POISTG (NPEROD,N,MPEROD,M,W(1),W(ID2+1),W(ID3+1),IDIMF,F, & IERR1,W(ID4+1)) go to 135 134 CONTINUE call GENBUN (NPEROD,N,MPEROD,M,W(1),W(ID2+1),W(ID3+1),IDIMF,F, & IERR1,W(ID4+1)) 135 CONTINUE W(1) = W(ID4+1)+3*M return end subroutine HSTCS1 (INTL, A, B, M, MBDCND, BDA, BDB, C, D, N, & NBDCND, BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERR1, AM, BM, CM, & AN, BN, CN, SNTH, RSQ, WRK) ! !! HSTCS1 is subsidiary to HSTCSP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (HSTCS1-S) !***AUTHOR (UNKNOWN) !***SEE ALSO HSTCSP !***ROUTINES CALLED BLKTRI !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE HSTCS1 DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , & F(IDIMF,*) ,AM(*) ,BM(*) ,CM(*) , & AN(*) ,BN(*) ,CN(*) ,SNTH(*) , & RSQ(*) ,WRK(*) !***FIRST EXECUTABLE STATEMENT HSTCS1 DTH = (B-A)/M DTHSQ = DTH*DTH DO 101 I=1,M SNTH(I) = SIN(A+(I-0.5)*DTH) 101 CONTINUE DR = (D-C)/N DO 102 J=1,N RSQ(J) = (C+(J-0.5)*DR)**2 102 CONTINUE ! ! MULTIPLY RIGHT SIDE BY R(J)**2 ! DO 104 J=1,N X = RSQ(J) DO 103 I=1,M F(I,J) = X*F(I,J) 103 CONTINUE 104 CONTINUE ! ! DEFINE COEFFICIENTS AM,BM,CM ! X = 1./(2.*COS(DTH/2.)) DO 105 I=2,M AM(I) = (SNTH(I-1)+SNTH(I))*X CM(I-1) = AM(I) 105 CONTINUE AM(1) = SIN(A) CM(M) = SIN(B) DO 106 I=1,M X = 1./SNTH(I) Y = X/DTHSQ AM(I) = AM(I)*Y CM(I) = CM(I)*Y BM(I) = ELMBDA*X*X-AM(I)-CM(I) 106 CONTINUE ! ! DEFINE COEFFICIENTS AN,BN,CN ! X = C/DR DO 107 J=1,N AN(J) = (X+J-1)**2 CN(J) = (X+J)**2 BN(J) = -(AN(J)+CN(J)) 107 CONTINUE ISW = 1 NB = NBDCND if (C == 0. .AND. NB == 2) NB = 6 ! ! ENTER DATA ON THETA BOUNDARIES ! go to (108,108,110,110,112,112,108,110,112),MBDCND 108 BM(1) = BM(1)-AM(1) X = 2.*AM(1) DO 109 J=1,N F(1,J) = F(1,J)-X*BDA(J) 109 CONTINUE go to 112 110 BM(1) = BM(1)+AM(1) X = DTH*AM(1) DO 111 J=1,N F(1,J) = F(1,J)+X*BDA(J) 111 CONTINUE 112 CONTINUE go to (113,115,115,113,113,115,117,117,117),MBDCND 113 BM(M) = BM(M)-CM(M) X = 2.*CM(M) DO 114 J=1,N F(M,J) = F(M,J)-X*BDB(J) 114 CONTINUE go to 117 115 BM(M) = BM(M)+CM(M) X = DTH*CM(M) DO 116 J=1,N F(M,J) = F(M,J)-X*BDB(J) 116 CONTINUE 117 CONTINUE ! ! ENTER DATA ON R BOUNDARIES ! go to (118,118,120,120,122,122),NB 118 BN(1) = BN(1)-AN(1) X = 2.*AN(1) DO 119 I=1,M F(I,1) = F(I,1)-X*BDC(I) 119 CONTINUE go to 122 120 BN(1) = BN(1)+AN(1) X = DR*AN(1) DO 121 I=1,M F(I,1) = F(I,1)+X*BDC(I) 121 CONTINUE 122 CONTINUE go to (123,125,125,123,123,125),NB 123 BN(N) = BN(N)-CN(N) X = 2.*CN(N) DO 124 I=1,M F(I,N) = F(I,N)-X*BDD(I) 124 CONTINUE go to 127 125 BN(N) = BN(N)+CN(N) X = DR*CN(N) DO 126 I=1,M F(I,N) = F(I,N)-X*BDD(I) 126 CONTINUE 127 CONTINUE ! ! CHECK FOR SINGULAR PROBLEM. if SINGULAR, PERTURB F. ! PERTRB = 0. go to (137,137,128,137,137,128,137,128,128),MBDCND 128 go to (137,137,129,137,137,129),NB 129 if (ELMBDA) 137,131,130 130 IERR1 = 10 go to 137 131 CONTINUE ISW = 2 DO 133 I=1,M X = 0. DO 132 J=1,N X = X+F(I,J) 132 CONTINUE PERTRB = PERTRB+X*SNTH(I) 133 CONTINUE X = 0. DO 134 J=1,N X = X+RSQ(J) 134 CONTINUE PERTRB = 2.*(PERTRB*SIN(DTH/2.))/(X*(COS(A)-COS(B))) DO 136 J=1,N X = RSQ(J)*PERTRB DO 135 I=1,M F(I,J) = F(I,J)-X 135 CONTINUE 136 CONTINUE 137 CONTINUE A2 = 0. DO 138 I=1,M A2 = A2+F(I,1) 138 CONTINUE A2 = A2/RSQ(1) ! ! INITIALIZE BLKTRI ! if (INTL /= 0) go to 139 call BLKTRI (0,1,N,AN,BN,CN,1,M,AM,BM,CM,IDIMF,F,IERR1,WRK) 139 CONTINUE ! ! call BLKTRI TO SOLVE SYSTEM OF EQUATIONS. ! call BLKTRI (1,1,N,AN,BN,CN,1,M,AM,BM,CM,IDIMF,F,IERR1,WRK) if (ISW /= 2 .OR. C /= 0. .OR. NBDCND /= 2) go to 143 A1 = 0. A3 = 0. DO 140 I=1,M A1 = A1+SNTH(I)*F(I,1) A3 = A3+SNTH(I) 140 CONTINUE A1 = A1+RSQ(1)*A2/2. if (MBDCND == 3) & A1 = A1+(SIN(B)*BDB(1)-SIN(A)*BDA(1))/(2.*(B-A)) A1 = A1/A3 A1 = BDC(1)-A1 DO 142 I=1,M DO 141 J=1,N F(I,J) = F(I,J)+A1 141 CONTINUE 142 CONTINUE 143 CONTINUE return end subroutine HSTCSP (INTL, A, B, M, MBDCND, BDA, BDB, C, D, N, & NBDCND, BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) ! !! HSTCSP solves the standard five-point finite difference ... ! approximation on a staggered grid to the modified Helmholtz ! equation in spherical coordinates assuming axisymmetry ! (no dependence on longitude). !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HSTCSP-S) !***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! HSTCSP solves the standard five-point finite difference ! approximation on a staggered grid to the modified Helmholtz ! equation spherical coordinates assuming axisymmetry (no dependence ! on longitude). ! ! (1/R**2)(d/dR)(R**2(dU/dR)) + ! ! 1/(R**2*SIN(THETA))(d/dTHETA)(SIN(THETA)(dU/dTHETA)) + ! ! (LAMBDA/(R*SIN(THETA))**2)U = F(THETA,R) ! ! where THETA is colatitude and R is the radial coordinate. ! This two-dimensional modified Helmholtz equation results from ! the Fourier transform of the three-dimensional Poisson equation. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! ! * * * * * * On Input * * * * * * ! ! INTL ! = 0 On initial entry to HSTCSP or if any of the arguments ! C, D, N, or NBDCND are changed from a previous call. ! ! = 1 If C, D, N, and NBDCND are all unchanged from previous ! call to HSTCSP. ! ! NOTE: A call with INTL = 0 takes approximately 1.5 times as much ! time as a call with INTL = 1. Once a call with INTL = 0 ! has been made then subsequent solutions corresponding to ! different F, BDA, BDB, BDC, and BDD can be obtained ! faster with INTL = 1 since initialization is not repeated. ! ! A,B ! The range of THETA (colatitude), i.e. A <= THETA <= B. A ! must be less than B and A must be non-negative. A and B are in ! radians. A = 0 corresponds to the north pole and B = PI ! corresponds to the south pole. ! ! * * * IMPORTANT * * * ! ! If B is equal to PI, then B must be computed using the statement ! ! B = PIMACH(DUM) ! ! This insures that B in the user's program is equal to PI in this ! program which permits several tests of the input parameters that ! otherwise would not be possible. ! ! * * * * * * * * * * * * ! ! M ! The number of grid points in the interval (A,B). The grid points ! in the THETA-direction are given by THETA(I) = A + (I-0.5)DTHETA ! for I=1,2,...,M where DTHETA =(B-A)/M. M must be greater than 4. ! ! MBDCND ! Indicates the type of boundary conditions at THETA = A and ! THETA = B. ! ! = 1 If the solution is specified at THETA = A and THETA = B. ! (See notes 1, 2 below) ! ! = 2 If the solution is specified at THETA = A and the derivative ! of the solution with respect to THETA is specified at ! THETA = B (See notes 1, 2 below). ! ! = 3 If the derivative of the solution with respect to THETA is ! specified at THETA = A (See notes 1, 2 below) and THETA = B. ! ! = 4 If the derivative of the solution with respect to THETA is ! specified at THETA = A (See notes 1, 2 below) and the ! solution is specified at THETA = B. ! ! = 5 If the solution is unspecified at THETA = A = 0 and the ! solution is specified at THETA = B. (See note 2 below) ! ! = 6 If the solution is unspecified at THETA = A = 0 and the ! derivative of the solution with respect to THETA is ! specified at THETA = B (See note 2 below). ! ! = 7 If the solution is specified at THETA = A and the ! solution is unspecified at THETA = B = PI. ! ! = 8 If the derivative of the solution with respect to ! THETA is specified at THETA = A (See note 1 below) ! and the solution is unspecified at THETA = B = PI. ! ! = 9 If the solution is unspecified at THETA = A = 0 and ! THETA = B = PI. ! ! NOTES: 1. If A = 0, do not use MBDCND = 1,2,3,4,7 or 8, ! but instead use MBDCND = 5, 6, or 9. ! ! 2. if B = PI, do not use MBDCND = 1,2,3,4,5 or 6, ! but instead use MBDCND = 7, 8, or 9. ! ! When A = 0 and/or B = PI the only meaningful boundary ! condition is dU/dTHETA = 0. (See D. Greenspan, 'Numerical ! Analysis of Elliptic Boundary Value Problems,' Harper and ! Row, 1965, Chapter 5.) ! ! BDA ! A one-dimensional array of length N that specifies the boundary ! values (if any) of the solution at THETA = A. When ! MBDCND = 1, 2, or 7, ! ! BDA(J) = U(A,R(J)) , J=1,2,...,N. ! ! When MBDCND = 3, 4, or 8, ! ! BDA(J) = (d/dTHETA)U(A,R(J)) , J=1,2,...,N. ! ! When MBDCND has any other value, BDA is a dummy variable. ! ! BDB ! A one-dimensional array of length N that specifies the boundary ! values of the solution at THETA = B. When MBDCND = 1, 4, or 5, ! ! BDB(J) = U(B,R(J)) , J=1,2,...,N. ! ! When MBDCND = 2,3, or 6, ! ! BDB(J) = (d/dTHETA)U(B,R(J)) , J=1,2,...,N. ! ! When MBDCND has any other value, BDB is a dummy variable. ! ! C,D ! The range of R , i.e. C <= R <= D. ! C must be less than D. C must be non-negative. ! ! N ! The number of unknowns in the interval (C,D). The unknowns in ! the R-direction are given by R(J) = C + (J-0.5)DR, ! J=1,2,...,N, where DR = (D-C)/N. N must be greater than 4. ! ! NBDCND ! Indicates the type of boundary conditions at R = C ! and R = D. ! ! = 1 If the solution is specified at R = C and R = D. ! ! = 2 If the solution is specified at R = C and the derivative ! of the solution with respect to R is specified at ! R = D. (See note 1 below) ! ! = 3 If the derivative of the solution with respect to R is ! specified at R = C and R = D. ! ! = 4 If the derivative of the solution with respect to R is ! specified at R = C and the solution is specified at ! R = D. ! ! = 5 If the solution is unspecified at R = C = 0 (See note 2 ! below) and the solution is specified at R = D. ! ! = 6 If the solution is unspecified at R = C = 0 (See note 2 ! below) and the derivative of the solution with respect to R ! is specified at R = D. ! ! NOTE 1: If C = 0 and MBDCND = 3,6,8 or 9, the system of equations ! to be solved is singular. The unique solution is ! determined by extrapolation to the specification of ! U(THETA(1),C). But in these cases the right side of the ! system will be perturbed by the constant PERTRB. ! ! NOTE 2: NBDCND = 5 or 6 cannot be used with MBDCND = 1, 2, 4, 5, ! or 7 (the former indicates that the solution is ! unspecified at R = 0; the latter indicates that the ! solution is specified). Use instead NBDCND = 1 or 2. ! ! BDC ! A one dimensional array of length M that specifies the boundary ! values of the solution at R = C. When NBDCND = 1 or 2, ! ! BDC(I) = U(THETA(I),C) , I=1,2,...,M. ! ! When NBDCND = 3 or 4, ! ! BDC(I) = (d/dR)U(THETA(I),C), I=1,2,...,M. ! ! When NBDCND has any other value, BDC is a dummy variable. ! ! BDD ! A one-dimensional array of length M that specifies the boundary ! values of the solution at R = D. When NBDCND = 1 or 4, ! ! BDD(I) = U(THETA(I),D) , I=1,2,...,M. ! ! When NBDCND = 2 or 3, ! ! BDD(I) = (d/dR)U(THETA(I),D) , I=1,2,...,M. ! ! When NBDCND has any other value, BDD is a dummy variable. ! ! ELMBDA ! The constant LAMBDA in the modified Helmholtz equation. If ! LAMBDA is greater than 0, a solution may not exist. However, ! HSTCSP will attempt to find a solution. ! ! F ! A two-dimensional array that specifies the values of the right ! side of the modified Helmholtz equation. For I=1,2,...,M and ! J=1,2,...,N ! ! F(I,J) = F(THETA(I),R(J)) . ! ! F must be dimensioned at least M X N. ! ! IDIMF ! The row (or first) dimension of the array F as it appears in the ! program calling HSTCSP. This parameter is used to specify the ! variable dimension of F. IDIMF must be at least M. ! ! W ! A one-dimensional array that must be provided by the user for ! work space. With K = INT(log2(N))+1 and L = 2**(K+1), W may ! require up to (K-2)*L+K+MAX(2N,6M)+4(N+M)+5 locations. The ! actual number of locations used is computed by HSTCSP and is ! returned in the location W(1). ! ! ! * * * * * * On Output * * * * * * ! ! F ! Contains the solution U(I,J) of the finite difference ! approximation for the grid point (THETA(I),R(J)) for ! I=1,2,...,M, J=1,2,...,N. ! ! PERTRB ! If a combination of periodic, derivative, or unspecified ! boundary conditions is specified for a Poisson equation ! (LAMBDA = 0), a solution may not exist. PERTRB is a con- ! stant, calculated and subtracted from F, which ensures ! that a solution exists. HSTCSP then computes this ! solution, which is a least squares solution to the ! original approximation. This solution plus any constant is also ! a solution; hence, the solution is not unique. The value of ! PERTRB should be small compared to the right side F. ! Otherwise, a solution is obtained to an essentially different ! problem. This comparison should always be made to insure that ! a meaningful solution has been obtained. ! ! IERROR ! An error flag that indicates invalid input parameters. ! Except for numbers 0 and 10, a solution is not attempted. ! ! = 0 No error ! ! = 1 A < 0 or B > PI ! ! = 2 A >= B ! ! = 3 MBDCND < 1 or MBDCND > 9 ! ! = 4 C < 0 ! ! = 5 C >= D ! ! = 6 NBDCND < 1 or NBDCND > 6 ! ! = 7 N < 5 ! ! = 8 NBDCND = 5 or 6 and MBDCND = 1, 2, 4, 5, or 7 ! ! = 9 C > 0 and NBDCND >= 5 ! ! = 10 ELMBDA > 0 ! ! = 11 IDIMF < M ! ! = 12 M < 5 ! ! = 13 A = 0 and MBDCND =1,2,3,4,7 or 8 ! ! = 14 B = PI and MBDCND <= 6 ! ! = 15 A > 0 and MBDCND = 5, 6, or 9 ! ! = 16 B < PI and MBDCND >= 7 ! ! = 17 LAMBDA /= 0 and NBDCND >= 5 ! ! Since this is the only means of indicating a possibly ! incorrect call to HSTCSP, the user should test IERROR after ! the call. ! ! W ! W(1) contains the required length of W. Also W contains ! intermediate values that must not be destroyed if HSTCSP ! will be called again with INTL = 1. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N), ! Arguments W(See argument list) ! ! Latest June 1979 ! Revision ! ! Subprograms HSTCSP,HSTCS1,BLKTRI,BLKTR1,INDXA,INDXB,INDXC, ! Required PROD,PRODP,CPROD,CPRODP,PPADD,PSGF,BSRH,PPSGF, ! PPSPF,COMPB,TEVLS,R1MACH ! ! Special NONE ! Conditions ! ! Common CBLKT ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Written by Roland Sweet at NCAR in May, 1977 ! ! Algorithm This subroutine defines the finite-difference ! equations, incorporates boundary data, adjusts the ! right side when the system is singular and calls ! BLKTRI which solves the linear system of equations. ! ! Space 5269(decimal) = 12225(octal) locations on the ! Required NCAR Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine HSTCSP is roughly proportional ! to M*N*log2(N), but depends on the input parameter ! INTL. Some values are listed in the table below. ! The solution process employed results in a loss ! of no more than FOUR significant digits for N and M ! as large as 64. More detailed information about ! accuracy can be found in the documentation for ! subroutine BLKTRI which is the routine that ! actually solves the finite difference equations. ! ! ! M(=N) INTL MBDCND(=NBDCND) T(MSECS) ! ----- ---- --------------- -------- ! ! 32 0 1-6 132 ! 32 1 1-6 88 ! 64 0 1-6 546 ! 64 1 1-6 380 ! ! Portability American National Standards Institute Fortran. ! The machine accuracy is set using function R1MACH. ! ! Required COS,SIN,ABS,SQRT ! Resident ! Routines ! ! Reference Swarztrauber, P.N., 'A Direct Method For The ! Discrete Solution Of Separable Elliptic Equations,' ! SIAM J. Numer. Anal. 11(1974), pp. 1136-1150. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran ! subprograms for the solution of elliptic equations, ! NCAR TN/IA-109, July 1975, 138 pp. ! P. N. Swarztrauber, A direct method for the discrete ! solution of separable elliptic equations, SIAM Journal ! on Numerical Analysis 11, (1974), pp. 1136-1150. !***ROUTINES CALLED HSTCS1, PIMACH !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HSTCSP ! ! DIMENSION F(IDIMF,*) ,BDA(*) ,BDB(*) ,BDC(*) , & BDD(*) ,W(*) !***FIRST EXECUTABLE STATEMENT HSTCSP PI = PIMACH(DUM) ! ! CHECK FOR INVALID INPUT PARAMETERS ! IERROR = 0 if (A < 0. .OR. B > PI) IERROR = 1 if (A >= B) IERROR = 2 if (MBDCND < 1 .OR. MBDCND > 9) IERROR = 3 if (C < 0.) IERROR = 4 if (C >= D) IERROR = 5 if (NBDCND < 1 .OR. NBDCND > 6) IERROR = 6 if (N < 5) IERROR = 7 if ((NBDCND == 5 .OR. NBDCND == 6) .AND. (MBDCND == 1 .OR. & MBDCND == 2 .OR. MBDCND == 4 .OR. MBDCND == 5 .OR. & MBDCND == 7)) & IERROR = 8 if (C > 0. .AND. NBDCND >= 5) IERROR = 9 if (IDIMF < M) IERROR = 11 if (M < 5) IERROR = 12 if (A == 0. .AND. MBDCND /= 5 .AND. MBDCND /= 6 .AND. MBDCND /= 9) & IERROR = 13 if (B == PI .AND. MBDCND <= 6) IERROR = 14 if (A > 0. .AND. (MBDCND == 5 .OR. MBDCND == 6 .OR. MBDCND == 9)) & IERROR = 15 if (B < PI .AND. MBDCND >= 7) IERROR = 16 if (ELMBDA /= 0. .AND. NBDCND >= 5) IERROR = 17 if (IERROR /= 0) go to 101 IWBM = M+1 IWCM = IWBM+M IWAN = IWCM+M IWBN = IWAN+N IWCN = IWBN+N IWSNTH = IWCN+N IWRSQ = IWSNTH+M IWWRK = IWRSQ+N IERR1 = 0 call HSTCS1 (INTL,A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD, & ELMBDA,F,IDIMF,PERTRB,IERR1,W,W(IWBM),W(IWCM), & W(IWAN),W(IWBN),W(IWCN),W(IWSNTH),W(IWRSQ),W(IWWRK)) W(1) = W(IWWRK)+IWWRK-1 IERROR = IERR1 101 CONTINUE return end subroutine HSTCYL (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, & BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) ! !! HSTCYL solves the standard five-point finite difference ... ! approximation on a staggered grid to the modified ! Helmholtz equation in cylindrical coordinates. !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HSTCYL-S) !***KEYWORDS CYLINDRICAL, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! HSTCYL solves the standard five-point finite difference ! approximation on a staggered grid to the modified Helmholtz ! equation in cylindrical coordinates ! ! (1/R)(d/dR)(R(dU/dR)) + (d/dZ)(dU/dZ)C ! + LAMBDA*(1/R**2)*U = F(R,Z) ! ! This two-dimensional modified Helmholtz equation results ! from the Fourier transform of a three-dimensional Poisson ! equation. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! A,B ! The range of R, i.e. A <= R <= B. A must be less than B and ! A must be non-negative. ! ! M ! The number of grid points in the interval (A,B). The grid points ! in the R-direction are given by R(I) = A + (I-0.5)DR for ! I=1,2,...,M where DR =(B-A)/M. M must be greater than 2. ! ! MBDCND ! Indicates the type of boundary conditions at R = A and R = B. ! ! = 1 If the solution is specified at R = A (see note below) and ! R = B. ! ! = 2 If the solution is specified at R = A (see note below) and ! the derivative of the solution with respect to R is ! specified at R = B. ! ! = 3 If the derivative of the solution with respect to R is ! specified at R = A (see note below) and R = B. ! ! = 4 If the derivative of the solution with respect to R is ! specified at R = A (see note below) and the solution is ! specified at R = B. ! ! = 5 If the solution is unspecified at R = A = 0 and the solution ! is specified at R = B. ! ! = 6 If the solution is unspecified at R = A = 0 and the ! derivative of the solution with respect to R is specified at ! R = B. ! ! NOTE: If A = 0, do not use MBDCND = 1,2,3, or 4, but instead ! use MBDCND = 5 or 6. The resulting approximation gives ! the only meaningful boundary condition, i.e. dU/dR = 0. ! (see D. Greenspan, 'Introductory Numerical Analysis Of ! Elliptic Boundary Value Problems,' Harper and Row, 1965, ! Chapter 5.) ! ! BDA ! A one-dimensional array of length N that specifies the boundary ! values (if any) of the solution at R = A. When MBDCND = 1 or 2, ! ! BDA(J) = U(A,Z(J)) , J=1,2,...,N. ! ! When MBDCND = 3 or 4, ! ! BDA(J) = (d/dR)U(A,Z(J)) , J=1,2,...,N. ! ! When MBDCND = 5 or 6, BDA is a dummy variable. ! ! BDB ! A one-dimensional array of length N that specifies the boundary ! values of the solution at R = B. When MBDCND = 1,4, or 5, ! ! BDB(J) = U(B,Z(J)) , J=1,2,...,N. ! ! When MBDCND = 2,3, or 6, ! ! BDB(J) = (d/dR)U(B,Z(J)) , J=1,2,...,N. ! ! C,D ! The range of Z, i.e. C <= Z <= D. C must be less ! than D. ! ! N ! The number of unknowns in the interval (C,D). The unknowns in ! the Z-direction are given by Z(J) = C + (J-0.5)DZ, ! J=1,2,...,N, where DZ = (D-C)/N. N must be greater than 2. ! ! NBDCND ! Indicates the type of boundary conditions at Z = C ! and Z = D. ! ! = 0 If the solution is periodic in Z, i.e. ! U(I,J) = U(I,N+J). ! ! = 1 If the solution is specified at Z = C and Z = D. ! ! = 2 If the solution is specified at Z = C and the derivative ! of the solution with respect to Z is specified at ! Z = D. ! ! = 3 If the derivative of the solution with respect to Z is ! specified at Z = C and Z = D. ! ! = 4 If the derivative of the solution with respect to Z is ! specified at Z = C and the solution is specified at ! Z = D. ! ! BDC ! A one dimensional array of length M that specifies the boundary ! values of the solution at Z = C. When NBDCND = 1 or 2, ! ! BDC(I) = U(R(I),C) , I=1,2,...,M. ! ! When NBDCND = 3 or 4, ! ! BDC(I) = (d/dZ)U(R(I),C), I=1,2,...,M. ! ! When NBDCND = 0, BDC is a dummy variable. ! ! BDD ! A one-dimensional array of length M that specifies the boundary ! values of the solution at Z = D. when NBDCND = 1 or 4, ! ! BDD(I) = U(R(I),D) , I=1,2,...,M. ! ! When NBDCND = 2 or 3, ! ! BDD(I) = (d/dZ)U(R(I),D) , I=1,2,...,M. ! ! When NBDCND = 0, BDD is a dummy variable. ! ! ELMBDA ! The constant LAMBDA in the modified Helmholtz equation. If ! LAMBDA is greater than 0, a solution may not exist. However, ! HSTCYL will attempt to find a solution. LAMBDA must be zero ! when MBDCND = 5 or 6. ! ! F ! A two-dimensional array that specifies the values of the right ! side of the modified Helmholtz equation. For I=1,2,...,M ! and J=1,2,...,N ! ! F(I,J) = F(R(I),Z(J)) . ! ! F must be dimensioned at least M X N. ! ! IDIMF ! The row (or first) dimension of the array F as it appears in the ! program calling HSTCYL. This parameter is used to specify the ! variable dimension of F. IDIMF must be at least M. ! ! W ! A one-dimensional array that must be provided by the user for ! work space. W may require up to 13M + 4N + M*INT(log2(N)) ! locations. The actual number of locations used is computed by ! HSTCYL and is returned in the location W(1). ! ! ! * * * * * * On Output * * * * * * ! ! F ! Contains the solution U(I,J) of the finite difference ! approximation for the grid point (R(I),Z(J)) for ! I=1,2,...,M, J=1,2,...,N. ! ! PERTRB ! If a combination of periodic, derivative, or unspecified ! boundary conditions is specified for a Poisson equation ! (LAMBDA = 0), a solution may not exist. PERTRB is a con- ! stant, calculated and subtracted from F, which ensures ! that a solution exists. HSTCYL then computes this ! solution, which is a least squares solution to the ! original approximation. This solution plus any constant is also ! a solution; hence, the solution is not unique. The value of ! PERTRB should be small compared to the right side F. ! Otherwise, a solution is obtained to an essentially different ! problem. This comparison should always be made to insure that ! a meaningful solution has been obtained. ! ! IERROR ! An error flag that indicates invalid input parameters. ! Except for numbers 0 and 11, a solution is not attempted. ! ! = 0 No error ! ! = 1 A < 0 ! ! = 2 A >= B ! ! = 3 MBDCND < 1 or MBDCND > 6 ! ! = 4 C >= D ! ! = 5 N <= 2 ! ! = 6 NBDCND < 0 or NBDCND > 4 ! ! = 7 A = 0 and MBDCND = 1,2,3, or 4 ! ! = 8 A > 0 and MBDCND >= 5 ! ! = 9 M <= 2 ! ! = 10 IDIMF < M ! ! = 11 LAMBDA > 0 ! ! = 12 A=0, MBDCND >= 5, ELMBDA /= 0 ! ! Since this is the only means of indicating a possibly ! incorrect call to HSTCYL, the user should test IERROR after ! the call. ! ! W ! W(1) contains the required length of W. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension OF BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N), ! Arguments W(see argument list) ! ! Latest June 1, 1977 ! Revision ! ! Subprograms HSTCYL,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2, ! Required COSGEN,MERGE,TRIX,TRI3,PIMACH ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Written by Roland Sweet at NCAR in March, 1977 ! ! Algorithm This subroutine defines the finite-difference ! equations, incorporates boundary data, adjusts the ! right side when the system is singular and calls ! either POISTG or GENBUN which solves the linear ! system of equations. ! ! Space 8228(decimal) = 20044(octal) locations on the ! Required NCAR Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine HSTCYL is roughly proportional ! to M*N*log2(N). Some typical values are listed in ! the table below. ! The solution process employed results in a loss ! of no more than four significant digits for N and M ! as large as 64. More detailed information about ! accuracy can be found in the documentation for ! subroutine POISTG which is the routine that ! actually solves the finite difference equations. ! ! ! M(=N) MBDCND NBDCND T(MSECS) ! ----- ------ ------ -------- ! ! 32 1-6 1-4 56 ! 64 1-6 1-4 230 ! ! Portability American National Standards Institute Fortran. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS ! Resident ! Routines ! ! Reference Schumann, U. and R. Sweet,'A Direct Method For ! The Solution of Poisson's Equation With Neumann ! Boundary Conditions On A Staggered Grid Of ! Arbitrary Size,' J. Comp. Phys. 20(1976), ! pp. 171-182. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES U. Schumann and R. Sweet, A direct method for the ! solution of Poisson's equation with Neumann boundary ! conditions on a staggered grid of arbitrary size, ! Journal of Computational Physics 20, (1976), ! pp. 171-182. !***ROUTINES CALLED GENBUN, POISTG !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HSTCYL ! ! DIMENSION F(IDIMF,*) ,BDA(*) ,BDB(*) ,BDC(*) , & BDD(*) ,W(*) !***FIRST EXECUTABLE STATEMENT HSTCYL IERROR = 0 if (A < 0.) IERROR = 1 if (A >= B) IERROR = 2 if (MBDCND <= 0 .OR. MBDCND >= 7) IERROR = 3 if (C >= D) IERROR = 4 if (N <= 2) IERROR = 5 if (NBDCND < 0 .OR. NBDCND >= 5) IERROR = 6 if (A == 0. .AND. MBDCND /= 5 .AND. MBDCND /= 6) IERROR = 7 if (A > 0. .AND. MBDCND >= 5) IERROR = 8 if (IDIMF < M) IERROR = 10 if (M <= 2) IERROR = 9 if (A == 0. .AND. MBDCND >= 5 .AND. ELMBDA /= 0.) IERROR = 12 if (IERROR /= 0) RETURN DELTAR = (B-A)/M DLRSQ = DELTAR**2 DELTHT = (D-C)/N DLTHSQ = DELTHT**2 NP = NBDCND+1 ! ! DEFINE A,B,C COEFFICIENTS IN W-ARRAY. ! IWB = M IWC = IWB+M IWR = IWC+M DO 101 I=1,M J = IWR+I W(J) = A+(I-0.5)*DELTAR W(I) = (A+(I-1)*DELTAR)/(DLRSQ*W(J)) K = IWC+I W(K) = (A+I*DELTAR)/(DLRSQ*W(J)) K = IWB+I W(K) = ELMBDA/W(J)**2-2./DLRSQ 101 CONTINUE ! ! ENTER BOUNDARY DATA FOR R-BOUNDARIES. ! go to (102,102,104,104,106,106),MBDCND 102 A1 = 2.*W(1) W(IWB+1) = W(IWB+1)-W(1) DO 103 J=1,N F(1,J) = F(1,J)-A1*BDA(J) 103 CONTINUE go to 106 104 A1 = DELTAR*W(1) W(IWB+1) = W(IWB+1)+W(1) DO 105 J=1,N F(1,J) = F(1,J)+A1*BDA(J) 105 CONTINUE 106 CONTINUE go to (107,109,109,107,107,109),MBDCND 107 W(IWC) = W(IWC)-W(IWR) A1 = 2.*W(IWR) DO 108 J=1,N F(M,J) = F(M,J)-A1*BDB(J) 108 CONTINUE go to 111 109 W(IWC) = W(IWC)+W(IWR) A1 = DELTAR*W(IWR) DO 110 J=1,N F(M,J) = F(M,J)-A1*BDB(J) 110 CONTINUE ! ! ENTER BOUNDARY DATA FOR THETA-BOUNDARIES. ! 111 A1 = 2./DLTHSQ go to (121,112,112,114,114),NP 112 DO 113 I=1,M F(I,1) = F(I,1)-A1*BDC(I) 113 CONTINUE go to 116 114 A1 = 1./DELTHT DO 115 I=1,M F(I,1) = F(I,1)+A1*BDC(I) 115 CONTINUE 116 A1 = 2./DLTHSQ go to (121,117,119,119,117),NP 117 DO 118 I=1,M F(I,N) = F(I,N)-A1*BDD(I) 118 CONTINUE go to 121 119 A1 = 1./DELTHT DO 120 I=1,M F(I,N) = F(I,N)-A1*BDD(I) 120 CONTINUE 121 CONTINUE ! ! ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A ! SOLUTION. ! PERTRB = 0. if (ELMBDA) 130,123,122 122 IERROR = 11 go to 130 123 go to (130,130,124,130,130,124),MBDCND 124 go to (125,130,130,125,130),NP 125 CONTINUE DO 127 I=1,M A1 = 0. DO 126 J=1,N A1 = A1+F(I,J) 126 CONTINUE J = IWR+I PERTRB = PERTRB+A1*W(J) 127 CONTINUE PERTRB = PERTRB/(M*N*0.5*(A+B)) DO 129 I=1,M DO 128 J=1,N F(I,J) = F(I,J)-PERTRB 128 CONTINUE 129 CONTINUE 130 CONTINUE ! ! MULTIPLY I-TH EQUATION THROUGH BY DELTHT**2 ! DO 132 I=1,M W(I) = W(I)*DLTHSQ J = IWC+I W(J) = W(J)*DLTHSQ J = IWB+I W(J) = W(J)*DLTHSQ DO 131 J=1,N F(I,J) = F(I,J)*DLTHSQ 131 CONTINUE 132 CONTINUE LP = NBDCND W(1) = 0. W(IWR) = 0. ! ! call GENBUN TO SOLVE THE SYSTEM OF EQUATIONS. ! if (NBDCND == 0) go to 133 call POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) go to 134 133 call GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) 134 CONTINUE W(1) = W(IWR+1)+3*M return end subroutine HSTPLR (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, & BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) ! !! HSTPLR solves the standard five-point finite difference ... ! approximation on a staggered grid to the Helmholtz equation ! in polar coordinates. !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HSTPLR-S) !***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, POLAR !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! HSTPLR solves the standard five-point finite difference ! approximation on a staggered grid to the Helmholtz equation in ! polar coordinates ! ! (1/R)(d/DR)(R(dU/DR)) + (1/R**2)(d/dTHETA)(dU/dTHETA) ! ! + LAMBDA*U = F(R,THETA) ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! A,B ! The range of R, i.e. A <= R <= B. A must be less than B and ! A must be non-negative. ! ! M ! The number of grid points in the interval (A,B). The grid points ! in the R-direction are given by R(I) = A + (I-0.5)DR for ! I=1,2,...,M where DR =(B-A)/M. M must be greater than 2. ! ! MBDCND ! Indicates the type of boundary conditions at R = A and R = B. ! ! = 1 If the solution is specified at R = A and R = B. ! ! = 2 If the solution is specified at R = A and the derivative ! of the solution with respect to R is specified at R = B. ! (see note 1 below) ! ! = 3 If the derivative of the solution with respect to R is ! specified at R = A (see note 2 below) and R = B. ! ! = 4 If the derivative of the solution with respect to R is ! specified at R = A (see note 2 below) and the solution is ! specified at R = B. ! ! = 5 If the solution is unspecified at R = A = 0 and the solution ! is specified at R = B. ! ! = 6 If the solution is unspecified at R = A = 0 and the ! derivative of the solution with respect to R is specified at ! R = B. ! ! NOTE 1: If A = 0, MBDCND = 2, and NBDCND = 0 or 3, the system of ! equations to be solved is singular. The unique solution ! is determined by extrapolation to the specification of ! U(0,THETA(1)). But in this case the right side of the ! system will be perturbed by the constant PERTRB. ! ! NOTE 2: If A = 0, do not use MBDCND = 3 or 4, but instead use ! MBDCND = 1,2,5, or 6. ! ! BDA ! A one-dimensional array of length N that specifies the boundary ! values (if any) of the solution at R = A. When MBDCND = 1 or 2, ! ! BDA(J) = U(A,THETA(J)) , J=1,2,...,N. ! ! When MBDCND = 3 or 4, ! ! BDA(J) = (d/dR)U(A,THETA(J)) , J=1,2,...,N. ! ! When MBDCND = 5 or 6, BDA is a dummy variable. ! ! BDB ! A one-dimensional array of length N that specifies the boundary ! values of the solution at R = B. When MBDCND = 1,4, or 5, ! ! BDB(J) = U(B,THETA(J)) , J=1,2,...,N. ! ! When MBDCND = 2,3, or 6, ! ! BDB(J) = (d/dR)U(B,THETA(J)) , J=1,2,...,N. ! ! C,D ! The range of THETA, i.e. C <= THETA <= D. C must be less ! than D. ! ! N ! The number of unknowns in the interval (C,D). The unknowns in ! the THETA-direction are given by THETA(J) = C + (J-0.5)DT, ! J=1,2,...,N, where DT = (D-C)/N. N must be greater than 2. ! ! NBDCND ! Indicates the type of boundary conditions at THETA = C ! and THETA = D. ! ! = 0 If the solution is periodic in THETA, i.e. ! U(I,J) = U(I,N+J). ! ! = 1 If the solution is specified at THETA = C and THETA = D ! (see note below). ! ! = 2 If the solution is specified at THETA = C and the derivative ! of the solution with respect to THETA is specified at ! THETA = D (see note below). ! ! = 3 If the derivative of the solution with respect to THETA is ! specified at THETA = C and THETA = D. ! ! = 4 If the derivative of the solution with respect to THETA is ! specified at THETA = C and the solution is specified at ! THETA = d (see note below). ! ! NOTE: When NBDCND = 1, 2, or 4, do not use MBDCND = 5 or 6 (the ! former indicates that the solution is specified at R = 0; the ! latter indicates the solution is unspecified at R = 0). Use ! instead MBDCND = 1 or 2. ! ! BDC ! A one dimensional array of length M that specifies the boundary ! values of the solution at THETA = C. When NBDCND = 1 or 2, ! ! BDC(I) = U(R(I),C) , I=1,2,...,M. ! ! When NBDCND = 3 or 4, ! ! BDC(I) = (d/dTHETA)U(R(I),C), I=1,2,...,M. ! ! When NBDCND = 0, BDC is a dummy variable. ! ! BDD ! A one-dimensional array of length M that specifies the boundary ! values of the solution at THETA = D. When NBDCND = 1 or 4, ! ! BDD(I) = U(R(I),D) , I=1,2,...,M. ! ! When NBDCND = 2 or 3, ! ! BDD(I) = (d/dTHETA)U(R(I),D) , I=1,2,...,M. ! ! When NBDCND = 0, BDD is a dummy variable. ! ! ELMBDA ! The constant LAMBDA in the Helmholtz equation. If LAMBDA is ! greater than 0, a solution may not exist. However, HSTPLR will ! attempt to find a solution. ! ! F ! A two-dimensional array that specifies the values of the right ! side of the Helmholtz equation. For I=1,2,...,M and J=1,2,...,N ! ! F(I,J) = F(R(I),THETA(J)) . ! ! F must be dimensioned at least M X N. ! ! IDIMF ! The row (or first) dimension of the array F as it appears in the ! program calling HSTPLR. This parameter is used to specify the ! variable dimension of F. IDIMF must be at least M. ! ! W ! A one-dimensional array that must be provided by the user for ! work space. W may require up to 13M + 4N + M*INT(log2(N)) ! locations. The actual number of locations used is computed by ! HSTPLR and is returned in the location W(1). ! ! ! * * * * * * On Output * * * * * * ! ! F ! Contains the solution U(I,J) of the finite difference ! approximation for the grid point (R(I),THETA(J)) for ! I=1,2,...,M, J=1,2,...,N. ! ! PERTRB ! If a combination of periodic, derivative, or unspecified ! boundary conditions is specified for a Poisson equation ! (LAMBDA = 0), a solution may not exist. PERTRB is a con- ! stant, calculated and subtracted from F, which ensures ! that a solution exists. HSTPLR then computes this ! solution, which is a least squares solution to the ! original approximation. This solution plus any constant is also ! a solution; hence, the solution is not unique. The value of ! PERTRB should be small compared to the right side F. ! Otherwise, a solution is obtained to an essentially different ! problem. This comparison should always be made to insure that ! a meaningful solution has been obtained. ! ! IERROR ! An error flag that indicates invalid input parameters. ! Except for numbers 0 and 11, a solution is not attempted. ! ! = 0 No error ! ! = 1 A < 0 ! ! = 2 A >= B ! ! = 3 MBDCND < 1 or MBDCND > 6 ! ! = 4 C >= D ! ! = 5 N <= 2 ! ! = 6 NBDCND < 0 or NBDCND > 4 ! ! = 7 A = 0 and MBDCND = 3 or 4 ! ! = 8 A > 0 and MBDCND >= 5 ! ! = 9 MBDCND >= 5 and NBDCND /= 0 or 3 ! ! = 10 IDIMF < M ! ! = 11 LAMBDA > 0 ! ! = 12 M <= 2 ! ! Since this is the only means of indicating a possibly ! incorrect call to HSTPLR, the user should test IERROR after ! the call. ! ! W ! W(1) contains the required length of W. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N), ! Arguments W(see ARGUMENT LIST) ! ! Latest June 1, 1977 ! Revision ! ! Subprograms HSTPLR,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2, ! Required COSGEN,MERGE,TRIX,TRI3,PIMACH ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Written by Roland Sweet at NCAR in February, 1977 ! ! Algorithm This subroutine defines the finite-difference ! equations, incorporates boundary data, adjusts the ! right side when the system is singular and calls ! either POISTG or GENBUN which solves the linear ! system of equations. ! ! Space 8265(decimal) = 20111(octal) LOCATIONS ON THE ! Required NCAR Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine HSTPLR is roughly proportional ! to M*N*log2(N). Some typical values are listed in ! the table below. ! The solution process employed results in a loss ! of no more than four significant digits for N and M ! as large as 64. More detailed information about ! accuracy can be found in the documentation for ! subroutine POISTG which is the routine that ! actually solves the finite difference equations. ! ! ! M(=N) MBDCND NBDCND T(MSECS) ! ----- ------ ------ -------- ! ! 32 1-6 1-4 56 ! 64 1-6 1-4 230 ! ! Portability American National Standards Institute Fortran. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS ! Resident ! Routines ! ! Reference Schumann, U. and R. Sweet,'A Direct Method For ! The Solution Of Poisson's Equation With Neumann ! Boundary Conditions On A Staggered Grid of ! Arbitrary Size,' J. Comp. Phys. 20(1976), ! pp. 171-182. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES U. Schumann and R. Sweet, A direct method for the ! solution of Poisson's equation with Neumann boundary ! conditions on a staggered grid of arbitrary size, ! Journal of Computational Physics 20, (1976), ! pp. 171-182. !***ROUTINES CALLED GENBUN, POISTG !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HSTPLR ! ! DIMENSION F(IDIMF,*) DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , & W(*) !***FIRST EXECUTABLE STATEMENT HSTPLR IERROR = 0 if (A < 0.) IERROR = 1 if (A >= B) IERROR = 2 if (MBDCND <= 0 .OR. MBDCND >= 7) IERROR = 3 if (C >= D) IERROR = 4 if (N <= 2) IERROR = 5 if (NBDCND < 0 .OR. NBDCND >= 5) IERROR = 6 if (A == 0. .AND. (MBDCND == 3 .OR. MBDCND == 4)) IERROR = 7 if (A > 0. .AND. MBDCND >= 5) IERROR = 8 if (MBDCND >= 5 .AND. NBDCND /= 0 .AND. NBDCND /= 3) IERROR = 9 if (IDIMF < M) IERROR = 10 if (M <= 2) IERROR = 12 if (IERROR /= 0) RETURN DELTAR = (B-A)/M DLRSQ = DELTAR**2 DELTHT = (D-C)/N DLTHSQ = DELTHT**2 NP = NBDCND+1 ISW = 1 MB = MBDCND if (A == 0. .AND. MBDCND == 2) MB = 6 ! ! DEFINE A,B,C COEFFICIENTS IN W-ARRAY. ! IWB = M IWC = IWB+M IWR = IWC+M DO 101 I=1,M J = IWR+I W(J) = A+(I-0.5)*DELTAR W(I) = (A+(I-1)*DELTAR)/DLRSQ K = IWC+I W(K) = (A+I*DELTAR)/DLRSQ K = IWB+I W(K) = (ELMBDA-2./DLRSQ)*W(J) 101 CONTINUE DO 103 I=1,M J = IWR+I A1 = W(J) DO 102 J=1,N F(I,J) = A1*F(I,J) 102 CONTINUE 103 CONTINUE ! ! ENTER BOUNDARY DATA FOR R-BOUNDARIES. ! go to (104,104,106,106,108,108),MB 104 A1 = 2.*W(1) W(IWB+1) = W(IWB+1)-W(1) DO 105 J=1,N F(1,J) = F(1,J)-A1*BDA(J) 105 CONTINUE go to 108 106 A1 = DELTAR*W(1) W(IWB+1) = W(IWB+1)+W(1) DO 107 J=1,N F(1,J) = F(1,J)+A1*BDA(J) 107 CONTINUE 108 go to (109,111,111,109,109,111),MB 109 A1 = 2.*W(IWR) W(IWC) = W(IWC)-W(IWR) DO 110 J=1,N F(M,J) = F(M,J)-A1*BDB(J) 110 CONTINUE go to 113 111 A1 = DELTAR*W(IWR) W(IWC) = W(IWC)+W(IWR) DO 112 J=1,N F(M,J) = F(M,J)-A1*BDB(J) 112 CONTINUE ! ! ENTER BOUNDARY DATA FOR THETA-BOUNDARIES. ! 113 A1 = 2./DLTHSQ go to (123,114,114,116,116),NP 114 DO 115 I=1,M J = IWR+I F(I,1) = F(I,1)-A1*BDC(I)/W(J) 115 CONTINUE go to 118 116 A1 = 1./DELTHT DO 117 I=1,M J = IWR+I F(I,1) = F(I,1)+A1*BDC(I)/W(J) 117 CONTINUE 118 A1 = 2./DLTHSQ go to (123,119,121,121,119),NP 119 DO 120 I=1,M J = IWR+I F(I,N) = F(I,N)-A1*BDD(I)/W(J) 120 CONTINUE go to 123 121 A1 = 1./DELTHT DO 122 I=1,M J = IWR+I F(I,N) = F(I,N)-A1*BDD(I)/W(J) 122 CONTINUE 123 CONTINUE ! ! ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A ! SOLUTION. ! PERTRB = 0. if (ELMBDA) 133,125,124 124 IERROR = 11 go to 133 125 go to (133,133,126,133,133,126),MB 126 go to (127,133,133,127,133),NP 127 CONTINUE ISW = 2 DO 129 J=1,N DO 128 I=1,M PERTRB = PERTRB+F(I,J) 128 CONTINUE 129 CONTINUE PERTRB = PERTRB/(M*N*0.5*(A+B)) DO 131 I=1,M J = IWR+I A1 = PERTRB*W(J) DO 130 J=1,N F(I,J) = F(I,J)-A1 130 CONTINUE 131 CONTINUE A2 = 0. DO 132 J=1,N A2 = A2+F(1,J) 132 CONTINUE A2 = A2/W(IWR+1) 133 CONTINUE ! ! MULTIPLY I-TH EQUATION THROUGH BY R(I)*DELTHT**2 ! DO 135 I=1,M J = IWR+I A1 = DLTHSQ*W(J) W(I) = A1*W(I) J = IWC+I W(J) = A1*W(J) J = IWB+I W(J) = A1*W(J) DO 134 J=1,N F(I,J) = A1*F(I,J) 134 CONTINUE 135 CONTINUE LP = NBDCND W(1) = 0. W(IWR) = 0. ! ! call POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS. ! if (LP == 0) go to 136 call POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) go to 137 136 call GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) 137 CONTINUE W(1) = W(IWR+1)+3*M if (A /= 0. .OR. MBDCND /= 2 .OR. ISW /= 2) go to 141 A1 = 0. DO 138 J=1,N A1 = A1+F(1,J) 138 CONTINUE A1 = (A1-DLRSQ*A2/16.)/N if (NBDCND == 3) A1 = A1+(BDD(1)-BDC(1))/(D-C) A1 = BDA(1)-A1 DO 140 I=1,M DO 139 J=1,N F(I,J) = F(I,J)+A1 139 CONTINUE 140 CONTINUE 141 CONTINUE return end subroutine HSTSSP (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, & BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) ! !! HSTSSP solves the standard five-point finite difference approximation ... ! on a staggered grid to the Helmholtz equation in spherical coordinates ! and on the surface of the unit sphere (radius of 1). ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HSTSSP-S) !***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! HSTSSP solves the standard five-point finite difference ! approximation on a staggered grid to the Helmholtz equation in ! spherical coordinates and on the surface of the unit sphere ! (radius of 1) ! ! (1/SIN(THETA))(d/dTHETA)(SIN(THETA)(dU/dTHETA)) + ! ! (1/SIN(THETA)**2)(d/dPHI)(dU/dPHI) + LAMBDA*U = F(THETA,PHI) ! ! where THETA is colatitude and PHI is longitude. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! A,B ! The range of THETA (colatitude), i.e. A <= THETA <= B. A ! must be less than B and A must be non-negative. A and B are in ! radians. A = 0 corresponds to the north pole and B = PI ! corresponds to the south pole. ! ! ! * * * IMPORTANT * * * ! ! If B is equal to PI, then B must be computed using the statement ! ! B = PIMACH(DUM) ! ! This insures that B in the user's program is equal to PI in this ! program which permits several tests of the input parameters that ! otherwise would not be possible. ! ! * * * * * * * * * * * * ! ! ! ! M ! The number of grid points in the interval (A,B). The grid points ! in the THETA-direction are given by THETA(I) = A + (I-0.5)DTHETA ! for I=1,2,...,M where DTHETA =(B-A)/M. M must be greater than 2. ! ! MBDCND ! Indicates the type of boundary conditions at THETA = A and ! THETA = B. ! ! = 1 If the solution is specified at THETA = A and THETA = B. ! (see note 3 below) ! ! = 2 If the solution is specified at THETA = A and the derivative ! of the solution with respect to THETA is specified at ! THETA = B (see notes 2 and 3 below). ! ! = 3 If the derivative of the solution with respect to THETA is ! specified at THETA = A (see notes 1, 2 below) and THETA = B. ! ! = 4 If the derivative of the solution with respect to THETA is ! specified at THETA = A (see notes 1 and 2 below) and the ! solution is specified at THETA = B. ! ! = 5 If the solution is unspecified at THETA = A = 0 and the ! solution is specified at THETA = B. (see note 3 below) ! ! = 6 If the solution is unspecified at THETA = A = 0 and the ! derivative of the solution with respect to THETA is ! specified at THETA = B (see note 2 below). ! ! = 7 If the solution is specified at THETA = A and the ! solution is unspecified at THETA = B = PI. (see note 3 below) ! ! = 8 If the derivative of the solution with respect to ! THETA is specified at THETA = A (see note 1 below) ! and the solution is unspecified at THETA = B = PI. ! ! = 9 If the solution is unspecified at THETA = A = 0 and ! THETA = B = PI. ! ! NOTES: 1. If A = 0, do not use MBDCND = 3, 4, or 8, ! but instead use MBDCND = 5, 6, or 9. ! ! 2. If B = PI, do not use MBDCND = 2, 3, or 6, ! but instead use MBDCND = 7, 8, or 9. ! ! 3. When the solution is specified at THETA = 0 and/or ! THETA = PI and the other boundary conditions are ! combinations of unspecified, normal derivative, or ! periodicity a singular system results. The unique ! solution is determined by extrapolation to the ! specification of the solution at either THETA = 0 or ! THETA = PI. But in these cases the right side of the ! system will be perturbed by the constant PERTRB. ! ! BDA ! A one-dimensional array of length N that specifies the boundary ! values (if any) of the solution at THETA = A. When ! MBDCND = 1, 2, or 7, ! ! BDA(J) = U(A,PHI(J)) , J=1,2,...,N. ! ! When MBDCND = 3, 4, or 8, ! ! BDA(J) = (d/dTHETA)U(A,PHI(J)) , J=1,2,...,N. ! ! When MBDCND has any other value, BDA is a dummy variable. ! ! BDB ! A one-dimensional array of length N that specifies the boundary ! values of the solution at THETA = B. When MBDCND = 1,4, or 5, ! ! BDB(J) = U(B,PHI(J)) , J=1,2,...,N. ! ! When MBDCND = 2,3, or 6, ! ! BDB(J) = (d/dTHETA)U(B,PHI(J)) , J=1,2,...,N. ! ! When MBDCND has any other value, BDB is a dummy variable. ! ! C,D ! The range of PHI (longitude), i.e. C <= PHI <= D. ! C must be less than D. If D-C = 2*PI, periodic boundary ! conditions are usually prescribed. ! ! N ! The number of unknowns in the interval (C,D). The unknowns in ! the PHI-direction are given by PHI(J) = C + (J-0.5)DPHI, ! J=1,2,...,N, where DPHI = (D-C)/N. N must be greater than 2. ! ! NBDCND ! Indicates the type of boundary conditions at PHI = C ! and PHI = D. ! ! = 0 If the solution is periodic in PHI, i.e. ! U(I,J) = U(I,N+J). ! ! = 1 If the solution is specified at PHI = C and PHI = D ! (see note below). ! ! = 2 If the solution is specified at PHI = C and the derivative ! of the solution with respect to PHI is specified at ! PHI = D (see note below). ! ! = 3 If the derivative of the solution with respect to PHI is ! specified at PHI = C and PHI = D. ! ! = 4 If the derivative of the solution with respect to PHI is ! specified at PHI = C and the solution is specified at ! PHI = D (see note below). ! ! NOTE: When NBDCND = 1, 2, or 4, do not use MBDCND = 5, 6, 7, 8, ! or 9 (the former indicates that the solution is specified at ! a pole; the latter indicates the solution is unspecified). Use ! instead MBDCND = 1 or 2. ! ! BDC ! A one dimensional array of length M that specifies the boundary ! values of the solution at PHI = C. When NBDCND = 1 or 2, ! ! BDC(I) = U(THETA(I),C) , I=1,2,...,M. ! ! When NBDCND = 3 or 4, ! ! BDC(I) = (d/dPHI)U(THETA(I),C), I=1,2,...,M. ! ! When NBDCND = 0, BDC is a dummy variable. ! ! BDD ! A one-dimensional array of length M that specifies the boundary ! values of the solution at PHI = D. When NBDCND = 1 or 4, ! ! BDD(I) = U(THETA(I),D) , I=1,2,...,M. ! ! When NBDCND = 2 or 3, ! ! BDD(I) = (d/dPHI)U(THETA(I),D) , I=1,2,...,M. ! ! When NBDCND = 0, BDD is a dummy variable. ! ! ELMBDA ! The constant LAMBDA in the Helmholtz equation. If LAMBDA is ! greater than 0, a solution may not exist. However, HSTSSP will ! attempt to find a solution. ! ! F ! A two-dimensional array that specifies the values of the right ! side of the Helmholtz equation. For I=1,2,...,M and J=1,2,...,N ! ! F(I,J) = F(THETA(I),PHI(J)) . ! ! F must be dimensioned at least M X N. ! ! IDIMF ! The row (or first) dimension of the array F as it appears in the ! program calling HSTSSP. This parameter is used to specify the ! variable dimension of F. IDIMF must be at least M. ! ! W ! A one-dimensional array that must be provided by the user for ! work space. W may require up to 13M + 4N + M*INT(log2(N)) ! locations. The actual number of locations used is computed by ! HSTSSP and is returned in the location W(1). ! ! ! * * * * * * On Output * * * * * * ! ! F ! Contains the solution U(I,J) of the finite difference ! approximation for the grid point (THETA(I),PHI(J)) for ! I=1,2,...,M, J=1,2,...,N. ! ! PERTRB ! If a combination of periodic, derivative, or unspecified ! boundary conditions is specified for a Poisson equation ! (LAMBDA = 0), a solution may not exist. PERTRB is a con- ! stant, calculated and subtracted from F, which ensures ! that a solution exists. HSTSSP then computes this ! solution, which is a least squares solution to the ! original approximation. This solution plus any constant is also ! a solution; hence, the solution is not unique. The value of ! PERTRB should be small compared to the right side F. ! Otherwise, a solution is obtained to an essentially different ! problem. This comparison should always be made to insure that ! a meaningful solution has been obtained. ! ! IERROR ! An error flag that indicates invalid input parameters. ! Except for numbers 0 and 14, a solution is not attempted. ! ! = 0 No error ! ! = 1 A < 0 or B > PI ! ! = 2 A >= B ! ! = 3 MBDCND < 1 or MBDCND > 9 ! ! = 4 C >= D ! ! = 5 N <= 2 ! ! = 6 NBDCND < 0 or NBDCND > 4 ! ! = 7 A > 0 and MBDCND = 5, 6, or 9 ! ! = 8 A = 0 and MBDCND = 3, 4, or 8 ! ! = 9 B < PI and MBDCND >= 7 ! ! = 10 B = PI and MBDCND = 2,3, or 6 ! ! = 11 MBDCND >= 5 and NDBCND = 1, 2, or 4 ! ! = 12 IDIMF < M ! ! = 13 M <= 2 ! ! = 14 LAMBDA > 0 ! ! Since this is the only means of indicating a possibly ! incorrect call to HSTSSP, the user should test IERROR after ! the call. ! ! W ! W(1) contains the required length of W. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N), ! Arguments W(see argument list) ! ! Latest June 1, 1977 ! Revision ! ! Subprograms HSTSSP,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2, ! Required COSGEN,MERGE,TRIX,TRI3,PIMACH ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Written by Roland Sweet at NCAR in April, 1977 ! ! Algorithm This subroutine defines the finite-difference ! equations, incorporates boundary data, adjusts the ! right side when the system is singular and calls ! either POISTG or GENBUN which solves the linear ! system of equations. ! ! Space 8427(decimal) = 20353(octal) locations on the ! Required NCAR Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine HSTSSP is roughly proportional ! to M*N*log2(N). Some typical values are listed in ! the table below. ! The solution process employed results in a loss ! of no more than four significant digits for N and M ! as large as 64. More detailed information about ! accuracy can be found in the documentation for ! subroutine POISTG which is the routine that ! actually solves the finite difference equations. ! ! ! M(=N) MBDCND NBDCND T(MSECS) ! ----- ------ ------ -------- ! ! 32 1-9 1-4 56 ! 64 1-9 1-4 230 ! ! Portability American National Standards Institute FORTRAN. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS ! Resident ! Routines ! ! Reference Schumann, U. and R. Sweet,'A Direct Method For ! The Solution Of Poisson's Equation With Neumann ! Boundary Conditions On A Staggered Grid Of ! Arbitrary Size,' J. Comp. Phys. 20(1976), ! pp. 171-182. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES U. Schumann and R. Sweet, A direct method for the ! solution of Poisson's equation with Neumann boundary ! conditions on a staggered grid of arbitrary size, ! Journal of Computational Physics 20, (1976), ! pp. 171-182. !***ROUTINES CALLED GENBUN, PIMACH, POISTG !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HSTSSP ! ! DIMENSION F(IDIMF,*) ,BDA(*) ,BDB(*) ,BDC(*) , & BDD(*) ,W(*) !***FIRST EXECUTABLE STATEMENT HSTSSP IERROR = 0 PI = PIMACH(DUM) if (A < 0. .OR. B > PI) IERROR = 1 if (A >= B) IERROR = 2 if (MBDCND <= 0 .OR. MBDCND > 9) IERROR = 3 if (C >= D) IERROR = 4 if (N <= 2) IERROR = 5 if (NBDCND < 0 .OR. NBDCND >= 5) IERROR = 6 if (A > 0. .AND. (MBDCND == 5 .OR. MBDCND == 6 .OR. MBDCND == 9)) & IERROR = 7 if (A == 0. .AND. (MBDCND == 3 .OR. MBDCND == 4 .OR. MBDCND == 8)) & IERROR = 8 if (B < PI .AND. MBDCND >= 7) IERROR = 9 if (B == PI .AND. (MBDCND == 2 .OR. MBDCND == 3 .OR. MBDCND == 6)) & IERROR = 10 if (MBDCND >= 5 .AND. & (NBDCND == 1 .OR. NBDCND == 2 .OR. NBDCND == 4)) IERROR = 11 if (IDIMF < M) IERROR = 12 if (M <= 2) IERROR = 13 if (IERROR /= 0) RETURN DELTAR = (B-A)/M DLRSQ = DELTAR**2 DELTHT = (D-C)/N DLTHSQ = DELTHT**2 NP = NBDCND+1 ISW = 1 JSW = 1 MB = MBDCND if (ELMBDA /= 0.) go to 105 go to (101,102,105,103,101,105,101,105,105),MBDCND 101 if (A /= 0. .OR. B /= PI) go to 105 MB = 9 go to 104 102 if (A /= 0.) go to 105 MB = 6 go to 104 103 if (B /= PI) go to 105 MB = 8 104 JSW = 2 105 CONTINUE ! ! DEFINE A,B,C COEFFICIENTS IN W-ARRAY. ! IWB = M IWC = IWB+M IWR = IWC+M IWS = IWR+M DO 106 I=1,M J = IWR+I W(J) = SIN(A+(I-0.5)*DELTAR) W(I) = SIN((A+(I-1)*DELTAR))/DLRSQ 106 CONTINUE MM1 = M-1 DO 107 I=1,MM1 K = IWC+I W(K) = W(I+1) J = IWR+I K = IWB+I W(K) = ELMBDA*W(J)-(W(I)+W(I+1)) 107 CONTINUE W(IWR) = SIN(B)/DLRSQ W(IWC) = ELMBDA*W(IWS)-(W(M)+W(IWR)) DO 109 I=1,M J = IWR+I A1 = W(J) DO 108 J=1,N F(I,J) = A1*F(I,J) 108 CONTINUE 109 CONTINUE ! ! ENTER BOUNDARY DATA FOR THETA-BOUNDARIES. ! go to (110,110,112,112,114,114,110,112,114),MB 110 A1 = 2.*W(1) W(IWB+1) = W(IWB+1)-W(1) DO 111 J=1,N F(1,J) = F(1,J)-A1*BDA(J) 111 CONTINUE go to 114 112 A1 = DELTAR*W(1) W(IWB+1) = W(IWB+1)+W(1) DO 113 J=1,N F(1,J) = F(1,J)+A1*BDA(J) 113 CONTINUE 114 go to (115,117,117,115,115,117,119,119,119),MB 115 A1 = 2.*W(IWR) W(IWC) = W(IWC)-W(IWR) DO 116 J=1,N F(M,J) = F(M,J)-A1*BDB(J) 116 CONTINUE go to 119 117 A1 = DELTAR*W(IWR) W(IWC) = W(IWC)+W(IWR) DO 118 J=1,N F(M,J) = F(M,J)-A1*BDB(J) 118 CONTINUE ! ! ENTER BOUNDARY DATA FOR PHI-BOUNDARIES. ! 119 A1 = 2./DLTHSQ go to (129,120,120,122,122),NP 120 DO 121 I=1,M J = IWR+I F(I,1) = F(I,1)-A1*BDC(I)/W(J) 121 CONTINUE go to 124 122 A1 = 1./DELTHT DO 123 I=1,M J = IWR+I F(I,1) = F(I,1)+A1*BDC(I)/W(J) 123 CONTINUE 124 A1 = 2./DLTHSQ go to (129,125,127,127,125),NP 125 DO 126 I=1,M J = IWR+I F(I,N) = F(I,N)-A1*BDD(I)/W(J) 126 CONTINUE go to 129 127 A1 = 1./DELTHT DO 128 I=1,M J = IWR+I F(I,N) = F(I,N)-A1*BDD(I)/W(J) 128 CONTINUE 129 CONTINUE ! ! ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A ! SOLUTION. ! PERTRB = 0. if (ELMBDA) 139,131,130 130 IERROR = 14 go to 139 131 go to (139,139,132,139,139,132,139,132,132),MB 132 go to (133,139,139,133,139),NP 133 CONTINUE ISW = 2 DO 135 J=1,N DO 134 I=1,M PERTRB = PERTRB+F(I,J) 134 CONTINUE 135 CONTINUE A1 = N*(COS(A)-COS(B))/(2.*SIN(0.5*DELTAR)) PERTRB = PERTRB/A1 DO 137 I=1,M J = IWR+I A1 = PERTRB*W(J) DO 136 J=1,N F(I,J) = F(I,J)-A1 136 CONTINUE 137 CONTINUE A2 = 0. A3 = 0. DO 138 J=1,N A2 = A2+F(1,J) A3 = A3+F(M,J) 138 CONTINUE A2 = A2/W(IWR+1) A3 = A3/W(IWS) 139 CONTINUE ! ! MULTIPLY I-TH EQUATION THROUGH BY R(I)*DELTHT**2 ! DO 141 I=1,M J = IWR+I A1 = DLTHSQ*W(J) W(I) = A1*W(I) J = IWC+I W(J) = A1*W(J) J = IWB+I W(J) = A1*W(J) DO 140 J=1,N F(I,J) = A1*F(I,J) 140 CONTINUE 141 CONTINUE LP = NBDCND W(1) = 0. W(IWR) = 0. ! ! call POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS. ! if (NBDCND == 0) go to 142 call POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) go to 143 142 call GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1)) 143 CONTINUE W(1) = W(IWR+1)+3*M if (ISW /= 2 .OR. JSW /= 2) go to 150 if (MB /= 8) go to 145 A1 = 0. DO 144 J=1,N A1 = A1+F(M,J) 144 CONTINUE A1 = (A1-DLRSQ*A3/16.)/N if (NBDCND == 3) A1 = A1+(BDD(M)-BDC(M))/(D-C) A1 = BDB(1)-A1 go to 147 145 A1 = 0. DO 146 J=1,N A1 = A1+F(1,J) 146 CONTINUE A1 = (A1-DLRSQ*A2/16.)/N if (NBDCND == 3) A1 = A1+(BDD(1)-BDC(1))/(D-C) A1 = BDA(1)-A1 147 DO 149 I=1,M DO 148 J=1,N F(I,J) = F(I,J)+A1 148 CONTINUE 149 CONTINUE 150 CONTINUE return end subroutine HTRIB3 (NM, N, A, TAU, M, ZR, ZI) ! !! HTRIB3 computes the eigenvectors of a complex Hermitian matrix from ... ! the eigenvectors of a real symmetric tridiagonal matrix output from HTRID3. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (HTRIB3-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of a complex analogue of ! the ALGOL procedure TRBAK3, NUM. MATH. 11, 181-195(1968) ! by Martin, Reinsch, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). ! ! This subroutine forms the eigenvectors of a COMPLEX HERMITIAN ! matrix by back transforming those of the corresponding ! real symmetric tridiagonal matrix determined by HTRID3. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A, ZR, and ZI, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! A contains some information about the unitary transformations ! used in the reduction by HTRID3. A is a two-dimensional ! REAL array, dimensioned A(NM,N). ! ! TAU contains further information about the transformations. ! TAU is a one-dimensional REAL array, dimensioned TAU(2,N). ! ! M is the number of eigenvectors to be back transformed. ! M is an INTEGER variable. ! ! ZR contains the eigenvectors to be back transformed in its ! first M columns. The contents of ZI are immaterial. ZR and ! ZI are two-dimensional REAL arrays, dimensioned ZR(NM,M) and ! ZI(NM,M). ! ! On OUTPUT ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the transformed eigenvectors in their first M columns. ! ! NOTE that the last component of each returned vector ! is real and that vector Euclidean norms are preserved. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HTRIB3 ! INTEGER I,J,K,L,M,N,NM REAL A(NM,*),TAU(2,*),ZR(NM,*),ZI(NM,*) REAL H,S,SI ! !***FIRST EXECUTABLE STATEMENT HTRIB3 if (M == 0) go to 200 ! .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC ! TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN ! TRIDIAGONAL MATRIX. .......... DO 50 K = 1, N ! DO 50 J = 1, M ZI(K,J) = -ZR(K,J) * TAU(2,K) ZR(K,J) = ZR(K,J) * TAU(1,K) 50 CONTINUE ! if (N == 1) go to 200 ! .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... DO 140 I = 2, N L = I - 1 H = A(I,I) if (H == 0.0E0) go to 140 ! DO 130 J = 1, M S = 0.0E0 SI = 0.0E0 DO K = 1, L S = S + A(I,K) * ZR(K,J) - A(K,I) * ZI(K,J) SI = SI + A(I,K) * ZI(K,J) + A(K,I) * ZR(K,J) end do ! ! DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW. ! S = (S / H) / H SI = (SI / H) / H DO K = 1, L ZR(K,J) = ZR(K,J) - S * A(I,K) - SI * A(K,I) ZI(K,J) = ZI(K,J) - SI * A(I,K) + S * A(K,I) end do 130 CONTINUE 140 CONTINUE 200 RETURN end subroutine HTRIBK (NM, N, AR, AI, TAU, M, ZR, ZI) ! !! HTRIBK forms the eigenvectors of a complex Hermitian matrix from ... ! the eigenvectors of a real symmetric tridiagonal matrix output from HTRIDI. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (HTRIBK-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of a complex analogue of ! the ALGOL procedure TRBAK1, NUM. MATH. 11, 181-195(1968) ! by Martin, Reinsch, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). ! ! This subroutine forms the eigenvectors of a COMPLEX HERMITIAN ! matrix by back transforming those of the corresponding ! real symmetric tridiagonal matrix determined by HTRIDI. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, AR, AI, ZR, and ZI, as declared in the ! calling program dimension statement. NM is an INTEGER ! variable. ! ! N is the order of the matrix. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! AR and AI contain some information about the unitary ! transformations used in the reduction by HTRIDI in the ! strict lower triangle of AR and the full lower triangle of ! AI. The remaining upper parts of the matrices are arbitrary. ! AR and AI are two-dimensional REAL arrays, dimensioned ! AR(NM,N) and AI(NM,N). ! ! TAU contains further information about the transformations. ! TAU is a one-dimensional REAL array, dimensioned TAU(2,N). ! ! M is the number of eigenvectors to be back transformed. ! M is an INTEGER variable. ! ! ZR contains the eigenvectors to be back transformed in its first ! M columns. The contents of ZI are immaterial. ZR and ZI are ! two-dimensional REAL arrays, dimensioned ZR(NM,M) and ! ZI(NM,M). ! ! On OUTPUT ! ! ZR and ZI contain the real and imaginary parts, respectively, ! of the transformed eigenvectors in their first M columns. ! ! Note that the last component of each returned vector ! is real and that vector Euclidean norms are preserved. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HTRIBK ! INTEGER I,J,K,L,M,N,NM REAL AR(NM,*),AI(NM,*),TAU(2,*),ZR(NM,*),ZI(NM,*) REAL H,S,SI ! !***FIRST EXECUTABLE STATEMENT HTRIBK if (M == 0) go to 200 ! .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC ! TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN ! TRIDIAGONAL MATRIX. .......... DO 50 K = 1, N ! DO 50 J = 1, M ZI(K,J) = -ZR(K,J) * TAU(2,K) ZR(K,J) = ZR(K,J) * TAU(1,K) 50 CONTINUE if (N == 1) go to 200 ! .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... DO 140 I = 2, N L = I - 1 H = AI(I,I) if (H == 0.0E0) go to 140 DO 130 J = 1, M S = 0.0E0 SI = 0.0E0 DO 110 K = 1, L S = S + AR(I,K) * ZR(K,J) - AI(I,K) * ZI(K,J) SI = SI + AR(I,K) * ZI(K,J) + AI(I,K) * ZR(K,J) 110 CONTINUE ! .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW .......... S = (S / H) / H SI = (SI / H) / H DO K = 1, L ZR(K,J) = ZR(K,J) - S * AR(I,K) - SI * AI(I,K) ZI(K,J) = ZI(K,J) - SI * AR(I,K) + S * AI(I,K) end do 130 CONTINUE 140 CONTINUE 200 RETURN end subroutine HTRID3 (NM, N, A, D, E, E2, TAU) ! !! HTRID3 reduces a complex Hermitian (packed) matrix to a real ... ! symmetric tridiagonal matrix by unitary similarity ! transformations. !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B1 !***TYPE SINGLE PRECISION (HTRID3-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of a complex analogue of ! the ALGOL procedure TRED3, NUM. MATH. 11, 181-195(1968) ! by Martin, Reinsch, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). ! ! This subroutine reduces a COMPLEX HERMITIAN matrix, stored as ! a single square array, to a real symmetric tridiagonal matrix ! using unitary similarity transformations. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, A, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! A contains the lower triangle of the complex Hermitian input ! matrix. The real parts of the matrix elements are stored ! in the full lower triangle of A, and the imaginary parts ! are stored in the transposed positions of the strict upper ! triangle of A. No storage is required for the zero ! imaginary parts of the diagonal elements. A is a two- ! dimensional REAL array, dimensioned A(NM,N). ! ! On OUTPUT ! ! A contains some information about the unitary transformations ! used in the reduction. ! ! D contains the diagonal elements of the real symmetric ! tridiagonal matrix. D is a one-dimensional REAL array, ! dimensioned D(N). ! ! E contains the subdiagonal elements of the real tridiagonal ! matrix in its last N-1 positions. E(1) is set to zero. ! E is a one-dimensional REAL array, dimensioned E(N). ! ! E2 contains the squares of the corresponding elements of E. ! E2(1) is set to zero. E2 may coincide with E if the squares ! are not needed. E2 is a one-dimensional REAL array, ! dimensioned E2(N). ! ! TAU contains further information about the transformations. ! TAU is a one-dimensional REAL array, dimensioned TAU(2,N). ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HTRID3 ! INTEGER I,J,K,L,N,II,NM,JM1,JP1 REAL A(NM,*),D(*),E(*),E2(*),TAU(2,*) REAL F,G,H,FI,GI,HH,SI,SCALE REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT HTRID3 TAU(1,N) = 1.0E0 TAU(2,N) = 0.0E0 ! .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... DO 300 II = 1, N I = N + 1 - II L = I - 1 H = 0.0E0 SCALE = 0.0E0 if (L < 1) go to 130 ! .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... DO 120 K = 1, L 120 SCALE = SCALE + ABS(A(I,K)) + ABS(A(K,I)) ! if (SCALE /= 0.0E0) go to 140 TAU(1,L) = 1.0E0 TAU(2,L) = 0.0E0 130 E(I) = 0.0E0 E2(I) = 0.0E0 go to 290 ! 140 DO 150 K = 1, L A(I,K) = A(I,K) / SCALE A(K,I) = A(K,I) / SCALE H = H + A(I,K) * A(I,K) + A(K,I) * A(K,I) 150 CONTINUE ! E2(I) = SCALE * SCALE * H G = SQRT(H) E(I) = SCALE * G F = PYTHAG(A(I,L),A(L,I)) ! .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... if (F == 0.0E0) go to 160 TAU(1,L) = (A(L,I) * TAU(2,I) - A(I,L) * TAU(1,I)) / F SI = (A(I,L) * TAU(2,I) + A(L,I) * TAU(1,I)) / F H = H + F * G G = 1.0E0 + G / F A(I,L) = G * A(I,L) A(L,I) = G * A(L,I) if (L == 1) go to 270 go to 170 160 TAU(1,L) = -TAU(1,I) SI = TAU(2,I) A(I,L) = G 170 F = 0.0E0 ! DO 240 J = 1, L G = 0.0E0 GI = 0.0E0 if (J == 1) go to 190 JM1 = J - 1 ! .......... FORM ELEMENT OF A*U .......... DO 180 K = 1, JM1 G = G + A(J,K) * A(I,K) + A(K,J) * A(K,I) GI = GI - A(J,K) * A(K,I) + A(K,J) * A(I,K) 180 CONTINUE ! 190 G = G + A(J,J) * A(I,J) GI = GI - A(J,J) * A(J,I) JP1 = J + 1 if (L < JP1) go to 220 ! DO 200 K = JP1, L G = G + A(K,J) * A(I,K) - A(J,K) * A(K,I) GI = GI - A(K,J) * A(K,I) - A(J,K) * A(I,K) 200 CONTINUE ! .......... FORM ELEMENT OF P .......... 220 E(J) = G / H TAU(2,J) = GI / H F = F + E(J) * A(I,J) - TAU(2,J) * A(J,I) 240 CONTINUE ! HH = F / (H + H) ! .......... FORM REDUCED A .......... DO 260 J = 1, L F = A(I,J) G = E(J) - HH * F E(J) = G FI = -A(J,I) GI = TAU(2,J) - HH * FI TAU(2,J) = -GI A(J,J) = A(J,J) - 2.0E0 * (F * G + FI * GI) if (J == 1) go to 260 JM1 = J - 1 ! DO 250 K = 1, JM1 A(J,K) = A(J,K) - F * E(K) - G * A(I,K) & + FI * TAU(2,K) + GI * A(K,I) A(K,J) = A(K,J) - F * TAU(2,K) - G * A(K,I) & - FI * E(K) - GI * A(I,K) 250 CONTINUE ! 260 CONTINUE ! 270 DO 280 K = 1, L A(I,K) = SCALE * A(I,K) A(K,I) = SCALE * A(K,I) 280 CONTINUE ! TAU(2,L) = -SI 290 D(I) = A(I,I) A(I,I) = SCALE * SQRT(H) 300 CONTINUE ! return end subroutine HTRIDI (NM, N, AR, AI, D, E, E2, TAU) ! !! HTRIDI reduces a complex Hermitian matrix to a real symmetric ... ! tridiagonal matrix using unitary similarity ! transformations. !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B1 !***TYPE SINGLE PRECISION (HTRIDI-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of a complex analogue of ! the ALGOL procedure TRED1, NUM. MATH. 11, 181-195(1968) ! by Martin, Reinsch, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). ! ! This subroutine reduces a COMPLEX HERMITIAN matrix ! to a real symmetric tridiagonal matrix using ! unitary similarity transformations. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, AR and AI, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A=(AR,AI). N is an INTEGER ! variable. N must be less than or equal to NM. ! ! AR and AI contain the real and imaginary parts, respectively, ! of the complex Hermitian input matrix. Only the lower ! triangle of the matrix need be supplied. AR and AI are two- ! dimensional REAL arrays, dimensioned AR(NM,N) and AI(NM,N). ! ! On OUTPUT ! ! AR and AI contain some information about the unitary trans- ! formations used in the reduction in the strict lower triangle ! of AR and the full lower triangle of AI. The rest of the ! matrices are unaltered. ! ! D contains the diagonal elements of the real symmetric ! tridiagonal matrix. D is a one-dimensional REAL array, ! dimensioned D(N). ! ! E contains the subdiagonal elements of the real tridiagonal ! matrix in its last N-1 positions. E(1) is set to zero. ! E is a one-dimensional REAL array, dimensioned E(N). ! ! E2 contains the squares of the corresponding elements of E. ! E2(1) is set to zero. E2 may coincide with E if the squares ! are not needed. E2 is a one-dimensional REAL array, ! dimensioned E2(N). ! ! TAU contains further information about the transformations. ! TAU is a one-dimensional REAL array, dimensioned TAU(2,N). ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HTRIDI ! INTEGER I,J,K,L,N,II,NM,JP1 REAL AR(NM,*),AI(NM,*),D(*),E(*),E2(*),TAU(2,*) REAL F,G,H,FI,GI,HH,SI,SCALE REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT HTRIDI TAU(1,N) = 1.0E0 TAU(2,N) = 0.0E0 ! DO 100 I = 1, N 100 D(I) = AR(I,I) ! .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... DO 300 II = 1, N I = N + 1 - II L = I - 1 H = 0.0E0 SCALE = 0.0E0 if (L < 1) go to 130 ! .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... DO 120 K = 1, L 120 SCALE = SCALE + ABS(AR(I,K)) + ABS(AI(I,K)) ! if (SCALE /= 0.0E0) go to 140 TAU(1,L) = 1.0E0 TAU(2,L) = 0.0E0 130 E(I) = 0.0E0 E2(I) = 0.0E0 go to 290 ! 140 DO 150 K = 1, L AR(I,K) = AR(I,K) / SCALE AI(I,K) = AI(I,K) / SCALE H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K) 150 CONTINUE ! E2(I) = SCALE * SCALE * H G = SQRT(H) E(I) = SCALE * G F = PYTHAG(AR(I,L),AI(I,L)) ! .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... if (F == 0.0E0) go to 160 TAU(1,L) = (AI(I,L) * TAU(2,I) - AR(I,L) * TAU(1,I)) / F SI = (AR(I,L) * TAU(2,I) + AI(I,L) * TAU(1,I)) / F H = H + F * G G = 1.0E0 + G / F AR(I,L) = G * AR(I,L) AI(I,L) = G * AI(I,L) if (L == 1) go to 270 go to 170 160 TAU(1,L) = -TAU(1,I) SI = TAU(2,I) AR(I,L) = G 170 F = 0.0E0 ! DO 240 J = 1, L G = 0.0E0 GI = 0.0E0 ! .......... FORM ELEMENT OF A*U .......... DO 180 K = 1, J G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K) GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K) 180 CONTINUE ! JP1 = J + 1 if (L < JP1) go to 220 ! DO 200 K = JP1, L G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K) GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K) 200 CONTINUE ! .......... FORM ELEMENT OF P .......... 220 E(J) = G / H TAU(2,J) = GI / H F = F + E(J) * AR(I,J) - TAU(2,J) * AI(I,J) 240 CONTINUE ! HH = F / (H + H) ! .......... FORM REDUCED A .......... DO 260 J = 1, L F = AR(I,J) G = E(J) - HH * F E(J) = G FI = -AI(I,J) GI = TAU(2,J) - HH * FI TAU(2,J) = -GI ! DO 260 K = 1, J AR(J,K) = AR(J,K) - F * E(K) - G * AR(I,K) & + FI * TAU(2,K) + GI * AI(I,K) AI(J,K) = AI(J,K) - F * TAU(2,K) - G * AI(I,K) & - FI * E(K) - GI * AR(I,K) 260 CONTINUE ! 270 DO 280 K = 1, L AR(I,K) = SCALE * AR(I,K) AI(I,K) = SCALE * AI(I,K) 280 CONTINUE ! TAU(2,L) = -SI 290 HH = D(I) D(I) = AR(I,I) AR(I,I) = HH AI(I,I) = SCALE * SQRT(H) 300 CONTINUE ! return end function HVNRM (V, NCOMP) ! !! HVNRM is subsidiary to DEABM, DEBDF and DERKF. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (HVNRM-S, DHVNRM-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! Compute the maximum norm of the vector V(*) of length NCOMP and ! return the result as HVNRM. ! !***SEE ALSO DEABM, DEBDF, DERKF !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891024 Changed routine name from VNORM to HVNRM. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE HVNRM DIMENSION V(*) !***FIRST EXECUTABLE STATEMENT HVNRM HVNRM=0. DO 10 K=1,NCOMP 10 HVNRM=MAX(HVNRM,ABS(V(K))) return end subroutine HW3CRT (XS, XF, L, LBDCND, BDXS, BDXF, YS, YF, M, & MBDCND, BDYS, BDYF, ZS, ZF, N, NBDCND, BDZS, BDZF, ELMBDA, & LDIMF, MDIMF, F, PERTRB, IERROR, W) ! !! HW3CRT solves the standard seven-point finite difference ... ! approximation to the Helmholtz equation in Cartesian ! coordinates. !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HW3CRT-S) !***KEYWORDS CARTESIAN, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine HW3CRT solves the standard seven-point finite ! difference approximation to the Helmholtz equation in Cartesian ! coordinates: ! ! (d/dX)(dU/dX) + (d/dY)(dU/dY) + (d/dZ)(dU/dZ) ! ! + LAMBDA*U = F(X,Y,Z) . ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! ! * * * * * * On Input * * * * * * ! ! XS,XF ! The range of X, i.e. XS <= X <= XF . ! XS must be less than XF. ! ! L ! The number of panels into which the interval (XS,XF) is ! subdivided. Hence, there will be L+1 grid points in the ! X-direction given by X(I) = XS+(I-1)DX for I=1,2,...,L+1, ! where DX = (XF-XS)/L is the panel width. L must be at ! least 5 . ! ! LBDCND ! Indicates the type of boundary conditions at X = XS and X = XF. ! ! = 0 If the solution is periodic in X, i.e. ! U(L+I,J,K) = U(I,J,K). ! = 1 If the solution is specified at X = XS and X = XF. ! = 2 If the solution is specified at X = XS and the derivative ! of the solution with respect to X is specified at X = XF. ! = 3 If the derivative of the solution with respect to X is ! specified at X = XS and X = XF. ! = 4 If the derivative of the solution with respect to X is ! specified at X = XS and the solution is specified at X=XF. ! ! BDXS ! A two-dimensional array that specifies the values of the ! derivative of the solution with respect to X at X = XS. ! when LBDCND = 3 or 4, ! ! BDXS(J,K) = (d/dX)U(XS,Y(J),Z(K)), J=1,2,...,M+1, ! K=1,2,...,N+1. ! ! When LBDCND has any other value, BDXS is a dummy variable. ! BDXS must be dimensioned at least (M+1)*(N+1). ! ! BDXF ! A two-dimensional array that specifies the values of the ! derivative of the solution with respect to X at X = XF. ! When LBDCND = 2 or 3, ! ! BDXF(J,K) = (d/dX)U(XF,Y(J),Z(K)), J=1,2,...,M+1, ! K=1,2,...,N+1. ! ! When LBDCND has any other value, BDXF is a dummy variable. ! BDXF must be dimensioned at least (M+1)*(N+1). ! ! YS,YF ! The range of Y, i.e. YS <= Y <= YF. ! YS must be less than YF. ! ! M ! The number of panels into which the interval (YS,YF) is ! subdivided. Hence, there will be M+1 grid points in the ! Y-direction given by Y(J) = YS+(J-1)DY for J=1,2,...,M+1, ! where DY = (YF-YS)/M is the panel width. M must be at ! least 5 . ! ! MBDCND ! Indicates the type of boundary conditions at Y = YS and Y = YF. ! ! = 0 If the solution is periodic in Y, i.e. ! U(I,M+J,K) = U(I,J,K). ! = 1 If the solution is specified at Y = YS and Y = YF. ! = 2 If the solution is specified at Y = YS and the derivative ! of the solution with respect to Y is specified at Y = YF. ! = 3 If the derivative of the solution with respect to Y is ! specified at Y = YS and Y = YF. ! = 4 If the derivative of the solution with respect to Y is ! specified at Y = YS and the solution is specified at Y=YF. ! ! BDYS ! A two-dimensional array that specifies the values of the ! derivative of the solution with respect to Y at Y = YS. ! When MBDCND = 3 or 4, ! ! BDYS(I,K) = (d/dY)U(X(I),YS,Z(K)), I=1,2,...,L+1, ! K=1,2,...,N+1. ! ! When MBDCND has any other value, BDYS is a dummy variable. ! BDYS must be dimensioned at least (L+1)*(N+1). ! ! BDYF ! A two-dimensional array that specifies the values of the ! derivative of the solution with respect to Y at Y = YF. ! When MBDCND = 2 or 3, ! ! BDYF(I,K) = (d/dY)U(X(I),YF,Z(K)), I=1,2,...,L+1, ! K=1,2,...,N+1. ! ! When MBDCND has any other value, BDYF is a dummy variable. ! BDYF must be dimensioned at least (L+1)*(N+1). ! ! ZS,ZF ! The range of Z, i.e. ZS <= Z <= ZF. ! ZS must be less than ZF. ! ! N ! The number of panels into which the interval (ZS,ZF) is ! subdivided. Hence, there will be N+1 grid points in the ! Z-direction given by Z(K) = ZS+(K-1)DZ for K=1,2,...,N+1, ! where DZ = (ZF-ZS)/N is the panel width. N must be at least 5. ! ! NBDCND ! Indicates the type of boundary conditions at Z = ZS and Z = ZF. ! ! = 0 If the solution is periodic in Z, i.e. ! U(I,J,N+K) = U(I,J,K). ! = 1 If the solution is specified at Z = ZS and Z = ZF. ! = 2 If the solution is specified at Z = ZS and the derivative ! of the solution with respect to Z is specified at Z = ZF. ! = 3 If the derivative of the solution with respect to Z is ! specified at Z = ZS and Z = ZF. ! = 4 If the derivative of the solution with respect to Z is ! specified at Z = ZS and the solution is specified at Z=ZF. ! ! BDZS ! A two-dimensional array that specifies the values of the ! derivative of the solution with respect to Z at Z = ZS. ! When NBDCND = 3 or 4, ! ! BDZS(I,J) = (d/dZ)U(X(I),Y(J),ZS), I=1,2,...,L+1, ! J=1,2,...,M+1. ! ! When NBDCND has any other value, BDZS is a dummy variable. ! BDZS must be dimensioned at least (L+1)*(M+1). ! ! BDZF ! A two-dimensional array that specifies the values of the ! derivative of the solution with respect to Z at Z = ZF. ! When NBDCND = 2 or 3, ! ! BDZF(I,J) = (d/dZ)U(X(I),Y(J),ZF), I=1,2,...,L+1, ! J=1,2,...,M+1. ! ! When NBDCND has any other value, BDZF is a dummy variable. ! BDZF must be dimensioned at least (L+1)*(M+1). ! ! ELMBDA ! The constant LAMBDA in the Helmholtz equation. If ! LAMBDA > 0, a solution may not exist. However, HW3CRT will ! attempt to find a solution. ! ! F ! A three-dimensional array that specifies the values of the ! right side of the Helmholtz equation and boundary values (if ! any). For I=2,3,...,L, J=2,3,...,M, and K=2,3,...,N ! ! F(I,J,K) = F(X(I),Y(J),Z(K)). ! ! On the boundaries F is defined by ! ! LBDCND F(1,J,K) F(L+1,J,K) ! ------ --------------- --------------- ! ! 0 F(XS,Y(J),Z(K)) F(XS,Y(J),Z(K)) ! 1 U(XS,Y(J),Z(K)) U(XF,Y(J),Z(K)) ! 2 U(XS,Y(J),Z(K)) F(XF,Y(J),Z(K)) J=1,2,...,M+1 ! 3 F(XS,Y(J),Z(K)) F(XF,Y(J),Z(K)) K=1,2,...,N+1 ! 4 F(XS,Y(J),Z(K)) U(XF,Y(J),Z(K)) ! ! MBDCND F(I,1,K) F(I,M+1,K) ! ------ --------------- --------------- ! ! 0 F(X(I),YS,Z(K)) F(X(I),YS,Z(K)) ! 1 U(X(I),YS,Z(K)) U(X(I),YF,Z(K)) ! 2 U(X(I),YS,Z(K)) F(X(I),YF,Z(K)) I=1,2,...,L+1 ! 3 F(X(I),YS,Z(K)) F(X(I),YF,Z(K)) K=1,2,...,N+1 ! 4 F(X(I),YS,Z(K)) U(X(I),YF,Z(K)) ! ! NBDCND F(I,J,1) F(I,J,N+1) ! ------ --------------- --------------- ! ! 0 F(X(I),Y(J),ZS) F(X(I),Y(J),ZS) ! 1 U(X(I),Y(J),ZS) U(X(I),Y(J),ZF) ! 2 U(X(I),Y(J),ZS) F(X(I),Y(J),ZF) I=1,2,...,L+1 ! 3 F(X(I),Y(J),ZS) F(X(I),Y(J),ZF) J=1,2,...,M+1 ! 4 F(X(I),Y(J),ZS) U(X(I),Y(J),ZF) ! ! F must be dimensioned at least (L+1)*(M+1)*(N+1). ! ! NOTE: ! ! If the table calls for both the solution U and the right side F ! on a boundary, then the solution must be specified. ! ! LDIMF ! The row (or first) dimension of the arrays F,BDYS,BDYF,BDZS, ! and BDZF as it appears in the program calling HW3CRT. this ! parameter is used to specify the variable dimension of these ! arrays. LDIMF must be at least L+1. ! ! MDIMF ! The column (or second) dimension of the array F and the row (or ! first) dimension of the arrays BDXS and BDXF as it appears in ! the program calling HW3CRT. This parameter is used to specify ! the variable dimension of these arrays. ! MDIMF must be at least M+1. ! ! W ! A one-dimensional array that must be provided by the user for ! work space. The length of W must be at least 30 + L + M + 5*N ! + MAX(L,M,N) + 7*(INT((L+1)/2) + INT((M+1)/2)) ! ! ! * * * * * * On Output * * * * * * ! ! F ! Contains the solution U(I,J,K) of the finite difference ! approximation for the grid point (X(I),Y(J),Z(K)) for ! I=1,2,...,L+1, J=1,2,...,M+1, and K=1,2,...,N+1. ! ! PERTRB ! If a combination of periodic or derivative boundary conditions ! is specified for a Poisson equation (LAMBDA = 0), a solution ! may not exist. PERTRB is a constant, calculated and subtracted ! from F, which ensures that a solution exists. PWSCRT then ! computes this solution, which is a least squares solution to ! the original approximation. This solution is not unique and is ! unnormalized. The value of PERTRB should be small compared to ! the right side F. Otherwise, a solution is obtained to an ! essentially different problem. This comparison should always ! be made to insure that a meaningful solution has been obtained. ! ! IERROR ! An error flag that indicates invalid input parameters. Except ! for numbers 0 and 12, a solution is not attempted. ! ! = 0 No error ! = 1 XS >= XF ! = 2 L < 5 ! = 3 LBDCND < 0 .OR. LBDCND > 4 ! = 4 YS >= YF ! = 5 M < 5 ! = 6 MBDCND < 0 .OR. MBDCND > 4 ! = 7 ZS >= ZF ! = 8 N < 5 ! = 9 NBDCND < 0 .OR. NBDCND > 4 ! = 10 LDIMF < L+1 ! = 11 MDIMF < M+1 ! = 12 LAMBDA > 0 ! ! Since this is the only means of indicating a possibly incorrect ! call to HW3CRT, the user should test IERROR after the call. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of BDXS(MDIMF,N+1),BDXF(MDIMF,N+1),BDYS(LDIMF,N+1), ! Arguments BDYF(LDIMF,N+1),BDZS(LDIMF,M+1),BDZF(LDIMF,M+1), ! F(LDIMF,MDIMF,N+1),W(see argument list) ! ! Latest December 1, 1978 ! Revision ! ! Subprograms HW3CRT,POIS3D,POS3D1,TRIDQ,RFFTI,RFFTF,RFFTF1, ! Required RFFTB,RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF, ! COSQF1,COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI, ! CFFTI1,CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB, ! CFFTF,CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF, ! PIMACH ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Written by Roland Sweet at NCAR in July 1977 ! ! Algorithm This subroutine defines the finite difference ! equations, incorporates boundary data, and ! adjusts the right side of singular systems and ! then calls POIS3D to solve the system. ! ! Space 7862(decimal) = 17300(octal) locations on the ! Required NCAR Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine HW3CRT is roughly proportional ! to L*M*N*(log2(L)+log2(M)+5), but also depends on ! input parameters LBDCND and MBDCND. Some typical ! values are listed in the table below. ! The solution process employed results in a loss ! of no more than three significant digits for L,M ! and N as large as 32. More detailed information ! about accuracy can be found in the documentation ! for subroutine POIS3D which is the routine that ! actually solves the finite difference equations. ! ! ! L(=M=N) LBDCND(=MBDCND=NBDCND) T(MSECS) ! ------- ---------------------- -------- ! ! 16 0 300 ! 16 1 302 ! 16 3 348 ! 32 0 1925 ! 32 1 1929 ! 32 3 2109 ! ! Portability American National Standards Institute FORTRAN. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS,SIN,ATAN ! Resident ! Routines ! ! Reference NONE ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES (NONE) !***ROUTINES CALLED POIS3D !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE HW3CRT ! ! DIMENSION BDXS(MDIMF,*) ,BDXF(MDIMF,*) , & BDYS(LDIMF,*) ,BDYF(LDIMF,*) , & BDZS(LDIMF,*) ,BDZF(LDIMF,*) , & F(LDIMF,MDIMF,*) ,W(*) !***FIRST EXECUTABLE STATEMENT HW3CRT IERROR = 0 if (XF <= XS) IERROR = 1 if (L < 5) IERROR = 2 if (LBDCND < 0 .OR. LBDCND > 4) IERROR = 3 if (YF <= YS) IERROR = 4 if (M < 5) IERROR = 5 if (MBDCND < 0 .OR. MBDCND > 4) IERROR = 6 if (ZF <= ZS) IERROR = 7 if (N < 5) IERROR = 8 if (NBDCND < 0 .OR. NBDCND > 4) IERROR = 9 if (LDIMF < L+1) IERROR = 10 if (MDIMF < M+1) IERROR = 11 if (IERROR /= 0) go to 188 DY = (YF-YS)/M TWBYDY = 2./DY C2 = 1./(DY**2) MSTART = 1 MSTOP = M MP1 = M+1 MP = MBDCND+1 go to (104,101,101,102,102),MP 101 MSTART = 2 102 go to (104,104,103,103,104),MP 103 MSTOP = MP1 104 MUNK = MSTOP-MSTART+1 DZ = (ZF-ZS)/N TWBYDZ = 2./DZ NP = NBDCND+1 C3 = 1./(DZ**2) NP1 = N+1 NSTART = 1 NSTOP = N go to (108,105,105,106,106),NP 105 NSTART = 2 106 go to (108,108,107,107,108),NP 107 NSTOP = NP1 108 NUNK = NSTOP-NSTART+1 LP1 = L+1 DX = (XF-XS)/L C1 = 1./(DX**2) TWBYDX = 2./DX LP = LBDCND+1 LSTART = 1 LSTOP = L ! ! ENTER BOUNDARY DATA FOR X-BOUNDARIES. ! go to (122,109,109,112,112),LP 109 LSTART = 2 DO 111 J=MSTART,MSTOP DO 110 K=NSTART,NSTOP F(2,J,K) = F(2,J,K)-C1*F(1,J,K) 110 CONTINUE 111 CONTINUE go to 115 112 DO 114 J=MSTART,MSTOP DO 113 K=NSTART,NSTOP F(1,J,K) = F(1,J,K)+TWBYDX*BDXS(J,K) 113 CONTINUE 114 CONTINUE 115 go to (122,116,119,119,116),LP 116 DO 118 J=MSTART,MSTOP DO 117 K=NSTART,NSTOP F(L,J,K) = F(L,J,K)-C1*F(LP1,J,K) 117 CONTINUE 118 CONTINUE go to 122 119 LSTOP = LP1 DO 121 J=MSTART,MSTOP DO 120 K=NSTART,NSTOP F(LP1,J,K) = F(LP1,J,K)-TWBYDX*BDXF(J,K) 120 CONTINUE 121 CONTINUE 122 LUNK = LSTOP-LSTART+1 ! ! ENTER BOUNDARY DATA FOR Y-BOUNDARIES. ! go to (136,123,123,126,126),MP 123 DO 125 I=LSTART,LSTOP DO 124 K=NSTART,NSTOP F(I,2,K) = F(I,2,K)-C2*F(I,1,K) 124 CONTINUE 125 CONTINUE go to 129 126 DO 128 I=LSTART,LSTOP DO 127 K=NSTART,NSTOP F(I,1,K) = F(I,1,K)+TWBYDY*BDYS(I,K) 127 CONTINUE 128 CONTINUE 129 go to (136,130,133,133,130),MP 130 DO 132 I=LSTART,LSTOP DO 131 K=NSTART,NSTOP F(I,M,K) = F(I,M,K)-C2*F(I,MP1,K) 131 CONTINUE 132 CONTINUE go to 136 133 DO 135 I=LSTART,LSTOP DO 134 K=NSTART,NSTOP F(I,MP1,K) = F(I,MP1,K)-TWBYDY*BDYF(I,K) 134 CONTINUE 135 CONTINUE 136 CONTINUE ! ! ENTER BOUNDARY DATA FOR Z-BOUNDARIES. ! go to (150,137,137,140,140),NP 137 DO 139 I=LSTART,LSTOP DO 138 J=MSTART,MSTOP F(I,J,2) = F(I,J,2)-C3*F(I,J,1) 138 CONTINUE 139 CONTINUE go to 143 140 DO 142 I=LSTART,LSTOP DO 141 J=MSTART,MSTOP F(I,J,1) = F(I,J,1)+TWBYDZ*BDZS(I,J) 141 CONTINUE 142 CONTINUE 143 go to (150,144,147,147,144),NP 144 DO 146 I=LSTART,LSTOP DO 145 J=MSTART,MSTOP F(I,J,N) = F(I,J,N)-C3*F(I,J,NP1) 145 CONTINUE 146 CONTINUE go to 150 147 DO 149 I=LSTART,LSTOP DO 148 J=MSTART,MSTOP F(I,J,NP1) = F(I,J,NP1)-TWBYDZ*BDZF(I,J) 148 CONTINUE 149 CONTINUE ! ! DEFINE A,B,C COEFFICIENTS IN W-ARRAY. ! 150 CONTINUE IWB = NUNK+1 IWC = IWB+NUNK IWW = IWC+NUNK DO 151 K=1,NUNK I = IWC+K-1 W(K) = C3 W(I) = C3 I = IWB+K-1 W(I) = -2.*C3+ELMBDA 151 CONTINUE go to (155,155,153,152,152),NP 152 W(IWC) = 2.*C3 153 go to (155,155,154,154,155),NP 154 W(IWB-1) = 2.*C3 155 CONTINUE PERTRB = 0. ! ! FOR SINGULAR PROBLEMS ADJUST DATA TO INSURE A SOLUTION WILL EXIST. ! go to (156,172,172,156,172),LP 156 go to (157,172,172,157,172),MP 157 go to (158,172,172,158,172),NP 158 if (ELMBDA) 172,160,159 159 IERROR = 12 go to 172 160 CONTINUE MSTPM1 = MSTOP-1 LSTPM1 = LSTOP-1 NSTPM1 = NSTOP-1 XLP = (2+LP)/3 YLP = (2+MP)/3 ZLP = (2+NP)/3 S1 = 0. DO 164 K=2,NSTPM1 DO 162 J=2,MSTPM1 DO 161 I=2,LSTPM1 S1 = S1+F(I,J,K) 161 CONTINUE S1 = S1+(F(1,J,K)+F(LSTOP,J,K))/XLP 162 CONTINUE S2 = 0. DO 163 I=2,LSTPM1 S2 = S2+F(I,1,K)+F(I,MSTOP,K) 163 CONTINUE S2 = (S2+(F(1,1,K)+F(1,MSTOP,K)+F(LSTOP,1,K)+F(LSTOP,MSTOP,K))/ & XLP)/YLP S1 = S1+S2 164 CONTINUE S = (F(1,1,1)+F(LSTOP,1,1)+F(1,1,NSTOP)+F(LSTOP,1,NSTOP)+ & F(1,MSTOP,1)+F(LSTOP,MSTOP,1)+F(1,MSTOP,NSTOP)+ & F(LSTOP,MSTOP,NSTOP))/(XLP*YLP) DO 166 J=2,MSTPM1 DO 165 I=2,LSTPM1 S = S+F(I,J,1)+F(I,J,NSTOP) 165 CONTINUE 166 CONTINUE S2 = 0. DO 167 I=2,LSTPM1 S2 = S2+F(I,1,1)+F(I,1,NSTOP)+F(I,MSTOP,1)+F(I,MSTOP,NSTOP) 167 CONTINUE S = S2/YLP+S S2 = 0. DO 168 J=2,MSTPM1 S2 = S2+F(1,J,1)+F(1,J,NSTOP)+F(LSTOP,J,1)+F(LSTOP,J,NSTOP) 168 CONTINUE S = S2/XLP+S PERTRB = (S/ZLP+S1)/((LUNK+1.-XLP)*(MUNK+1.-YLP)* & (NUNK+1.-ZLP)) DO 171 I=1,LUNK DO 170 J=1,MUNK DO 169 K=1,NUNK F(I,J,K) = F(I,J,K)-PERTRB 169 CONTINUE 170 CONTINUE 171 CONTINUE 172 CONTINUE NPEROD = 0 if (NBDCND == 0) go to 173 NPEROD = 1 W(1) = 0. W(IWW-1) = 0. 173 CONTINUE call POIS3D (LBDCND,LUNK,C1,MBDCND,MUNK,C2,NPEROD,NUNK,W,W(IWB), & W(IWC),LDIMF,MDIMF,F(LSTART,MSTART,NSTART),IR,W(IWW)) ! ! FILL IN SIDES FOR PERIODIC BOUNDARY CONDITIONS. ! if (LP /= 1) go to 180 if (MP /= 1) go to 175 DO 174 K=NSTART,NSTOP F(1,MP1,K) = F(1,1,K) 174 CONTINUE MSTOP = MP1 175 if (NP /= 1) go to 177 DO 176 J=MSTART,MSTOP F(1,J,NP1) = F(1,J,1) 176 CONTINUE NSTOP = NP1 177 DO 179 J=MSTART,MSTOP DO 178 K=NSTART,NSTOP F(LP1,J,K) = F(1,J,K) 178 CONTINUE 179 CONTINUE 180 CONTINUE if (MP /= 1) go to 185 if (NP /= 1) go to 182 DO 181 I=LSTART,LSTOP F(I,1,NP1) = F(I,1,1) 181 CONTINUE NSTOP = NP1 182 DO 184 I=LSTART,LSTOP DO 183 K=NSTART,NSTOP F(I,MP1,K) = F(I,1,K) 183 CONTINUE 184 CONTINUE 185 CONTINUE if (NP /= 1) go to 188 DO 187 I=LSTART,LSTOP DO 186 J=MSTART,MSTOP F(I,J,NP1) = F(I,J,1) 186 CONTINUE 187 CONTINUE 188 CONTINUE return end subroutine HWSCRT (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, & BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) ! !! HWSCRT solves the standard five-point finite difference ... ! approximation to the Helmholtz equation in Cartesian ! coordinates. !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HWSCRT-S) !***KEYWORDS CARTESIAN, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine HWSCRT solves the standard five-point finite ! difference approximation to the Helmholtz equation in Cartesian ! coordinates: ! ! (d/dX)(dU/dX) + (d/dY)(dU/dY) + LAMBDA*U = F(X,Y). ! ! ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! A,B ! The range of X, i.e., A <= X <= B. A must be less than B. ! ! M ! The number of panels into which the interval (A,B) is ! subdivided. Hence, there will be M+1 grid points in the ! X-direction given by X(I) = A+(I-1)DX for I = 1,2,...,M+1, ! where DX = (B-A)/M is the panel width. M must be greater than 3. ! ! MBDCND ! Indicates the type of boundary conditions at X = A and X = B. ! ! = 0 If the solution is periodic in X, i.e., U(I,J) = U(M+I,J). ! = 1 If the solution is specified at X = A and X = B. ! = 2 If the solution is specified at X = A and the derivative of ! the solution with respect to X is specified at X = B. ! = 3 If the derivative of the solution with respect to X is ! specified at X = A and X = B. ! = 4 If the derivative of the solution with respect to X is ! specified at X = A and the solution is specified at X = B. ! ! BDA ! A one-dimensional array of length N+1 that specifies the values ! of the derivative of the solution with respect to X at X = A. ! When MBDCND = 3 or 4, ! ! BDA(J) = (d/dX)U(A,Y(J)), J = 1,2,...,N+1 . ! ! When MBDCND has any other value, BDA is a dummy variable. ! ! BDB ! A one-dimensional array of length N+1 that specifies the values ! of the derivative of the solution with respect to X at X = B. ! When MBDCND = 2 or 3, ! ! BDB(J) = (d/dX)U(B,Y(J)), J = 1,2,...,N+1 . ! ! When MBDCND has any other value BDB is a dummy variable. ! ! C,D ! The range of Y, i.e., C <= Y <= D. C must be less than D. ! ! N ! The number of panels into which the interval (C,D) is ! subdivided. Hence, there will be N+1 grid points in the ! Y-direction given by Y(J) = C+(J-1)DY for J = 1,2,...,N+1, where ! DY = (D-C)/N is the panel width. N must be greater than 3. ! ! NBDCND ! Indicates the type of boundary conditions at Y = C and Y = D. ! ! = 0 If the solution is periodic in Y, i.e., U(I,J) = U(I,N+J). ! = 1 If the solution is specified at Y = C and Y = D. ! = 2 If the solution is specified at Y = C and the derivative of ! the solution with respect to Y is specified at Y = D. ! = 3 If the derivative of the solution with respect to Y is ! specified at Y = C and Y = D. ! = 4 If the derivative of the solution with respect to Y is ! specified at Y = C and the solution is specified at Y = D. ! ! BDC ! A one-dimensional array of length M+1 that specifies the values ! of the derivative of the solution with respect to Y at Y = C. ! When NBDCND = 3 or 4, ! ! BDC(I) = (d/dY)U(X(I),C), I = 1,2,...,M+1 . ! ! When NBDCND has any other value, BDC is a dummy variable. ! ! BDD ! A one-dimensional array of length M+1 that specifies the values ! of the derivative of the solution with respect to Y at Y = D. ! When NBDCND = 2 or 3, ! ! BDD(I) = (d/dY)U(X(I),D), I = 1,2,...,M+1 . ! ! When NBDCND has any other value, BDD is a dummy variable. ! ! ELMBDA ! The constant LAMBDA in the Helmholtz equation. If ! LAMBDA > 0, a solution may not exist. However, HWSCRT will ! attempt to find a solution. ! ! F ! A two-dimensional array which specifies the values of the right ! side of the Helmholtz equation and boundary values (if any). ! For I = 2,3,...,M and J = 2,3,...,N ! ! F(I,J) = F(X(I),Y(J)). ! ! On the boundaries F is defined by ! ! MBDCND F(1,J) F(M+1,J) ! ------ --------- -------- ! ! 0 F(A,Y(J)) F(A,Y(J)) ! 1 U(A,Y(J)) U(B,Y(J)) ! 2 U(A,Y(J)) F(B,Y(J)) J = 1,2,...,N+1 ! 3 F(A,Y(J)) F(B,Y(J)) ! 4 F(A,Y(J)) U(B,Y(J)) ! ! ! NBDCND F(I,1) F(I,N+1) ! ------ --------- -------- ! ! 0 F(X(I),C) F(X(I),C) ! 1 U(X(I),C) U(X(I),D) ! 2 U(X(I),C) F(X(I),D) I = 1,2,...,M+1 ! 3 F(X(I),C) F(X(I),D) ! 4 F(X(I),C) U(X(I),D) ! ! F must be dimensioned at least (M+1)*(N+1). ! ! NOTE: ! ! If the table calls for both the solution U and the right side F ! at a corner then the solution must be specified. ! ! IDIMF ! The row (or first) dimension of the array F as it appears in the ! program calling HWSCRT. This parameter is used to specify the ! variable dimension of F. IDIMF must be at least M+1 . ! ! W ! A one-dimensional array that must be provided by the user for ! work space. W may require up to 4*(N+1) + ! (13 + INT(log2(N+1)))*(M+1) locations. The actual number of ! locations used is computed by HWSCRT and is returned in location ! W(1). ! ! ! * * * * * * On Output * * * * * * ! ! F ! Contains the solution U(I,J) of the finite difference ! approximation for the grid point (X(I),Y(J)), I = 1,2,...,M+1, ! J = 1,2,...,N+1 . ! ! PERTRB ! If a combination of periodic or derivative boundary conditions ! is specified for a Poisson equation (LAMBDA = 0), a solution may ! not exist. PERTRB is a constant, calculated and subtracted from ! F, which ensures that a solution exists. HWSCRT then computes ! this solution, which is a least squares solution to the original ! approximation. This solution plus any constant is also a ! solution. Hence, the solution is not unique. The value of ! PERTRB should be small compared to the right side F. Otherwise, ! a solution is obtained to an essentially different problem. ! This comparison should always be made to insure that a ! meaningful solution has been obtained. ! ! IERROR ! An error flag that indicates invalid input parameters. Except ! for numbers 0 and 6, a solution is not attempted. ! ! = 0 No error. ! = 1 A >= B. ! = 2 MBDCND < 0 or MBDCND > 4 . ! = 3 C >= D. ! = 4 N <= 3 ! = 5 NBDCND < 0 or NBDCND > 4 . ! = 6 LAMBDA > 0 . ! = 7 IDIMF < M+1 . ! = 8 M <= 3 ! ! Since this is the only means of indicating a possibly incorrect ! call to HWSCRT, the user should test IERROR after the call. ! ! W ! W(1) contains the required length of W. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! ! Dimension of BDA(N+1),BDB(N+1),BDC(M+1),BDD(M+1),F(IDIMF,N+1), ! Arguments W(see argument list) ! ! Latest June 1, 1976 ! Revision ! ! Subprograms HWSCRT,GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE, ! Required TRIX,TRI3,PIMACH ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Standardized September 1, 1973 ! Revised April 1, 1976 ! ! Algorithm The routine defines the finite difference ! equations, incorporates boundary data, and adjusts ! the right side of singular systems and then calls ! GENBUN to solve the system. ! ! Space 13110(octal) = 5704(decimal) locations on the NCAR ! Required Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine HWSCRT is roughly proportional ! to M*N*log2(N), but also depends on the input ! parameters NBDCND and MBDCND. Some typical values ! are listed in the table below. ! The solution process employed results in a loss ! of no more than three significant digits for N and ! M as large as 64. More detailed information about ! accuracy can be found in the documentation for ! subroutine GENBUN which is the routine that ! solves the finite difference equations. ! ! ! M(=N) MBDCND NBDCND T(MSECS) ! ----- ------ ------ -------- ! ! 32 0 0 31 ! 32 1 1 23 ! 32 3 3 36 ! 64 0 0 128 ! 64 1 1 96 ! 64 3 3 142 ! ! Portability American National Standards Institute FORTRAN. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Reference Swarztrauber, P. and R. Sweet, 'Efficient FORTRAN ! Subprograms for The Solution Of Elliptic Equations' ! NCAR TN/IA-109, July, 1975, 138 pp. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran ! subprograms for the solution of elliptic equations, ! NCAR TN/IA-109, July 1975, 138 pp. !***ROUTINES CALLED GENBUN !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HWSCRT ! ! DIMENSION F(IDIMF,*) DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , & W(*) !***FIRST EXECUTABLE STATEMENT HWSCRT IERROR = 0 if (A >= B) IERROR = 1 if (MBDCND < 0 .OR. MBDCND > 4) IERROR = 2 if (C >= D) IERROR = 3 if (N <= 3) IERROR = 4 if (NBDCND < 0 .OR. NBDCND > 4) IERROR = 5 if (IDIMF < M+1) IERROR = 7 if (M <= 3) IERROR = 8 if (IERROR /= 0) RETURN NPEROD = NBDCND MPEROD = 0 if (MBDCND > 0) MPEROD = 1 DELTAX = (B-A)/M TWDELX = 2./DELTAX DELXSQ = 1./DELTAX**2 DELTAY = (D-C)/N TWDELY = 2./DELTAY DELYSQ = 1./DELTAY**2 NP = NBDCND+1 NP1 = N+1 MP = MBDCND+1 MP1 = M+1 NSTART = 1 NSTOP = N NSKIP = 1 go to (104,101,102,103,104),NP 101 NSTART = 2 go to 104 102 NSTART = 2 103 NSTOP = NP1 NSKIP = 2 104 NUNK = NSTOP-NSTART+1 ! ! ENTER BOUNDARY DATA FOR X-BOUNDARIES. ! MSTART = 1 MSTOP = M MSKIP = 1 go to (117,105,106,109,110),MP 105 MSTART = 2 go to 107 106 MSTART = 2 MSTOP = MP1 MSKIP = 2 107 DO 108 J=NSTART,NSTOP F(2,J) = F(2,J)-F(1,J)*DELXSQ 108 CONTINUE go to 112 109 MSTOP = MP1 MSKIP = 2 110 DO 111 J=NSTART,NSTOP F(1,J) = F(1,J)+BDA(J)*TWDELX 111 CONTINUE 112 go to (113,115),MSKIP 113 DO 114 J=NSTART,NSTOP F(M,J) = F(M,J)-F(MP1,J)*DELXSQ 114 CONTINUE go to 117 115 DO 116 J=NSTART,NSTOP F(MP1,J) = F(MP1,J)-BDB(J)*TWDELX 116 CONTINUE 117 MUNK = MSTOP-MSTART+1 ! ! ENTER BOUNDARY DATA FOR Y-BOUNDARIES. ! go to (127,118,118,120,120),NP 118 DO 119 I=MSTART,MSTOP F(I,2) = F(I,2)-F(I,1)*DELYSQ 119 CONTINUE go to 122 120 DO 121 I=MSTART,MSTOP F(I,1) = F(I,1)+BDC(I)*TWDELY 121 CONTINUE 122 go to (123,125),NSKIP 123 DO 124 I=MSTART,MSTOP F(I,N) = F(I,N)-F(I,NP1)*DELYSQ 124 CONTINUE go to 127 125 DO 126 I=MSTART,MSTOP F(I,NP1) = F(I,NP1)-BDD(I)*TWDELY 126 CONTINUE ! ! MULTIPLY RIGHT SIDE BY DELTAY**2. ! 127 DELYSQ = DELTAY*DELTAY DO 129 I=MSTART,MSTOP DO 128 J=NSTART,NSTOP F(I,J) = F(I,J)*DELYSQ 128 CONTINUE 129 CONTINUE ! ! DEFINE THE A,B,C COEFFICIENTS IN W-ARRAY. ! ID2 = MUNK ID3 = ID2+MUNK ID4 = ID3+MUNK S = DELYSQ*DELXSQ ST2 = 2.*S DO 130 I=1,MUNK W(I) = S J = ID2+I W(J) = -ST2+ELMBDA*DELYSQ J = ID3+I W(J) = S 130 CONTINUE if (MP == 1) go to 131 W(1) = 0. W(ID4) = 0. 131 CONTINUE go to (135,135,132,133,134),MP 132 W(ID2) = ST2 go to 135 133 W(ID2) = ST2 134 W(ID3+1) = ST2 135 CONTINUE PERTRB = 0. if (ELMBDA) 144,137,136 136 IERROR = 6 go to 144 137 if ((NBDCND == 0 .OR. NBDCND == 3) .AND. & (MBDCND == 0 .OR. MBDCND == 3)) go to 138 go to 144 ! ! FOR SINGULAR PROBLEMS MUST ADJUST DATA TO INSURE THAT A SOLUTION ! WILL EXIST. ! 138 A1 = 1. A2 = 1. if (NBDCND == 3) A2 = 2. if (MBDCND == 3) A1 = 2. S1 = 0. MSP1 = MSTART+1 MSTM1 = MSTOP-1 NSP1 = NSTART+1 NSTM1 = NSTOP-1 DO 140 J=NSP1,NSTM1 S = 0. DO 139 I=MSP1,MSTM1 S = S+F(I,J) 139 CONTINUE S1 = S1+S*A1+F(MSTART,J)+F(MSTOP,J) 140 CONTINUE S1 = A2*S1 S = 0. DO 141 I=MSP1,MSTM1 S = S+F(I,NSTART)+F(I,NSTOP) 141 CONTINUE S1 = S1+S*A1+F(MSTART,NSTART)+F(MSTART,NSTOP)+F(MSTOP,NSTART)+ & F(MSTOP,NSTOP) S = (2.+(NUNK-2)*A2)*(2.+(MUNK-2)*A1) PERTRB = S1/S DO 143 J=NSTART,NSTOP DO 142 I=MSTART,MSTOP F(I,J) = F(I,J)-PERTRB 142 CONTINUE 143 CONTINUE PERTRB = PERTRB/DELYSQ ! ! SOLVE THE EQUATION. ! 144 call GENBUN (NPEROD,NUNK,MPEROD,MUNK,W(1),W(ID2+1),W(ID3+1), & IDIMF,F(MSTART,NSTART),IERR1,W(ID4+1)) W(1) = W(ID4+1)+3*MUNK ! ! FILL IN IDENTICAL VALUES WHEN HAVE PERIODIC BOUNDARY CONDITIONS. ! if (NBDCND /= 0) go to 146 DO 145 I=MSTART,MSTOP F(I,NP1) = F(I,1) 145 CONTINUE 146 if (MBDCND /= 0) go to 148 DO 147 J=NSTART,NSTOP F(MP1,J) = F(1,J) 147 CONTINUE if (NBDCND == 0) F(MP1,NP1) = F(1,NP1) 148 CONTINUE return end subroutine HWSCS1 (INTL, TS, TF, M, MBDCND, BDTS, BDTF, RS, RF, N, & NBDCND, BDRS, BDRF, ELMBDA, F, IDIMF, PERTRB, W, S, AN, BN, CN, & R, AM, BM, CM, SINT, BMH) ! !! HWSCS1 is subsidiary to HWSCSP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (HWSCS1-S) !***AUTHOR (UNKNOWN) !***SEE ALSO HWSCSP !***ROUTINES CALLED BLKTRI !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced variables. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE HWSCS1 DIMENSION F(IDIMF,*) ,BDRS(*) ,BDRF(*) ,BDTS(*) , & BDTF(*) ,AM(*) ,BM(*) ,CM(*) , & AN(*) ,BN(*) ,CN(*) ,S(*) , & R(*) ,SINT(*) ,BMH(*) ,W(*) !***FIRST EXECUTABLE STATEMENT HWSCS1 MP1 = M+1 DTH = (TF-TS)/M TDT = DTH+DTH HDTH = DTH/2. SDTS = 1./(DTH*DTH) DO 102 I=1,MP1 THETA = TS+(I-1)*DTH SINT(I) = SIN(THETA) if (SINT(I)) 101,102,101 101 T1 = SDTS/SINT(I) AM(I) = T1*SIN(THETA-HDTH) CM(I) = T1*SIN(THETA+HDTH) BM(I) = -(AM(I)+CM(I)) 102 CONTINUE NP1 = N+1 DR = (RF-RS)/N HDR = DR/2. TDR = DR+DR DR2 = DR*DR CZR = 6.*DTH/(DR2*(COS(TS)-COS(TF))) DO 103 J=1,NP1 R(J) = RS+(J-1)*DR AN(J) = (R(J)-HDR)**2/DR2 CN(J) = (R(J)+HDR)**2/DR2 BN(J) = -(AN(J)+CN(J)) 103 CONTINUE MP = 1 NP = 1 ! ! BOUNDARY CONDITION AT PHI=PS ! go to (104,104,105,105,106,106,104,105,106),MBDCND 104 AT = AM(2) ITS = 2 go to 107 105 AT = AM(1) ITS = 1 CM(1) = CM(1)+AM(1) go to 107 106 ITS = 1 BM(1) = -4.*SDTS CM(1) = -BM(1) ! ! BOUNDARY CONDITION AT PHI=PF ! 107 go to (108,109,109,108,108,109,110,110,110),MBDCND 108 CT = CM(M) ITF = M go to 111 109 CT = CM(M+1) AM(M+1) = AM(M+1)+CM(M+1) ITF = M+1 go to 111 110 ITF = M+1 AM(M+1) = 4.*SDTS BM(M+1) = -AM(M+1) 111 WTS = SINT(ITS+1)*AM(ITS+1)/CM(ITS) WTF = SINT(ITF-1)*CM(ITF-1)/AM(ITF) ITSP = ITS+1 ITFM = ITF-1 ! ! BOUNDARY CONDITION AT R=RS ! ICTR = 0 go to (112,112,113,113,114,114),NBDCND 112 AR = AN(2) JRS = 2 go to 118 113 AR = AN(1) JRS = 1 CN(1) = CN(1)+AN(1) go to 118 114 JRS = 2 ICTR = 1 S(N) = AN(N)/BN(N) DO 115 J=3,N L = N-J+2 S(L) = AN(L)/(BN(L)-CN(L)*S(L+1)) 115 CONTINUE S(2) = -S(2) DO 116 J=3,N S(J) = -S(J)*S(J-1) 116 CONTINUE WTNM = WTS+WTF DO 117 I=ITSP,ITFM WTNM = WTNM+SINT(I) 117 CONTINUE YPS = CZR*WTNM*(S(2)-1.) ! ! BOUNDARY CONDITION AT R=RF ! 118 go to (119,120,120,119,119,120),NBDCND 119 CR = CN(N) JRF = N go to 121 120 CR = CN(N+1) AN(N+1) = AN(N+1)+CN(N+1) JRF = N+1 121 WRS = AN(JRS+1)*R(JRS)**2/CN(JRS) WRF = CN(JRF-1)*R(JRF)**2/AN(JRF) WRZ = AN(JRS)/CZR JRSP = JRS+1 JRFM = JRF-1 MUNK = ITF-ITS+1 NUNK = JRF-JRS+1 DO 122 I=ITS,ITF BMH(I) = BM(I) 122 CONTINUE ISING = 0 go to (132,132,123,132,132,123),NBDCND 123 go to (132,132,124,132,132,124,132,124,124),MBDCND 124 if (ELMBDA) 132,125,125 125 ISING = 1 SUM = WTS*WRS+WTS*WRF+WTF*WRS+WTF*WRF if (ICTR) 126,127,126 126 SUM = SUM+WRZ 127 DO 129 J=JRSP,JRFM R2 = R(J)**2 DO 128 I=ITSP,ITFM SUM = SUM+R2*SINT(I) 128 CONTINUE 129 CONTINUE DO 130 J=JRSP,JRFM SUM = SUM+(WTS+WTF)*R(J)**2 130 CONTINUE DO 131 I=ITSP,ITFM SUM = SUM+(WRS+WRF)*SINT(I) 131 CONTINUE HNE = SUM 132 go to (133,133,133,133,134,134,133,133,134),MBDCND 133 BM(ITS) = BMH(ITS)+ELMBDA/SINT(ITS)**2 134 go to (135,135,135,135,135,135,136,136,136),MBDCND 135 BM(ITF) = BMH(ITF)+ELMBDA/SINT(ITF)**2 136 DO 137 I=ITSP,ITFM BM(I) = BMH(I)+ELMBDA/SINT(I)**2 137 CONTINUE go to (138,138,140,140,142,142,138,140,142),MBDCND 138 DO 139 J=JRS,JRF F(2,J) = F(2,J)-AT*F(1,J)/R(J)**2 139 CONTINUE go to 142 140 DO 141 J=JRS,JRF F(1,J) = F(1,J)+TDT*BDTS(J)*AT/R(J)**2 141 CONTINUE 142 go to (143,145,145,143,143,145,147,147,147),MBDCND 143 DO 144 J=JRS,JRF F(M,J) = F(M,J)-CT*F(M+1,J)/R(J)**2 144 CONTINUE go to 147 145 DO 146 J=JRS,JRF F(M+1,J) = F(M+1,J)-TDT*BDTF(J)*CT/R(J)**2 146 CONTINUE 147 go to (151,151,153,153,148,148),NBDCND 148 if (MBDCND-3) 155,149,155 149 YHLD = F(ITS,1)-CZR/TDT*(SIN(TF)*BDTF(2)-SIN(TS)*BDTS(2)) DO 150 I=1,MP1 F(I,1) = YHLD 150 CONTINUE go to 155 151 RS2 = (RS+DR)**2 DO 152 I=ITS,ITF F(I,2) = F(I,2)-AR*F(I,1)/RS2 152 CONTINUE go to 155 153 DO 154 I=ITS,ITF F(I,1) = F(I,1)+TDR*BDRS(I)*AR/RS**2 154 CONTINUE 155 go to (156,158,158,156,156,158),NBDCND 156 RF2 = (RF-DR)**2 DO 157 I=ITS,ITF F(I,N) = F(I,N)-CR*F(I,N+1)/RF2 157 CONTINUE go to 160 158 DO 159 I=ITS,ITF F(I,N+1) = F(I,N+1)-TDR*BDRF(I)*CR/RF**2 159 CONTINUE 160 CONTINUE PERTRB = 0. if (ISING) 161,170,161 161 SUM = WTS*WRS*F(ITS,JRS)+WTS*WRF*F(ITS,JRF)+WTF*WRS*F(ITF,JRS)+ & WTF*WRF*F(ITF,JRF) if (ICTR) 162,163,162 162 SUM = SUM+WRZ*F(ITS,1) 163 DO 165 J=JRSP,JRFM R2 = R(J)**2 DO 164 I=ITSP,ITFM SUM = SUM+R2*SINT(I)*F(I,J) 164 CONTINUE 165 CONTINUE DO 166 J=JRSP,JRFM SUM = SUM+R(J)**2*(WTS*F(ITS,J)+WTF*F(ITF,J)) 166 CONTINUE DO 167 I=ITSP,ITFM SUM = SUM+SINT(I)*(WRS*F(I,JRS)+WRF*F(I,JRF)) 167 CONTINUE PERTRB = SUM/HNE DO 169 J=1,NP1 DO 168 I=1,MP1 F(I,J) = F(I,J)-PERTRB 168 CONTINUE 169 CONTINUE 170 DO 172 J=JRS,JRF RSQ = R(J)**2 DO 171 I=ITS,ITF F(I,J) = RSQ*F(I,J) 171 CONTINUE 172 CONTINUE IFLG = INTL 173 call BLKTRI (IFLG,NP,NUNK,AN(JRS),BN(JRS),CN(JRS),MP,MUNK, & AM(ITS),BM(ITS),CM(ITS),IDIMF,F(ITS,JRS),IERROR,W) IFLG = IFLG+1 if (IFLG-1) 174,173,174 174 if (NBDCND) 177,175,177 175 DO 176 I=1,MP1 F(I,JRF+1) = F(I,JRS) 176 CONTINUE 177 if (MBDCND) 180,178,180 178 DO 179 J=1,NP1 F(ITF+1,J) = F(ITS,J) 179 CONTINUE 180 XP = 0. if (ICTR) 181,188,181 181 if (ISING) 186,182,186 182 SUM = WTS*F(ITS,2)+WTF*F(ITF,2) DO 183 I=ITSP,ITFM SUM = SUM+SINT(I)*F(I,2) 183 CONTINUE YPH = CZR*SUM XP = (F(ITS,1)-YPH)/YPS DO 185 J=JRS,JRF XPS = XP*S(J) DO 184 I=ITS,ITF F(I,J) = F(I,J)+XPS 184 CONTINUE 185 CONTINUE 186 DO 187 I=1,MP1 F(I,1) = XP 187 CONTINUE 188 RETURN end subroutine HWSCSP (INTL, TS, TF, M, MBDCND, BDTS, BDTF, RS, RF, N, & NBDCND, BDRS, BDRF, ELMBDA, F, IDIMF, PERTRB, IERROR, W) ! !! HWSCSP solves a finite difference approximation to the modified ... ! Helmholtz equation in spherical coordinates assuming ! axisymmetry (no dependence on longitude). !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HWSCSP-S) !***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine HWSCSP solves a finite difference approximation to the ! modified Helmholtz equation in spherical coordinates assuming ! axisymmetry (no dependence on longitude) ! ! (1/R**2)(d/dR)((R**2)(d/dR)U) ! ! + (1/(R**2)SIN(THETA))(d/dTHETA)(SIN(THETA)(d/dTHETA)U) ! ! + (LAMBDA/(RSIN(THETA))**2)U = F(THETA,R). ! ! This two dimensional modified Helmholtz equation results from ! the Fourier transform of the three dimensional Poisson equation ! ! * * * * * * * * * * On Input * * * * * * * * * * ! ! INTL ! = 0 On initial entry to HWSCSP or if any of the arguments ! RS, RF, N, NBDCND are changed from a previous call. ! = 1 If RS, RF, N, NBDCND are all unchanged from previous call ! to HWSCSP. ! ! NOTE A call with INTL=0 takes approximately 1.5 times as ! much time as a call with INTL = 1. Once a call with ! INTL = 0 has been made then subsequent solutions ! corresponding to different F, BDTS, BDTF, BDRS, BDRF can ! be obtained faster with INTL = 1 since initialization is ! not repeated. ! ! TS,TF ! The range of THETA (colatitude), i.e., TS <= THETA <= TF. ! TS must be less than TF. TS and TF are in radians. A TS of ! zero corresponds to the north pole and a TF of PI corresponds ! to the south pole. ! ! * * * * * * * * * * * * * * IMPORTANT * * * * * * * * * * * * * * ! ! If TF is equal to PI then it must be computed using the statement ! TF = PIMACH(DUM). This insures that TF in the users program is ! equal to PI in this program which permits several tests of the ! input parameters that otherwise would not be possible. ! ! M ! The number of panels into which the interval (TS,TF) is ! subdivided. Hence, there will be M+1 grid points in the ! THETA-direction given by THETA(K) = (I-1)DTHETA+TS for ! I = 1,2,...,M+1, where DTHETA = (TF-TS)/M is the panel width. ! ! MBDCND ! Indicates the type of boundary condition at THETA = TS and ! THETA = TF. ! ! = 1 If the solution is specified at THETA = TS and THETA = TF. ! = 2 If the solution is specified at THETA = TS and the ! derivative of the solution with respect to THETA is ! specified at THETA = TF (see note 2 below). ! = 3 If the derivative of the solution with respect to THETA is ! specified at THETA = TS and THETA = TF (see notes 1,2 ! below). ! = 4 If the derivative of the solution with respect to THETA is ! specified at THETA = TS (see note 1 below) and the ! solution is specified at THETA = TF. ! = 5 If the solution is unspecified at THETA = TS = 0 and the ! solution is specified at THETA = TF. ! = 6 If the solution is unspecified at THETA = TS = 0 and the ! derivative of the solution with respect to THETA is ! specified at THETA = TF (see note 2 below). ! = 7 If the solution is specified at THETA = TS and the ! solution is unspecified at THETA = TF = PI. ! = 8 If the derivative of the solution with respect to THETA is ! specified at THETA = TS (see note 1 below) and the solution ! is unspecified at THETA = TF = PI. ! = 9 If the solution is unspecified at THETA = TS = 0 and ! THETA = TF = PI. ! ! NOTES: 1. If TS = 0, do not use MBDCND = 3,4, or 8, but ! instead use MBDCND = 5,6, or 9 . ! 2. If TF = PI, do not use MBDCND = 2,3, or 6, but ! instead use MBDCND = 7,8, or 9 . ! ! BDTS ! A one-dimensional array of length N+1 that specifies the values ! of the derivative of the solution with respect to THETA at ! THETA = TS. When MBDCND = 3,4, or 8, ! ! BDTS(J) = (d/dTHETA)U(TS,R(J)), J = 1,2,...,N+1 . ! ! When MBDCND has any other value, BDTS is a dummy variable. ! ! BDTF ! A one-dimensional array of length N+1 that specifies the values ! of the derivative of the solution with respect to THETA at ! THETA = TF. When MBDCND = 2,3, or 6, ! ! BDTF(J) = (d/dTHETA)U(TF,R(J)), J = 1,2,...,N+1 . ! ! When MBDCND has any other value, BDTF is a dummy variable. ! ! RS,RF ! The range of R, i.e., RS <= R < RF. RS must be less than ! RF. RS must be non-negative. ! ! N ! The number of panels into which the interval (RS,RF) is ! subdivided. Hence, there will be N+1 grid points in the ! R-direction given by R(J) = (J-1)DR+RS for J = 1,2,...,N+1, ! where DR = (RF-RS)/N is the panel width. ! N must be greater than 2 ! ! NBDCND ! Indicates the type of boundary condition at R = RS and R = RF. ! ! = 1 If the solution is specified at R = RS and R = RF. ! = 2 If the solution is specified at R = RS and the derivative ! of the solution with respect to R is specified at R = RF. ! = 3 If the derivative of the solution with respect to R is ! specified at R = RS and R = RF. ! = 4 If the derivative of the solution with respect to R is ! specified at RS and the solution is specified at R = RF. ! = 5 If the solution is unspecified at R = RS = 0 (see note ! below) and the solution is specified at R = RF. ! = 6 If the solution is unspecified at R = RS = 0 (see note ! below) and the derivative of the solution with respect to ! R is specified at R = RF. ! ! NOTE: NBDCND = 5 or 6 cannot be used with ! MBDCND = 1,2,4,5, or 7 (the former indicates that the ! solution is unspecified at R = 0, the latter ! indicates that the solution is specified). ! Use instead ! NBDCND = 1 or 2 . ! ! BDRS ! A one-dimensional array of length M+1 that specifies the values ! of the derivative of the solution with respect to R at R = RS. ! When NBDCND = 3 or 4, ! ! BDRS(I) = (d/dR)U(THETA(I),RS), I = 1,2,...,M+1 . ! ! When NBDCND has any other value, BDRS is a dummy variable. ! ! BDRF ! A one-dimensional array of length M+1 that specifies the values ! of the derivative of the solution with respect to R at R = RF. ! When NBDCND = 2,3, or 6, ! ! BDRF(I) = (d/dR)U(THETA(I),RF), I = 1,2,...,M+1 . ! ! When NBDCND has any other value, BDRF is a dummy variable. ! ! ELMBDA ! The constant LAMBDA in the Helmholtz equation. If ! LAMBDA > 0, a solution may not exist. However, HWSCSP will ! attempt to find a solution. If NBDCND = 5 or 6 or ! MBDCND = 5,6,7,8, or 9, ELMBDA must be zero. ! ! F ! A two-dimensional array that specifies the value of the right ! side of the Helmholtz equation and boundary values (if any). ! for I = 2,3,...,M and J = 2,3,...,N ! ! F(I,J) = F(THETA(I),R(J)). ! ! On the boundaries F is defined by ! ! MBDCND F(1,J) F(M+1,J) ! ------ ---------- ---------- ! ! 1 U(TS,R(J)) U(TF,R(J)) ! 2 U(TS,R(J)) F(TF,R(J)) ! 3 F(TS,R(J)) F(TF,R(J)) ! 4 F(TS,R(J)) U(TF,R(J)) ! 5 F(0,R(J)) U(TF,R(J)) J = 1,2,...,N+1 ! 6 F(0,R(J)) F(TF,R(J)) ! 7 U(TS,R(J)) F(PI,R(J)) ! 8 F(TS,R(J)) F(PI,R(J)) ! 9 F(0,R(J)) F(PI,R(J)) ! ! NBDCND F(I,1) F(I,N+1) ! ------ -------------- -------------- ! ! 1 U(THETA(I),RS) U(THETA(I),RF) ! 2 U(THETA(I),RS) F(THETA(I),RF) ! 3 F(THETA(I),RS) F(THETA(I),RF) ! 4 F(THETA(I),RS) U(THETA(I),RF) I = 1,2,...,M+1 ! 5 F(TS,0) U(THETA(I),RF) ! 6 F(TS,0) F(THETA(I),RF) ! ! F must be dimensioned at least (M+1)*(N+1). ! ! NOTE ! ! If the table calls for both the solution U and the right side F ! at a corner then the solution must be specified. ! ! IDIMF ! The row (or first) dimension of the array F as it appears in the ! program calling HWSCSP. This parameter is used to specify the ! variable dimension of F. IDIMF must be at least M+1 . ! ! W ! A one-dimensional array that must be provided by the user for ! work space. Its length can be computed from the formula below ! which depends on the value of NBDCND. ! ! If NBDCND=2,4 or 6 define NUNK=N ! If NBDCND=1 or 5 define NUNK=N-1 ! If NBDCND=3 define NUNK=N+1 ! ! Now set K=INT(log2(NUNK))+1 and L=2**(K+1) then W must be ! dimensioned at least (K-2)*L+K+5*(M+N)+MAX(2*N,6*M)+23 ! ! **IMPORTANT** For purposes of checking, the required length ! of W is computed by HWSCSP and stored in W(1) ! in floating point format. ! ! ! * * * * * * * * * * On Output * * * * * * * * * * ! ! F ! Contains the solution U(I,J) of the finite difference ! approximation for the grid point (THETA(I),R(J)), ! I = 1,2,...,M+1, J = 1,2,...,N+1 . ! ! PERTRB ! If a combination of periodic or derivative boundary conditions ! is specified for a Poisson equation (LAMBDA = 0), a solution may ! not exist. PERTRB is a constant, calculated and subtracted from ! F, which ensures that a solution exists. HWSCSP then computes ! this solution, which is a least squares solution to the original ! approximation. This solution is not unique and is unnormalized. ! The value of PERTRB should be small compared to the right side ! F. Otherwise , a solution is obtained to an essentially ! different problem. This comparison should always be made to ! insure that a meaningful solution has been obtained. ! ! IERROR ! An error flag that indicates invalid input parameters. Except ! for numbers 0 and 10, a solution is not attempted. ! ! = 1 TS < 0. or TF > PI ! = 2 TS >= TF ! = 3 M < 5 ! = 4 MBDCND < 1 or MBDCND > 9 ! = 5 RS < 0 ! = 6 RS >= RF ! = 7 N < 5 ! = 8 NBDCND < 1 or NBDCND > 6 ! = 9 ELMBDA > 0 ! = 10 IDIMF < M+1 ! = 11 ELMBDA /= 0 and MBDCND >= 5 ! = 12 ELMBDA /= 0 and NBDCND equals 5 or 6 ! = 13 MBDCND equals 5,6 or 9 and TS /= 0 ! = 14 MBDCND >= 7 and TF /= PI ! = 15 TS == 0 and MBDCND equals 3,4 or 8 ! = 16 TF == PI and MBDCND equals 2,3 or 6 ! = 17 NBDCND >= 5 and RS /= 0 ! = 18 NBDCND >= 5 and MBDCND equals 1,2,4,5 or 7 ! ! Since this is the only means of indicating a possibly incorrect ! call to HWSCSP, the user should test IERROR after a call. ! ! W ! Contains intermediate values that must not be destroyed if ! HWSCSP will be called again with INTL = 1. W(1) contains the ! number of locations which W must have. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of BDTS(N+1),BDTF(N+1),BDRS(M+1),BDRF(M+1), ! Arguments F(IDIMF,N+1),W(see argument list) ! ! Latest June 1979 ! Revision ! ! Subprograms HWSCSP,HWSCS1,BLKTRI,BLKTR1,PROD,PRODP,CPROD,CPRODP ! Required ,COMBP,PPADD,PSGF,BSRH,PPSGF,PPSPF,TEVLS,INDXA, ! ,INDXB,INDXC,R1MACH ! ! Special ! Conditions ! ! Common CBLKT ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Paul N Swarztrauber ! ! Language FORTRAN ! ! History Version 1 September 1973 ! Version 2 April 1976 ! Version 3 June 1979 ! ! Algorithm The routine defines the finite difference ! equations, incorporates boundary data, and adjusts ! the right side of singular systems and then calls ! BLKTRI to solve the system. ! ! Space ! Required ! ! Portability American National Standards Institute FORTRAN. ! The machine accuracy is set using function R1MACH. ! ! Required NONE ! Resident ! Routines ! ! Reference Swarztrauber,P. and R. Sweet, 'Efficient FORTRAN ! Subprograms for The Solution Of Elliptic Equations' ! NCAR TN/IA-109, July, 1975, 138 pp. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran ! subprograms for the solution of elliptic equations, ! NCAR TN/IA-109, July 1975, 138 pp. !***ROUTINES CALLED HWSCS1, PIMACH !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HWSCSP ! DIMENSION F(IDIMF,*) ,BDTS(*) ,BDTF(*) ,BDRS(*) , & BDRF(*) ,W(*) !***FIRST EXECUTABLE STATEMENT HWSCSP PI = PIMACH(DUM) IERROR = 0 if (TS < 0. .OR. TF > PI) IERROR = 1 if (TS >= TF) IERROR = 2 if (M < 5) IERROR = 3 if (MBDCND < 1 .OR. MBDCND > 9) IERROR = 4 if (RS < 0.) IERROR = 5 if (RS >= RF) IERROR = 6 if (N < 5) IERROR = 7 if (NBDCND < 1 .OR. NBDCND > 6) IERROR = 8 if (ELMBDA > 0.) IERROR = 9 if (IDIMF < M+1) IERROR = 10 if (ELMBDA /= 0. .AND. MBDCND >= 5) IERROR = 11 if (ELMBDA /= 0. .AND. (NBDCND == 5 .OR. NBDCND == 6)) IERROR = 12 if ((MBDCND == 5 .OR. MBDCND == 6 .OR. MBDCND == 9) .AND. & TS /= 0.) IERROR = 13 if (MBDCND >= 7 .AND. TF /= PI) IERROR = 14 if (TS == 0. .AND. & (MBDCND == 4 .OR. MBDCND == 8 .OR. MBDCND == 3)) IERROR = 15 if (TF == PI .AND. & (MBDCND == 2 .OR. MBDCND == 3 .OR. MBDCND == 6)) IERROR = 16 if (NBDCND >= 5 .AND. RS /= 0.) IERROR = 17 if (NBDCND >= 5 .AND. (MBDCND == 1 .OR. MBDCND == 2 .OR. & MBDCND == 5 .OR. MBDCND == 7)) & IERROR = 18 if (IERROR /= 0 .AND. IERROR /= 9) RETURN NCK = N go to (101,103,102,103,101,103),NBDCND 101 NCK = NCK-1 go to 103 102 NCK = NCK+1 103 L = 2 K = 1 104 L = L+L K = K+1 if (NCK-L) 105,105,104 105 L = L+L NP1 = N+1 MP1 = M+1 I1 = (K-2)*L+K+MAX(2*N,6*M)+13 I2 = I1+NP1 I3 = I2+NP1 I4 = I3+NP1 I5 = I4+NP1 I6 = I5+NP1 I7 = I6+MP1 I8 = I7+MP1 I9 = I8+MP1 I10 = I9+MP1 W(1) = I10+M call HWSCS1 (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS, & BDRF,ELMBDA,F,IDIMF,PERTRB,W(2),W(I1),W(I2),W(I3), & W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10)) return end subroutine HWSCYL (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, & BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) ! !! HWSCYL solves a standard finite difference approximation ... ! to the Helmholtz equation in cylindrical coordinates. ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HWSCYL-S) !***KEYWORDS CYLINDRICAL, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine HWSCYL solves a finite difference approximation to the ! Helmholtz equation in cylindrical coordinates: ! ! (1/R)(d/dR)(R(dU/dR)) + (d/dZ)(dU/dZ) ! ! + (LAMBDA/R**2)U = F(R,Z) ! ! This modified Helmholtz equation results from the Fourier ! transform of the three-dimensional Poisson equation. ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! A,B ! The range of R, i.e., A <= R <= B. A must be less than B ! and A must be non-negative. ! ! M ! The number of panels into which the interval (A,B) is ! subdivided. Hence, there will be M+1 grid points in the ! R-direction given by R(I) = A+(I-1)DR, for I = 1,2,...,M+1, ! where DR = (B-A)/M is the panel width. M must be greater than 3. ! ! MBDCND ! Indicates the type of boundary conditions at R = A and R = B. ! ! = 1 If the solution is specified at R = A and R = B. ! = 2 If the solution is specified at R = A and the derivative of ! the solution with respect to R is specified at R = B. ! = 3 If the derivative of the solution with respect to R is ! specified at R = A (see note below) and R = B. ! = 4 If the derivative of the solution with respect to R is ! specified at R = A (see note below) and the solution is ! specified at R = B. ! = 5 If the solution is unspecified at R = A = 0 and the ! solution is specified at R = B. ! = 6 If the solution is unspecified at R = A = 0 and the ! derivative of the solution with respect to R is specified ! at R = B. ! ! NOTE: If A = 0, do not use MBDCND = 3 or 4, but instead use ! MBDCND = 1,2,5, or 6 . ! ! BDA ! A one-dimensional array of length N+1 that specifies the values ! of the derivative of the solution with respect to R at R = A. ! When MBDCND = 3 or 4, ! ! BDA(J) = (d/dR)U(A,Z(J)), J = 1,2,...,N+1 . ! ! When MBDCND has any other value, BDA is a dummy variable. ! ! BDB ! A one-dimensional array of length N+1 that specifies the values ! of the derivative of the solution with respect to R at R = B. ! When MBDCND = 2,3, or 6, ! ! BDB(J) = (d/dR)U(B,Z(J)), J = 1,2,...,N+1 . ! ! When MBDCND has any other value, BDB is a dummy variable. ! ! C,D ! The range of Z, i.e., C <= Z <= D. C must be less than D. ! ! N ! The number of panels into which the interval (C,D) is ! subdivided. Hence, there will be N+1 grid points in the ! Z-direction given by Z(J) = C+(J-1)DZ, for J = 1,2,...,N+1, ! where DZ = (D-C)/N is the panel width. N must be greater than 3. ! ! NBDCND ! Indicates the type of boundary conditions at Z = C and Z = D. ! ! = 0 If the solution is periodic in Z, i.e., U(I,1) = U(I,N+1). ! = 1 If the solution is specified at Z = C and Z = D. ! = 2 If the solution is specified at Z = C and the derivative of ! the solution with respect to Z is specified at Z = D. ! = 3 If the derivative of the solution with respect to Z is ! specified at Z = C and Z = D. ! = 4 If the derivative of the solution with respect to Z is ! specified at Z = C and the solution is specified at Z = D. ! ! BDC ! A one-dimensional array of length M+1 that specifies the values ! of the derivative of the solution with respect to Z at Z = C. ! When NBDCND = 3 or 4, ! ! BDC(I) = (d/dZ)U(R(I),C), I = 1,2,...,M+1 . ! ! When NBDCND has any other value, BDC is a dummy variable. ! ! BDD ! A one-dimensional array of length M+1 that specifies the values ! of the derivative of the solution with respect to Z at Z = D. ! When NBDCND = 2 or 3, ! ! BDD(I) = (d/dZ)U(R(I),D), I = 1,2,...,M+1 . ! ! When NBDCND has any other value, BDD is a dummy variable. ! ! ELMBDA ! The constant LAMBDA in the Helmholtz equation. If ! LAMBDA > 0, a solution may not exist. However, HWSCYL will ! attempt to find a solution. LAMBDA must be zero when ! MBDCND = 5 or 6 . ! ! F ! A two-dimensional array that specifies the values of the right ! side of the Helmholtz equation and boundary data (if any). For ! I = 2,3,...,M and J = 2,3,...,N ! ! F(I,J) = F(R(I),Z(J)). ! ! On the boundaries F is defined by ! ! MBDCND F(1,J) F(M+1,J) ! ------ --------- --------- ! ! 1 U(A,Z(J)) U(B,Z(J)) ! 2 U(A,Z(J)) F(B,Z(J)) ! 3 F(A,Z(J)) F(B,Z(J)) J = 1,2,...,N+1 ! 4 F(A,Z(J)) U(B,Z(J)) ! 5 F(0,Z(J)) U(B,Z(J)) ! 6 F(0,Z(J)) F(B,Z(J)) ! ! NBDCND F(I,1) F(I,N+1) ! ------ --------- --------- ! ! 0 F(R(I),C) F(R(I),C) ! 1 U(R(I),C) U(R(I),D) ! 2 U(R(I),C) F(R(I),D) I = 1,2,...,M+1 ! 3 F(R(I),C) F(R(I),D) ! 4 F(R(I),C) U(R(I),D) ! ! F must be dimensioned at least (M+1)*(N+1). ! ! NOTE ! ! If the table calls for both the solution U and the right side F ! at a corner then the solution must be specified. ! ! IDIMF ! The row (or first) dimension of the array F as it appears in the ! program calling HWSCYL. This parameter is used to specify the ! variable dimension of F. IDIMF must be at least M+1 . ! ! W ! A one-dimensional array that must be provided by the user for ! work space. W may require up to 4*(N+1) + ! (13 + INT(log2(N+1)))*(M+1) locations. The actual number of ! locations used is computed by HWSCYL and is returned in location ! W(1). ! ! ! * * * * * * On Output * * * * * * ! ! F ! Contains the solution U(I,J) of the finite difference ! approximation for the grid point (R(I),Z(J)), I = 1,2,...,M+1, ! J = 1,2,...,N+1 . ! ! PERTRB ! If one specifies a combination of periodic, derivative, and ! unspecified boundary conditions for a Poisson equation ! (LAMBDA = 0), a solution may not exist. PERTRB is a constant, ! calculated and subtracted from F, which ensures that a solution ! exists. HWSCYL then computes this solution, which is a least ! squares solution to the original approximation. This solution ! plus any constant is also a solution. Hence, the solution is ! not unique. The value of PERTRB should be small compared to the ! right side F. Otherwise, a solution is obtained to an ! essentially different problem. This comparison should always ! be made to insure that a meaningful solution has been obtained. ! ! IERROR ! An error flag which indicates invalid input parameters. Except ! for numbers 0 and 11, a solution is not attempted. ! ! = 0 No error. ! = 1 A < 0 . ! = 2 A >= B. ! = 3 MBDCND < 1 or MBDCND > 6 . ! = 4 C >= D. ! = 5 N <= 3 ! = 6 NBDCND < 0 or NBDCND > 4 . ! = 7 A = 0, MBDCND = 3 or 4 . ! = 8 A > 0, MBDCND >= 5 . ! = 9 A = 0, LAMBDA /= 0, MBDCND >= 5 . ! = 10 IDIMF < M+1 . ! = 11 LAMBDA > 0 . ! = 12 M <= 3 ! ! Since this is the only means of indicating a possibly incorrect ! call to HWSCYL, the user should test IERROR after the call. ! ! W ! W(1) contains the required length of W. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of BDA(N+1),BDB(N+1),BDC(M+1),BDD(M+1),F(IDIMF,N+1), ! Arguments W(see argument list) ! ! Latest June 1, 1976 ! Revision ! ! Subprograms HWSCYL,GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE, ! Required TRIX,TRI3,PIMACH ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Standardized September 1, 1973 ! Revised April 1, 1976 ! ! Algorithm The routine defines the finite difference ! equations, incorporates boundary data, and adjusts ! the right side of singular systems and then calls ! GENBUN to solve the system. ! ! Space 5818(decimal) = 13272(octal) locations on the NCAR ! Required Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine HWSCYL is roughly proportional ! to M*N*log2(N), but also depends on the input ! parameters NBDCND and MBDCND. Some typical values ! are listed in the table below. ! The solution process employed results in a loss ! of no more than three significant digits for N and ! M as large as 64. More detailed information about ! accuracy can be found in the documentation for ! subroutine GENBUN which is the routine that ! solves the finite difference equations. ! ! ! M(=N) MBDCND NBDCND T(MSECS) ! ----- ------ ------ -------- ! ! 32 1 0 31 ! 32 1 1 23 ! 32 3 3 36 ! 64 1 0 128 ! 64 1 1 96 ! 64 3 3 142 ! ! Portability American National Standards Institute FORTRAN. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS ! Resident ! Routines ! ! Reference Swarztrauber, P. and R. Sweet, 'Efficient FORTRAN ! Subprograms for the Solution of Elliptic Equations' ! NCAR TN/IA-109, July, 1975, 138 pp. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran ! subprograms for the solution of elliptic equations, ! NCAR TN/IA-109, July 1975, 138 pp. !***ROUTINES CALLED GENBUN !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HWSCYL ! ! DIMENSION F(IDIMF,*) DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , & W(*) !***FIRST EXECUTABLE STATEMENT HWSCYL IERROR = 0 if (A < 0.) IERROR = 1 if (A >= B) IERROR = 2 if (MBDCND <= 0 .OR. MBDCND >= 7) IERROR = 3 if (C >= D) IERROR = 4 if (N <= 3) IERROR = 5 if (NBDCND <= -1 .OR. NBDCND >= 5) IERROR = 6 if (A == 0. .AND. (MBDCND == 3 .OR. MBDCND == 4)) IERROR = 7 if (A > 0. .AND. MBDCND >= 5) IERROR = 8 if (A == 0. .AND. ELMBDA /= 0. .AND. MBDCND >= 5) IERROR = 9 if (IDIMF < M+1) IERROR = 10 if (M <= 3) IERROR = 12 if (IERROR /= 0) RETURN MP1 = M+1 DELTAR = (B-A)/M DLRBY2 = DELTAR/2. DLRSQ = DELTAR**2 NP1 = N+1 DELTHT = (D-C)/N DLTHSQ = DELTHT**2 NP = NBDCND+1 ! ! DEFINE RANGE OF INDICES I AND J FOR UNKNOWNS U(I,J). ! MSTART = 2 MSTOP = M go to (104,103,102,101,101,102),MBDCND 101 MSTART = 1 go to 104 102 MSTART = 1 103 MSTOP = MP1 104 MUNK = MSTOP-MSTART+1 NSTART = 1 NSTOP = N go to (108,105,106,107,108),NP 105 NSTART = 2 go to 108 106 NSTART = 2 107 NSTOP = NP1 108 NUNK = NSTOP-NSTART+1 ! ! DEFINE A,B,C COEFFICIENTS IN W-ARRAY. ! ID2 = MUNK ID3 = ID2+MUNK ID4 = ID3+MUNK ID5 = ID4+MUNK ID6 = ID5+MUNK ISTART = 1 A1 = 2./DLRSQ IJ = 0 if (MBDCND == 3 .OR. MBDCND == 4) IJ = 1 if (MBDCND <= 4) go to 109 W(1) = 0. W(ID2+1) = -2.*A1 W(ID3+1) = 2.*A1 ISTART = 2 IJ = 1 109 DO 110 I=ISTART,MUNK R = A+(I-IJ)*DELTAR J = ID5+I W(J) = R J = ID6+I W(J) = 1./R**2 W(I) = (R-DLRBY2)/(R*DLRSQ) J = ID3+I W(J) = (R+DLRBY2)/(R*DLRSQ) K = ID6+I J = ID2+I W(J) = -A1+ELMBDA*W(K) 110 CONTINUE go to (114,111,112,113,114,112),MBDCND 111 W(ID2) = A1 go to 114 112 W(ID2) = A1 113 W(ID3+1) = A1*ISTART 114 CONTINUE ! ! ENTER BOUNDARY DATA FOR R-BOUNDARIES. ! go to (115,115,117,117,119,119),MBDCND 115 A1 = W(1) DO 116 J=NSTART,NSTOP F(2,J) = F(2,J)-A1*F(1,J) 116 CONTINUE go to 119 117 A1 = 2.*DELTAR*W(1) DO 118 J=NSTART,NSTOP F(1,J) = F(1,J)+A1*BDA(J) 118 CONTINUE 119 go to (120,122,122,120,120,122),MBDCND 120 A1 = W(ID4) DO 121 J=NSTART,NSTOP F(M,J) = F(M,J)-A1*F(MP1,J) 121 CONTINUE go to 124 122 A1 = 2.*DELTAR*W(ID4) DO 123 J=NSTART,NSTOP F(MP1,J) = F(MP1,J)-A1*BDB(J) 123 CONTINUE ! ! ENTER BOUNDARY DATA FOR Z-BOUNDARIES. ! 124 A1 = 1./DLTHSQ L = ID5-MSTART+1 go to (134,125,125,127,127),NP 125 DO 126 I=MSTART,MSTOP F(I,2) = F(I,2)-A1*F(I,1) 126 CONTINUE go to 129 127 A1 = 2./DELTHT DO 128 I=MSTART,MSTOP F(I,1) = F(I,1)+A1*BDC(I) 128 CONTINUE 129 A1 = 1./DLTHSQ go to (134,130,132,132,130),NP 130 DO 131 I=MSTART,MSTOP F(I,N) = F(I,N)-A1*F(I,NP1) 131 CONTINUE go to 134 132 A1 = 2./DELTHT DO 133 I=MSTART,MSTOP F(I,NP1) = F(I,NP1)-A1*BDD(I) 133 CONTINUE 134 CONTINUE ! ! ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A ! SOLUTION. ! PERTRB = 0. if (ELMBDA) 146,136,135 135 IERROR = 11 go to 146 136 W(ID5+1) = .5*(W(ID5+2)-DLRBY2) go to (146,146,138,146,146,137),MBDCND 137 W(ID5+1) = .5*W(ID5+1) 138 go to (140,146,146,139,146),NP 139 A2 = 2. go to 141 140 A2 = 1. 141 K = ID5+MUNK W(K) = .5*(W(K-1)+DLRBY2) S = 0. DO 143 I=MSTART,MSTOP S1 = 0. NSP1 = NSTART+1 NSTM1 = NSTOP-1 DO 142 J=NSP1,NSTM1 S1 = S1+F(I,J) 142 CONTINUE K = I+L S = S+(A2*S1+F(I,NSTART)+F(I,NSTOP))*W(K) 143 CONTINUE S2 = M*A+(.75+(M-1)*(M+1))*DLRBY2 if (MBDCND == 3) S2 = S2+.25*DLRBY2 S1 = (2.+A2*(NUNK-2))*S2 PERTRB = S/S1 DO 145 I=MSTART,MSTOP DO 144 J=NSTART,NSTOP F(I,J) = F(I,J)-PERTRB 144 CONTINUE 145 CONTINUE 146 CONTINUE ! ! MULTIPLY I-TH EQUATION THROUGH BY DELTHT**2 TO PUT EQUATION INTO ! CORRECT FORM FOR SUBROUTINE GENBUN. ! DO 148 I=MSTART,MSTOP K = I-MSTART+1 W(K) = W(K)*DLTHSQ J = ID2+K W(J) = W(J)*DLTHSQ J = ID3+K W(J) = W(J)*DLTHSQ DO 147 J=NSTART,NSTOP F(I,J) = F(I,J)*DLTHSQ 147 CONTINUE 148 CONTINUE W(1) = 0. W(ID4) = 0. ! ! call GENBUN TO SOLVE THE SYSTEM OF EQUATIONS. ! call GENBUN (NBDCND,NUNK,1,MUNK,W(1),W(ID2+1),W(ID3+1),IDIMF, & F(MSTART,NSTART),IERR1,W(ID4+1)) W(1) = W(ID4+1)+3*MUNK if (NBDCND /= 0) go to 150 DO 149 I=MSTART,MSTOP F(I,NP1) = F(I,1) 149 CONTINUE 150 CONTINUE return end subroutine HWSPLR (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND, & BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W) ! !! HWSPLR solves a finite difference approximation to the Helmholtz ... ! equation in polar coordinates. ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HWSPLR-S) !***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, POLAR !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine HWSPLR solves a finite difference approximation to the ! Helmholtz equation in polar coordinates: ! ! (1/R)(d/dR)(R(dU/dR)) + (1/R**2)(d/dTHETA)(dU/dTHETA) ! ! + LAMBDA*U = F(R,THETA). ! ! ! ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! A,B ! The range of R, i.e., A <= R <= B. A must be less than B ! and A must be non-negative. ! ! M ! The number of panels into which the interval (A,B) is ! subdivided. Hence, there will be M+1 grid points in the ! R-direction given by R(I) = A+(I-1)DR, for I = 1,2,...,M+1, ! where DR = (B-A)/M is the panel width. M must be greater than 3. ! ! MBDCND ! Indicates the type of boundary condition at R = A and R = B. ! ! = 1 If the solution is specified at R = A and R = B. ! = 2 If the solution is specified at R = A and the derivative of ! the solution with respect to R is specified at R = B. ! = 3 If the derivative of the solution with respect to R is ! specified at R = A (see note below) and R = B. ! = 4 If the derivative of the solution with respect to R is ! specified at R = A (see note below) and the solution is ! specified at R = B. ! = 5 If the solution is unspecified at R = A = 0 and the ! solution is specified at R = B. ! = 6 If the solution is unspecified at R = A = 0 and the ! derivative of the solution with respect to R is specified ! at R = B. ! ! NOTE: If A = 0, do not use MBDCND = 3 or 4, but instead use ! MBDCND = 1,2,5, or 6 . ! ! BDA ! A one-dimensional array of length N+1 that specifies the values ! of the derivative of the solution with respect to R at R = A. ! When MBDCND = 3 or 4, ! ! BDA(J) = (d/dR)U(A,THETA(J)), J = 1,2,...,N+1 . ! ! When MBDCND has any other value, BDA is a dummy variable. ! ! BDB ! A one-dimensional array of length N+1 that specifies the values ! of the derivative of the solution with respect to R at R = B. ! When MBDCND = 2,3, or 6, ! ! BDB(J) = (d/dR)U(B,THETA(J)), J = 1,2,...,N+1 . ! ! When MBDCND has any other value, BDB is a dummy variable. ! ! C,D ! The range of THETA, i.e., C <= THETA <= D. C must be less ! than D. ! ! N ! The number of panels into which the interval (C,D) is ! subdivided. Hence, there will be N+1 grid points in the ! THETA-direction given by THETA(J) = C+(J-1)DTHETA for ! J = 1,2,...,N+1, where DTHETA = (D-C)/N is the panel width. N ! must be greater than 3. ! ! NBDCND ! Indicates the type of boundary conditions at THETA = C and ! at THETA = D. ! ! = 0 If the solution is periodic in THETA, i.e., ! U(I,J) = U(I,N+J). ! = 1 If the solution is specified at THETA = C and THETA = D ! (see note below). ! = 2 If the solution is specified at THETA = C and the ! derivative of the solution with respect to THETA is ! specified at THETA = D (see note below). ! = 4 If the derivative of the solution with respect to THETA is ! specified at THETA = C and the solution is specified at ! THETA = D (see note below). ! ! NOTE: When NBDCND = 1,2, or 4, do not use MBDCND = 5 or 6 ! (the former indicates that the solution is specified at ! R = 0, the latter indicates the solution is unspecified ! at R = 0). Use instead MBDCND = 1 or 2 . ! ! BDC ! A one-dimensional array of length M+1 that specifies the values ! of the derivative of the solution with respect to THETA at ! THETA = C. When NBDCND = 3 or 4, ! ! BDC(I) = (d/dTHETA)U(R(I),C), I = 1,2,...,M+1 . ! ! When NBDCND has any other value, BDC is a dummy variable. ! ! BDD ! A one-dimensional array of length M+1 that specifies the values ! of the derivative of the solution with respect to THETA at ! THETA = D. When NBDCND = 2 or 3, ! ! BDD(I) = (d/dTHETA)U(R(I),D), I = 1,2,...,M+1 . ! ! When NBDCND has any other value, BDD is a dummy variable. ! ! ELMBDA ! The constant LAMBDA in the Helmholtz equation. If ! LAMBDA < 0, a solution may not exist. However, HWSPLR will ! attempt to find a solution. ! ! F ! A two-dimensional array that specifies the values of the right ! side of the Helmholtz equation and boundary values (if any). ! For I = 2,3,...,M and J = 2,3,...,N ! ! F(I,J) = F(R(I),THETA(J)). ! ! On the boundaries F is defined by ! ! MBDCND F(1,J) F(M+1,J) ! ------ ------------- ------------- ! ! 1 U(A,THETA(J)) U(B,THETA(J)) ! 2 U(A,THETA(J)) F(B,THETA(J)) ! 3 F(A,THETA(J)) F(B,THETA(J)) ! 4 F(A,THETA(J)) U(B,THETA(J)) J = 1,2,...,N+1 ! 5 F(0,0) U(B,THETA(J)) ! 6 F(0,0) F(B,THETA(J)) ! ! NBDCND F(I,1) F(I,N+1) ! ------ --------- --------- ! ! 0 F(R(I),C) F(R(I),C) ! 1 U(R(I),C) U(R(I),D) ! 2 U(R(I),C) F(R(I),D) I = 1,2,...,M+1 ! 3 F(R(I),C) F(R(I),D) ! 4 F(R(I),C) U(R(I),D) ! ! F must be dimensioned at least (M+1)*(N+1). ! ! NOTE ! ! If the table calls for both the solution U and the right side F ! at a corner then the solution must be specified. ! ! ! IDIMF ! The row (or first) dimension of the array F as it appears in the ! program calling HWSPLR. This parameter is used to specify the ! variable dimension of F. IDIMF must be at least M+1 . ! ! W ! A one-dimensional array that must be provided by the user for ! work space. W may require up to 4*(N+1) + ! (13 + INT(log2(N+1)))*(M+1) locations. The actual number of ! locations used is computed by HWSPLR and is returned in location ! W(1). ! ! ! * * * * * * On Output * * * * * * ! ! F ! Contains the solution U(I,J) of the finite difference ! approximation for the grid point (R(I),THETA(J)), ! I = 1,2,...,M+1, J = 1,2,...,N+1 . ! ! PERTRB ! If a combination of periodic, derivative, or unspecified ! boundary conditions is specified for a Poisson equation ! (LAMBDA = 0), a solution may not exist. PERTRB is a constant, ! calculated and subtracted from F, which ensures that a solution ! exists. HWSPLR then computes this solution, which is a least ! squares solution to the original approximation. This solution ! plus any constant is also a solution. Hence, the solution is ! not unique. PERTRB should be small compared to the right side. ! Otherwise, a solution is obtained to an essentially different ! problem. This comparison should always be made to insure that a ! meaningful solution has been obtained. ! ! IERROR ! An error flag that indicates invalid input parameters. Except ! for numbers 0 and 11, a solution is not attempted. ! ! = 0 No error. ! = 1 A < 0 . ! = 2 A >= B. ! = 3 MBDCND < 1 or MBDCND > 6 . ! = 4 C >= D. ! = 5 N <= 3 ! = 6 NBDCND < 0 or > 4 . ! = 7 A = 0, MBDCND = 3 or 4 . ! = 8 A > 0, MBDCND >= 5 . ! = 9 MBDCND >= 5, NBDCND /= 0 and NBDCND /= 3 . ! = 10 IDIMF < M+1 . ! = 11 LAMBDA > 0 . ! = 12 M <= 3 ! ! Since this is the only means of indicating a possibly incorrect ! call to HWSPLR, the user should test IERROR after the call. ! ! W ! W(1) contains the required length of W. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of BDA(N+1),BDB(N+1),BDC(M+1),BDD(M+1),F(IDIMF,N+1), ! Arguments W(see argument list) ! ! Latest June 1, 1976 ! Revision ! ! Subprograms HWSPLR,GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE, ! Required TRIX,TRI3,PIMACH ! ! Special None ! Conditions ! ! Common NONE ! Blocks ! ! I/O ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Standardized April 1, 1973 ! Revised January 1, 1976 ! ! Algorithm The routine defines the finite difference ! equations, incorporates boundary data, and adjusts ! the right side of singular systems and then calls ! GENBUN to solve the system. ! ! Space 13430(octal) = 5912(decimal) locations on the NCAR ! Required Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine HWSPLR is roughly proportional ! to M*N*log2(N), but also depends on the input ! parameters NBDCND and MBDCND. Some typical values ! are listed in the table below. ! The solution process employed results in a loss ! of no more than three significant digits for N and ! M as large as 64. More detailed information about ! accuracy can be found in the documentation for ! subroutine GENBUN which is the routine that ! solves the finite difference equations. ! ! ! M(=N) MBDCND NBDCND T(MSECS) ! ----- ------ ------ -------- ! ! 32 1 0 31 ! 32 1 1 23 ! 32 3 3 36 ! 64 1 0 128 ! 64 1 1 96 ! 64 3 3 142 ! ! Portability American National Standards Institute FORTRAN. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS ! Resident ! Routines ! ! Reference Swarztrauber, P. and R. Sweet, 'Efficient FORTRAN ! Subprograms For The Solution Of Elliptic Equations' ! NCAR TN/IA-109, July, 1975, 138 pp. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran ! subprograms for the solution of elliptic equations, ! NCAR TN/IA-109, July 1975, 138 pp. !***ROUTINES CALLED GENBUN !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HWSPLR ! ! DIMENSION F(IDIMF,*) DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , & W(*) !***FIRST EXECUTABLE STATEMENT HWSPLR IERROR = 0 if (A < 0.) IERROR = 1 if (A >= B) IERROR = 2 if (MBDCND <= 0 .OR. MBDCND >= 7) IERROR = 3 if (C >= D) IERROR = 4 if (N <= 3) IERROR = 5 if (NBDCND <= -1 .OR. NBDCND >= 5) IERROR = 6 if (A == 0. .AND. (MBDCND == 3 .OR. MBDCND == 4)) IERROR = 7 if (A > 0. .AND. MBDCND >= 5) IERROR = 8 if (MBDCND >= 5 .AND. NBDCND /= 0 .AND. NBDCND /= 3) IERROR = 9 if (IDIMF < M+1) IERROR = 10 if (M <= 3) IERROR = 12 if (IERROR /= 0) RETURN MP1 = M+1 DELTAR = (B-A)/M DLRBY2 = DELTAR/2. DLRSQ = DELTAR**2 NP1 = N+1 DELTHT = (D-C)/N DLTHSQ = DELTHT**2 NP = NBDCND+1 ! ! DEFINE RANGE OF INDICES I AND J FOR UNKNOWNS U(I,J). ! MSTART = 2 MSTOP = MP1 go to (101,105,102,103,104,105),MBDCND 101 MSTOP = M go to 105 102 MSTART = 1 go to 105 103 MSTART = 1 104 MSTOP = M 105 MUNK = MSTOP-MSTART+1 NSTART = 1 NSTOP = N go to (109,106,107,108,109),NP 106 NSTART = 2 go to 109 107 NSTART = 2 108 NSTOP = NP1 109 NUNK = NSTOP-NSTART+1 ! ! DEFINE A,B,C COEFFICIENTS IN W-ARRAY. ! ID2 = MUNK ID3 = ID2+MUNK ID4 = ID3+MUNK ID5 = ID4+MUNK ID6 = ID5+MUNK A1 = 2./DLRSQ IJ = 0 if (MBDCND == 3 .OR. MBDCND == 4) IJ = 1 DO 110 I=1,MUNK R = A+(I-IJ)*DELTAR J = ID5+I W(J) = R J = ID6+I W(J) = 1./R**2 W(I) = (R-DLRBY2)/(R*DLRSQ) J = ID3+I W(J) = (R+DLRBY2)/(R*DLRSQ) J = ID2+I W(J) = -A1+ELMBDA 110 CONTINUE go to (114,111,112,113,114,111),MBDCND 111 W(ID2) = A1 go to 114 112 W(ID2) = A1 113 W(ID3+1) = A1 114 CONTINUE ! ! ENTER BOUNDARY DATA FOR R-BOUNDARIES. ! go to (115,115,117,117,119,119),MBDCND 115 A1 = W(1) DO 116 J=NSTART,NSTOP F(2,J) = F(2,J)-A1*F(1,J) 116 CONTINUE go to 119 117 A1 = 2.*DELTAR*W(1) DO 118 J=NSTART,NSTOP F(1,J) = F(1,J)+A1*BDA(J) 118 CONTINUE 119 go to (120,122,122,120,120,122),MBDCND 120 A1 = W(ID4) DO 121 J=NSTART,NSTOP F(M,J) = F(M,J)-A1*F(MP1,J) 121 CONTINUE go to 124 122 A1 = 2.*DELTAR*W(ID4) DO 123 J=NSTART,NSTOP F(MP1,J) = F(MP1,J)-A1*BDB(J) 123 CONTINUE ! ! ENTER BOUNDARY DATA FOR THETA-BOUNDARIES. ! 124 A1 = 1./DLTHSQ L = ID5-MSTART+1 LP = ID6-MSTART+1 go to (134,125,125,127,127),NP 125 DO 126 I=MSTART,MSTOP J = I+LP F(I,2) = F(I,2)-A1*W(J)*F(I,1) 126 CONTINUE go to 129 127 A1 = 2./DELTHT DO 128 I=MSTART,MSTOP J = I+LP F(I,1) = F(I,1)+A1*W(J)*BDC(I) 128 CONTINUE 129 A1 = 1./DLTHSQ go to (134,130,132,132,130),NP 130 DO 131 I=MSTART,MSTOP J = I+LP F(I,N) = F(I,N)-A1*W(J)*F(I,NP1) 131 CONTINUE go to 134 132 A1 = 2./DELTHT DO 133 I=MSTART,MSTOP J = I+LP F(I,NP1) = F(I,NP1)-A1*W(J)*BDD(I) 133 CONTINUE 134 CONTINUE ! ! ADJUST RIGHT SIDE OF EQUATION FOR UNKNOWN AT POLE WHEN HAVE ! DERIVATIVE SPECIFIED BOUNDARY CONDITIONS. ! if (MBDCND >= 5 .AND. NBDCND == 3) & F(1,1) = F(1,1)-(BDD(2)-BDC(2))*4./(N*DELTHT*DLRSQ) ! ! ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A ! SOLUTION. ! PERTRB = 0. if (ELMBDA) 144,136,135 135 IERROR = 11 go to 144 136 if (NBDCND /= 0 .AND. NBDCND /= 3) go to 144 S2 = 0. go to (144,144,137,144,144,138),MBDCND 137 W(ID5+1) = .5*(W(ID5+2)-DLRBY2) S2 = .25*DELTAR 138 A2 = 2. if (NBDCND == 0) A2 = 1. J = ID5+MUNK W(J) = .5*(W(J-1)+DLRBY2) S = 0. DO 140 I=MSTART,MSTOP S1 = 0. IJ = NSTART+1 K = NSTOP-1 DO 139 J=IJ,K S1 = S1+F(I,J) 139 CONTINUE J = I+L S = S+(A2*S1+F(I,NSTART)+F(I,NSTOP))*W(J) 140 CONTINUE S2 = M*A+DELTAR*((M-1)*(M+1)*.5+.25)+S2 S1 = (2.+A2*(NUNK-2))*S2 if (MBDCND == 3) go to 141 S2 = N*A2*DELTAR/8. S = S+F(1,1)*S2 S1 = S1+S2 141 CONTINUE PERTRB = S/S1 DO 143 I=MSTART,MSTOP DO 142 J=NSTART,NSTOP F(I,J) = F(I,J)-PERTRB 142 CONTINUE 143 CONTINUE 144 CONTINUE ! ! MULTIPLY I-TH EQUATION THROUGH BY (R(I)*DELTHT)**2. ! DO 146 I=MSTART,MSTOP K = I-MSTART+1 J = I+LP A1 = DLTHSQ/W(J) W(K) = A1*W(K) J = ID2+K W(J) = A1*W(J) J = ID3+K W(J) = A1*W(J) DO 145 J=NSTART,NSTOP F(I,J) = A1*F(I,J) 145 CONTINUE 146 CONTINUE W(1) = 0. W(ID4) = 0. ! ! call GENBUN TO SOLVE THE SYSTEM OF EQUATIONS. ! call GENBUN (NBDCND,NUNK,1,MUNK,W(1),W(ID2+1),W(ID3+1),IDIMF, & F(MSTART,NSTART),IERR1,W(ID4+1)) IWSTOR = W(ID4+1)+3*MUNK go to (157,157,157,157,148,147),MBDCND ! ! ADJUST THE SOLUTION AS NECESSARY FOR THE PROBLEMS WHERE A = 0. ! 147 if (ELMBDA /= 0.) go to 148 YPOLE = 0. go to 155 148 CONTINUE J = ID5+MUNK W(J) = W(ID2)/W(ID3) DO 149 IP=3,MUNK I = MUNK-IP+2 J = ID5+I LP = ID2+I K = ID3+I W(J) = W(I)/(W(LP)-W(K)*W(J+1)) 149 CONTINUE W(ID5+1) = -.5*DLTHSQ/(W(ID2+1)-W(ID3+1)*W(ID5+2)) DO 150 I=2,MUNK J = ID5+I W(J) = -W(J)*W(J-1) 150 CONTINUE S = 0. DO 151 J=NSTART,NSTOP S = S+F(2,J) 151 CONTINUE A2 = NUNK if (NBDCND == 0) go to 152 S = S-.5*(F(2,NSTART)+F(2,NSTOP)) A2 = A2-1. 152 YPOLE = (.25*DLRSQ*F(1,1)-S/A2)/(W(ID5+1)-1.+ELMBDA*DLRSQ*.25) DO 154 I=MSTART,MSTOP K = L+I DO 153 J=NSTART,NSTOP F(I,J) = F(I,J)+YPOLE*W(K) 153 CONTINUE 154 CONTINUE 155 DO 156 J=1,NP1 F(1,J) = YPOLE 156 CONTINUE 157 CONTINUE if (NBDCND /= 0) go to 159 DO 158 I=MSTART,MSTOP F(I,NP1) = F(I,1) 158 CONTINUE 159 CONTINUE W(1) = IWSTOR return end subroutine HWSSS1 (TS, TF, M, MBDCND, BDTS, BDTF, PS, PF, N, & NBDCND, BDPS, BDPF, ELMBDA, F, IDIMF, PERTRB, AM, BM, CM, SN, & SS, SINT, D) ! !! HWSSS1 is subsidiary to HWSSSP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (HWSSS1-S) !***AUTHOR (UNKNOWN) !***SEE ALSO HWSSSP !***ROUTINES CALLED GENBUN !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891009 Removed unreferenced variables. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE HWSSS1 DIMENSION F(IDIMF,*) ,BDTS(*) ,BDTF(*) ,BDPS(*) , & BDPF(*) ,AM(*) ,BM(*) ,CM(*) , & SS(*) ,SN(*) ,D(*) ,SINT(*) ! !***FIRST EXECUTABLE STATEMENT HWSSS1 MP1 = M+1 NP1 = N+1 FN = N FM = M DTH = (TF-TS)/FM HDTH = DTH/2. TDT = DTH+DTH DPHI = (PF-PS)/FN TDP = DPHI+DPHI DPHI2 = DPHI*DPHI DTH2 = DTH*DTH CP = 4./(FN*DTH2) WP = FN*SIN(HDTH)/4. DO 102 I=1,MP1 FIM1 = I-1 THETA = FIM1*DTH+TS SINT(I) = SIN(THETA) if (SINT(I)) 101,102,101 101 T1 = 1./(DTH2*SINT(I)) AM(I) = T1*SIN(THETA-HDTH) CM(I) = T1*SIN(THETA+HDTH) BM(I) = -AM(I)-CM(I)+ELMBDA 102 CONTINUE INP = 0 ISP = 0 ! ! BOUNDARY CONDITION AT THETA=TS ! MBR = MBDCND+1 go to (103,104,104,105,105,106,106,104,105,106),MBR 103 ITS = 1 go to 107 104 AT = AM(2) ITS = 2 go to 107 105 AT = AM(1) ITS = 1 CM(1) = AM(1)+CM(1) go to 107 106 AT = AM(2) INP = 1 ITS = 2 ! ! BOUNDARY CONDITION THETA=TF ! 107 go to (108,109,110,110,109,109,110,111,111,111),MBR 108 ITF = M go to 112 109 CT = CM(M) ITF = M go to 112 110 CT = CM(M+1) AM(M+1) = AM(M+1)+CM(M+1) ITF = M+1 go to 112 111 ITF = M ISP = 1 CT = CM(M) ! ! COMPUTE HOMOGENEOUS SOLUTION WITH SOLUTION AT POLE EQUAL TO ONE ! 112 ITSP = ITS+1 ITFM = ITF-1 WTS = SINT(ITS+1)*AM(ITS+1)/CM(ITS) WTF = SINT(ITF-1)*CM(ITF-1)/AM(ITF) MUNK = ITF-ITS+1 if (ISP) 116,116,113 113 D(ITS) = CM(ITS)/BM(ITS) DO 114 I=ITSP,M D(I) = CM(I)/(BM(I)-AM(I)*D(I-1)) 114 CONTINUE SS(M) = -D(M) IID = M-ITS DO 115 II=1,IID I = M-II SS(I) = -D(I)*SS(I+1) 115 CONTINUE SS(M+1) = 1. 116 if (INP) 120,120,117 117 SN(1) = 1. D(ITF) = AM(ITF)/BM(ITF) IID = ITF-2 DO 118 II=1,IID I = ITF-II D(I) = AM(I)/(BM(I)-CM(I)*D(I+1)) 118 CONTINUE SN(2) = -D(2) DO 119 I=3,ITF SN(I) = -D(I)*SN(I-1) 119 CONTINUE ! ! BOUNDARY CONDITIONS AT PHI=PS ! 120 NBR = NBDCND+1 WPS = 1. WPF = 1. go to (121,122,122,123,123),NBR 121 JPS = 1 go to 124 122 JPS = 2 go to 124 123 JPS = 1 WPS = .5 ! ! BOUNDARY CONDITION AT PHI=PF ! 124 go to (125,126,127,127,126),NBR 125 JPF = N go to 128 126 JPF = N go to 128 127 WPF = .5 JPF = N+1 128 JPSP = JPS+1 JPFM = JPF-1 NUNK = JPF-JPS+1 FJJ = JPFM-JPSP+1 ! ! SCALE COEFFICIENTS FOR SUBROUTINE GENBUN ! DO 129 I=ITS,ITF CF = DPHI2*SINT(I)*SINT(I) AM(I) = CF*AM(I) BM(I) = CF*BM(I) CM(I) = CF*CM(I) 129 CONTINUE AM(ITS) = 0. CM(ITF) = 0. ISING = 0 go to (130,138,138,130,138,138,130,138,130,130),MBR 130 go to (131,138,138,131,138),NBR 131 if (ELMBDA) 138,132,132 132 ISING = 1 SUM = WTS*WPS+WTS*WPF+WTF*WPS+WTF*WPF if (INP) 134,134,133 133 SUM = SUM+WP 134 if (ISP) 136,136,135 135 SUM = SUM+WP 136 SUM1 = 0. DO 137 I=ITSP,ITFM SUM1 = SUM1+SINT(I) 137 CONTINUE SUM = SUM+FJJ*(SUM1+WTS+WTF) SUM = SUM+(WPS+WPF)*SUM1 HNE = SUM 138 go to (146,142,142,144,144,139,139,142,144,139),MBR 139 if (NBDCND-3) 146,140,146 140 YHLD = F(1,JPS)-4./(FN*DPHI*DTH2)*(BDPF(2)-BDPS(2)) DO 141 J=1,NP1 F(1,J) = YHLD 141 CONTINUE go to 146 142 DO 143 J=JPS,JPF F(2,J) = F(2,J)-AT*F(1,J) 143 CONTINUE go to 146 144 DO 145 J=JPS,JPF F(1,J) = F(1,J)+TDT*BDTS(J)*AT 145 CONTINUE 146 go to (154,150,152,152,150,150,152,147,147,147),MBR 147 if (NBDCND-3) 154,148,154 148 YHLD = F(M+1,JPS)-4./(FN*DPHI*DTH2)*(BDPF(M)-BDPS(M)) DO 149 J=1,NP1 F(M+1,J) = YHLD 149 CONTINUE go to 154 150 DO 151 J=JPS,JPF F(M,J) = F(M,J)-CT*F(M+1,J) 151 CONTINUE go to 154 152 DO 153 J=JPS,JPF F(M+1,J) = F(M+1,J)-TDT*BDTF(J)*CT 153 CONTINUE 154 go to (159,155,155,157,157),NBR 155 DO 156 I=ITS,ITF F(I,2) = F(I,2)-F(I,1)/(DPHI2*SINT(I)*SINT(I)) 156 CONTINUE go to 159 157 DO 158 I=ITS,ITF F(I,1) = F(I,1)+TDP*BDPS(I)/(DPHI2*SINT(I)*SINT(I)) 158 CONTINUE 159 go to (164,160,162,162,160),NBR 160 DO 161 I=ITS,ITF F(I,N) = F(I,N)-F(I,N+1)/(DPHI2*SINT(I)*SINT(I)) 161 CONTINUE go to 164 162 DO 163 I=ITS,ITF F(I,N+1) = F(I,N+1)-TDP*BDPF(I)/(DPHI2*SINT(I)*SINT(I)) 163 CONTINUE 164 CONTINUE PERTRB = 0. if (ISING) 165,176,165 165 SUM = WTS*WPS*F(ITS,JPS)+WTS*WPF*F(ITS,JPF)+WTF*WPS*F(ITF,JPS)+ & WTF*WPF*F(ITF,JPF) if (INP) 167,167,166 166 SUM = SUM+WP*F(1,JPS) 167 if (ISP) 169,169,168 168 SUM = SUM+WP*F(M+1,JPS) 169 DO 171 I=ITSP,ITFM SUM1 = 0. DO 170 J=JPSP,JPFM SUM1 = SUM1+F(I,J) 170 CONTINUE SUM = SUM+SINT(I)*SUM1 171 CONTINUE SUM1 = 0. SUM2 = 0. DO 172 J=JPSP,JPFM SUM1 = SUM1+F(ITS,J) SUM2 = SUM2+F(ITF,J) 172 CONTINUE SUM = SUM+WTS*SUM1+WTF*SUM2 SUM1 = 0. SUM2 = 0. DO 173 I=ITSP,ITFM SUM1 = SUM1+SINT(I)*F(I,JPS) SUM2 = SUM2+SINT(I)*F(I,JPF) 173 CONTINUE SUM = SUM+WPS*SUM1+WPF*SUM2 PERTRB = SUM/HNE DO 175 J=1,NP1 DO 174 I=1,MP1 F(I,J) = F(I,J)-PERTRB 174 CONTINUE 175 CONTINUE ! ! SCALE RIGHT SIDE FOR SUBROUTINE GENBUN ! 176 DO 178 I=ITS,ITF CF = DPHI2*SINT(I)*SINT(I) DO 177 J=JPS,JPF F(I,J) = CF*F(I,J) 177 CONTINUE 178 CONTINUE call GENBUN (NBDCND,NUNK,1,MUNK,AM(ITS),BM(ITS),CM(ITS),IDIMF, & F(ITS,JPS),IERROR,D) if (ISING) 186,186,179 179 if (INP) 183,183,180 180 if (ISP) 181,181,186 181 DO 182 J=1,NP1 F(1,J) = 0. 182 CONTINUE go to 209 183 if (ISP) 186,186,184 184 DO 185 J=1,NP1 F(M+1,J) = 0. 185 CONTINUE go to 209 186 if (INP) 193,193,187 187 SUM = WPS*F(ITS,JPS)+WPF*F(ITS,JPF) DO 188 J=JPSP,JPFM SUM = SUM+F(ITS,J) 188 CONTINUE DFN = CP*SUM DNN = CP*((WPS+WPF+FJJ)*(SN(2)-1.))+ELMBDA DSN = CP*(WPS+WPF+FJJ)*SN(M) if (ISP) 189,189,194 189 CNP = (F(1,1)-DFN)/DNN DO 191 I=ITS,ITF HLD = CNP*SN(I) DO 190 J=JPS,JPF F(I,J) = F(I,J)+HLD 190 CONTINUE 191 CONTINUE DO 192 J=1,NP1 F(1,J) = CNP 192 CONTINUE go to 209 193 if (ISP) 209,209,194 194 SUM = WPS*F(ITF,JPS)+WPF*F(ITF,JPF) DO 195 J=JPSP,JPFM SUM = SUM+F(ITF,J) 195 CONTINUE DFS = CP*SUM DSS = CP*((WPS+WPF+FJJ)*(SS(M)-1.))+ELMBDA DNS = CP*(WPS+WPF+FJJ)*SS(2) if (INP) 196,196,200 196 CSP = (F(M+1,1)-DFS)/DSS DO 198 I=ITS,ITF HLD = CSP*SS(I) DO 197 J=JPS,JPF F(I,J) = F(I,J)+HLD 197 CONTINUE 198 CONTINUE DO 199 J=1,NP1 F(M+1,J) = CSP 199 CONTINUE go to 209 200 RTN = F(1,1)-DFN RTS = F(M+1,1)-DFS if (ISING) 202,202,201 201 CSP = 0. CNP = RTN/DNN go to 205 202 if (ABS(DNN)-ABS(DSN)) 204,204,203 203 DEN = DSS-DNS*DSN/DNN RTS = RTS-RTN*DSN/DNN CSP = RTS/DEN CNP = (RTN-CSP*DNS)/DNN go to 205 204 DEN = DNS-DSS*DNN/DSN RTN = RTN-RTS*DNN/DSN CSP = RTN/DEN CNP = (RTS-DSS*CSP)/DSN 205 DO 207 I=ITS,ITF HLD = CNP*SN(I)+CSP*SS(I) DO 206 J=JPS,JPF F(I,J) = F(I,J)+HLD 206 CONTINUE 207 CONTINUE DO 208 J=1,NP1 F(1,J) = CNP F(M+1,J) = CSP 208 CONTINUE 209 if (NBDCND) 212,210,212 210 DO 211 I=1,MP1 F(I,JPF+1) = F(I,JPS) 211 CONTINUE 212 RETURN end subroutine HWSSSP (TS, TF, M, MBDCND, BDTS, BDTF, PS, PF, N, & NBDCND, BDPS, BDPF, ELMBDA, F, IDIMF, PERTRB, IERROR, W) ! !! HWSSSP solves a finite difference approximation to the Helmholtz ... ! equation in spherical coordinates and on the surface of the ! unit sphere (radius of 1). ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A1A !***TYPE SINGLE PRECISION (HWSSSP-S) !***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine HWSSSP solves a finite difference approximation to the ! Helmholtz equation in spherical coordinates and on the surface of ! the unit sphere (radius of 1): ! ! (1/SIN(THETA))(d/dTHETA)(SIN(THETA)(dU/dTHETA)) ! ! + (1/SIN(THETA)**2)(d/dPHI)(dU/dPHI) ! ! + LAMBDA*U = F(THETA,PHI) ! ! Where THETA is colatitude and PHI is longitude. ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! TS,TF ! The range of THETA (colatitude), i.e., TS <= THETA <= TF. ! TS must be less than TF. TS and TF are in radians. A TS of ! zero corresponds to the north pole and a TF of PI corresponds to ! the south pole. ! ! * * * * * * * * * * * * * * IMPORTANT * * * * * * * * * * * * * * ! ! If TF is equal to PI then it must be computed using the statement ! TF = PIMACH(DUM). This insures that TF in the users program is ! equal to PI in this program which permits several tests of the ! input parameters that otherwise would not be possible. ! ! ! M ! The number of panels into which the interval (TS,TF) is ! subdivided. Hence, there will be M+1 grid points in the ! THETA-direction given by THETA(I) = (I-1)DTHETA+TS for ! I = 1,2,...,M+1, where DTHETA = (TF-TS)/M is the panel width. ! M must be greater than 5. ! ! MBDCND ! Indicates the type of boundary condition at THETA = TS and ! THETA = TF. ! ! = 1 If the solution is specified at THETA = TS and THETA = TF. ! = 2 If the solution is specified at THETA = TS and the ! derivative of the solution with respect to THETA is ! specified at THETA = TF (see note 2 below). ! = 3 If the derivative of the solution with respect to THETA is ! specified at THETA = TS and THETA = TF (see notes 1,2 ! below). ! = 4 If the derivative of the solution with respect to THETA is ! specified at THETA = TS (see note 1 below) and the ! solution is specified at THETA = TF. ! = 5 If the solution is unspecified at THETA = TS = 0 and the ! solution is specified at THETA = TF. ! = 6 If the solution is unspecified at THETA = TS = 0 and the ! derivative of the solution with respect to THETA is ! specified at THETA = TF (see note 2 below). ! = 7 If the solution is specified at THETA = TS and the ! solution is unspecified at THETA = TF = PI. ! = 8 If the derivative of the solution with respect to THETA is ! specified at THETA = TS (see note 1 below) and the ! solution is unspecified at THETA = TF = PI. ! = 9 If the solution is unspecified at THETA = TS = 0 and ! THETA = TF = PI. ! ! NOTES: 1. If TS = 0, do not use MBDCND = 3,4, or 8, but ! instead use MBDCND = 5,6, or 9 . ! 2. If TF = PI, do not use MBDCND = 2,3, or 6, but ! instead use MBDCND = 7,8, or 9 . ! ! BDTS ! A one-dimensional array of length N+1 that specifies the values ! of the derivative of the solution with respect to THETA at ! THETA = TS. When MBDCND = 3,4, or 8, ! ! BDTS(J) = (d/dTHETA)U(TS,PHI(J)), J = 1,2,...,N+1 . ! ! When MBDCND has any other value, BDTS is a dummy variable. ! ! BDTF ! A one-dimensional array of length N+1 that specifies the values ! of the derivative of the solution with respect to THETA at ! THETA = TF. When MBDCND = 2,3, or 6, ! ! BDTF(J) = (d/dTHETA)U(TF,PHI(J)), J = 1,2,...,N+1 . ! ! When MBDCND has any other value, BDTF is a dummy variable. ! ! PS,PF ! The range of PHI (longitude), i.e., PS <= PHI <= PF. PS ! must be less than PF. PS and PF are in radians. If PS = 0 and ! PF = 2*PI, periodic boundary conditions are usually prescribed. ! ! * * * * * * * * * * * * * * IMPORTANT * * * * * * * * * * * * * * ! ! If PF is equal to 2*PI then it must be computed using the ! statement PF = 2.*PIMACH(DUM). This insures that PF in the users ! program is equal to 2*PI in this program which permits tests of ! the input parameters that otherwise would not be possible. ! ! ! N ! The number of panels into which the interval (PS,PF) is ! subdivided. Hence, there will be N+1 grid points in the ! PHI-direction given by PHI(J) = (J-1)DPHI+PS for ! J = 1,2,...,N+1, where DPHI = (PF-PS)/N is the panel width. ! N must be greater than 4. ! ! NBDCND ! Indicates the type of boundary condition at PHI = PS and ! PHI = PF. ! ! = 0 If the solution is periodic in PHI, i.e., ! U(I,J) = U(I,N+J). ! = 1 If the solution is specified at PHI = PS and PHI = PF ! (see note below). ! = 2 If the solution is specified at PHI = PS (see note below) ! and the derivative of the solution with respect to PHI is ! specified at PHI = PF. ! = 3 If the derivative of the solution with respect to PHI is ! specified at PHI = PS and PHI = PF. ! = 4 If the derivative of the solution with respect to PHI is ! specified at PS and the solution is specified at PHI = PF ! (see note below). ! ! NOTE: NBDCND = 1,2, or 4 cannot be used with ! MBDCND = 5,6,7,8, or 9 (the former indicates that the ! solution is specified at a pole, the latter ! indicates that the solution is unspecified). ! Use instead ! MBDCND = 1 or 2 . ! ! BDPS ! A one-dimensional array of length M+1 that specifies the values ! of the derivative of the solution with respect to PHI at ! PHI = PS. When NBDCND = 3 or 4, ! ! BDPS(I) = (d/dPHI)U(THETA(I),PS), I = 1,2,...,M+1 . ! ! When NBDCND has any other value, BDPS is a dummy variable. ! ! BDPF ! A one-dimensional array of length M+1 that specifies the values ! of the derivative of the solution with respect to PHI at ! PHI = PF. When NBDCND = 2 or 3, ! ! BDPF(I) = (d/dPHI)U(THETA(I),PF), I = 1,2,...,M+1 . ! ! When NBDCND has any other value, BDPF is a dummy variable. ! ! ELMBDA ! The constant LAMBDA in the Helmholtz equation. If ! LAMBDA > 0, a solution may not exist. However, HWSSSP will ! attempt to find a solution. ! ! F ! A two-dimensional array that specifies the value of the right ! side of the Helmholtz equation and boundary values (if any). ! For I = 2,3,...,M and J = 2,3,...,N ! ! F(I,J) = F(THETA(I),PHI(J)). ! ! On the boundaries F is defined by ! ! MBDCND F(1,J) F(M+1,J) ! ------ ------------ ------------ ! ! 1 U(TS,PHI(J)) U(TF,PHI(J)) ! 2 U(TS,PHI(J)) F(TF,PHI(J)) ! 3 F(TS,PHI(J)) F(TF,PHI(J)) ! 4 F(TS,PHI(J)) U(TF,PHI(J)) ! 5 F(0,PS) U(TF,PHI(J)) J = 1,2,...,N+1 ! 6 F(0,PS) F(TF,PHI(J)) ! 7 U(TS,PHI(J)) F(PI,PS) ! 8 F(TS,PHI(J)) F(PI,PS) ! 9 F(0,PS) F(PI,PS) ! ! NBDCND F(I,1) F(I,N+1) ! ------ -------------- -------------- ! ! 0 F(THETA(I),PS) F(THETA(I),PS) ! 1 U(THETA(I),PS) U(THETA(I),PF) ! 2 U(THETA(I),PS) F(THETA(I),PF) I = 1,2,...,M+1 ! 3 F(THETA(I),PS) F(THETA(I),PF) ! 4 F(THETA(I),PS) U(THETA(I),PF) ! ! F must be dimensioned at least (M+1)*(N+1). ! ! *NOTE* ! ! If the table calls for both the solution U and the right side F ! at a corner then the solution must be specified. ! ! ! IDIMF ! The row (or first) dimension of the array F as it appears in the ! program calling HWSSSP. This parameter is used to specify the ! variable dimension of F. IDIMF must be at least M+1 . ! ! W ! A one-dimensional array that must be provided by the user for ! work space. W may require up to 4*(N+1)+(16+INT(log2(N+1)))(M+1) ! locations. The actual number of locations used is computed by ! HWSSSP and is output in location W(1). INT( ) denotes the ! FORTRAN integer function. ! ! ! * * * * * * * * * * On Output * * * * * * * * * * ! ! F ! Contains the solution U(I,J) of the finite difference ! approximation for the grid point (THETA(I),PHI(J)), ! I = 1,2,...,M+1, J = 1,2,...,N+1 . ! ! PERTRB ! If one specifies a combination of periodic, derivative or ! unspecified boundary conditions for a Poisson equation ! (LAMBDA = 0), a solution may not exist. PERTRB is a constant, ! calculated and subtracted from F, which ensures that a solution ! exists. HWSSSP then computes this solution, which is a least ! squares solution to the original approximation. This solution ! is not unique and is unnormalized. The value of PERTRB should ! be small compared to the right side F. Otherwise , a solution ! is obtained to an essentially different problem. This comparison ! should always be made to insure that a meaningful solution has ! been obtained. ! ! IERROR ! An error flag that indicates invalid input parameters. Except ! for numbers 0 and 8, a solution is not attempted. ! ! = 0 No error ! = 1 TS < 0 or TF > PI ! = 2 TS >= TF ! = 3 MBDCND < 1 or MBDCND > 9 ! = 4 PS < 0 or PS > PI+PI ! = 5 PS >= PF ! = 6 N < 5 ! = 7 M < 5 ! = 8 NBDCND < 0 or NBDCND > 4 ! = 9 ELMBDA > 0 ! = 10 IDIMF < M+1 ! = 11 NBDCND equals 1,2 or 4 and MBDCND >= 5 ! = 12 TS == 0 and MBDCND equals 3,4 or 8 ! = 13 TF == PI and MBDCND equals 2,3 or 6 ! = 14 MBDCND equals 5,6 or 9 and TS /= 0 ! = 15 MBDCND >= 7 and TF /= PI ! ! Since this is the only means of indicating a possibly incorrect ! call to HWSSSP, the user should test IERROR after a call. ! ! W ! Contains intermediate values that must not be destroyed if ! HWSSSP will be called again with INTL = 1. W(1) contains the ! required length of W . ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of BDTS(N+1),BDTF(N+1),BDPS(M+1),BDPF(M+1), ! Arguments F(IDIMF,N+1),W(see argument list) ! ! Latest January 1978 ! Revision ! ! ! Subprograms HWSSSP,HWSSS1,GENBUN,POISD2,POISN2,POISP2,COSGEN,ME ! Required TRIX,TRI3,PIMACH ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Paul Swarztrauber ! ! Language FORTRAN ! ! History Version 1 - September 1973 ! Version 2 - April 1976 ! Version 3 - January 1978 ! ! Algorithm The routine defines the finite difference ! equations, incorporates boundary data, and adjusts ! the right side of singular systems and then calls ! GENBUN to solve the system. ! ! Space ! Required CONTROL DATA 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine HWSSSP is roughly proportional ! to M*N*log2(N), but also depends on the input ! parameters NBDCND and MBDCND. Some typical values ! are listed in the table below. ! The solution process employed results in a loss ! of no more than three significant digits for N and ! M as large as 64. More detailed information about ! accuracy can be found in the documentation for ! subroutine GENBUN which is the routine that ! solves the finite difference equations. ! ! ! M(=N) MBDCND NBDCND T(MSECS) ! ----- ------ ------ -------- ! ! 32 0 0 31 ! 32 1 1 23 ! 32 3 3 36 ! 64 0 0 128 ! 64 1 1 96 ! 64 3 3 142 ! ! Portability American National Standards Institute FORTRAN. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required SIN,COS ! Resident ! Routines ! ! References P. N. Swarztrauber,'The Direct Solution Of The ! Discrete Poisson Equation On The Surface Of a ! Sphere, SIAM J. Numer. Anal.,15(1974), pp 212-215 ! ! Swarztrauber,P. and R. Sweet, 'Efficient FORTRAN ! Subprograms for The Solution of Elliptic Equations' ! NCAR TN/IA-109, July, 1975, 138 pp. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES P. N. Swarztrauber and R. Sweet, Efficient Fortran ! subprograms for the solution of elliptic equations, ! NCAR TN/IA-109, July 1975, 138 pp. ! P. N. Swarztrauber, The direct solution of the discrete ! Poisson equation on the surface of a sphere, SIAM ! Journal on Numerical Analysis 15 (1974), pp. 212-215. !***ROUTINES CALLED HWSSS1, PIMACH !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE HWSSSP ! DIMENSION F(IDIMF,*) ,BDTS(*) ,BDTF(*) ,BDPS(*) , & BDPF(*) ,W(*) !***FIRST EXECUTABLE STATEMENT HWSSSP PI = PIMACH(DUM) TPI = 2.*PI IERROR = 0 if (TS < 0. .OR. TF > PI) IERROR = 1 if (TS >= TF) IERROR = 2 if (MBDCND < 1 .OR. MBDCND > 9) IERROR = 3 if (PS < 0. .OR. PF > TPI) IERROR = 4 if (PS >= PF) IERROR = 5 if (N < 5) IERROR = 6 if (M < 5) IERROR = 7 if (NBDCND < 0 .OR. NBDCND > 4) IERROR = 8 if (ELMBDA > 0.) IERROR = 9 if (IDIMF < M+1) IERROR = 10 if ((NBDCND == 1 .OR. NBDCND == 2 .OR. NBDCND == 4) .AND. & MBDCND >= 5) IERROR = 11 if (TS == 0. .AND. & (MBDCND == 3 .OR. MBDCND == 4 .OR. MBDCND == 8)) IERROR = 12 if (TF == PI .AND. & (MBDCND == 2 .OR. MBDCND == 3 .OR. MBDCND == 6)) IERROR = 13 if ((MBDCND == 5 .OR. MBDCND == 6 .OR. MBDCND == 9) .AND. & TS /= 0.) IERROR = 14 if (MBDCND >= 7 .AND. TF /= PI) IERROR = 15 if (IERROR /= 0 .AND. IERROR /= 9) RETURN call HWSSS1 (TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,BDPF, & ELMBDA,F,IDIMF,PERTRB,W,W(M+2),W(2*M+3),W(3*M+4), & W(4*M+5),W(5*M+6),W(6*M+7)) W(1) = W(6*M+7)+6*(M+1) return end FUNCTION I1MACH (I) ! !! I1MACH returns integer machine dependent constants. ! !***LIBRARY SLATEC !***CATEGORY R1 !***TYPE INTEGER (I1MACH-I) !***KEYWORDS MACHINE CONSTANTS !***AUTHOR Fox, P. A., (Bell Labs) ! Hall, A. D., (Bell Labs) ! Schryer, N. L., (Bell Labs) !***DESCRIPTION ! ! I1MACH can be used to obtain machine-dependent parameters for the ! local machine environment. It is a function subprogram with one ! (input) argument and can be referenced as follows: ! ! K = I1MACH(I) ! ! where I=1,...,16. The (output) value of K above is determined by ! the (input) value of I. The results for various values of I are ! discussed below. ! ! I/O unit numbers: ! I1MACH( 1) = the standard input unit. ! I1MACH( 2) = the standard output unit. ! I1MACH( 3) = the standard punch unit. ! I1MACH( 4) = the standard error message unit. ! ! Words: ! I1MACH( 5) = the number of bits per integer storage unit. ! I1MACH( 6) = the number of characters per integer storage unit. ! ! Integers: ! assume integers are represented in the S-digit, base-A form ! ! sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) ! ! where 0 <= X(I) < A for I=0,...,S-1. ! I1MACH( 7) = A, the base. ! I1MACH( 8) = S, the number of base-A digits. ! I1MACH( 9) = A**S - 1, the largest magnitude. ! ! Floating-Point Numbers: ! Assume floating-point numbers are represented in the T-digit, ! base-B form ! sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) ! ! where 0 <= X(I) < B for I=1,...,T, ! 0 < X(1), and EMIN <= E <= EMAX. ! I1MACH(10) = B, the base. ! ! Single-Precision: ! I1MACH(11) = T, the number of base-B digits. ! I1MACH(12) = EMIN, the smallest exponent E. ! I1MACH(13) = EMAX, the largest exponent E. ! ! Double-Precision: ! I1MACH(14) = T, the number of base-B digits. ! I1MACH(15) = EMIN, the smallest exponent E. ! I1MACH(16) = EMAX, the largest exponent E. ! ! To alter this function for a particular environment, the desired ! set of DATA statements should be activated by removing the C from ! column 1. Also, the values of I1MACH(1) - I1MACH(4) should be ! checked for consistency with the local operating system. ! !***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for ! a portable library, ACM Transactions on Mathematical ! Software 4, 2 (June 1978), pp. 177-188. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 891012 Added VAX G-floating constants. (WRB) ! 891012 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900618 Added DEC RISC constants. (WRB) ! 900723 Added IBM RS 6000 constants. (WRB) ! 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. ! (RWC) ! 910710 Added HP 730 constants. (SMR) ! 911114 Added Convex IEEE constants. (WRB) ! 920121 Added SUN -r8 compiler option constants. (WRB) ! 920229 Added Touchstone Delta i860 constants. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 920625 Added Convex -p8 and -pd8 compiler option constants. ! (BKS, WRB) ! 930201 Added DEC Alpha and SGI constants. (RWC and WRB) ! 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler ! options. (DWL, RWC and WRB). !***END PROLOGUE I1MACH ! integer i1mach INTEGER IMACH(16),OUTPUT SAVE IMACH EQUIVALENCE (IMACH(4),OUTPUT) ! ! MACHINE CONSTANTS FOR THE AMIGA ! ABSOFT COMPILER ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 5 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -126 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1022 / ! DATA IMACH(16) / 1023 / ! ! MACHINE CONSTANTS FOR THE APOLLO ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -125 / ! DATA IMACH(13) / 129 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1021 / ! DATA IMACH(16) / 1025 / ! ! MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM ! ! DATA IMACH( 1) / 7 / ! DATA IMACH( 2) / 2 / ! DATA IMACH( 3) / 2 / ! DATA IMACH( 4) / 2 / ! DATA IMACH( 5) / 36 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 33 / ! DATA IMACH( 9) / Z1FFFFFFFF / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -256 / ! DATA IMACH(13) / 255 / ! DATA IMACH(14) / 60 / ! DATA IMACH(15) / -256 / ! DATA IMACH(16) / 255 / ! ! MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 7 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 48 / ! DATA IMACH( 6) / 6 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 39 / ! DATA IMACH( 9) / O0007777777777777 / ! DATA IMACH(10) / 8 / ! DATA IMACH(11) / 13 / ! DATA IMACH(12) / -50 / ! DATA IMACH(13) / 76 / ! DATA IMACH(14) / 26 / ! DATA IMACH(15) / -50 / ! DATA IMACH(16) / 76 / ! ! MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 7 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 48 / ! DATA IMACH( 6) / 6 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 39 / ! DATA IMACH( 9) / O0007777777777777 / ! DATA IMACH(10) / 8 / ! DATA IMACH(11) / 13 / ! DATA IMACH(12) / -50 / ! DATA IMACH(13) / 76 / ! DATA IMACH(14) / 26 / ! DATA IMACH(15) / -32754 / ! DATA IMACH(16) / 32780 / ! ! MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 7 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 64 / ! DATA IMACH( 6) / 8 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 63 / ! DATA IMACH( 9) / 9223372036854775807 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 47 / ! DATA IMACH(12) / -4095 / ! DATA IMACH(13) / 4094 / ! DATA IMACH(14) / 94 / ! DATA IMACH(15) / -4095 / ! DATA IMACH(16) / 4094 / ! ! MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 7 / ! DATA IMACH( 4) / 6LOUTPUT/ ! DATA IMACH( 5) / 60 / ! DATA IMACH( 6) / 10 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 48 / ! DATA IMACH( 9) / 00007777777777777777B / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 47 / ! DATA IMACH(12) / -929 / ! DATA IMACH(13) / 1070 / ! DATA IMACH(14) / 94 / ! DATA IMACH(15) / -929 / ! DATA IMACH(16) / 1069 / ! ! MACHINE CONSTANTS FOR THE CELERITY C1260 ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 0 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / Z'7FFFFFFF' / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -126 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1022 / ! DATA IMACH(16) / 1023 / ! ! MACHINE CONSTANTS FOR THE CONVEX ! USING THE -fn COMPILER OPTION ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 7 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -127 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1023 / ! DATA IMACH(16) / 1023 / ! ! MACHINE CONSTANTS FOR THE CONVEX ! USING THE -fi COMPILER OPTION ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 7 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -125 / ! DATA IMACH(13) / 128 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1021 / ! DATA IMACH(16) / 1024 / ! ! MACHINE CONSTANTS FOR THE CONVEX ! USING THE -p8 COMPILER OPTION ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 7 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 64 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 63 / ! DATA IMACH( 9) / 9223372036854775807 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 53 / ! DATA IMACH(12) / -1023 / ! DATA IMACH(13) / 1023 / ! DATA IMACH(14) / 113 / ! DATA IMACH(15) / -16383 / ! DATA IMACH(16) / 16383 / ! ! MACHINE CONSTANTS FOR THE CONVEX ! USING THE -pd8 COMPILER OPTION ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 7 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 64 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 63 / ! DATA IMACH( 9) / 9223372036854775807 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 53 / ! DATA IMACH(12) / -1023 / ! DATA IMACH(13) / 1023 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1023 / ! DATA IMACH(16) / 1023 / ! ! MACHINE CONSTANTS FOR THE CRAY ! USING THE 46 BIT INTEGER COMPILER OPTION ! ! DATA IMACH( 1) / 100 / ! DATA IMACH( 2) / 101 / ! DATA IMACH( 3) / 102 / ! DATA IMACH( 4) / 101 / ! DATA IMACH( 5) / 64 / ! DATA IMACH( 6) / 8 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 46 / ! DATA IMACH( 9) / 1777777777777777B / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 47 / ! DATA IMACH(12) / -8189 / ! DATA IMACH(13) / 8190 / ! DATA IMACH(14) / 94 / ! DATA IMACH(15) / -8099 / ! DATA IMACH(16) / 8190 / ! ! MACHINE CONSTANTS FOR THE CRAY ! USING THE 64 BIT INTEGER COMPILER OPTION ! ! DATA IMACH( 1) / 100 / ! DATA IMACH( 2) / 101 / ! DATA IMACH( 3) / 102 / ! DATA IMACH( 4) / 101 / ! DATA IMACH( 5) / 64 / ! DATA IMACH( 6) / 8 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 63 / ! DATA IMACH( 9) / 777777777777777777777B / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 47 / ! DATA IMACH(12) / -8189 / ! DATA IMACH(13) / 8190 / ! DATA IMACH(14) / 94 / ! DATA IMACH(15) / -8099 / ! DATA IMACH(16) / 8190 / ! ! MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 ! ! DATA IMACH( 1) / 11 / ! DATA IMACH( 2) / 12 / ! DATA IMACH( 3) / 8 / ! DATA IMACH( 4) / 10 / ! DATA IMACH( 5) / 16 / ! DATA IMACH( 6) / 2 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 15 / ! DATA IMACH( 9) / 32767 / ! DATA IMACH(10) / 16 / ! DATA IMACH(11) / 6 / ! DATA IMACH(12) / -64 / ! DATA IMACH(13) / 63 / ! DATA IMACH(14) / 14 / ! DATA IMACH(15) / -64 / ! DATA IMACH(16) / 63 / ! ! MACHINE CONSTANTS FOR THE DEC ALPHA ! USING G_FLOAT ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 5 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -127 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1023 / ! DATA IMACH(16) / 1023 / ! ! MACHINE CONSTANTS FOR THE DEC ALPHA ! USING IEEE_FLOAT ! DATA IMACH( 1) / 5 / DATA IMACH( 2) / 6 / DATA IMACH( 3) / 6 / DATA IMACH( 4) / 6 / DATA IMACH( 5) / 32 / DATA IMACH( 6) / 4 / DATA IMACH( 7) / 2 / DATA IMACH( 8) / 31 / DATA IMACH( 9) / 2147483647 / DATA IMACH(10) / 2 / DATA IMACH(11) / 24 / DATA IMACH(12) / -125 / DATA IMACH(13) / 128 / DATA IMACH(14) / 53 / DATA IMACH(15) / -1021 / DATA IMACH(16) / 1024 / ! ! MACHINE CONSTANTS FOR THE DEC RISC ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -125 / ! DATA IMACH(13) / 128 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1021 / ! DATA IMACH(16) / 1024 / ! ! MACHINE CONSTANTS FOR THE DEC VAX ! USING D_FLOATING ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 5 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -127 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 56 / ! DATA IMACH(15) / -127 / ! DATA IMACH(16) / 127 / ! ! MACHINE CONSTANTS FOR THE DEC VAX ! USING G_FLOATING ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 5 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -127 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1023 / ! DATA IMACH(16) / 1023 / ! ! MACHINE CONSTANTS FOR THE ELXSI 6400 ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 32 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -126 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1022 / ! DATA IMACH(16) / 1023 / ! ! MACHINE CONSTANTS FOR THE HARRIS 220 ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 0 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 24 / ! DATA IMACH( 6) / 3 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 23 / ! DATA IMACH( 9) / 8388607 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 23 / ! DATA IMACH(12) / -127 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 38 / ! DATA IMACH(15) / -127 / ! DATA IMACH(16) / 127 / ! ! MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 43 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 36 / ! DATA IMACH( 6) / 6 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 35 / ! DATA IMACH( 9) / O377777777777 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 27 / ! DATA IMACH(12) / -127 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 63 / ! DATA IMACH(15) / -127 / ! DATA IMACH(16) / 127 / ! ! MACHINE CONSTANTS FOR THE HP 730 ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -125 / ! DATA IMACH(13) / 128 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1021 / ! DATA IMACH(16) / 1024 / ! ! MACHINE CONSTANTS FOR THE HP 2100 ! 3 WORD DOUBLE PRECISION OPTION WITH FTN4 ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 4 / ! DATA IMACH( 4) / 1 / ! DATA IMACH( 5) / 16 / ! DATA IMACH( 6) / 2 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 15 / ! DATA IMACH( 9) / 32767 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 23 / ! DATA IMACH(12) / -128 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 39 / ! DATA IMACH(15) / -128 / ! DATA IMACH(16) / 127 / ! ! MACHINE CONSTANTS FOR THE HP 2100 ! 4 WORD DOUBLE PRECISION OPTION WITH FTN4 ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 4 / ! DATA IMACH( 4) / 1 / ! DATA IMACH( 5) / 16 / ! DATA IMACH( 6) / 2 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 15 / ! DATA IMACH( 9) / 32767 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 23 / ! DATA IMACH(12) / -128 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 55 / ! DATA IMACH(15) / -128 / ! DATA IMACH(16) / 127 / ! ! MACHINE CONSTANTS FOR THE HP 9000 ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 7 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 32 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -126 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1015 / ! DATA IMACH(16) / 1017 / ! ! MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, ! THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND ! THE PERKIN ELMER (INTERDATA) 7/32. ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 7 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / Z7FFFFFFF / ! DATA IMACH(10) / 16 / ! DATA IMACH(11) / 6 / ! DATA IMACH(12) / -64 / ! DATA IMACH(13) / 63 / ! DATA IMACH(14) / 14 / ! DATA IMACH(15) / -64 / ! DATA IMACH(16) / 63 / ! ! MACHINE CONSTANTS FOR THE IBM PC ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 0 / ! DATA IMACH( 4) / 0 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -125 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1021 / ! DATA IMACH(16) / 1023 / ! ! MACHINE CONSTANTS FOR THE IBM RS 6000 ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 0 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -125 / ! DATA IMACH(13) / 128 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1021 / ! DATA IMACH(16) / 1024 / ! ! MACHINE CONSTANTS FOR THE INTEL i860 ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -125 / ! DATA IMACH(13) / 128 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1021 / ! DATA IMACH(16) / 1024 / ! ! MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 5 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 36 / ! DATA IMACH( 6) / 5 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 35 / ! DATA IMACH( 9) / "377777777777 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 27 / ! DATA IMACH(12) / -128 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 54 / ! DATA IMACH(15) / -101 / ! DATA IMACH(16) / 127 / ! ! MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 5 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 36 / ! DATA IMACH( 6) / 5 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 35 / ! DATA IMACH( 9) / "377777777777 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 27 / ! DATA IMACH(12) / -128 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 62 / ! DATA IMACH(15) / -128 / ! DATA IMACH(16) / 127 / ! ! MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING ! 32-BIT INTEGER ARITHMETIC. ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 5 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -127 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 56 / ! DATA IMACH(15) / -127 / ! DATA IMACH(16) / 127 / ! ! MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING ! 16-BIT INTEGER ARITHMETIC. ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 5 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 16 / ! DATA IMACH( 6) / 2 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 15 / ! DATA IMACH( 9) / 32767 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -127 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 56 / ! DATA IMACH(15) / -127 / ! DATA IMACH(16) / 127 / ! ! MACHINE CONSTANTS FOR THE SILICON GRAPHICS ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -125 / ! DATA IMACH(13) / 128 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1021 / ! DATA IMACH(16) / 1024 / ! ! MACHINE CONSTANTS FOR THE SUN ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -125 / ! DATA IMACH(13) / 128 / ! DATA IMACH(14) / 53 / ! DATA IMACH(15) / -1021 / ! DATA IMACH(16) / 1024 / ! ! MACHINE CONSTANTS FOR THE SUN ! USING THE -r8 COMPILER OPTION ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 6 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 32 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 31 / ! DATA IMACH( 9) / 2147483647 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 53 / ! DATA IMACH(12) / -1021 / ! DATA IMACH(13) / 1024 / ! DATA IMACH(14) / 113 / ! DATA IMACH(15) / -16381 / ! DATA IMACH(16) / 16384 / ! ! MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER ! ! DATA IMACH( 1) / 5 / ! DATA IMACH( 2) / 6 / ! DATA IMACH( 3) / 1 / ! DATA IMACH( 4) / 6 / ! DATA IMACH( 5) / 36 / ! DATA IMACH( 6) / 4 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 35 / ! DATA IMACH( 9) / O377777777777 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 27 / ! DATA IMACH(12) / -128 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 60 / ! DATA IMACH(15) / -1024 / ! DATA IMACH(16) / 1023 / ! ! MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR ! ! DATA IMACH( 1) / 1 / ! DATA IMACH( 2) / 1 / ! DATA IMACH( 3) / 0 / ! DATA IMACH( 4) / 1 / ! DATA IMACH( 5) / 16 / ! DATA IMACH( 6) / 2 / ! DATA IMACH( 7) / 2 / ! DATA IMACH( 8) / 15 / ! DATA IMACH( 9) / 32767 / ! DATA IMACH(10) / 2 / ! DATA IMACH(11) / 24 / ! DATA IMACH(12) / -127 / ! DATA IMACH(13) / 127 / ! DATA IMACH(14) / 56 / ! DATA IMACH(15) / -127 / ! DATA IMACH(16) / 127 / ! !***FIRST EXECUTABLE STATEMENT I1MACH ! if ( I < 1 .OR. I > 16 ) then WRITE (UNIT = OUTPUT, FMT = 9000) 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') STOP end if I1MACH = IMACH(I) return end subroutine I1MERG (ICOS, I1, M1, I2, M2, I3) ! !! I1MERG merges two strings of ascending integers. ! !***LIBRARY SLATEC !***TYPE INTEGER (S1MERG-S, D1MERG-D, C1MERG-C, I1MERG-I) !***AUTHOR Boland, W. Robert, (LANL) ! Clemens, Reginald, (PLK) !***DESCRIPTION ! ! This subroutine merges two ascending strings of integers in the ! array ICOS. The first string is of length M1 and starts at ! ICOS(I1+1). The second string is of length M2 and starts at ! ICOS(I2+1). The merged string goes into ICOS(I3+1). ! !***ROUTINES CALLED ICOPY !***REVISION HISTORY (YYMMDD) ! 920202 DATE WRITTEN !***END PROLOGUE I1MERG INTEGER I1, I2, I3, M1, M2 REAL ICOS(*) ! INTEGER J1, J2, J3 ! !***FIRST EXECUTABLE STATEMENT I1MERG if (M1 == 0 .AND. M2 == 0) RETURN ! if (M1 == 0 .AND. M2 /= 0) THEN call ICOPY (M2, ICOS(I2+1), 1, ICOS(I3+1), 1) return end if ! if (M1 /= 0 .AND. M2 == 0) THEN call ICOPY (M1, ICOS(I1+1), 1, ICOS(I3+1), 1) return end if ! J1 = 1 J2 = 1 J3 = 1 ! 10 if (ICOS(I1+J1) <= ICOS(I2+J2)) THEN ICOS(I3+J3) = ICOS(I1+J1) J1 = J1+1 if (J1 > M1) THEN call ICOPY (M2-J2+1, ICOS(I2+J2), 1, ICOS(I3+J3+1), 1) return ENDIF ELSE ICOS(I3+J3) = ICOS(I2+J2) J2 = J2+1 if (J2 > M2) THEN call ICOPY (M1-J1+1, ICOS(I1+J1), 1, ICOS(I3+J3+1), 1) return ENDIF end if J3 = J3+1 go to 10 end INTEGER FUNCTION ICAMAX (N, CX, INCX) ! !! ICAMAX finds the smallest index of the component of a complex ... ! vector having the maximum sum of magnitudes of real ! and imaginary parts. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A2 !***TYPE COMPLEX (ISAMAX-S, IDAMAX-D, ICAMAX-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! CX complex vector with N elements ! INCX storage spacing between elements of CX ! ! --Output-- ! ICAMAX smallest index (zero if N <= 0) ! ! Returns the smallest index of the component of CX having the ! largest sum of magnitudes of real and imaginary parts. ! ICAMAX = first I, I = 1 to N, to maximize ! ABS(REAL(CX(IX+(I-1)*INCX))) + ABS(IMAG(CX(IX+(I-1)*INCX))), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900821 Modified to correct problem with a negative increment. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ICAMAX COMPLEX CX(*) REAL SMAX, XMAG INTEGER I, INCX, IX, N COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) !***FIRST EXECUTABLE STATEMENT ICAMAX ICAMAX = 0 if (N <= 0) RETURN ICAMAX = 1 if (N == 1) RETURN ! if (INCX == 1) GOTO 20 ! ! Code for increment not equal to 1. ! IX = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 SMAX = CABS1(CX(IX)) IX = IX + INCX DO 10 I = 2,N XMAG = CABS1(CX(IX)) if (XMAG > SMAX) THEN ICAMAX = I SMAX = XMAG ENDIF IX = IX + INCX 10 CONTINUE return ! ! Code for increment equal to 1. ! 20 SMAX = CABS1(CX(1)) DO 30 I = 2,N XMAG = CABS1(CX(I)) if (XMAG > SMAX) THEN ICAMAX = I SMAX = XMAG ENDIF 30 CONTINUE return end subroutine ICOPY (N, IX, INCX, IY, INCY) ! !! ICOPY copies a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A5 !***TYPE INTEGER (ICOPY-S, DCOPY-D, CCOPY-C, ICOPY-I) !***KEYWORDS BLAS, COPY, LINEAR ALGEBRA, VECTOR !***AUTHOR Boland, W. Robert, (LANL) ! Clemens, Reginald, (PLK) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! IX integer vector with N elements ! INCX storage spacing between elements of IX ! IY integer vector with N elements ! INCY storage spacing between elements of IY ! ! --Output-- ! IY copy of vector IX (unchanged if N <= 0) ! ! Copy integer IX to integer IY. ! For I = 0 to N-1, copy IX(LX+I*INCX) to IY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 930201 DATE WRITTEN !***END PROLOGUE ICOPY INTEGER IX(*), IY(*) !***FIRST EXECUTABLE STATEMENT ICOPY if (N <= 0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IIX = 1 IIY = 1 if (INCX < 0) IIX = (-N+1)*INCX + 1 if (INCY < 0) IIY = (-N+1)*INCY + 1 DO 10 I = 1,N IY(IIY) = IX(IIX) IIX = IIX + INCX IIY = IIY + INCY 10 CONTINUE return ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 7. ! 20 M = MOD(N,7) if (M == 0) go to 40 DO 30 I = 1,M IY(I) = IX(I) 30 CONTINUE if (N < 7) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 IY(I) = IX(I) IY(I+1) = IX(I+1) IY(I+2) = IX(I+2) IY(I+3) = IX(I+3) IY(I+4) = IX(I+4) IY(I+5) = IX(I+5) IY(I+6) = IX(I+6) 50 CONTINUE return ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX IY(I) = IX(I) 70 CONTINUE return end INTEGER FUNCTION IDAMAX (N, DX, INCX) ! !! IDAMAX finds the smallest index of that component of a vector ... ! having the maximum magnitude. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A2 !***TYPE DOUBLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! DX double precision vector with N elements ! INCX storage spacing between elements of DX ! ! --Output-- ! IDAMAX smallest index (zero if N <= 0) ! ! Find smallest index of maximum magnitude of double precision DX. ! IDAMAX = first I, I = 1 to N, to maximize ABS(DX(IX+(I-1)*INCX)), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900821 Modified to correct problem with a negative increment. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE IDAMAX DOUBLE PRECISION DX(*), DMAX, XMAG INTEGER I, INCX, IX, N !***FIRST EXECUTABLE STATEMENT IDAMAX IDAMAX = 0 if (N <= 0) RETURN IDAMAX = 1 if (N == 1) RETURN ! if (INCX == 1) GOTO 20 ! ! Code for increments not equal to 1. ! IX = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 DMAX = ABS(DX(IX)) IX = IX + INCX DO 10 I = 2,N XMAG = ABS(DX(IX)) if (XMAG > DMAX) THEN IDAMAX = I DMAX = XMAG ENDIF IX = IX + INCX 10 CONTINUE return ! ! Code for increments equal to 1. ! 20 DMAX = ABS(DX(1)) DO 30 I = 2,N XMAG = ABS(DX(I)) if (XMAG > DMAX) THEN IDAMAX = I DMAX = XMAG ENDIF 30 CONTINUE return end INTEGER FUNCTION IDLOC (LOC, SX, IX) ! !! IDLOC is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (IPLOC-S, IDLOC-D) !***KEYWORDS RELATIVE ADDRESS DETERMINATION FUNCTION, SLATEC !***AUTHOR Boland, W. Robert, (LANL) ! Nicol, Tom, (University of British Columbia) !***DESCRIPTION ! ! Given a "virtual" location, IDLOC returns the relative working ! address of the vector component stored in SX, IX. Any necessary ! page swaps are performed automatically for the user in this ! function subprogram. ! ! LOC is the "virtual" address of the data to be retrieved. ! SX ,IX represent the matrix where the data is stored. ! !***SEE ALSO DSPLP !***ROUTINES CALLED DPRWPG, XERMSG !***REVISION HISTORY (YYMMDD) ! 890606 DATE WRITTEN ! 890606 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 910731 Added code to set IDLOC to 0 if LOC is non-positive. (WRB) !***END PROLOGUE IDLOC DOUBLE PRECISION SX(*) INTEGER IX(*) !***FIRST EXECUTABLE STATEMENT IDLOC if (LOC <= 0) THEN call XERMSG ('SLATEC', 'IDLOC', & 'A value of LOC, the first argument, <= 0 was encountered', & 55, 1) IDLOC = 0 return end if ! ! Two cases exist: (1 <= LOC <= K) .OR. (LOC > K). ! K = IX(3) + 4 LMX = IX(1) LMXM1 = LMX - 1 if (LOC <= K) THEN IDLOC = LOC return end if ! ! Compute length of the page, starting address of the page, page ! number and relative working address. ! LPG = LMX-K ITEMP = LOC - K - 1 IPAGE = ITEMP/LPG + 1 IDLOC = MOD(ITEMP,LPG) + K + 1 NP = ABS(IX(LMXM1)) ! ! Determine if a page fault has occurred. If so, write page NP ! and read page IPAGE. Write the page only if it has been ! modified. ! if (IPAGE /= NP) THEN if (SX(LMX) == 1.0) THEN SX(LMX) = 0.0 KEY = 2 call DPRWPG (KEY, NP, LPG, SX, IX) ENDIF KEY = 1 call DPRWPG (KEY, IPAGE, LPG, SX, IX) end if return end subroutine IMTQL1 (N, D, E, IERR) ! !! IMTQL1 computes the eigenvalues of a symmetric tridiagonal matrix ! using the implicit QL method. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5, D4C2A !***TYPE SINGLE PRECISION (IMTQL1-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure IMTQL1, ! NUM. MATH. 12, 377-383(1968) by Martin and Wilkinson, ! as modified in NUM. MATH. 15, 450(1970) by Dubrulle. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). ! ! This subroutine finds the eigenvalues of a SYMMETRIC ! TRIDIAGONAL matrix by the implicit QL method. ! ! On INPUT ! ! N is the order of the matrix. N is an INTEGER variable. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is ! arbitrary. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! On OUTPUT ! ! D contains the eigenvalues in ascending order. If an error ! exit is made, the eigenvalues are correct and ordered for ! indices 1, 2, ..., IERR-1, but may not be the smallest ! eigenvalues. ! ! E has been destroyed. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues should be correct for indices ! 1, 2, ..., IERR-1. These eigenvalues are ! ordered, but are not necessarily the smallest. ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE IMTQL1 ! INTEGER I,J,L,M,N,II,MML,IERR REAL D(*),E(*) REAL B,C,F,G,P,R,S,S1,S2 REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT IMTQL1 IERR = 0 if (N == 1) go to 1001 ! DO 100 I = 2, N 100 E(I-1) = E(I) ! E(N) = 0.0E0 ! DO 290 L = 1, N J = 0 ! .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 105 DO 110 M = L, N if (M == N) go to 120 S1 = ABS(D(M)) + ABS(D(M+1)) S2 = S1 + ABS(E(M)) if (S2 == S1) go to 120 110 CONTINUE ! 120 P = D(L) if (M == L) go to 215 if (J == 30) go to 1000 J = J + 1 ! .......... FORM SHIFT .......... G = (D(L+1) - P) / (2.0E0 * E(L)) R = PYTHAG(G,1.0E0) G = D(M) - P + E(L) / (G + SIGN(R,G)) S = 1.0E0 C = 1.0E0 P = 0.0E0 MML = M - L ! .......... 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) < ABS(G)) go to 150 C = G / F R = SQRT(C*C+1.0E0) E(I+1) = F * R S = 1.0E0 / R C = C * S go to 160 150 S = F / G R = SQRT(S*S+1.0E0) E(I+1) = G * R C = 1.0E0 / R S = S * C 160 G = D(I+1) - P R = (D(I) - G) * S + 2.0E0 * C * B P = S * R D(I+1) = G + P G = C * R - B 200 CONTINUE ! D(L) = D(L) - P E(L) = G E(M) = 0.0E0 go to 105 ! .......... ORDER EIGENVALUES .......... 215 if (L == 1) go to 250 ! .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... DO 230 II = 2, L I = L + 2 - II if (P >= D(I-1)) go to 270 D(I) = D(I-1) 230 CONTINUE ! 250 I = 1 270 D(I) = P 290 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN end subroutine IMTQL2 (NM, N, D, E, Z, IERR) ! !! IMTQL2 computes eigenvalues and eigenvectors of a symmetric tridiagonal ... ! matrix using the implicit QL method. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5, D4C2A !***TYPE SINGLE PRECISION (IMTQL2-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure IMTQL2, ! NUM. MATH. 12, 377-383(1968) by Martin and Wilkinson, ! as modified in NUM. MATH. 15, 450(1970) by Dubrulle. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). ! ! This subroutine finds the eigenvalues and eigenvectors ! of a SYMMETRIC TRIDIAGONAL matrix by the implicit QL method. ! The eigenvectors of a FULL SYMMETRIC matrix can also ! be found if TRED2 has been used to reduce this ! full matrix to tridiagonal form. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, Z, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is ! arbitrary. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! Z contains the transformation matrix produced in the reduction ! by TRED2, if performed. This transformation matrix is ! necessary if you want to obtain the eigenvectors of the full ! symmetric matrix. If the eigenvectors of the symmetric ! tridiagonal matrix are desired, Z must contain the identity ! matrix. Z is a two-dimensional REAL array, dimensioned ! Z(NM,N). ! ! On OUTPUT ! ! D contains the eigenvalues in ascending order. If an ! error exit is made, the eigenvalues are correct but ! unordered for indices 1, 2, ..., IERR-1. ! ! E has been destroyed. ! ! Z contains orthonormal eigenvectors of the full symmetric ! or symmetric tridiagonal matrix, depending on what it ! contained on input. If an error exit is made, Z contains ! the eigenvectors associated with the stored eigenvalues. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues and eigenvectors should be correct ! for indices 1, 2, ..., IERR-1, but the eigenvalues ! are not ordered. ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE IMTQL2 ! INTEGER I,J,K,L,M,N,II,NM,MML,IERR REAL D(*),E(*),Z(NM,*) REAL B,C,F,G,P,R,S,S1,S2 REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT IMTQL2 IERR = 0 if (N == 1) go to 1001 ! DO 100 I = 2, N 100 E(I-1) = E(I) ! E(N) = 0.0E0 ! DO 240 L = 1, N J = 0 ! .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 105 DO 110 M = L, N if (M == N) go to 120 S1 = ABS(D(M)) + ABS(D(M+1)) S2 = S1 + ABS(E(M)) if (S2 == S1) go to 120 110 CONTINUE ! 120 P = D(L) if (M == L) go to 240 if (J == 30) go to 1000 J = J + 1 ! .......... FORM SHIFT .......... G = (D(L+1) - P) / (2.0E0 * E(L)) R = PYTHAG(G,1.0E0) G = D(M) - P + E(L) / (G + SIGN(R,G)) S = 1.0E0 C = 1.0E0 P = 0.0E0 MML = M - L ! .......... 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) < ABS(G)) go to 150 C = G / F R = SQRT(C*C+1.0E0) E(I+1) = F * R S = 1.0E0 / R C = C * S go to 160 150 S = F / G R = SQRT(S*S+1.0E0) E(I+1) = G * R C = 1.0E0 / R S = S * C 160 G = D(I+1) - P R = (D(I) - G) * S + 2.0E0 * C * B P = S * R D(I+1) = G + P G = C * R - B ! .......... 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 ! 200 CONTINUE ! D(L) = D(L) - P E(L) = G E(M) = 0.0E0 go to 105 240 CONTINUE ! .......... ORDER EIGENVALUES AND EIGENVECTORS .......... DO 300 II = 2, N I = II - 1 K = I P = D(I) ! DO 260 J = II, N if (D(J) >= P) go to 260 K = J P = D(J) 260 CONTINUE ! if (K == I) go to 300 D(K) = D(I) D(I) = P ! DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE ! 300 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN end subroutine IMTQLV (N, D, E, E2, W, IND, IERR, RV1) ! !! IMTQLV computes the eigenvalues of a symmetric tridiagonal matrix ... ! using the implicit QL method. Eigenvectors may be computed ... ! later. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5, D4C2A !***TYPE SINGLE PRECISION (IMTQLV-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a variant of IMTQL1 which is a translation of ! ALGOL procedure IMTQL1, NUM. MATH. 12, 377-383(1968) by Martin and ! Wilkinson, as modified in NUM. MATH. 15, 450(1970) by Dubrulle. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). ! ! This subroutine finds the eigenvalues of a SYMMETRIC TRIDIAGONAL ! matrix by the implicit QL method and associates with them ! their corresponding submatrix indices. ! ! On INPUT ! ! N is the order of the matrix. N is an INTEGER variable. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is ! arbitrary. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! E2 contains the squares of the corresponding elements of E in ! its last N-1 positions. E2(1) is arbitrary. E2 is a one- ! dimensional REAL array, dimensioned E2(N). ! ! On OUTPUT ! ! D and E are unaltered. ! ! Elements of E2, corresponding to elements of E regarded as ! negligible, have been replaced by zero causing the matrix to ! split into a direct sum of submatrices. E2(1) is also set ! to zero. ! ! W contains the eigenvalues in ascending order. If an error ! exit is made, the eigenvalues are correct and ordered for ! indices 1, 2, ..., IERR-1, but may not be the smallest ! eigenvalues. W is a one-dimensional REAL array, dimensioned ! W(N). ! ! IND contains the submatrix indices associated with the ! corresponding eigenvalues in W -- 1 for eigenvalues belonging ! to the first submatrix from the top, 2 for those belonging to ! the second submatrix, etc. IND is a one-dimensional REAL ! array, dimensioned IND(N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues should be correct for indices ! 1, 2, ..., IERR-1. These eigenvalues are ! ordered, but are not necessarily the smallest. ! ! RV1 is a one-dimensional REAL array used for temporary storage, ! dimensioned RV1(N). ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE IMTQLV ! INTEGER I,J,K,L,M,N,II,MML,TAG,IERR REAL D(*),E(*),E2(*),W(*),RV1(*) REAL B,C,F,G,P,R,S,S1,S2 REAL PYTHAG INTEGER IND(*) ! !***FIRST EXECUTABLE STATEMENT IMTQLV IERR = 0 K = 0 TAG = 0 ! DO 100 I = 1, N W(I) = D(I) if (I /= 1) RV1(I-1) = E(I) 100 CONTINUE ! E2(1) = 0.0E0 RV1(N) = 0.0E0 ! DO 290 L = 1, N J = 0 ! .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 105 DO 110 M = L, N if (M == N) go to 120 S1 = ABS(W(M)) + ABS(W(M+1)) S2 = S1 + ABS(RV1(M)) if (S2 == S1) go to 120 ! .......... GUARD AGAINST UNDERFLOWED ELEMENT OF E2 .......... if (E2(M+1) == 0.0E0) go to 125 110 CONTINUE ! 120 if (M <= K) go to 130 if (M /= N) E2(M+1) = 0.0E0 125 K = M TAG = TAG + 1 130 P = W(L) if (M == L) go to 215 if (J == 30) go to 1000 J = J + 1 ! .......... FORM SHIFT .......... G = (W(L+1) - P) / (2.0E0 * RV1(L)) R = PYTHAG(G,1.0E0) G = W(M) - P + RV1(L) / (G + SIGN(R,G)) S = 1.0E0 C = 1.0E0 P = 0.0E0 MML = M - L ! .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... DO 200 II = 1, MML I = M - II F = S * RV1(I) B = C * RV1(I) if (ABS(F) < ABS(G)) go to 150 C = G / F R = SQRT(C*C+1.0E0) RV1(I+1) = F * R S = 1.0E0 / R C = C * S go to 160 150 S = F / G R = SQRT(S*S+1.0E0) RV1(I+1) = G * R C = 1.0E0 / R S = S * C 160 G = W(I+1) - P R = (W(I) - G) * S + 2.0E0 * C * B P = S * R W(I+1) = G + P G = C * R - B 200 CONTINUE ! W(L) = W(L) - P RV1(L) = G RV1(M) = 0.0E0 go to 105 ! .......... ORDER EIGENVALUES .......... 215 if (L == 1) go to 250 ! .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... DO 230 II = 2, L I = L + 2 - II if (P >= W(I-1)) go to 270 W(I) = W(I-1) IND(I) = IND(I-1) 230 CONTINUE ! 250 I = 1 270 W(I) = P IND(I) = TAG 290 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN end subroutine INDXA (I, IR, IDXA, NA) ! !! INDXA is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE INTEGER (INDXA-I) !***AUTHOR (UNKNOWN) !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CBLKT !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE INDXA COMMON /CBLKT/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT INDXA NA = 2**IR IDXA = I-NA+1 if (I-NM) 102,102,101 101 NA = 0 102 RETURN end subroutine INDXB (I, IR, IDX, IDP) ! !! INDXB is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE INTEGER (INDXB-I) !***AUTHOR (UNKNOWN) !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CBLKT !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 920422 Added statement so IDX would always be defined. (WRB) !***END PROLOGUE INDXB ! COMMON /CBLKT/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT INDXB IDX = I IDP = 0 if (IR) 107,101,103 101 if (I-NM) 102,102,107 102 IDX = I IDP = 1 return 103 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) 105,105,104 104 IDP = 0 return 105 if (I+IPL-NM) 107,107,106 106 IDP = NM+IPL-I+1 107 RETURN end subroutine INDXC (I, IR, IDXC, NC) ! !! INDXC is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE INTEGER (INDXC-I) !***AUTHOR (UNKNOWN) !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CBLKT !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE INDXC COMMON /CBLKT/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT INDXC NC = 2**IR IDXC = I if (IDXC+NC-1-NM) 102,102,101 101 NC = 0 102 RETURN end function INITDS (OS, NOS, ETA) ! !! INITDS determines the number of terms needed in an orthogonal ... ! polynomial series so that it meets a specified accuracy. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C3A2 !***TYPE DOUBLE PRECISION (INITS-S, INITDS-D) !***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, ! ORTHOGONAL SERIES, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Initialize the orthogonal series, represented by the array OS, so ! that INITDS is the number of terms needed to insure the error is no ! larger than ETA. Ordinarily, ETA will be chosen to be one-tenth ! machine precision. ! ! Input Arguments -- ! OS double precision array of NOS coefficients in an orthogonal ! series. ! NOS number of coefficients in OS. ! ETA single precision scalar containing requested accuracy of ! series. ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891115 Modified error message. (WRB) ! 891115 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE INITDS DOUBLE PRECISION OS(*) !***FIRST EXECUTABLE STATEMENT INITDS if (NOS < 1) call XERMSG ('SLATEC', 'INITDS', & 'Number of coefficients is less than 1', 2, 1) ! ERR = 0. DO 10 II = 1,NOS I = NOS + 1 - II ERR = ERR + ABS(REAL(OS(I))) if (ERR > ETA) go to 20 10 CONTINUE ! 20 if (I == NOS) call XERMSG ('SLATEC', 'INITDS', & 'Chebyshev series too short for specified accuracy', 1, 1) INITDS = I ! return end function INITS (OS, NOS, ETA) ! !! INITS determines the number of terms needed in an orthogonal ... ! polynomial series so that it meets a specified accuracy. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C3A2 !***TYPE SINGLE PRECISION (INITS-S, INITDS-D) !***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, ! ORTHOGONAL SERIES, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Initialize the orthogonal series, represented by the array OS, so ! that INITS is the number of terms needed to insure the error is no ! larger than ETA. Ordinarily, ETA will be chosen to be one-tenth ! machine precision. ! ! Input Arguments -- ! OS single precision array of NOS coefficients in an orthogonal ! series. ! NOS number of coefficients in OS. ! ETA single precision scalar containing requested accuracy of ! series. ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891115 Modified error message. (WRB) ! 891115 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE INITS REAL OS(*) !***FIRST EXECUTABLE STATEMENT INITS if (NOS < 1) call XERMSG ('SLATEC', 'INITS', & 'Number of coefficients is less than 1', 2, 1) ! ERR = 0. DO 10 II = 1,NOS I = NOS + 1 - II ERR = ERR + ABS(OS(I)) if (ERR > ETA) go to 20 10 CONTINUE ! 20 if (I == NOS) call XERMSG ('SLATEC', 'INITS', & 'Chebyshev series too short for specified accuracy', 1, 1) INITS = I ! return end subroutine INTRV (XT, LXT, X, ILO, ILEFT, MFLAG) ! !! INTRV computes the largest integer ILEFT in 1 <= ILEFT <= LXT ... ! such that XT(ILEFT) <= X where XT(*) is a subdivision ... ! of the X interval. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE SINGLE PRECISION (INTRV-S, DINTRV-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract ! INTRV is the INTERV routine of the reference. ! ! INTRV computes the largest integer ILEFT in 1 <= ILEFT <= ! LXT such that XT(ILEFT) <= X where XT(*) is a subdivision of ! the X interval. Precisely, ! ! X < XT(1) 1 -1 ! if XT(I) <= X < XT(I+1) then ILEFT=I , MFLAG=0 ! XT(LXT) <= X LXT 1, ! ! That is, when multiplicities are present in the break point ! to the left of X, the largest index is taken for ILEFT. ! ! Description of Arguments ! Input ! XT - XT is a knot or break point vector of length LXT ! LXT - length of the XT vector ! X - argument ! ILO - an initialization parameter which must be set ! to 1 the first time the spline array XT is ! processed by INTRV. ! ! Output ! ILO - ILO contains information for efficient process- ! ing after the initial call, and ILO must not be ! changed by the user. Distinct splines require ! distinct ILO parameters. ! ILEFT - largest integer satisfying XT(ILEFT) <= X ! MFLAG - signals when X lies out of bounds ! ! Error Conditions ! None ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE INTRV ! INTEGER IHI, ILEFT, ILO, ISTEP, LXT, MFLAG, MIDDLE REAL X, XT DIMENSION XT(*) !***FIRST EXECUTABLE STATEMENT INTRV IHI = ILO + 1 if (IHI < LXT) go to 10 if (X >= XT(LXT)) go to 110 if (LXT <= 1) go to 90 ILO = LXT - 1 IHI = LXT ! 10 if (X >= XT(IHI)) go to 40 if (X >= XT(ILO)) go to 100 ! ! *** NOW X < XT(IHI) . FIND LOWER BOUND ISTEP = 1 20 IHI = ILO ILO = IHI - ISTEP if (ILO <= 1) go to 30 if (X >= XT(ILO)) go to 70 ISTEP = ISTEP*2 go to 20 30 ILO = 1 if (X < XT(1)) go to 90 go to 70 ! *** NOW X >= XT(ILO) . FIND UPPER BOUND 40 ISTEP = 1 50 ILO = IHI IHI = ILO + ISTEP if (IHI >= LXT) go to 60 if (X < XT(IHI)) go to 70 ISTEP = ISTEP*2 go to 50 60 if (X >= XT(LXT)) go to 110 IHI = LXT ! ! *** NOW XT(ILO) <= X < XT(IHI) . NARROW THE INTERVAL 70 MIDDLE = (ILO+IHI)/2 if (MIDDLE == ILO) go to 100 ! NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1 if (X < XT(MIDDLE)) go to 80 ILO = MIDDLE go to 70 80 IHI = MIDDLE go to 70 ! *** SET OUTPUT AND RETURN 90 MFLAG = -1 ILEFT = 1 return 100 MFLAG = 0 ILEFT = ILO return 110 MFLAG = 1 ILEFT = LXT return end subroutine INTYD (T, K, YH, NYH, DKY, IFLAG) ! !! INTYD is subsidiary to DEBDF. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (INTYD-S, DINTYD-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! INTYD approximates the solution and derivatives at T by polynomial ! interpolation. Must be used in conjunction with the integrator ! package DEBDF. ! ---------------------------------------------------------------------- ! INTYD computes interpolated values of the K-th derivative of the ! dependent variable vector Y, and stores it in DKY. ! This routine is called by DEBDF with K = 0,1 and T = TOUT, but may ! also be called by the user for any K up to the current order. ! (see detailed instructions in LSODE usage documentation.) ! ---------------------------------------------------------------------- ! The computed values in DKY are gotten by interpolation using the ! Nordsieck history array YH. This array corresponds uniquely to a ! vector-valued polynomial of degree NQCUR or less, and DKY is set ! to the K-th derivative of this polynomial at T. ! The formula for DKY is.. ! Q ! DKY(I) = sum C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) ! J=K ! where C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. ! The quantities NQ = NQCUR, L = NQ+1, N = NEQ, TN, and H are ! communicated by common. The above sum is done in reverse order. ! IFLAG is returned negative if either K or T is out of bounds. ! ---------------------------------------------------------------------- ! !***SEE ALSO DEBDF !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DEBDF1 !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE INTYD ! !LLL. OPTIMIZE INTEGER K, NYH, IFLAG, I, IC, IER, IOWND, IOWNS, J, JB, JB2, & JJ, JJ1, JP1, JSTART, KFLAG, L, MAXORD, METH, MITER, N, NFE, & NJE, NQ, NQU, NST REAL T, YH, DKY, & ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND, & C, R, S, TP DIMENSION YH(NYH,*), DKY(*) COMMON /DEBDF1/ ROWND, ROWNS(210), & EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6), & IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, & NJE, NQU ! !***FIRST EXECUTABLE STATEMENT INTYD IFLAG = 0 if (K < 0 .OR. K > NQ) go to 80 TP = TN - HU*(1.0E0 + 100.0E0*UROUND) if ((T-TP)*(T-TN) > 0.0E0) go to 90 ! S = (T - TN)/H IC = 1 if (K == 0) go to 15 JJ1 = L - K DO 10 JJ = JJ1,NQ 10 IC = IC*JJ 15 C = IC DO 20 I = 1,N 20 DKY(I) = C*YH(I,L) if (K == NQ) go to 55 JB2 = NQ - K DO 50 JB = 1,JB2 J = NQ - JB JP1 = J + 1 IC = 1 if (K == 0) go to 35 JJ1 = JP1 - K DO 30 JJ = JJ1,J 30 IC = IC*JJ 35 C = IC DO 40 I = 1,N 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) 50 CONTINUE if (K == 0) RETURN 55 R = H**(-K) DO 60 I = 1,N 60 DKY(I) = R*DKY(I) return ! 80 IFLAG = -1 return 90 IFLAG = -2 return !----------------------- END OF SUBROUTINE INTYD ----------------------- end subroutine INVIT (NM, N, A, WR, WI, SELECT, MM, M, Z, IERR, RM1, & RV1, RV2) ! !! INVIT computes the eigenvectors of a real upper Hessenberg ... ! matrix associated with specified eigenvalues by inverse ... ! iteration. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C2B !***TYPE SINGLE PRECISION (INVIT-S, CINVIT-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure INVIT ! by Peters and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). ! ! This subroutine finds those eigenvectors of a REAL UPPER ! Hessenberg matrix corresponding to specified eigenvalues, ! using inverse iteration. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! A contains the upper Hessenberg matrix. A is a two-dimensional ! REAL array, dimensioned A(NM,N). ! ! WR and WI contain the real and imaginary parts, respectively, ! of the eigenvalues of the Hessenberg matrix. The eigenvalues ! must be stored in a manner identical to that output by ! subroutine HQR, which recognizes possible splitting of the ! matrix. WR and WI are one-dimensional REAL arrays, ! dimensioned WR(N) and WI(N). ! ! SELECT specifies the eigenvectors to be found. The ! eigenvector corresponding to the J-th eigenvalue is ! specified by setting SELECT(J) to .TRUE. SELECT is a ! one-dimensional LOGICAL array, dimensioned SELECT(N). ! ! MM should be set to an upper bound for the number of ! columns required to store the eigenvectors to be found. ! NOTE that two columns are required to store the ! eigenvector corresponding to a complex eigenvalue. One ! column is required to store the eigenvector corresponding ! to a real eigenvalue. MM is an INTEGER variable. ! ! On OUTPUT ! ! A and WI are unaltered. ! ! WR may have been altered since close eigenvalues are perturbed ! slightly in searching for independent eigenvectors. ! ! SELECT may have been altered. If the elements corresponding ! to a pair of conjugate complex eigenvalues were each ! initially set to .TRUE., the program resets the second of ! the two elements to .FALSE. ! ! M is the number of columns actually used to store the ! eigenvectors. M is an INTEGER variable. ! ! Z contains the real and imaginary parts of the eigenvectors. ! The eigenvectors are packed into the columns of Z starting ! at the first column. If the next selected eigenvalue is ! real, the next column of Z contains its eigenvector. If the ! eigenvalue is complex, the next two columns of Z contain the ! real and imaginary parts of its eigenvector, with the real ! part first. The eigenvectors are normalized so that the ! component of largest magnitude is 1. Any vector which fails ! the acceptance test is set to zero. Z is a two-dimensional ! REAL array, dimensioned Z(NM,MM). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! -(2*N+1) if more than MM columns of Z are necessary ! to store the eigenvectors corresponding to ! the specified eigenvalues (in this case, M is ! equal to the number of columns of Z containing ! eigenvectors already computed), ! -K if the iteration corresponding to the K-th ! value fails (if this occurs more than once, K ! is the index of the last occurrence); the ! corresponding columns of Z are set to zero ! vectors, ! -(N+K) if both error situations occur. ! ! RM1 is a two-dimensional REAL array used for temporary storage. ! This array holds the triangularized form of the upper ! Hessenberg matrix used in the inverse iteration process. ! RM1 is dimensioned RM1(N,N). ! ! RV1 and RV2 are one-dimensional REAL arrays used for temporary ! storage. They hold the approximate eigenvectors during the ! inverse iteration process. RV1 and RV2 are dimensioned ! RV1(N) and RV2(N). ! ! The ALGOL procedure GUESSVEC appears in INVIT in-line. ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! Calls CDIV for complex division. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED CDIV, PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE INVIT ! INTEGER I,J,K,L,M,N,S,II,IP,MM,MP,NM,NS,N1,UK,IP1,ITS,KM1,IERR REAL A(NM,*),WR(*),WI(*),Z(NM,*) REAL RM1(N,*),RV1(*),RV2(*) REAL T,W,X,Y,EPS3 REAL NORM,NORMV,GROWTO,ILAMBD,RLAMBD,UKROOT REAL PYTHAG LOGICAL SELECT(N) ! !***FIRST EXECUTABLE STATEMENT INVIT IERR = 0 UK = 0 S = 1 ! .......... IP = 0, REAL EIGENVALUE ! 1, FIRST OF CONJUGATE COMPLEX PAIR ! -1, SECOND OF CONJUGATE COMPLEX PAIR .......... IP = 0 N1 = N - 1 ! DO 980 K = 1, N if (WI(K) == 0.0E0 .OR. IP < 0) go to 100 IP = 1 if (SELECT(K) .AND. SELECT(K+1)) SELECT(K+1) = .FALSE. 100 if (.NOT. SELECT(K)) go to 960 if (WI(K) /= 0.0E0) S = S + 1 if (S > MM) go to 1000 if (UK >= K) go to 200 ! .......... CHECK FOR POSSIBLE SPLITTING .......... DO 120 UK = K, N if (UK == N) go to 140 if (A(UK+1,UK) == 0.0E0) go to 140 120 CONTINUE ! .......... COMPUTE INFINITY NORM OF LEADING UK BY UK ! (HESSENBERG) MATRIX .......... 140 NORM = 0.0E0 MP = 1 ! DO 180 I = 1, UK X = 0.0E0 ! DO 160 J = MP, UK 160 X = X + ABS(A(I,J)) ! if (X > NORM) NORM = X MP = I 180 CONTINUE ! .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION ! AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... if (NORM == 0.0E0) NORM = 1.0E0 EPS3 = NORM 190 EPS3 = 0.5E0*EPS3 if (NORM + EPS3 > NORM) go to 190 EPS3 = 2.0E0*EPS3 ! .......... GROWTO IS THE CRITERION FOR THE GROWTH .......... UKROOT = SQRT(REAL(UK)) GROWTO = 0.1E0 / UKROOT 200 RLAMBD = WR(K) ILAMBD = WI(K) if (K == 1) go to 280 KM1 = K - 1 go to 240 ! .......... PERTURB EIGENVALUE if IT IS CLOSE ! TO ANY PREVIOUS EIGENVALUE .......... 220 RLAMBD = RLAMBD + EPS3 ! .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... 240 DO 260 II = 1, KM1 I = K - II if (SELECT(I) .AND. ABS(WR(I)-RLAMBD) < EPS3 .AND. & ABS(WI(I)-ILAMBD) < EPS3) go to 220 260 CONTINUE ! WR(K) = RLAMBD ! .......... PERTURB CONJUGATE EIGENVALUE TO MATCH .......... IP1 = K + IP WR(IP1) = RLAMBD ! .......... FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED) ! AND INITIAL REAL VECTOR .......... 280 MP = 1 ! DO 320 I = 1, UK ! DO 300 J = MP, UK 300 RM1(J,I) = A(I,J) ! RM1(I,I) = RM1(I,I) - RLAMBD MP = I RV1(I) = EPS3 320 CONTINUE ! ITS = 0 if (ILAMBD /= 0.0E0) go to 520 ! .......... REAL EIGENVALUE. ! TRIANGULAR DECOMPOSITION WITH INTERCHANGES, ! REPLACING ZERO PIVOTS BY EPS3 .......... if (UK == 1) go to 420 ! DO 400 I = 2, UK MP = I - 1 if (ABS(RM1(MP,I)) <= ABS(RM1(MP,MP))) go to 360 ! DO 340 J = MP, UK Y = RM1(J,I) RM1(J,I) = RM1(J,MP) RM1(J,MP) = Y 340 CONTINUE ! 360 if (RM1(MP,MP) == 0.0E0) RM1(MP,MP) = EPS3 X = RM1(MP,I) / RM1(MP,MP) if (X == 0.0E0) go to 400 ! DO 380 J = I, UK 380 RM1(J,I) = RM1(J,I) - X * RM1(J,MP) ! 400 CONTINUE ! 420 if (RM1(UK,UK) == 0.0E0) RM1(UK,UK) = EPS3 ! .......... BACK SUBSTITUTION FOR REAL VECTOR ! FOR I=UK STEP -1 UNTIL 1 DO -- .......... 440 DO 500 II = 1, UK I = UK + 1 - II Y = RV1(I) if (I == UK) go to 480 IP1 = I + 1 ! DO 460 J = IP1, UK 460 Y = Y - RM1(J,I) * RV1(J) ! 480 RV1(I) = Y / RM1(I,I) 500 CONTINUE ! go to 740 ! .......... COMPLEX EIGENVALUE. ! TRIANGULAR DECOMPOSITION WITH INTERCHANGES, ! REPLACING ZERO PIVOTS BY EPS3. STORE IMAGINARY ! PARTS IN UPPER TRIANGLE STARTING AT (1,3) .......... 520 NS = N - S Z(1,S-1) = -ILAMBD Z(1,S) = 0.0E0 if (N == 2) go to 550 RM1(1,3) = -ILAMBD Z(1,S-1) = 0.0E0 if (N == 3) go to 550 ! DO 540 I = 4, N 540 RM1(1,I) = 0.0E0 ! 550 DO 640 I = 2, UK MP = I - 1 W = RM1(MP,I) if (I < N) T = RM1(MP,I+1) if (I == N) T = Z(MP,S-1) X = RM1(MP,MP) * RM1(MP,MP) + T * T if (W * W <= X) go to 580 X = RM1(MP,MP) / W Y = T / W RM1(MP,MP) = W if (I < N) RM1(MP,I+1) = 0.0E0 if (I == N) Z(MP,S-1) = 0.0E0 ! DO 560 J = I, UK W = RM1(J,I) RM1(J,I) = RM1(J,MP) - X * W RM1(J,MP) = W if (J < N1) go to 555 L = J - NS Z(I,L) = Z(MP,L) - Y * W Z(MP,L) = 0.0E0 go to 560 555 RM1(I,J+2) = RM1(MP,J+2) - Y * W RM1(MP,J+2) = 0.0E0 560 CONTINUE ! RM1(I,I) = RM1(I,I) - Y * ILAMBD if (I < N1) go to 570 L = I - NS Z(MP,L) = -ILAMBD Z(I,L) = Z(I,L) + X * ILAMBD go to 640 570 RM1(MP,I+2) = -ILAMBD RM1(I,I+2) = RM1(I,I+2) + X * ILAMBD go to 640 580 if (X /= 0.0E0) go to 600 RM1(MP,MP) = EPS3 if (I < N) RM1(MP,I+1) = 0.0E0 if (I == N) Z(MP,S-1) = 0.0E0 T = 0.0E0 X = EPS3 * EPS3 600 W = W / X X = RM1(MP,MP) * W Y = -T * W ! DO 620 J = I, UK if (J < N1) go to 610 L = J - NS T = Z(MP,L) Z(I,L) = -X * T - Y * RM1(J,MP) go to 615 610 T = RM1(MP,J+2) RM1(I,J+2) = -X * T - Y * RM1(J,MP) 615 RM1(J,I) = RM1(J,I) - X * RM1(J,MP) + Y * T 620 CONTINUE ! if (I < N1) go to 630 L = I - NS Z(I,L) = Z(I,L) - ILAMBD go to 640 630 RM1(I,I+2) = RM1(I,I+2) - ILAMBD 640 CONTINUE ! if (UK < N1) go to 650 L = UK - NS T = Z(UK,L) go to 655 650 T = RM1(UK,UK+2) 655 if (RM1(UK,UK) == 0.0E0 .AND. T == 0.0E0) RM1(UK,UK) = EPS3 ! .......... BACK SUBSTITUTION FOR COMPLEX VECTOR ! FOR I=UK STEP -1 UNTIL 1 DO -- .......... 660 DO 720 II = 1, UK I = UK + 1 - II X = RV1(I) Y = 0.0E0 if (I == UK) go to 700 IP1 = I + 1 ! DO 680 J = IP1, UK if (J < N1) go to 670 L = J - NS T = Z(I,L) go to 675 670 T = RM1(I,J+2) 675 X = X - RM1(J,I) * RV1(J) + T * RV2(J) Y = Y - RM1(J,I) * RV2(J) - T * RV1(J) 680 CONTINUE ! 700 if (I < N1) go to 710 L = I - NS T = Z(I,L) go to 715 710 T = RM1(I,I+2) 715 call CDIV(X,Y,RM1(I,I),T,RV1(I),RV2(I)) 720 CONTINUE ! .......... ACCEPTANCE TEST FOR REAL OR COMPLEX ! EIGENVECTOR AND NORMALIZATION .......... 740 ITS = ITS + 1 NORM = 0.0E0 NORMV = 0.0E0 ! DO 780 I = 1, UK if (ILAMBD == 0.0E0) X = ABS(RV1(I)) if (ILAMBD /= 0.0E0) X = PYTHAG(RV1(I),RV2(I)) if (NORMV >= X) go to 760 NORMV = X J = I 760 NORM = NORM + X 780 CONTINUE ! if (NORM < GROWTO) go to 840 ! .......... ACCEPT VECTOR .......... X = RV1(J) if (ILAMBD == 0.0E0) X = 1.0E0 / X if (ILAMBD /= 0.0E0) Y = RV2(J) ! DO 820 I = 1, UK if (ILAMBD /= 0.0E0) go to 800 Z(I,S) = RV1(I) * X go to 820 800 call CDIV(RV1(I),RV2(I),X,Y,Z(I,S-1),Z(I,S)) 820 CONTINUE ! if (UK == N) go to 940 J = UK + 1 go to 900 ! .......... IN-LINE PROCEDURE FOR CHOOSING ! A NEW STARTING VECTOR .......... 840 if (ITS >= UK) go to 880 X = UKROOT Y = EPS3 / (X + 1.0E0) RV1(1) = EPS3 ! DO 860 I = 2, UK 860 RV1(I) = Y ! J = UK - ITS + 1 RV1(J) = RV1(J) - EPS3 * X if (ILAMBD == 0.0E0) go to 440 go to 660 ! .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... 880 J = 1 IERR = -K ! .......... SET REMAINING VECTOR COMPONENTS TO ZERO .......... 900 DO 920 I = J, N Z(I,S) = 0.0E0 if (ILAMBD /= 0.0E0) Z(I,S-1) = 0.0E0 920 CONTINUE ! 940 S = S + 1 960 if (IP == (-1)) IP = 0 if (IP == 1) IP = -1 980 CONTINUE ! go to 1001 ! .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR ! SPACE REQUIRED .......... 1000 if (IERR /= 0) IERR = IERR - N if (IERR == 0) IERR = -(2 * N + 1) 1001 M = S - 1 - ABS(IP) return end subroutine INXCA (I, IR, IDXA, NA) ! !! INXCA is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE INTEGER (INXCA-I) !***AUTHOR (UNKNOWN) !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CCBLK !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE INXCA COMMON /CCBLK/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT INXCA NA = 2**IR IDXA = I-NA+1 if (I-NM) 102,102,101 101 NA = 0 102 RETURN end subroutine INXCB (I, IR, IDX, IDP) ! !! INXCB is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE INTEGER (INXCB-I) !***AUTHOR (UNKNOWN) !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CCBLK !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE INXCB ! COMMON /CCBLK/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT INXCB IDP = 0 if (IR) 107,101,103 101 if (I-NM) 102,102,107 102 IDX = I IDP = 1 return 103 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) 105,105,104 104 IDP = 0 return 105 if (I+IPL-NM) 107,107,106 106 IDP = NM+IPL-I+1 107 RETURN end subroutine INXCC (I, IR, IDXC, NC) ! !! INXCC is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE INTEGER (INXCC-I) !***AUTHOR (UNKNOWN) !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CCBLK !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE INXCC COMMON /CCBLK/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT INXCC NC = 2**IR IDXC = I if (IDXC+NC-1-NM) 102,102,101 101 NC = 0 102 RETURN end INTEGER FUNCTION IPLOC (LOC, SX, IX) ! !! IPLOC is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (IPLOC-S, IDLOC-D) !***KEYWORDS RELATIVE ADDRESS DETERMINATION FUNCTION, SLATEC !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! Given a "virtual" location, IPLOC returns the relative working ! address of the vector component stored in SX, IX. Any necessary ! page swaps are performed automatically for the user in this ! function subprogram. ! ! LOC is the "virtual" address of the data to be retrieved. ! SX ,IX represent the matrix where the data is stored. ! !***SEE ALSO SPLP !***ROUTINES CALLED PRWPGE, XERMSG !***REVISION HISTORY (YYMMDD) ! 810306 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890606 Restructured to match double precision version. (WRB) ! 890606 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 910731 Added code to set IPLOC to 0 if LOC is non-positive. (WRB) !***END PROLOGUE IPLOC REAL SX(*) INTEGER IX(*) !***FIRST EXECUTABLE STATEMENT IPLOC if (LOC <= 0) THEN call XERMSG ('SLATEC', 'IPLOC', & 'A value of LOC, the first argument, <= 0 was encountered', & 55, 1) IPLOC = 0 return end if ! ! Two cases exist: (1 <= LOC <= K) .OR. (LOC > K). ! K = IX(3) + 4 LMX = IX(1) LMXM1 = LMX - 1 if (LOC <= K) THEN IPLOC = LOC return end if ! ! Compute length of the page, starting address of the page, page ! number and relative working address. ! LPG = LMX-K ITEMP = LOC - K - 1 IPAGE = ITEMP/LPG + 1 IPLOC = MOD(ITEMP,LPG) + K + 1 NP = ABS(IX(LMXM1)) ! ! Determine if a page fault has occurred. If so, write page NP ! and read page IPAGE. Write the page only if it has been ! modified. ! if (IPAGE /= NP) THEN if (SX(LMX) == 1.0) THEN SX(LMX) = 0.0 KEY = 2 call PRWPGE (KEY, NP, LPG, SX, IX) ENDIF KEY = 1 call PRWPGE (KEY, IPAGE, LPG, SX, IX) end if return end subroutine IPPERM (IX, N, IPERM, IER) ! !! IPPERM rearranges a given array according to a prescribed ... ! permutation vector. ! !***LIBRARY SLATEC !***CATEGORY N8 !***TYPE INTEGER (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H) !***KEYWORDS APPLICATION OF PERMUTATION TO DATA VECTOR !***AUTHOR McClain, M. A., (NIST) ! Rhoads, G. S., (NBS) !***DESCRIPTION ! ! IPPERM rearranges the data vector IX according to the ! permutation IPERM: IX(I) <--- IX(IPERM(I)). IPERM could come ! from one of the sorting routines IPSORT, SPSORT, DPSORT or ! HPSORT. ! ! Description of Parameters ! IX - input/output -- integer array of values to be rearranged. ! N - input -- number of values in integer array IX. ! IPERM - input -- permutation vector. ! IER - output -- error indicator: ! = 0 if no error, ! = 1 if N is zero or negative, ! = 2 if IPERM is not a valid permutation. ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 900618 DATE WRITTEN ! 920507 Modified by M. McClain to revise prologue text. !***END PROLOGUE IPPERM INTEGER IX(*), N, IPERM(*), I, IER, INDX, INDX0, ITEMP, ISTRT !***FIRST EXECUTABLE STATEMENT IPPERM IER=0 if ( N < 1)THEN IER=1 call XERMSG ('SLATEC', 'IPPERM', & 'The number of values to be rearranged, N, is not positive.', & IER, 1) return end if ! ! CHECK WHETHER IPERM IS A VALID PERMUTATION ! DO 100 I=1,N INDX=ABS(IPERM(I)) if ( (INDX >= 1).AND.(INDX <= N))THEN if ( IPERM(INDX) > 0)THEN IPERM(INDX)=-IPERM(INDX) GOTO 100 ENDIF ENDIF IER=2 call XERMSG ('SLATEC', 'IPPERM', & 'The permutation vector, IPERM, is not valid.', IER, 1) return 100 CONTINUE ! ! REARRANGE THE VALUES OF IX ! ! USE THE IPERM VECTOR AS A FLAG. ! if IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION ! DO 330 ISTRT = 1 , N if (IPERM(ISTRT) > 0) GOTO 330 INDX = ISTRT INDX0 = INDX ITEMP = IX(ISTRT) 320 CONTINUE if (IPERM(INDX) >= 0) GOTO 325 IX(INDX) = IX(-IPERM(INDX)) INDX0 = INDX IPERM(INDX) = -IPERM(INDX) INDX = IPERM(INDX) GOTO 320 325 CONTINUE IX(INDX0) = ITEMP 330 CONTINUE ! return end subroutine IPSORT (IX, N, IPERM, KFLAG, IER) ! !! IPSORT returns the permutation vector generated by sorting a given ... ! array and, optionally, rearrange the elements of the array. ... ! The array may be sorted in increasing or decreasing order. ... ! A slightly modified quicksort algorithm is used. ! !***LIBRARY SLATEC !***CATEGORY N6A1A, N6A2A !***TYPE INTEGER (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H) !***KEYWORDS NUMBER SORTING, PASSIVE SORTING, SINGLETON QUICKSORT, SORT !***AUTHOR Jones, R. E., (SNLA) ! Kahaner, D. K., (NBS) ! Rhoads, G. S., (NBS) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! IPSORT returns the permutation vector IPERM generated by sorting ! the array IX and, optionally, rearranges the values in IX. IX may ! be sorted in increasing or decreasing order. A slightly modified ! quicksort algorithm is used. ! ! IPERM is such that IX(IPERM(I)) is the Ith value in the ! rearrangement of IX. IPERM may be applied to another array by ! calling IPPERM, SPPERM, DPPERM or HPPERM. ! ! The main difference between IPSORT and its active sorting equivalent ! ISORT is that the data are referenced indirectly rather than ! directly. Therefore, IPSORT should require approximately twice as ! long to execute as ISORT. However, IPSORT is more general. ! ! Description of Parameters ! IX - input/output -- integer array of values to be sorted. ! If ABS(KFLAG) = 2, then the values in IX will be ! rearranged on output; otherwise, they are unchanged. ! N - input -- number of values in array IX to be sorted. ! IPERM - output -- permutation array such that IPERM(I) is the ! index of the value in the original order of the ! IX array that is in the Ith location in the sorted ! order. ! KFLAG - input -- control parameter: ! = 2 means return the permutation vector resulting from ! sorting IX in increasing order and sort IX also. ! = 1 means return the permutation vector resulting from ! sorting IX in increasing order and do not sort IX. ! = -1 means return the permutation vector resulting from ! sorting IX in decreasing order and do not sort IX. ! = -2 means return the permutation vector resulting from ! sorting IX in decreasing order and sort IX also. ! IER - output -- error indicator: ! = 0 if no error, ! = 1 if N is zero or negative, ! = 2 if KFLAG is not 2, 1, -1, or -2. !***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm ! for sorting with minimal storage, Communications of ! the ACM, 12, 3 (1969), pp. 185-187. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 761101 DATE WRITTEN ! 761118 Modified by John A. Wisniewski to use the Singleton ! quicksort algorithm. ! 810801 Further modified by David K. Kahaner. ! 870423 Modified by Gregory S. Rhoads for passive sorting with the ! option for the rearrangement of the original data. ! 890620 Algorithm for rearranging the data vector corrected by R. ! Boisvert. ! 890622 Prologue upgraded to Version 4.0 style by D. Lozier. ! 891128 Error when KFLAG < 0 and N=1 corrected by R. Boisvert. ! 920507 Modified by M. McClain to revise prologue text. ! 920818 Declarations section rebuilt and code restructured to use ! IF-THEN-ELSE-ENDIF. (SMR, WRB) !***END PROLOGUE IPSORT ! .. Scalar Arguments .. INTEGER IER, KFLAG, N ! .. Array Arguments .. INTEGER IPERM(*), IX(*) ! .. Local Scalars .. REAL R INTEGER I, IJ, INDX, INDX0, ISTRT, ITEMP, J, K, KK, L, LM, LMT, M, & NN ! .. Local Arrays .. INTEGER IL(21), IU(21) ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, INT !***FIRST EXECUTABLE STATEMENT IPSORT IER = 0 NN = N if (NN < 1) THEN IER = 1 call XERMSG ('SLATEC', 'IPSORT', & 'The number of values to be sorted, N, is not positive.', & IER, 1) return end if KK = ABS(KFLAG) if (KK /= 1 .AND. KK /= 2) THEN IER = 2 call XERMSG ('SLATEC', 'IPSORT', & 'The sort control parameter, KFLAG, is not 2, 1, -1, or -2.', & IER, 1) return end if ! ! Initialize permutation vector ! DO 10 I=1,NN IPERM(I) = I 10 CONTINUE ! ! Return if only one value is to be sorted ! if (NN == 1) RETURN ! ! Alter array IX to get decreasing order if needed ! if (KFLAG <= -1) THEN DO 20 I=1,NN IX(I) = -IX(I) 20 CONTINUE end if ! ! Sort IX only ! M = 1 I = 1 J = NN R = .375E0 ! 30 if (I == J) go to 80 if (R <= 0.5898437E0) THEN R = R+3.90625E-2 ELSE R = R-0.21875E0 end if ! 40 K = I ! ! Select a central element of the array and save it in location L ! IJ = I + INT((J-I)*R) LM = IPERM(IJ) ! ! If first element of array is greater than LM, interchange with LM ! if (IX(IPERM(I)) > IX(LM)) THEN IPERM(IJ) = IPERM(I) IPERM(I) = LM LM = IPERM(IJ) end if L = J ! ! If last element of array is less than LM, interchange with LM ! if (IX(IPERM(J)) < IX(LM)) THEN IPERM(IJ) = IPERM(J) IPERM(J) = LM LM = IPERM(IJ) ! ! If first element of array is greater than LM, interchange ! with LM ! if (IX(IPERM(I)) > IX(LM)) THEN IPERM(IJ) = IPERM(I) IPERM(I) = LM LM = IPERM(IJ) ENDIF end if go to 60 50 LMT = IPERM(L) IPERM(L) = IPERM(K) IPERM(K) = LMT ! ! Find an element in the second half of the array which is smaller ! than LM ! 60 L = L-1 if (IX(IPERM(L)) > IX(LM)) go to 60 ! ! Find an element in the first half of the array which is greater ! than LM ! 70 K = K+1 if (IX(IPERM(K)) < IX(LM)) go to 70 ! ! Interchange these elements ! if (K <= L) go to 50 ! ! Save upper and lower subscripts of the array yet to be sorted ! if (L-I > J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 90 ! ! Begin again on another portion of the unsorted array ! 80 M = M-1 if (M == 0) go to 120 I = IL(M) J = IU(M) ! 90 if (J-I >= 1) go to 40 if (I == 1) go to 30 I = I-1 ! 100 I = I+1 if (I == J) go to 80 LM = IPERM(I+1) if (IX(IPERM(I)) <= IX(LM)) go to 100 K = I ! 110 IPERM(K+1) = IPERM(K) K = K-1 ! if (IX(LM) < IX(IPERM(K))) go to 110 IPERM(K+1) = LM go to 100 ! ! Clean up ! 120 if (KFLAG <= -1) THEN DO 130 I=1,NN IX(I) = -IX(I) 130 CONTINUE end if ! ! Rearrange the values of IX if desired ! if (KK == 2) THEN ! ! Use the IPERM vector as a flag. ! If IPERM(I) < 0, then the I-th value is in correct location ! DO 150 ISTRT=1,NN if (IPERM(ISTRT) >= 0) THEN INDX = ISTRT INDX0 = INDX ITEMP = IX(ISTRT) 140 if (IPERM(INDX) > 0) THEN IX(INDX) = IX(IPERM(INDX)) INDX0 = INDX IPERM(INDX) = -IPERM(INDX) INDX = ABS(IPERM(INDX)) go to 140 ENDIF IX(INDX0) = ITEMP ENDIF 150 CONTINUE ! ! Revert the signs of the IPERM values ! DO 160 I=1,NN IPERM(I) = -IPERM(I) 160 CONTINUE ! end if ! return end INTEGER FUNCTION ISAMAX (N, SX, INCX) ! !! ISAMAX finds the smallest index of that component of a vector ! having the maximum magnitude. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A2 !***TYPE SINGLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! ! --Output-- ! ISAMAX smallest index (zero if N <= 0) ! ! Find smallest index of maximum magnitude of single precision SX. ! ISAMAX = first I, I = 1 to N, to maximize ABS(SX(IX+(I-1)*INCX)), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900821 Modified to correct problem with a negative increment. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 920618 Slight restructuring of code. (RWC, WRB) !***END PROLOGUE ISAMAX REAL SX(*), SMAX, XMAG INTEGER I, INCX, IX, N !***FIRST EXECUTABLE STATEMENT ISAMAX ISAMAX = 0 if (N <= 0) RETURN ISAMAX = 1 if (N == 1) RETURN ! if (INCX == 1) GOTO 20 ! ! Code for increment not equal to 1. ! IX = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 SMAX = ABS(SX(IX)) IX = IX + INCX DO 10 I = 2,N XMAG = ABS(SX(IX)) if (XMAG > SMAX) THEN ISAMAX = I SMAX = XMAG ENDIF IX = IX + INCX 10 CONTINUE return ! ! Code for increments equal to 1. ! 20 SMAX = ABS(SX(1)) DO 30 I = 2,N XMAG = ABS(SX(I)) if (XMAG > SMAX) THEN ISAMAX = I SMAX = XMAG ENDIF 30 CONTINUE return end INTEGER FUNCTION ISDBCG (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, & DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) ! !! ISDBCG is the Preconditioned BiConjugate Gradient Stop Test. ! ! This routine calculates the stop test for the BiConjugate ! Gradient iteration scheme. It returns a non-zero if the ! error estimate (the type of which is determined by ITOL) ! is less than the user specified tolerance TOL. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (ISSBCG-S, ISDBCG-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, ! SPARSE, STOP TEST !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER ! INTEGER IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N) ! DOUBLE PRECISION RR(N), ZZ(N), PP(N), DZ(N) ! DOUBLE PRECISION RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM ! EXTERNAL MSOLVE ! ! if ( ISDBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, DZ, ! $ RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) ! $ THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", in the SLAP ! routine DBCG for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for Z ! given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine ! must be declared external in the calling program. The ! calling sequence of MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector, and Z is the solution upon return. NELT, IA, JA, A, ! and ISYM define the SLAP matrix data structure. ! RWORK is a double precision array that can be used to pass ! necessary preconditioning information and/or workspace to ! MSOLVE. ! IWORK is an integer work array for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Double Precision. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Double Precision R(N). ! The residual r = b - Ax. ! Z :WORK Double Precision Z(N). ! P :DUMMY Double Precision P(N). ! RR :DUMMY Double Precision RR(N). ! ZZ :DUMMY Double Precision ZZ(N). ! PP :DUMMY Double Precision PP(N). ! Double Precision arrays used for workspace. ! DZ :WORK Double Precision DZ(N). ! If ITOL.eq.0 then DZ is used to hold M-inv * B on the first ! call. If ITOL.eq.11 then DZ is used to hold X-SOLN. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used for workspace in ! MSOLVE and MTSOLV. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE ! and MTSOLV. ! AK :IN Double Precision. ! Current iterate BiConjugate Gradient iteration parameter. ! BK :IN Double Precision. ! Current iterate BiConjugate Gradient iteration parameter. ! BNRM :INOUT Double Precision. ! Norm of the right hand side. Type of norm depends on ITOL. ! Calculated only on the first call. ! SOLNRM :INOUT Double Precision. ! 2-Norm of the true solution, SOLN. Only computed and used ! if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DBCG !***ROUTINES CALLED D1MACH, DNRM2 !***COMMON BLOCKS DSLBLK !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to DBCG. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920930 Corrected to not print AK,BK when ITER=0. (FNF) ! 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in ! output format. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE ISDBCG ! .. Scalar Arguments .. DOUBLE PRECISION AK, BK, BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), DZ(N), P(N), PP(N), R(N), RR(N), & RWORK(*), X(N), Z(N), ZZ(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Arrays in Common .. DOUBLE PRECISION SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. DOUBLE PRECISION D1MACH, DNRM2 EXTERNAL D1MACH, DNRM2 ! .. Common blocks .. COMMON /DSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISDBCG ISDBCG = 0 ! if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = DNRM2(N, B, 1) ERR = DNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) BNRM = DNRM2(N, DZ, 1) ENDIF ERR = DNRM2(N, Z, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0) SOLNRM = DNRM2(N, SOLN, 1) DO 10 I = 1, N DZ(I) = X(I) - SOLN(I) 10 CONTINUE ERR = DNRM2(N, DZ, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = D1MACH(2) IERR = 3 end if ! if ( IUNIT /= 0) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) N, ITOL WRITE(IUNIT,1010) ITER, ERR ELSE WRITE(IUNIT,1010) ITER, ERR, AK, BK ENDIF end if if ( ERR <= TOL) ISDBCG = 1 ! return 1000 FORMAT(' Preconditioned BiConjugate Gradient for N, ITOL = ', & I5,I5,/' ITER',' Error Estimate',' Alpha', & ' Beta') 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7,1X,D16.7) !------------- LAST LINE OF ISDBCG FOLLOWS ---------------------------- end INTEGER FUNCTION ISDCG (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, & IWORK, AK, BK, BNRM, SOLNRM) ! !! ISDCG is the Preconditioned Conjugate Gradient Stop Test. ! ! This routine calculates the stop test for the Conjugate ! Gradient iteration scheme. It returns a non-zero if the ! error estimate (the type of which is determined by ITOL) ! is less than the user specified tolerance TOL. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2B4 !***TYPE DOUBLE PRECISION (ISSCG-S, ISDCG-D) !***KEYWORDS LINEAR SYSTEM, SLAP, SPARSE, STOP TEST !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER ! INTEGER IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N) ! DOUBLE PRECISION P(N), DZ(N), RWORK(USER DEFINED), AK, BK ! DOUBLE PRECISION BNRM, SOLNRM ! EXTERNAL MSOLVE ! ! if ( ISDCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, IWORK, ! $ AK, BK, BNRM, SOLNRM) /= 0 ) THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :IN Double Precision X(N). ! The current approximate solution vector. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description" ! in the DCG, DSDCG or DSICCG routines. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IWORK is an integer work array ! for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Double Precision. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Double Precision. ! Error estimate of error in the X(N) approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Double Precision R(N). ! The residual R = B-AX. ! Z :WORK Double Precision Z(N). ! Workspace used to hold the pseudo-residual M Z = R. ! P :IN Double Precision P(N). ! The conjugate direction vector. ! DZ :WORK Double Precision DZ(N). ! Workspace used to hold temporary vector(s). ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! AK :IN Double Precision. ! BK :IN Double Precision. ! Current conjugate gradient parameters alpha and beta. ! BNRM :INOUT Double Precision. ! Norm of the right hand side. Type of norm depends on ITOL. ! Calculated only on the first call. ! SOLNRM :INOUT Double Precision. ! 2-Norm of the true solution, SOLN. Only computed and used ! if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DCG, DSDCG, DSICCG !***ROUTINES CALLED D1MACH, DNRM2 !***COMMON BLOCKS DSLBLK !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to DCG. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920930 Corrected to not print AK,BK when ITER=0. (FNF) ! 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in ! output format. (FNF) !***END PROLOGUE ISDCG ! .. Scalar Arguments .. DOUBLE PRECISION AK, BK, BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), DZ(N), P(N), R(N), RWORK(*), X(N), & Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Arrays in Common .. DOUBLE PRECISION SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. DOUBLE PRECISION D1MACH, DNRM2 EXTERNAL D1MACH, DNRM2 ! .. Common blocks .. COMMON /DSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISDCG ISDCG = 0 ! if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = DNRM2(N, B, 1) ERR = DNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) BNRM = DNRM2(N, DZ, 1) ENDIF ERR = DNRM2(N, Z, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0) SOLNRM = DNRM2(N, SOLN, 1) DO 10 I = 1, N DZ(I) = X(I) - SOLN(I) 10 CONTINUE ERR = DNRM2(N, DZ, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = D1MACH(2) IERR = 3 end if ! if ( IUNIT /= 0) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) N, ITOL WRITE(IUNIT,1010) ITER, ERR ELSE WRITE(IUNIT,1010) ITER, ERR, AK, BK ENDIF end if if ( ERR <= TOL) ISDCG = 1 return 1000 FORMAT(' Preconditioned Conjugate Gradient for ', & 'N, ITOL = ',I5, I5, & /' ITER',' Error Estimate',' Alpha', & ' Beta') 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7,1X,D16.7) !------------- LAST LINE OF ISDCG FOLLOWS ------------------------------ end INTEGER FUNCTION ISDCGN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, & MTTVEC, MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, & P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) ! !! ISDCGN is the Preconditioned CG on Normal Equations Stop Test. ! ! This routine calculates the stop test for the Conjugate ! Gradient iteration scheme applied to the normal equations. ! It returns a non-zero if the error estimate (the type of ! which is determined by ITOL) is less than the user ! specified tolerance TOL. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (ISSCGN-S, ISDCGN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, ! NORMAL EQUATIONS, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER ! INTEGER IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N) ! DOUBLE PRECISION ATP(N), ATZ(N), DZ(N), ATDZ(N) ! DOUBLE PRECISION RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM ! EXTERNAL MATVEC, MTTVEC, MSOLVE ! ! if ( ISTPCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, ! $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ! $ ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) ! $ /= 0 ) THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :IN Double Precision X(N). ! The current approximate solution vector. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description" in the ! DCGN routine. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP-Column IA, JA, A storage for the matrix ! A. ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MTTVEC :EXT External. ! Name of a routine which performs the matrix transpose vector ! multiply y = A'*X given A and X (where ' denotes transpose). ! The name of the MTTVEC routine must be declared external in ! the calling program. The calling sequence to MTTVEC is the ! same as that for MATVEC, viz.: ! call MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A'*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP-Column IA, JA, A storage for the matrix ! A. ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IWORK is an integer work array ! for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Double Precision. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Double Precision. ! Error estimate of error in the X(N) approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Double Precision R(N). ! The residual R = B-AX. ! Z :WORK Double Precision Z(N). ! Double Precision array used for workspace. ! P :IN Double Precision P(N). ! The conjugate direction vector. ! ATP :IN Double Precision ATP(N). ! A-transpose times the conjugate direction vector. ! ATZ :IN Double Precision ATZ(N). ! A-transpose times the pseudo-residual. ! DZ :IN Double Precision DZ(N). ! Workspace used to hold temporary vector(s). ! ATDZ :WORK Double Precision ATDZ(N). ! Workspace. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! AK :IN Double Precision. ! BK :IN Double Precision. ! Current conjugate gradient parameters alpha and beta. ! BNRM :INOUT Double Precision. ! Norm of the right hand side. Type of norm depends on ITOL. ! Calculated only on the first call. ! SOLNRM :INOUT Double Precision. ! 2-Norm of the true solution, SOLN. Only computed and used ! if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DCGN !***ROUTINES CALLED D1MACH, DNRM2 !***COMMON BLOCKS DSLBLK !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC, MTTVEC and MSOLVE from ROUTINES CALLED ! list. (FNF) ! 910506 Made subsidiary to DCGN. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920930 Corrected to not print AK,BK when ITER=0. (FNF) ! 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in ! output format. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE ISDCGN ! .. Scalar Arguments .. DOUBLE PRECISION AK, BK, BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(N), ATDZ(N), ATP(N), ATZ(N), B(N), DZ(N), P(N), & R(N), RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE, MTTVEC ! .. Arrays in Common .. DOUBLE PRECISION SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. DOUBLE PRECISION D1MACH, DNRM2 EXTERNAL D1MACH, DNRM2 ! .. Common blocks .. COMMON /DSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISDCGN ISDCGN = 0 ! if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = DNRM2(N, B, 1) ERR = DNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) call MTTVEC(N, DZ, ATDZ, NELT, IA, JA, A, ISYM) BNRM = DNRM2(N, ATDZ, 1) ENDIF ERR = DNRM2(N, ATZ, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0) SOLNRM = DNRM2(N, SOLN, 1) DO 10 I = 1, N DZ(I) = X(I) - SOLN(I) 10 CONTINUE ERR = DNRM2(N, DZ, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = D1MACH(2) IERR = 3 end if ! if ( IUNIT /= 0 ) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) N, ITOL WRITE(IUNIT,1010) ITER, ERR ELSE WRITE(IUNIT,1010) ITER, ERR, AK, BK ENDIF end if if ( ERR <= TOL ) ISDCGN = 1 ! return 1000 FORMAT(' PCG Applied to the Normal Equations for ', & 'N, ITOL = ',I5, I5, & /' ITER',' Error Estimate',' Alpha', & ' Beta') 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7,1X,D16.7) !------------- LAST LINE OF ISDCGN FOLLOWS ---------------------------- end INTEGER FUNCTION ISDCGS (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, & MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, & U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) ! !! ISDCGS is the Preconditioned BiConjugate Gradient Squared Stop Test. ! ! This routine calculates the stop test for the BiConjugate ! Gradient Squared iteration scheme. It returns a non-zero ! if the error estimate (the type of which is determined by ! ITOL) is less than the user specified tolerance TOL. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (ISSCGS-S, ISDCGS-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, ! SPARSE, STOP TEST !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER ! INTEGER IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), R0(N), P(N) ! DOUBLE PRECISION Q(N), U(N), V1(N), V2(N) ! DOUBLE PRECISION RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM ! EXTERNAL MATVEC, MSOLVE ! ! if ( ISDCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ITOL, ! $ TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U, V1, ! $ V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) ! $ THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :INOUT Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description" in SLAP routine ! DCGS for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! operation Y = A*X given A and X. The name of the MATVEC ! routine must be declared external in the calling program. ! The calling sequence of MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X upon ! return, X is an input vector. NELT, IA, JA, A, and ISYM ! define the SLAP matrix data structure. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for Z ! given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine ! must be declared external in the calling program. The ! calling sequence of MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector, and Z is the solution upon return. NELT, IA, JA, A, ! and ISYM define the SLAP matrix data structure. ! RWORK is a double precision array that can be used to pass ! necessary preconditioning information and/or workspace to ! MSOLVE. ! IWORK is an integer work array for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! This routine must calculate the residual from R = A*X - B. ! This is unnatural and hence expensive for this type of iter- ! ative method. ITOL=2 is *STRONGLY* recommended. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv time a vector is the pre- ! conditioning step. This is the *NATURAL* stopping for this ! iterative method and is *STRONGLY* recommended. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Double Precision. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ITMAX iterations. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Double Precision R(N). ! The residual r = b - Ax. ! R0 :WORK Double Precision R0(N). ! P :DUMMY Double Precision P(N). ! Q :DUMMY Double Precision Q(N). ! U :DUMMY Double Precision U(N). ! V1 :DUMMY Double Precision V1(N). ! Double Precision arrays used for workspace. ! V2 :WORK Double Precision V2(N). ! If ITOL.eq.1 then V2 is used to hold A * X - B on every call. ! If ITOL.eq.2 then V2 is used to hold M-inv * B on the first ! call. ! If ITOL.eq.11 then V2 is used to X - SOLN. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used for workspace in ! MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE. ! AK :IN Double Precision. ! Current iterate BiConjugate Gradient iteration parameter. ! BK :IN Double Precision. ! Current iterate BiConjugate Gradient iteration parameter. ! BNRM :INOUT Double Precision. ! Norm of the right hand side. Type of norm depends on ITOL. ! Calculated only on the first call. ! SOLNRM :INOUT Double Precision. ! 2-Norm of the true solution, SOLN. Only computed and used ! if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DCGS !***ROUTINES CALLED D1MACH, DNRM2 !***COMMON BLOCKS DSLBLK !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to DCGS. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920930 Corrected to not print AK,BK when ITER=0. (FNF) ! 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in ! output format. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE ISDCGS ! .. Scalar Arguments .. DOUBLE PRECISION AK, BK, BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), P(N), Q(N), R(N), R0(N), RWORK(*), & U(N), V1(N), V2(N), X(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Arrays in Common .. DOUBLE PRECISION SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. DOUBLE PRECISION D1MACH, DNRM2 EXTERNAL D1MACH, DNRM2 ! .. Common blocks .. COMMON /DSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISDCGS ISDCGS = 0 ! if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = DNRM2(N, B, 1) call MATVEC(N, X, V2, NELT, IA, JA, A, ISYM ) DO 5 I = 1, N V2(I) = V2(I) - B(I) 5 CONTINUE ERR = DNRM2(N, V2, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, B, V2, NELT, IA, JA, A, ISYM, RWORK, IWORK) BNRM = DNRM2(N, V2, 1) ENDIF ERR = DNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0) SOLNRM = DNRM2(N, SOLN, 1) DO 10 I = 1, N V2(I) = X(I) - SOLN(I) 10 CONTINUE ERR = DNRM2(N, V2, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = D1MACH(2) IERR = 3 end if ! ! Print the error and Coefficients AK, BK on each step, ! if desired. if ( IUNIT /= 0) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) N, ITOL WRITE(IUNIT,1010) ITER, ERR ELSE WRITE(IUNIT,1010) ITER, ERR, AK, BK ENDIF end if if ( ERR <= TOL) ISDCGS = 1 ! return 1000 FORMAT(' Preconditioned BiConjugate Gradient Squared for ', & 'N, ITOL = ',I5, I5, & /' ITER',' Error Estimate',' Alpha', & ' Beta') 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7,1X,D16.7) !------------- LAST LINE OF ISDCGS FOLLOWS ---------------------------- end INTEGER FUNCTION ISDGMR (N, B, X, XL, NELT, IA, JA, A, ISYM, & MSOLVE, NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, R, Z, DZ, & RWORK, IWORK, RNRM, BNRM, SB, SX, JSCAL, KMP, LGMR, MAXL, & MAXLP1, V, Q, SNORMW, PROD, R0NRM, HES, JPRE) ! !! ISDGMR is the Generalized Minimum Residual Stop Test. ! ! This routine calculates the stop test for the Generalized ! Minimum RESidual (GMRES) iteration scheme. It returns a ! non-zero if the error estimate (the type of which is ! determined by ITOL) is less than the user specified ! tolerance TOL. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (ISSGMR-S, ISDGMR-D) !***KEYWORDS GMRES, LINEAR SYSTEM, SLAP, SPARSE, STOP TEST !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NMSL, ITOL ! INTEGER ITMAX, ITER, IUNIT, IWORK(USER DEFINED), JSCAL ! INTEGER KMP, LGMR, MAXL, MAXLP1, JPRE ! DOUBLE PRECISION B(N), X(N), XL(MAXL), A(NELT), TOL, ERR, ! $ R(N), Z(N), DZ(N), RWORK(USER DEFINED), ! $ RNRM, BNRM, SB(N), SX(N), V(N,MAXLP1), ! $ Q(2*MAXL), SNORMW, PROD, R0NRM, ! $ HES(MAXLP1,MAXL) ! EXTERNAL MSOLVE ! ! if (ISDGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, ! $ NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, R, Z, DZ, ! $ RWORK, IWORK, RNRM, BNRM, SB, SX, JSCAL, ! $ KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, ! $ HES, JPRE) /= 0) THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand-side vector. ! X :IN Double Precision X(N). ! Approximate solution vector as of the last restart. ! XL :OUT Double Precision XL(N) ! An array of length N used to hold the approximate ! solution as of the current iteration. Only computed by ! this routine when ITOL=11. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", in the DGMRES, ! DSLUGM and DSDGMR routines for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system Mz = r for z ! given r with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays. The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IWORK is an integer work array ! for the same purpose as RWORK. ! NMSL :INOUT Integer. ! A counter for the number of calls to MSOLVE. ! ITOL :IN Integer. ! Flag to indicate the type of convergence criterion used. ! ITOL=0 Means the iteration stops when the test described ! below on the residual RL is satisfied. This is ! the "Natural Stopping Criteria" for this routine. ! Other values of ITOL cause extra, otherwise ! unnecessary, computation per iteration and are ! therefore much less efficient. ! ITOL=1 Means the iteration stops when the first test ! described below on the residual RL is satisfied, ! and there is either right or no preconditioning ! being used. ! ITOL=2 Implies that the user is using left ! preconditioning, and the second stopping criterion ! below is used. ! ITOL=3 Means the iteration stops when the third test ! described below on Minv*Residual is satisfied, and ! there is either left or no preconditioning begin ! used. ! ITOL=11 is often useful for checking and comparing ! different routines. For this case, the user must ! supply the "exact" solution or a very accurate ! approximation (one with an error much less than ! TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the ! difference between the iterative approximation and ! the user-supplied solution divided by the 2-norm ! of the user-supplied solution is less than TOL. ! Note that this requires the user to set up the ! "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling ! routine. The routine with this declaration should ! be loaded before the stop test so that the correct ! length is used by the loader. This procedure is ! not standard Fortran and may not work correctly on ! your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 ! then this common block is indeed standard Fortran. ! TOL :IN Double Precision. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! The iteration for which to check for convergence. ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. Letting norm() denote the Euclidean ! norm, ERR is defined as follows.. ! ! If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! for right or no preconditioning, and ! ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! for left preconditioning. ! If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! since right or no preconditioning ! being used. ! If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! since left preconditioning is being ! used. ! If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| ! i=1,n ! If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :INOUT Double Precision R(N). ! Work array used in calling routine. It contains ! information necessary to compute the residual RL = B-A*XL. ! Z :WORK Double Precision Z(N). ! Workspace used to hold the pseudo-residual M z = r. ! DZ :WORK Double Precision DZ(N). ! Workspace used to hold temporary vector(s). ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! RNRM :IN Double Precision. ! Norm of the current residual. Type of norm depends on ITOL. ! BNRM :IN Double Precision. ! Norm of the right hand side. Type of norm depends on ITOL. ! SB :IN Double Precision SB(N). ! Scaling vector for B. ! SX :IN Double Precision SX(N). ! Scaling vector for X. ! JSCAL :IN Integer. ! Flag indicating if scaling arrays SB and SX are being ! used in the calling routine DPIGMR. ! JSCAL=0 means SB and SX are not used and the ! algorithm will perform as if all ! SB(i) = 1 and SX(i) = 1. ! JSCAL=1 means only SX is used, and the algorithm ! performs as if all SB(i) = 1. ! JSCAL=2 means only SB is used, and the algorithm ! performs as if all SX(i) = 1. ! JSCAL=3 means both SB and SX are used. ! KMP :IN Integer ! The number of previous vectors the new vector VNEW ! must be made orthogonal to. (KMP .le. MAXL) ! LGMR :IN Integer ! The number of GMRES iterations performed on the current call ! to DPIGMR (i.e., # iterations since the last restart) and ! the current order of the upper Hessenberg ! matrix HES. ! MAXL :IN Integer ! The maximum allowable order of the matrix H. ! MAXLP1 :IN Integer ! MAXPL1 = MAXL + 1, used for dynamic dimensioning of HES. ! V :IN Double Precision V(N,MAXLP1) ! The N by (LGMR+1) array containing the LGMR ! orthogonal vectors V(*,1) to V(*,LGMR). ! Q :IN Double Precision Q(2*MAXL) ! A double precision array of length 2*MAXL containing the ! components of the Givens rotations used in the QR ! decomposition of HES. ! SNORMW :IN Double Precision ! A scalar containing the scaled norm of VNEW before it ! is renormalized in DPIGMR. ! PROD :IN Double Precision ! The product s1*s2*...*sl = the product of the sines of the ! Givens rotations used in the QR factorization of the ! Hessenberg matrix HES. ! R0NRM :IN Double Precision ! The scaled norm of initial residual R0. ! HES :IN Double Precision HES(MAXLP1,MAXL) ! The upper triangular factor of the QR decomposition ! of the (LGMR+1) by LGMR upper Hessenberg matrix whose ! entries are the scaled inner-products of A*V(*,I) ! and V(*,K). ! JPRE :IN Integer ! Preconditioner type flag. ! (See description of IGWK(4) in DGMRES.) ! ! *Description ! When using the GMRES solver, the preferred value for ITOL ! is 0. This is due to the fact that when ITOL=0 the norm of ! the residual required in the stopping test is obtained for ! free, since this value is already calculated in the GMRES ! algorithm. The variable RNRM contains the appropriate ! norm, which is equal to norm(SB*(RL - A*XL)) when right or ! no preconditioning is being performed, and equal to ! norm(SB*Minv*(RL - A*XL)) when using left preconditioning. ! Here, norm() is the Euclidean norm. Nonzero values of ITOL ! require additional work to calculate the actual scaled ! residual or its scaled/preconditioned form, and/or the ! approximate solution XL. Hence, these values of ITOL will ! not be as efficient as ITOL=0. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! ! This routine does not verify that ITOL has a valid value. ! The calling routine should make such a test before calling ! ISDGMR, as is done in DGMRES. ! !***SEE ALSO DGMRES !***ROUTINES CALLED D1MACH, DCOPY, DNRM2, DRLCAL, DSCAL, DXLCAL !***COMMON BLOCKS DSLBLK !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Corrected conversion errors, etc. (FNF) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to DGMRES. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921026 Corrected D to E in output format. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE ISDGMR ! .. Scalar Arguments .. DOUBLE PRECISION BNRM, ERR, PROD, R0NRM, RNRM, SNORMW, TOL INTEGER ISYM, ITER, ITMAX, ITOL, IUNIT, JPRE, JSCAL, KMP, LGMR, & MAXL, MAXLP1, N, NELT, NMSL ! .. Array Arguments .. DOUBLE PRECISION A(*), B(*), DZ(*), HES(MAXLP1, MAXL), Q(*), R(*), & RWORK(*), SB(*), SX(*), V(N,*), X(*), XL(*), Z(*) INTEGER IA(*), IWORK(*), JA(*) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Arrays in Common .. DOUBLE PRECISION SOLN(1) ! .. Local Scalars .. DOUBLE PRECISION DXNRM, FUZZ, RAT, RATMAX, SOLNRM, TEM INTEGER I, IELMAX ! .. External Functions .. DOUBLE PRECISION D1MACH, DNRM2 EXTERNAL D1MACH, DNRM2 ! .. External Subroutines .. EXTERNAL DCOPY, DRLCAL, DSCAL, DXLCAL ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. Common blocks .. COMMON /DSLBLK/ SOLN ! .. Save statement .. SAVE SOLNRM !***FIRST EXECUTABLE STATEMENT ISDGMR ISDGMR = 0 if ( ITOL == 0 ) THEN ! ! Use input from DPIGMR to determine if stop conditions are met. ! ERR = RNRM/BNRM end if if ( (ITOL > 0) .AND. (ITOL <= 3) ) THEN ! ! Use DRLCAL to calculate the scaled residual vector. ! Store answer in R. ! if ( LGMR /= 0 ) call DRLCAL(N, KMP, LGMR, MAXL, V, Q, R, & SNORMW, PROD, R0NRM) if ( ITOL <= 2 ) THEN ! err = ||Residual||/||RightHandSide||(2-Norms). ERR = DNRM2(N, R, 1)/BNRM ! ! Unscale R by R0NRM*PROD when KMP < MAXL. ! if ( (KMP < MAXL) .AND. (LGMR /= 0) ) THEN TEM = 1.0D0/(R0NRM*PROD) call DSCAL(N, TEM, R, 1) ENDIF ELSEIF ( ITOL == 3 ) THEN ! err = Max |(Minv*Residual)(i)/x(i)| ! When JPRE .lt. 0, R already contains Minv*Residual. if ( JPRE > 0 ) THEN call MSOLVE(N, R, DZ, NELT, IA, JA, A, ISYM, RWORK, & IWORK) NMSL = NMSL + 1 ENDIF ! ! Unscale R by R0NRM*PROD when KMP < MAXL. ! if ( (KMP < MAXL) .AND. (LGMR /= 0) ) THEN TEM = 1.0D0/(R0NRM*PROD) call DSCAL(N, TEM, R, 1) ENDIF ! FUZZ = D1MACH(1) IELMAX = 1 RATMAX = ABS(DZ(1))/MAX(ABS(X(1)),FUZZ) DO 25 I = 2, N RAT = ABS(DZ(I))/MAX(ABS(X(I)),FUZZ) if ( RAT > RATMAX ) THEN IELMAX = I RATMAX = RAT ENDIF 25 CONTINUE ERR = RATMAX if ( RATMAX <= TOL ) ISDGMR = 1 if ( IUNIT > 0 ) WRITE(IUNIT,1020) ITER, IELMAX, RATMAX return ENDIF end if if ( ITOL == 11 ) THEN ! ! Use DXLCAL to calculate the approximate solution XL. ! if ( (LGMR /= 0) .AND. (ITER > 0) ) THEN call DXLCAL(N, LGMR, X, XL, XL, HES, MAXLP1, Q, V, R0NRM, & DZ, SX, JSCAL, JPRE, MSOLVE, NMSL, RWORK, IWORK, & NELT, IA, JA, A, ISYM) ELSEIF ( ITER == 0 ) THEN ! Copy X to XL to check if initial guess is good enough. call DCOPY(N, X, 1, XL, 1) ELSE ! Return since this is the first call to DPIGMR on a restart. return ENDIF ! if ((JSCAL == 0) .OR.(JSCAL == 2)) THEN ! err = ||x-TrueSolution||/||TrueSolution||(2-Norms). if ( ITER == 0 ) SOLNRM = DNRM2(N, SOLN, 1) DO 30 I = 1, N DZ(I) = XL(I) - SOLN(I) 30 CONTINUE ERR = DNRM2(N, DZ, 1)/SOLNRM ELSE if (ITER == 0) THEN SOLNRM = 0 DO 40 I = 1,N SOLNRM = SOLNRM + (SX(I)*SOLN(I))**2 40 CONTINUE SOLNRM = SQRT(SOLNRM) ENDIF DXNRM = 0 DO 50 I = 1,N DXNRM = DXNRM + (SX(I)*(XL(I)-SOLN(I)))**2 50 CONTINUE DXNRM = SQRT(DXNRM) ! err = ||SX*(x-TrueSolution)||/||SX*TrueSolution|| (2-Norms). ERR = DXNRM/SOLNRM ENDIF end if ! if ( IUNIT /= 0 ) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) N, ITOL, MAXL, KMP ENDIF WRITE(IUNIT,1010) ITER, RNRM/BNRM, ERR end if if ( ERR <= TOL ) ISDGMR = 1 ! return 1000 FORMAT(' Generalized Minimum Residual(',I3,I3,') for ', & 'N, ITOL = ',I5, I5, & /' ITER',' Natural Err Est',' Error Estimate') 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7) 1020 FORMAT(1X,' ITER = ',I5, ' IELMAX = ',I5, & ' |R(IELMAX)/X(IELMAX)| = ',D12.5) !------------- LAST LINE OF ISDGMR FOLLOWS ---------------------------- end INTEGER FUNCTION ISDIR (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, & IWORK, BNRM, SOLNRM) ! !! ISDIR is the Preconditioned Iterative Refinement Stop Test. ! ! This routine calculates the stop test for the iterative ! refinement iteration scheme. It returns a non-zero if the ! error estimate (the type of which is determined by ITOL) ! is less than the user specified tolerance TOL. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (ISSIR-S, ISDIR-D) !***KEYWORDS LINEAR SYSTEM, SLAP, SPARSE, STOP TEST !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER ! INTEGER IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N), DZ(N) ! DOUBLE PRECISION RWORK(USER DEFINED), BNRM, SOLNRM ! EXTERNAL MSOLVE ! ! if ( ISDIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK, ! $ BNRM, SOLNRM) /= 0 ) THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :IN Double Precision X(N). ! The current approximate solution vector. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "C *Description" in the ! DIR routine. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system Mz = r for ! z given r with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays. The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IWORK is an integer work array ! for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Double Precision. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Double Precision. ! Error estimate of error in the X(N) approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Double Precision R(N). ! The residual R = B-AX. ! Z :WORK Double Precision Z(N). ! Workspace used to hold the pseudo-residual M z = r. ! DZ :WORK Double Precision DZ(N). ! Workspace used to hold temporary vector(s). ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! BNRM :INOUT Double Precision. ! Norm of the right hand side. Type of norm depends on ITOL. ! Calculated only on the first call. ! SOLNRM :INOUT Double Precision. ! 2-Norm of the true solution, SOLN. Only computed and used ! if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DIR, DSJAC, DSGS !***ROUTINES CALLED D1MACH, DNRM2 !***COMMON BLOCKS DSLBLK !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 880320 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to DIR. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921026 Changed 1.0E10 to D1MACH(2) and corrected E to D in ! output format. (FNF) !***END PROLOGUE ISDIR ! .. Scalar Arguments .. DOUBLE PRECISION BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. DOUBLE PRECISION A(NELT), B(N), DZ(N), R(N), RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Arrays in Common .. DOUBLE PRECISION SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. DOUBLE PRECISION D1MACH, DNRM2 EXTERNAL D1MACH, DNRM2 ! .. Common blocks .. COMMON /DSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISDIR ISDIR = 0 if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = DNRM2(N, B, 1) ERR = DNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) BNRM = DNRM2(N, DZ, 1) ENDIF ERR = DNRM2(N, Z, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0 ) SOLNRM = DNRM2(N, SOLN, 1) DO 10 I = 1, N DZ(I) = X(I) - SOLN(I) 10 CONTINUE ERR = DNRM2(N, DZ, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = D1MACH(2) IERR = 3 end if ! if ( IUNIT /= 0 ) THEN WRITE(IUNIT,1000) ITER,ERR end if ! if ( ERR <= TOL ) ISDIR = 1 ! return 1000 FORMAT(5X,'ITER = ',I4,' Error Estimate = ',D16.7) !------------- LAST LINE OF ISDIR FOLLOWS ----------------------------- end INTEGER FUNCTION ISDOMN (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, & NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, & EMAP, DZ, CSAV, RWORK, IWORK, AK, BNRM, SOLNRM) ! !! ISDOMN is the Preconditioned Orthomin Stop Test. ! ! This routine calculates the stop test for the Orthomin ! iteration scheme. It returns a non-zero if the error ! estimate (the type of which is determined by ITOL) is ! less than the user specified tolerance TOL. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (ISSOMN-S, ISDOMN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, ! ORTHOMIN, SLAP, SPARSE, STOP TEST !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) ! DOUBLE PRECISION P(N,0:NSAVE), AP(N,0:NSAVE), EMAP(N,0:NSAVE) ! DOUBLE PRECISION DZ(N), CSAV(NSAVE), RWORK(USER DEFINED), AK ! DOUBLE PRECISION BNRM, SOLNRM ! EXTERNAL MSOLVE ! ! if ( ISDOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, ! $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, ! $ EMAP, DZ, CSAV, RWORK, IWORK, AK, BNRM, SOLNRM) ! $ /= 0 ) THEN ITERATION CONVERGED ! ! *Arguments: ! N :IN Integer. ! Order of the matrix. ! B :IN Double Precision B(N). ! Right-hand side vector. ! X :IN Double Precision X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Double Precision A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description" ! in the DSDOMN or DSLUOM prologue. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a double precision array ! that can be used to pass necessary preconditioning information ! and/or workspace to MSOLVE. IWORK is an integer work array ! for the same purpose as RWORK. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize against. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /DSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Double Precision. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Double Precision. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Double Precision R(N). ! The residual R = B-AX. ! Z :WORK Double Precision Z(N). ! P :IN Double Precision P(N,0:NSAVE). ! Workspace used to hold the conjugate direction vector(s). ! AP :IN Double Precision AP(N,0:NSAVE). ! Workspace used to hold the matrix A times the P vector(s). ! EMAP :IN Double Precision EMAP(N,0:NSAVE). ! Workspace used to hold M-inv times the AP vector(s). ! DZ :WORK Double Precision DZ(N). ! Workspace. ! CSAV :DUMMY Double Precision CSAV(NSAVE) ! Reserved for future use. ! RWORK :WORK Double Precision RWORK(USER DEFINED). ! Double Precision array that can be used for workspace in ! MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE. ! AK :IN Double Precision. ! Current iterate Orthomin iteration parameter. ! BNRM :OUT Double Precision. ! Current solution B-norm, if ITOL = 1 or 2. ! SOLNRM :OUT Double Precision. ! True solution norm, if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO DOMN, DSDOMN, DSLUOM !***ROUTINES CALLED D1MACH, DNRM2 !***COMMON BLOCKS DSLBLK !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to DOMN. (FNF) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920930 Corrected to not print AK when ITER=0. (FNF) ! 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in ! output format. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE ISDOMN ! .. Scalar Arguments .. DOUBLE PRECISION AK, BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT, NSAVE ! .. Array Arguments .. DOUBLE PRECISION A(NELT), AP(N,0:NSAVE), B(N), CSAV(NSAVE), & DZ(N), EMAP(N,0:NSAVE), P(N,0:NSAVE), R(N), & RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Arrays in Common .. DOUBLE PRECISION SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. DOUBLE PRECISION D1MACH, DNRM2 EXTERNAL D1MACH, DNRM2 ! .. Common blocks .. COMMON /DSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISDOMN ISDOMN = 0 ! if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = DNRM2(N, B, 1) ERR = DNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) BNRM = DNRM2(N, DZ, 1) ENDIF ERR = DNRM2(N, Z, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0) SOLNRM = DNRM2(N, SOLN, 1) DO 10 I = 1, N DZ(I) = X(I) - SOLN(I) 10 CONTINUE ERR = DNRM2(N, DZ, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = D1MACH(2) IERR = 3 end if ! if ( IUNIT /= 0) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) NSAVE, N, ITOL WRITE(IUNIT,1010) ITER, ERR ELSE WRITE(IUNIT,1010) ITER, ERR, AK ENDIF end if if ( ERR <= TOL) ISDOMN = 1 ! return 1000 FORMAT(' Preconditioned Orthomin(',I3,') for ', & 'N, ITOL = ',I5, I5, & /' ITER',' Error Estimate',' Alpha') 1010 FORMAT(1X,I4,1X,D16.7,1X,D16.7) !------------- LAST LINE OF ISDOMN FOLLOWS ---------------------------- end subroutine ISORT (IX, IY, N, KFLAG) ! !! ISORT sorts an array and optionally make the same interchanges in ... ! an auxiliary array. The array may be sorted in increasing ... ! or decreasing order. A slightly modified QUICKSORT ... ! algorithm is used. ! !***LIBRARY SLATEC !***CATEGORY N6A2A !***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) !***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING !***AUTHOR Jones, R. E., (SNLA) ! Kahaner, D. K., (NBS) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! ISORT sorts array IX and optionally makes the same interchanges in ! array IY. The array IX may be sorted in increasing order or ! decreasing order. A slightly modified quicksort algorithm is used. ! ! Description of Parameters ! IX - integer array of values to be sorted ! IY - integer array to be (optionally) carried along ! N - number of values in integer array IX to be sorted ! KFLAG - control parameter ! = 2 means sort IX in increasing order and carry IY along. ! = 1 means sort IX in increasing order (ignoring IY) ! = -1 means sort IX in decreasing order (ignoring IY) ! = -2 means sort IX in decreasing order and carry IY along. ! !***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm ! for sorting with minimal storage, Communications of ! the ACM, 12, 3 (1969), pp. 185-187. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 761118 DATE WRITTEN ! 810801 Modified by David K. Kahaner. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced statement labels. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) ! 920501 Reformatted the REFERENCES section. (DWL, WRB) ! 920519 Clarified error messages. (DWL) ! 920801 Declarations section rebuilt and code restructured to use ! IF-THEN-ELSE-ENDIF. (RWC, WRB) !***END PROLOGUE ISORT ! .. Scalar Arguments .. INTEGER KFLAG, N ! .. Array Arguments .. INTEGER IX(*), IY(*) ! .. Local Scalars .. REAL R INTEGER I, IJ, J, K, KK, L, M, NN, T, TT, TTY, TY ! .. Local Arrays .. INTEGER IL(21), IU(21) ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, INT !***FIRST EXECUTABLE STATEMENT ISORT NN = N if (NN < 1) THEN call XERMSG ('SLATEC', 'ISORT', & 'The number of values to be sorted is not positive.', 1, 1) return end if ! KK = ABS(KFLAG) if (KK /= 1 .AND. KK /= 2) THEN call XERMSG ('SLATEC', 'ISORT', & 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, & 1) return end if ! ! Alter array IX to get decreasing order if needed ! if (KFLAG <= -1) THEN DO 10 I=1,NN IX(I) = -IX(I) 10 CONTINUE end if ! if (KK == 2) go to 100 ! ! Sort IX only ! M = 1 I = 1 J = NN R = 0.375E0 ! 20 if (I == J) go to 60 if (R <= 0.5898437E0) THEN R = R+3.90625E-2 ELSE R = R-0.21875E0 end if ! 30 K = I ! ! Select a central element of the array and save it in location T ! IJ = I + INT((J-I)*R) T = IX(IJ) ! ! If first element of array is greater than T, interchange with T ! if (IX(I) > T) THEN IX(IJ) = IX(I) IX(I) = T T = IX(IJ) end if L = J ! ! If last element of array is less than than T, interchange with T ! if (IX(J) < T) THEN IX(IJ) = IX(J) IX(J) = T T = IX(IJ) ! ! If first element of array is greater than T, interchange with T ! if (IX(I) > T) THEN IX(IJ) = IX(I) IX(I) = T T = IX(IJ) ENDIF end if ! ! Find an element in the second half of the array which is smaller ! than T ! 40 L = L-1 if (IX(L) > T) go to 40 ! ! Find an element in the first half of the array which is greater ! than T ! 50 K = K+1 if (IX(K) < T) go to 50 ! ! Interchange these elements ! if (K <= L) THEN TT = IX(L) IX(L) = IX(K) IX(K) = TT go to 40 end if ! ! Save upper and lower subscripts of the array yet to be sorted ! if (L-I > J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 70 ! ! Begin again on another portion of the unsorted array ! 60 M = M-1 if (M == 0) go to 190 I = IL(M) J = IU(M) ! 70 if (J-I >= 1) go to 30 if (I == 1) go to 20 I = I-1 ! 80 I = I+1 if (I == J) go to 60 T = IX(I+1) if (IX(I) <= T) go to 80 K = I ! 90 IX(K+1) = IX(K) K = K-1 if (T < IX(K)) go to 90 IX(K+1) = T go to 80 ! ! Sort IX and carry IY along ! 100 M = 1 I = 1 J = NN R = 0.375E0 ! 110 if (I == J) go to 150 if (R <= 0.5898437E0) THEN R = R+3.90625E-2 ELSE R = R-0.21875E0 end if ! 120 K = I ! ! Select a central element of the array and save it in location T ! IJ = I + INT((J-I)*R) T = IX(IJ) TY = IY(IJ) ! ! If first element of array is greater than T, interchange with T ! if (IX(I) > T) THEN IX(IJ) = IX(I) IX(I) = T T = IX(IJ) IY(IJ) = IY(I) IY(I) = TY TY = IY(IJ) end if L = J ! ! If last element of array is less than T, interchange with T ! if (IX(J) < T) THEN IX(IJ) = IX(J) IX(J) = T T = IX(IJ) IY(IJ) = IY(J) IY(J) = TY TY = IY(IJ) ! ! If first element of array is greater than T, interchange with T ! if (IX(I) > T) THEN IX(IJ) = IX(I) IX(I) = T T = IX(IJ) IY(IJ) = IY(I) IY(I) = TY TY = IY(IJ) ENDIF end if ! ! Find an element in the second half of the array which is smaller ! than T ! 130 L = L-1 if (IX(L) > T) go to 130 ! ! Find an element in the first half of the array which is greater ! than T ! 140 K = K+1 if (IX(K) < T) go to 140 ! ! Interchange these elements ! if (K <= L) THEN TT = IX(L) IX(L) = IX(K) IX(K) = TT TTY = IY(L) IY(L) = IY(K) IY(K) = TTY go to 130 end if ! ! Save upper and lower subscripts of the array yet to be sorted ! if (L-I > J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 160 ! ! Begin again on another portion of the unsorted array ! 150 M = M-1 if (M == 0) go to 190 I = IL(M) J = IU(M) ! 160 if (J-I >= 1) go to 120 if (I == 1) go to 110 I = I-1 ! 170 I = I+1 if (I == J) go to 150 T = IX(I+1) TY = IY(I+1) if (IX(I) <= T) go to 170 K = I ! 180 IX(K+1) = IX(K) IY(K+1) = IY(K) K = K-1 if (T < IX(K)) go to 180 IX(K+1) = T IY(K+1) = TY go to 170 ! ! Clean up ! 190 if (KFLAG <= -1) THEN DO 200 I=1,NN IX(I) = -IX(I) 200 CONTINUE end if return end INTEGER FUNCTION ISSBCG (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, & DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) ! !! ISSBCG is the Preconditioned BiConjugate Gradient Stop Test. ! ! This routine calculates the stop test for the BiConjugate ! Gradient iteration scheme. It returns a non-zero if the ! error estimate (the type of which is determined by ITOL) ! is less than the user specified tolerance TOL. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (ISSBCG-S, ISDBCG-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, ! SPARSE, STOP TEST !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER ! INTEGER IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N) ! REAL RR(N), ZZ(N), PP(N), DZ(N) ! REAL RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM ! EXTERNAL MSOLVE ! ! if ( ISSBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, DZ, ! $ RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) ! $ THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", in the SLAP ! routine SBCG for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for Z ! given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine ! must be declared external in the calling program. The ! calling sequence of MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector, and Z is the solution upon return. NELT, IA, JA, A, ! and ISYM define the SLAP matrix data structure. ! RWORK is a real array that can be used to pass necessary ! preconditioning information and/or workspace to MSOLVE. ! IWORK is an integer work array for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Real. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Real R(N). ! The residual r = b - Ax. ! Z :WORK Real Z(N). ! P :DUMMY Real P(N). ! RR :DUMMY Real RR(N). ! ZZ :DUMMY Real ZZ(N). ! PP :DUMMY Real PP(N). ! Real arrays used for workspace. ! DZ :WORK Real DZ(N). ! If ITOL.eq.0 then DZ is used to hold M-inv * B on the first ! call. If ITOL.eq.11 then DZ is used to hold X-SOLN. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used for workspace in MSOLVE ! and MTSOLV. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE ! and MTSOLV. ! AK :IN Real. ! Current iterate BiConjugate Gradient iteration parameter. ! BK :IN Real. ! Current iterate BiConjugate Gradient iteration parameter. ! BNRM :INOUT Real. ! Norm of the right hand side. Type of norm depends on ITOL. ! Calculated only on the first call. ! SOLNRM :INOUT Real. ! 2-Norm of the true solution, SOLN. Only computed and used ! if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SBCG !***ROUTINES CALLED R1MACH, SNRM2 !***COMMON BLOCKS SSLBLK !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to SBCG. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920930 Corrected to not print AK,BK when ITER=0. (FNF) ! 921026 Changed 1.0E10 to R1MACH(2). (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE ISSBCG ! .. Scalar Arguments .. REAL AK, BK, BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), DZ(N), P(N), PP(N), R(N), RR(N), RWORK(*), & X(N), Z(N), ZZ(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Arrays in Common .. REAL SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. REAL R1MACH, SNRM2 EXTERNAL R1MACH, SNRM2 ! .. Common blocks .. COMMON /SSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISSBCG ISSBCG = 0 ! if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = SNRM2(N, B, 1) ERR = SNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) BNRM = SNRM2(N, DZ, 1) ENDIF ERR = SNRM2(N, Z, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0) SOLNRM = SNRM2(N, SOLN, 1) DO 10 I = 1, N DZ(I) = X(I) - SOLN(I) 10 CONTINUE ERR = SNRM2(N, DZ, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = R1MACH(2) IERR = 3 end if ! if ( IUNIT /= 0) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) N, ITOL WRITE(IUNIT,1010) ITER, ERR ELSE WRITE(IUNIT,1010) ITER, ERR, AK, BK ENDIF end if if ( ERR <= TOL) ISSBCG = 1 ! return 1000 FORMAT(' Preconditioned BiConjugate Gradient for N, ITOL = ', & I5,I5,/' ITER',' Error Estimate',' Alpha', & ' Beta') 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7,1X,E16.7) !------------- LAST LINE OF ISSBCG FOLLOWS ---------------------------- end INTEGER FUNCTION ISSCG (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, & IWORK, AK, BK, BNRM, SOLNRM) ! !! ISSCG is the Preconditioned Conjugate Gradient Stop Test. ! ! This routine calculates the stop test for the Conjugate ! Gradient iteration scheme. It returns a non-zero if the ! error estimate (the type of which is determined by ITOL) ! is less than the user specified tolerance TOL. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2B4 !***TYPE SINGLE PRECISION (ISSCG-S, ISDCG-D) !***KEYWORDS LINEAR SYSTEM, SLAP, SPARSE, STOP TEST !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER ! INTEGER IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(N), TOL, ERR, R(N), Z(N) ! REAL P(N), DZ(N), RWORK(USER DEFINED), AK, BK ! REAL BNRM, SOLNRM ! EXTERNAL MSOLVE ! ! if ( ISSCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, IWORK, ! $ AK, BK, BNRM, SOLNRM) /= 0 ) THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :IN Real X(N). ! The current approximate solution vector. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description" ! in the SCG, SSDCG or SSICCG routines. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a real array that can ! be used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Real. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Real. ! Error estimate of error in the X(N) approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Real R(N). ! The residual R = B-AX. ! Z :WORK Real Z(N). ! Workspace used to hold the pseudo-residual M Z = R. ! P :IN Real P(N). ! The conjugate direction vector. ! DZ :WORK Real DZ(N). ! Workspace used to hold temporary vector(s). ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! AK :IN Real. ! BK :IN Real. ! Current conjugate gradient parameters alpha and beta. ! BNRM :INOUT Real. ! Norm of the right hand side. Type of norm depends on ITOL. ! Calculated only on the first call. ! SOLNRM :INOUT Real. ! 2-Norm of the true solution, SOLN. Only computed and used ! if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SCG, SSDCG, SSICCG !***ROUTINES CALLED R1MACH, SNRM2 !***COMMON BLOCKS SSLBLK !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to SCG. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920930 Corrected to not print AK,BK when ITER=0. (FNF) ! 921026 Changed 1.0E10 to R1MACH(2). (FNF) !***END PROLOGUE ISSCG ! .. Scalar Arguments .. REAL AK, BK, BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), DZ(N), P(N), R(N), RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Arrays in Common .. REAL SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. REAL R1MACH, SNRM2 EXTERNAL R1MACH, SNRM2 ! .. Common blocks .. COMMON /SSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISSCG ISSCG = 0 ! if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = SNRM2(N, B, 1) ERR = SNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) BNRM = SNRM2(N, DZ, 1) ENDIF ERR = SNRM2(N, Z, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0) SOLNRM = SNRM2(N, SOLN, 1) DO 10 I = 1, N DZ(I) = X(I) - SOLN(I) 10 CONTINUE ERR = SNRM2(N, DZ, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = R1MACH(2) IERR = 3 end if ! if ( IUNIT /= 0) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) N, ITOL WRITE(IUNIT,1010) ITER, ERR ELSE WRITE(IUNIT,1010) ITER, ERR, AK, BK ENDIF end if if ( ERR <= TOL) ISSCG = 1 return 1000 FORMAT(' Preconditioned Conjugate Gradient for ', & 'N, ITOL = ',I5, I5, & /' ITER',' Error Estimate',' Alpha', & ' Beta') 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7,1X,E16.7) !------------- LAST LINE OF ISSCG FOLLOWS ------------------------------ end INTEGER FUNCTION ISSCGN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, & MTTVEC, MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, & P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) ! !! ISSCGN is the Preconditioned CG on Normal Equations Stop Test. ! ! This routine calculates the stop test for the Conjugate ! Gradient iteration scheme applied to the normal equations. ! It returns a non-zero if the error estimate (the type of ! which is determined by ITOL) is less than the user ! specified tolerance TOL. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (ISSCGN-S, ISDCGN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, ! NORMAL EQUATIONS, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER ! INTEGER IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N) ! REAL ATP(N), ATZ(N), DZ(N), ATDZ(N) ! REAL RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM ! EXTERNAL MATVEC, MTTVEC, MSOLVE ! ! if ( ISTPCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, ! $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ! $ ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) ! $ /= 0 ) THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :IN Real X(N). ! The current approximate solution vector. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description" in the ! SCGN routine. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP-Column IA, JA, A storage for the matrix ! A. ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MTTVEC :EXT External. ! Name of a routine which performs the matrix transpose vector ! multiply y = A'*X given A and X (where ' denotes transpose). ! The name of the MTTVEC routine must be declared external in ! the calling program. The calling sequence to MTTVEC is the ! same as that for MATVEC, viz.: ! call MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A'*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP-Column IA, JA, A storage for the matrix ! A. ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a real array that can ! be used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Real. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Real. ! Error estimate of error in the X(N) approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Real R(N). ! The residual R = B-AX. ! Z :WORK Real Z(N). ! Real array used for workspace. ! P :IN Real P(N). ! The conjugate direction vector. ! ATP :IN Real ATP(N). ! A-transpose times the conjugate direction vector. ! ATZ :IN Real ATZ(N). ! A-transpose times the pseudo-residual. ! DZ :IN Real DZ(N). ! Workspace used to hold temporary vector(s). ! ATDZ :WORK Real ATDZ(N). ! Workspace. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! AK :IN Real. ! BK :IN Real. ! Current conjugate gradient parameters alpha and beta. ! BNRM :INOUT Real. ! Norm of the right hand side. Type of norm depends on ITOL. ! Calculated only on the first call. ! SOLNRM :INOUT Real. ! 2-Norm of the true solution, SOLN. Only computed and used ! if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SCGN !***ROUTINES CALLED R1MACH, SNRM2 !***COMMON BLOCKS SSLBLK !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC, MTTVEC and MSOLVE from ROUTINES CALLED ! list. (FNF) ! 910506 Made subsidiary to SCGN. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920930 Corrected to not print AK,BK when ITER=0. (FNF) ! 921026 Changed 1.0E10 to R1MACH(2). (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE ISSCGN ! .. Scalar Arguments .. REAL AK, BK, BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. REAL A(N), ATDZ(N), ATP(N), ATZ(N), B(N), DZ(N), P(N), R(N), & RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE, MTTVEC ! .. Arrays in Common .. REAL SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. REAL R1MACH, SNRM2 EXTERNAL R1MACH, SNRM2 ! .. Common blocks .. COMMON /SSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISSCGN ISSCGN = 0 ! if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = SNRM2(N, B, 1) ERR = SNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) call MTTVEC(N, DZ, ATDZ, NELT, IA, JA, A, ISYM) BNRM = SNRM2(N, ATDZ, 1) ENDIF ERR = SNRM2(N, ATZ, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0) SOLNRM = SNRM2(N, SOLN, 1) DO 10 I = 1, N DZ(I) = X(I) - SOLN(I) 10 CONTINUE ERR = SNRM2(N, DZ, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = R1MACH(2) IERR = 3 end if ! if ( IUNIT /= 0 ) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) N, ITOL WRITE(IUNIT,1010) ITER, ERR ELSE WRITE(IUNIT,1010) ITER, ERR, AK, BK ENDIF end if if ( ERR <= TOL ) ISSCGN = 1 ! return 1000 FORMAT(' PCG Applied to the Normal Equations for ', & 'N, ITOL = ',I5, I5, & /' ITER',' Error Estimate',' Alpha', & ' Beta') 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7,1X,E16.7) !------------- LAST LINE OF ISSCGN FOLLOWS ---------------------------- end INTEGER FUNCTION ISSCGS (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, & MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, & U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) ! !! ISSCGS is the Preconditioned BiConjugate Gradient Squared Stop Test. ! ! This routine calculates the stop test for the BiConjugate ! Gradient Squared iteration scheme. It returns a non-zero ! if the error estimate (the type of which is determined by ! ITOL) is less than the user specified tolerance TOL. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (ISSCGS-S, ISDCGS-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, ! SPARSE, STOP TEST !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER ! INTEGER IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(N), TOL, ERR, R(N), R0(N), P(N) ! REAL Q(N), U(N), V1(N), V2(N) ! REAL RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM ! EXTERNAL MATVEC, MSOLVE ! ! if ( ISSCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ITOL, ! $ TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U, V1, ! $ V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) ! $ THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description" in SLAP routine ! SCGS for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! operation Y = A*X given A and X. The name of the MATVEC ! routine must be declared external in the calling program. ! The calling sequence of MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X upon ! return, X is an input vector. NELT, IA, JA, A, and ISYM ! define the SLAP matrix data structure. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for Z ! given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine ! must be declared external in the calling program. The ! calling sequence of MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector, and Z is the solution upon return. NELT, IA, JA, A, ! and ISYM define the SLAP matrix data structure. ! RWORK is a real array that can be used to pass necessary ! preconditioning information and/or workspace to MSOLVE. ! IWORK is an integer work array for the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! This routine must calculate the residual from R = A*X - B. ! This is unnatural and hence expensive for this type of iter- ! ative method. ITOL=2 is *STRONGLY* recommended. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv time a vector is the pre- ! conditioning step. This is the *NATURAL* stopping for this ! iterative method and is *STRONGLY* recommended. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Real. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Real R(N). ! The residual r = b - Ax. ! R0 :WORK Real R0(N). ! P :DUMMY Real P(N). ! Q :DUMMY Real Q(N). ! U :DUMMY Real U(N). ! V1 :DUMMY Real V1(N). ! Real arrays used for workspace. ! V2 :WORK Real V2(N). ! If ITOL.eq.1 then V2 is used to hold A * X - B on every call. ! If ITOL.eq.2 then V2 is used to hold M-inv * B on the first ! call. ! If ITOL.eq.11 then V2 is used to X - SOLN. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used for workspace in MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE. ! AK :IN Real. ! Current iterate BiConjugate Gradient iteration parameter. ! BK :IN Real. ! Current iterate BiConjugate Gradient iteration parameter. ! BNRM :INOUT Real. ! Norm of the right hand side. Type of norm depends on ITOL. ! Calculated only on the first call. ! SOLNRM :INOUT Real. ! 2-Norm of the true solution, SOLN. Only computed and used ! if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SCGS !***ROUTINES CALLED R1MACH, SNRM2 !***COMMON BLOCKS SSLBLK !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to SCGS. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920930 Corrected to not print AK,BK when ITER=0. (FNF) ! 921026 Changed 1.0E10 to R1MACH(2). (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE ISSCGS ! .. Scalar Arguments .. REAL AK, BK, BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), P(N), Q(N), R(N), R0(N), RWORK(*), U(N), & V1(N), V2(N), X(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Arrays in Common .. REAL SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. REAL R1MACH, SNRM2 EXTERNAL R1MACH, SNRM2 ! .. Common blocks .. COMMON /SSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISSCGS ISSCGS = 0 ! if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = SNRM2(N, B, 1) call MATVEC(N, X, V2, NELT, IA, JA, A, ISYM ) DO 5 I = 1, N V2(I) = V2(I) - B(I) 5 CONTINUE ERR = SNRM2(N, V2, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, B, V2, NELT, IA, JA, A, ISYM, RWORK, IWORK) BNRM = SNRM2(N, V2, 1) ENDIF ERR = SNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0) SOLNRM = SNRM2(N, SOLN, 1) DO 10 I = 1, N V2(I) = X(I) - SOLN(I) 10 CONTINUE ERR = SNRM2(N, V2, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = R1MACH(2) IERR = 3 end if ! ! Print the error and coefficients AK, BK on each step, ! if desired. if ( IUNIT /= 0) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) N, ITOL WRITE(IUNIT,1010) ITER, ERR ELSE WRITE(IUNIT,1010) ITER, ERR, AK, BK ENDIF end if if ( ERR <= TOL) ISSCGS = 1 ! return 1000 FORMAT(' Preconditioned BiConjugate Gradient Squared for ', & 'N, ITOL = ',I5, I5, & /' ITER',' Error Estimate',' Alpha', & ' Beta') 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7,1X,E16.7) !------------- LAST LINE OF ISSCGS FOLLOWS ---------------------------- end INTEGER FUNCTION ISSGMR (N, B, X, XL, NELT, IA, JA, A, ISYM, & MSOLVE, NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, R, Z, DZ, & RWORK, IWORK, RNRM, BNRM, SB, SX, JSCAL, KMP, LGMR, MAXL, & MAXLP1, V, Q, SNORMW, PROD, R0NRM, HES, JPRE) ! !! ISSGMR is the Generalized Minimum Residual Stop Test. ! ! This routine calculates the stop test for the Generalized ! Minimum RESidual (GMRES) iteration scheme. It returns a ! non-zero if the error estimate (the type of which is ! determined by ITOL) is less than the user specified ! tolerance TOL. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (ISSGMR-S, ISDGMR-D) !***KEYWORDS GMRES, LINEAR SYSTEM, SLAP, SPARSE, STOP TEST !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NMSL, ITOL ! INTEGER ITMAX, ITER, IUNIT, IWORK(USER DEFINED), JSCAL ! INTEGER KMP, LGMR, MAXL, MAXLP1, JPRE ! REAL B(N), X(N), XL(MAXL), A(NELT), TOL, ERR, R(N), Z(N), ! $ DZ(N), RWORK(USER DEFINED), RNRM, BNRM, SB(N), SX(N), ! $ V(N,MAXLP1), Q(2*MAXL), SNORMW, PROD, R0NRM, ! $ HES(MAXLP1,MAXL) ! EXTERNAL MSOLVE ! ! if (ISSGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, ! $ NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, R, Z, DZ, ! $ RWORK, IWORK, RNRM, BNRM, SB, SX, JSCAL, ! $ KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, ! $ HES, JPRE) /= 0) THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand-side vector. ! X :IN Real X(N). ! Approximate solution vector as of the last restart. ! XL :OUT Real XL(N) ! An array of length N used to hold the approximate ! solution as of the current iteration. Only computed by ! this routine when ITOL=11. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", in the SGMRES, ! SSLUGM and SSDGMR routines for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system Mz = r for z ! given r with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays. The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a real array that can ! be used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! NMSL :INOUT Integer. ! A counter for the number of calls to MSOLVE. ! ITOL :IN Integer. ! Flag to indicate the type of convergence criterion used. ! ITOL=0 Means the iteration stops when the test described ! below on the residual RL is satisfied. This is ! the "Natural Stopping Criteria" for this routine. ! Other values of ITOL cause extra, otherwise ! unnecessary, computation per iteration and are ! therefore much less efficient. ! ITOL=1 Means the iteration stops when the first test ! described below on the residual RL is satisfied, ! and there is either right or no preconditioning ! being used. ! ITOL=2 Implies that the user is using left ! preconditioning, and the second stopping criterion ! below is used. ! ITOL=3 Means the iteration stops when the third test ! described below on Minv*Residual is satisfied, and ! there is either left or no preconditioning begin ! used. ! ITOL=11 is often useful for checking and comparing ! different routines. For this case, the user must ! supply the "exact" solution or a very accurate ! approximation (one with an error much less than ! TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the ! difference between the iterative approximation and ! the user-supplied solution divided by the 2-norm ! of the user-supplied solution is less than TOL. ! Note that this requires the user to set up the ! "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling ! routine. The routine with this declaration should ! be loaded before the stop test so that the correct ! length is used by the loader. This procedure is ! not standard Fortran and may not work correctly on ! your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 ! then this common block is indeed standard Fortran. ! TOL :IN Real. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! The iteration for which to check for convergence. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. Letting norm() denote the Euclidean ! norm, ERR is defined as follows.. ! ! If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! for right or no preconditioning, and ! ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! for left preconditioning. ! If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! since right or no preconditioning ! being used. ! If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! since left preconditioning is being ! used. ! If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| ! i=1,n ! If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :INOUT Real R(N). ! Work array used in calling routine. It contains ! information necessary to compute the residual RL = B-A*XL. ! Z :WORK Real Z(N). ! Workspace used to hold the pseudo-residual M z = r. ! DZ :WORK Real DZ(N). ! Workspace used to hold temporary vector(s). ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! RNRM :IN Real. ! Norm of the current residual. Type of norm depends on ITOL. ! BNRM :IN Real. ! Norm of the right hand side. Type of norm depends on ITOL. ! SB :IN Real SB(N). ! Scaling vector for B. ! SX :IN Real SX(N). ! Scaling vector for X. ! JSCAL :IN Integer. ! Flag indicating if scaling arrays SB and SX are being ! used in the calling routine SPIGMR. ! JSCAL=0 means SB and SX are not used and the ! algorithm will perform as if all ! SB(i) = 1 and SX(i) = 1. ! JSCAL=1 means only SX is used, and the algorithm ! performs as if all SB(i) = 1. ! JSCAL=2 means only SB is used, and the algorithm ! performs as if all SX(i) = 1. ! JSCAL=3 means both SB and SX are used. ! KMP :IN Integer ! The number of previous vectors the new vector VNEW ! must be made orthogonal to. (KMP .le. MAXL) ! LGMR :IN Integer ! The number of GMRES iterations performed on the current call ! to SPIGMR (i.e., # iterations since the last restart) and ! the current order of the upper Hessenberg ! matrix HES. ! MAXL :IN Integer ! The maximum allowable order of the matrix H. ! MAXLP1 :IN Integer ! MAXPL1 = MAXL + 1, used for dynamic dimensioning of HES. ! V :IN Real V(N,MAXLP1) ! The N by (LGMR+1) array containing the LGMR ! orthogonal vectors V(*,1) to V(*,LGMR). ! Q :IN Real Q(2*MAXL) ! A real array of length 2*MAXL containing the components ! of the Givens rotations used in the QR decomposition ! of HES. ! SNORMW :IN Real ! A scalar containing the scaled norm of VNEW before it ! is renormalized in SPIGMR. ! PROD :IN Real ! The product s1*s2*...*sl = the product of the sines of the ! Givens rotations used in the QR factorization of the ! Hessenberg matrix HES. ! R0NRM :IN Real ! The scaled norm of initial residual R0. ! HES :IN Real HES(MAXLP1,MAXL) ! The upper triangular factor of the QR decomposition ! of the (LGMR+1) by LGMR upper Hessenberg matrix whose ! entries are the scaled inner-products of A*V(*,I) ! and V(*,K). ! JPRE :IN Integer ! Preconditioner type flag. ! (See description of IGWK(4) in SGMRES.) ! ! *Description ! When using the GMRES solver, the preferred value for ITOL ! is 0. This is due to the fact that when ITOL=0 the norm of ! the residual required in the stopping test is obtained for ! free, since this value is already calculated in the GMRES ! algorithm. The variable RNRM contains the appropriate ! norm, which is equal to norm(SB*(RL - A*XL)) when right or ! no preconditioning is being performed, and equal to ! norm(SB*Minv*(RL - A*XL)) when using left preconditioning. ! Here, norm() is the Euclidean norm. Nonzero values of ITOL ! require additional work to calculate the actual scaled ! residual or its scaled/preconditioned form, and/or the ! approximate solution XL. Hence, these values of ITOL will ! not be as efficient as ITOL=0. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! ! This routine does not verify that ITOL has a valid value. ! The calling routine should make such a test before calling ! ISSGMR, as is done in SGMRES. ! !***SEE ALSO SGMRES !***ROUTINES CALLED R1MACH, SCOPY, SNRM2, SRLCAL, SSCAL, SXLCAL !***COMMON BLOCKS SSLBLK !***REVISION HISTORY (YYMMDD) ! 871211 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Corrected conversion errors, etc. (FNF) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to SGMRES. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE ISSGMR ! .. Scalar Arguments .. REAL BNRM, ERR, PROD, R0NRM, RNRM, SNORMW, TOL INTEGER ISYM, ITER, ITMAX, ITOL, IUNIT, JPRE, JSCAL, KMP, LGMR, & MAXL, MAXLP1, N, NELT, NMSL ! .. Array Arguments .. REAL A(*), B(*), DZ(*), HES(MAXLP1, MAXL), Q(*), R(*), RWORK(*), & SB(*), SX(*), V(N,*), X(*), XL(*), Z(*) INTEGER IA(*), IWORK(*), JA(*) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Arrays in Common .. REAL SOLN(1) ! .. Local Scalars .. REAL DXNRM, FUZZ, RAT, RATMAX, SOLNRM, TEM INTEGER I, IELMAX ! .. External Functions .. REAL R1MACH, SNRM2 EXTERNAL R1MACH, SNRM2 ! .. External Subroutines .. EXTERNAL SCOPY, SRLCAL, SSCAL, SXLCAL ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. Common blocks .. COMMON /SSLBLK/ SOLN ! .. Save statement .. SAVE SOLNRM !***FIRST EXECUTABLE STATEMENT ISSGMR ISSGMR = 0 if ( ITOL == 0 ) THEN ! ! Use input from SPIGMR to determine if stop conditions are met. ! ERR = RNRM/BNRM end if if ( (ITOL > 0) .AND. (ITOL <= 3) ) THEN ! ! Use SRLCAL to calculate the scaled residual vector. ! Store answer in R. ! if ( LGMR /= 0 ) call SRLCAL(N, KMP, LGMR, MAXL, V, Q, R, & SNORMW, PROD, R0NRM) if ( ITOL <= 2 ) THEN ! err = ||Residual||/||RightHandSide||(2-Norms). ERR = SNRM2(N, R, 1)/BNRM ! ! Unscale R by R0NRM*PROD when KMP < MAXL. ! if ( (KMP < MAXL) .AND. (LGMR /= 0) ) THEN TEM = 1.0E0/(R0NRM*PROD) call SSCAL(N, TEM, R, 1) ENDIF ELSEIF ( ITOL == 3 ) THEN ! err = Max |(Minv*Residual)(i)/x(i)| ! When JPRE .lt. 0, R already contains Minv*Residual. if ( JPRE > 0 ) THEN call MSOLVE(N, R, DZ, NELT, IA, JA, A, ISYM, RWORK, & IWORK) NMSL = NMSL + 1 ENDIF ! ! Unscale R by R0NRM*PROD when KMP < MAXL. ! if ( (KMP < MAXL) .AND. (LGMR /= 0) ) THEN TEM = 1.0E0/(R0NRM*PROD) call SSCAL(N, TEM, R, 1) ENDIF ! FUZZ = R1MACH(1) IELMAX = 1 RATMAX = ABS(DZ(1))/MAX(ABS(X(1)),FUZZ) DO 25 I = 2, N RAT = ABS(DZ(I))/MAX(ABS(X(I)),FUZZ) if ( RAT > RATMAX ) THEN IELMAX = I RATMAX = RAT ENDIF 25 CONTINUE ERR = RATMAX if ( RATMAX <= TOL ) ISSGMR = 1 if ( IUNIT > 0 ) WRITE(IUNIT,1020) ITER, IELMAX, RATMAX return ENDIF end if if ( ITOL == 11 ) THEN ! ! Use SXLCAL to calculate the approximate solution XL. ! if ( (LGMR /= 0) .AND. (ITER > 0) ) THEN call SXLCAL(N, LGMR, X, XL, XL, HES, MAXLP1, Q, V, R0NRM, & DZ, SX, JSCAL, JPRE, MSOLVE, NMSL, RWORK, IWORK, & NELT, IA, JA, A, ISYM) ELSEIF ( ITER == 0 ) THEN ! Copy X to XL to check if initial guess is good enough. call SCOPY(N, X, 1, XL, 1) ELSE ! Return since this is the first call to SPIGMR on a restart. return ENDIF ! if ((JSCAL == 0) .OR.(JSCAL == 2)) THEN ! err = ||x-TrueSolution||/||TrueSolution||(2-Norms). if ( ITER == 0 ) SOLNRM = SNRM2(N, SOLN, 1) DO 30 I = 1, N DZ(I) = XL(I) - SOLN(I) 30 CONTINUE ERR = SNRM2(N, DZ, 1)/SOLNRM ELSE if (ITER == 0) THEN SOLNRM = 0 DO 40 I = 1,N SOLNRM = SOLNRM + (SX(I)*SOLN(I))**2 40 CONTINUE SOLNRM = SQRT(SOLNRM) ENDIF DXNRM = 0 DO 50 I = 1,N DXNRM = DXNRM + (SX(I)*(XL(I)-SOLN(I)))**2 50 CONTINUE DXNRM = SQRT(DXNRM) ! err = ||SX*(x-TrueSolution)||/||SX*TrueSolution|| (2-Norms). ERR = DXNRM/SOLNRM ENDIF end if ! if ( IUNIT /= 0 ) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) N, ITOL, MAXL, KMP ENDIF WRITE(IUNIT,1010) ITER, RNRM/BNRM, ERR end if if ( ERR <= TOL ) ISSGMR = 1 ! return 1000 FORMAT(' Generalized Minimum Residual(',I3,I3,') for ', & 'N, ITOL = ',I5, I5, & /' ITER',' Natural Err Est',' Error Estimate') 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7) 1020 FORMAT(1X,' ITER = ',I5, ' IELMAX = ',I5, & ' |R(IELMAX)/X(IELMAX)| = ',E12.5) !------------- LAST LINE OF ISSGMR FOLLOWS ---------------------------- end INTEGER FUNCTION ISSIR (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, & IWORK, BNRM, SOLNRM) ! !! ISSIR is the Preconditioned Iterative Refinement Stop Test. ! ! This routine calculates the stop test for the iterative ! refinement iteration scheme. It returns a non-zero if the ! error estimate (the type of which is determined by ITOL) ! is less than the user specified tolerance TOL. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (ISSIR-S, ISDIR-D) !***KEYWORDS LINEAR SYSTEM, SLAP, SPARSE, STOP TEST !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER ! INTEGER IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(N), TOL, ERR, R(N), Z(N), DZ(N) ! REAL RWORK(USER DEFINED), BNRM, SOLNRM ! EXTERNAL MSOLVE ! ! if ( ISSIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK, ! $ BNRM, SOLNRM) /= 0 ) THEN ITERATION DONE ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :IN Real X(N). ! The current approximate solution vector. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "C *Description" in the ! SIR routine. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system Mz = r for ! z given r with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays. The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a real array that can ! be used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Real. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Real. ! Error estimate of error in the X(N) approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Real R(N). ! The residual R = B-AX. ! Z :WORK Real Z(N). ! Workspace used to hold the pseudo-residual M z = r. ! DZ :WORK Real DZ(N). ! Workspace used to hold temporary vector(s). ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! BNRM :INOUT Real. ! Norm of the right hand side. Type of norm depends on ITOL. ! Calculated only on the first call. ! SOLNRM :INOUT Real. ! 2-Norm of the true solution, SOLN. Only computed and used ! if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SIR, SSJAC, SSGS !***ROUTINES CALLED R1MACH, SNRM2 !***COMMON BLOCKS SSLBLK !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 880320 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to SIR. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921026 Changed 1.0E10 to R1MACH(2). (FNF) !***END PROLOGUE ISSIR ! .. Scalar Arguments .. REAL BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), DZ(N), R(N), RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Arrays in Common .. REAL SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. REAL R1MACH, SNRM2 EXTERNAL R1MACH, SNRM2 ! .. Common blocks .. COMMON /SSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISSIR ISSIR = 0 if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = SNRM2(N, B, 1) ERR = SNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) BNRM = SNRM2(N, DZ, 1) ENDIF ERR = SNRM2(N, Z, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0 ) SOLNRM = SNRM2(N, SOLN, 1) DO 10 I = 1, N DZ(I) = X(I) - SOLN(I) 10 CONTINUE ERR = SNRM2(N, DZ, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = R1MACH(2) IERR = 3 end if ! if ( IUNIT /= 0 ) THEN WRITE(IUNIT,1000) ITER,ERR end if ! if ( ERR <= TOL ) ISSIR = 1 ! return 1000 FORMAT(5X,'ITER = ',I4,' Error Estimate = ',E16.7) !------------- LAST LINE OF ISSIR FOLLOWS ----------------------------- end INTEGER FUNCTION ISSOMN (N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, & NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, & EMAP, DZ, CSAV, RWORK, IWORK, AK, BNRM, SOLNRM) ! !! ISSOMN is the Preconditioned Orthomin Stop Test. ! ! This routine calculates the stop test for the Orthomin ! iteration scheme. It returns a non-zero if the error ! estimate (the type of which is determined by ITOL) is ! less than the user specified tolerance TOL. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (ISSOMN-S, ISDOMN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, ! ORTHOMIN, SLAP, SPARSE, STOP TEST !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) ! REAL P(N,0:NSAVE), AP(N,0:NSAVE), EMAP(N,0:NSAVE) ! REAL DZ(N), CSAV(NSAVE), RWORK(USER DEFINED), AK ! REAL BNRM, SOLNRM ! EXTERNAL MSOLVE ! ! if ( ISSOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, ! $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, ! $ EMAP, DZ, CSAV, RWORK, IWORK, AK, BNRM, SOLNRM) ! $ /= 0 ) THEN ITERATION CONVERGED ! ! *Arguments: ! N :IN Integer. ! Order of the matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :IN Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description" ! in the SSDOMN or SSLUOM prologue. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a real array that can ! be used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize against. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :IN Real. ! Convergence criterion, as described above. ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :IN Integer. ! Current iteration count. (Must be zero on first call.) ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Error flag. IERR is set to 3 if ITOL is not one of the ! acceptable values, see above. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :IN Real R(N). ! The residual R = B-AX. ! Z :WORK Real Z(N). ! P :IN Real P(N,0:NSAVE). ! Workspace used to hold the conjugate direction vector(s). ! AP :IN Real AP(N,0:NSAVE). ! Workspace used to hold the matrix A times the P vector(s). ! EMAP :IN Real EMAP(N,0:NSAVE). ! Workspace used to hold M-inv times the AP vector(s). ! DZ :WORK Real DZ(N). ! Workspace. ! CSAV :DUMMY Real CSAV(NSAVE) ! Reserved for future use. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used for workspace in MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE. ! AK :IN Real. ! Current iterate Orthomin iteration parameter. ! BNRM :OUT Real. ! Current solution B-norm, if ITOL = 1 or 2. ! SOLNRM :OUT Real. ! True solution norm, if ITOL = 11. ! ! *Function Return Values: ! 0 : Error estimate (determined by ITOL) is *NOT* less than the ! specified tolerance, TOL. The iteration must continue. ! 1 : Error estimate (determined by ITOL) is less than the ! specified tolerance, TOL. The iteration can be considered ! complete. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SOMN, SSDOMN, SSLUOM !***ROUTINES CALLED R1MACH, SNRM2 !***COMMON BLOCKS SSLBLK !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891003 Removed C***REFER TO line, per MKS. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to SOMN. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920930 Corrected to not print AK when ITER=0. (FNF) ! 921026 Changed 1.0E10 to R1MACH(2). (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE ISSOMN ! .. Scalar Arguments .. REAL AK, BNRM, ERR, SOLNRM, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT, NSAVE ! .. Array Arguments .. REAL A(NELT), AP(N,0:NSAVE), B(N), CSAV(NSAVE), DZ(N), & EMAP(N,0:NSAVE), P(N,0:NSAVE), R(N), RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Arrays in Common .. REAL SOLN(1) ! .. Local Scalars .. INTEGER I ! .. External Functions .. REAL R1MACH, SNRM2 EXTERNAL R1MACH, SNRM2 ! .. Common blocks .. COMMON /SSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT ISSOMN ISSOMN = 0 ! if ( ITOL == 1 ) THEN ! err = ||Residual||/||RightHandSide|| (2-Norms). if ( ITER == 0) BNRM = SNRM2(N, B, 1) ERR = SNRM2(N, R, 1)/BNRM ELSE if ( ITOL == 2 ) THEN ! -1 -1 ! err = ||M Residual||/||M RightHandSide|| (2-Norms). if ( ITER == 0) THEN call MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) BNRM = SNRM2(N, DZ, 1) ENDIF ERR = SNRM2(N, Z, 1)/BNRM ELSE if ( ITOL == 11 ) THEN ! err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). if ( ITER == 0) SOLNRM = SNRM2(N, SOLN, 1) DO 10 I = 1, N DZ(I) = X(I) - SOLN(I) 10 CONTINUE ERR = SNRM2(N, DZ, 1)/SOLNRM ELSE ! ! If we get here ITOL is not one of the acceptable values. ERR = R1MACH(2) IERR = 3 end if ! if ( IUNIT /= 0) THEN if ( ITER == 0 ) THEN WRITE(IUNIT,1000) NSAVE, N, ITOL WRITE(IUNIT,1010) ITER, ERR ELSE WRITE(IUNIT,1010) ITER, ERR, AK ENDIF end if if ( ERR <= TOL) ISSOMN = 1 ! return 1000 FORMAT(' Preconditioned Orthomin(',I3,') for ', & 'N, ITOL = ',I5, I5, & /' ITER',' Error Estimate',' Alpha') 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7) !------------- LAST LINE OF ISSOMN FOLLOWS ---------------------------- end subroutine ISWAP (N, IX, INCX, IY, INCY) ! !! ISWAP interchanges two vectors. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A5 !***TYPE INTEGER (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) !***KEYWORDS BLAS, INTERCHANGE, LINEAR ALGEBRA, VECTOR !***AUTHOR Vandevender, W. H., (SNLA) !***DESCRIPTION ! ! Extended B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! IX integer vector with N elements ! INCX storage spacing between elements of IX ! IY integer vector with N elements ! INCY storage spacing between elements of IY ! ! --Output-- ! IX input vector IY (unchanged if N <= 0) ! IY input vector IX (unchanged if N <= 0) ! ! Interchange integer IX and integer IY. ! For I = 0 to N-1, interchange IX(LX+I*INCX) and IY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 850601 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ISWAP INTEGER IX(*), IY(*), ITEMP1, ITEMP2, ITEMP3 !***FIRST EXECUTABLE STATEMENT ISWAP if (N <= 0) RETURN if (INCX /= INCY) go to 5 if (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IIX = 1 IIY = 1 if (INCX < 0) IIX = (1-N)*INCX + 1 if (INCY < 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 ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 3. ! 20 M = MOD(N,3) if (M == 0) go to 40 DO 30 I = 1,M ITEMP1 = IX(I) IX(I) = IY(I) IY(I) = ITEMP1 30 CONTINUE if (N < 3) RETURN 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 ! ! Code for equal, positive, non-unit increments. ! 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 IVOUT (N, IX, IFMT, IDIGIT) ! !! IVOUT prints an integer vector. ! !***LIBRARY SLATEC !***TYPE INTEGER (IVOUT-I) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! INTEGER VECTOR OUTPUT ROUTINE. ! ! INPUT.. ! ! N,IX(*) PRINT THE INTEGER ARRAY IX(I),I=1,...,N, ON OUTPUT ! UNIT LOUT. THE HEADING IN THE FORTRAN FORMAT ! STATEMENT IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST ! STEP. THE COMPONENTS IX(I) ARE INDEXED, ON OUTPUT, ! IN A PLEASANT FORMAT. ! IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON OUTPUT ! UNIT LOUT WITH THE VARIABLE FORMAT FORTRAN STATEMENT ! WRITE(LOUT,IFMT) ! IDIGIT PRINT UP TO ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. ! THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10 OR 14 ! WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF ! PLACES. if IDIGIT < 0, 72 PRINTING COLUMNS ARE UTILIZED ! TO WRITE EACH LINE OF OUTPUT OF THE ARRAY IX(*). (THIS ! CAN BE USED ON MOST TIME-SHARING TERMINALS). IF ! IDIGIT >= 0, 133 PRINTING COLUMNS ARE UTILIZED. (THIS CAN ! BE USED ON MOST LINE PRINTERS). ! ! EXAMPLE.. ! ! PRINT AN ARRAY CALLED (COSTS OF PURCHASES) OF LENGTH 100 SHOWING ! 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING ! SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. ! ! DIMENSION ICOSTS(100) ! N = 100 ! IDIGIT = -6 ! call IVOUT(N,ICOSTS,'(''1COSTS OF PURCHASES'')',IDIGIT) ! !***SEE ALSO SPLP !***ROUTINES CALLED I1MACH !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 910403 Updated AUTHOR section. (WRB) !***END PROLOGUE IVOUT DIMENSION IX(*) CHARACTER IFMT*(*) ! ! GET THE UNIT NUMBER WHERE OUTPUT WILL BE WRITTEN. !***FIRST EXECUTABLE STATEMENT IVOUT J=2 LOUT=I1MACH(J) WRITE(LOUT,IFMT) if ( N <= 0) RETURN NDIGIT = IDIGIT if ( IDIGIT == 0) NDIGIT = 4 if ( IDIGIT >= 0) go to 80 ! NDIGIT = -IDIGIT if ( NDIGIT > 4) go to 20 ! DO 10 K1=1,N,10 K2 = MIN(N,K1+9) WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) 10 CONTINUE return ! 20 CONTINUE if ( NDIGIT > 6) go to 40 ! DO 30 K1=1,N,7 K2 = MIN(N,K1+6) WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) 30 CONTINUE return ! 40 CONTINUE if ( NDIGIT > 10) go to 60 ! DO 50 K1=1,N,5 K2=MIN(N,K1+4) WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) 50 CONTINUE return ! 60 CONTINUE DO 70 K1=1,N,3 K2 = MIN(N,K1+2) WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) 70 CONTINUE return ! 80 CONTINUE if ( NDIGIT > 4) go to 100 ! DO 90 K1=1,N,20 K2 = MIN(N,K1+19) WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) 90 CONTINUE return ! 100 CONTINUE if ( NDIGIT > 6) go to 120 ! DO 110 K1=1,N,15 K2 = MIN(N,K1+14) WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) 110 CONTINUE return ! 120 CONTINUE if ( NDIGIT > 10) go to 140 ! DO 130 K1=1,N,10 K2 = MIN(N,K1+9) WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) 130 CONTINUE return ! 140 CONTINUE DO 150 K1=1,N,7 K2 = MIN(N,K1+6) WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) 150 CONTINUE return 1000 FORMAT(1X,I4,' - ',I4,20(1X,I5)) 1001 FORMAT(1X,I4,' - ',I4,15(1X,I7)) 1002 FORMAT(1X,I4,' - ',I4,10(1X,I11)) 1003 FORMAT(1X,I4,' - ',I4,7(1X,I15)) end function J4SAVE (IWHICH, IVALUE, ISET) ! !! J4SAVE saves or recalls global variables needed by error handling routines. ! !***LIBRARY SLATEC (XERROR) !***TYPE INTEGER (J4SAVE-I) !***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! J4SAVE saves and recalls several global variables needed ! by the library error handling routines. ! ! Description of Parameters ! --Input-- ! IWHICH - Index of item desired. ! = 1 Refers to current error number. ! = 2 Refers to current error control flag. ! = 3 Refers to current unit number to which error ! messages are to be sent. (0 means use standard.) ! = 4 Refers to the maximum number of times any ! message is to be printed (as set by XERMAX). ! = 5 Refers to the total number of units to which ! each error message is to be written. ! = 6 Refers to the 2nd unit for error messages ! = 7 Refers to the 3rd unit for error messages ! = 8 Refers to the 4th unit for error messages ! = 9 Refers to the 5th unit for error messages ! IVALUE - The value to be set for the IWHICH-th parameter, ! if ISET is .TRUE. . ! ISET - If ISET=.TRUE., the IWHICH-th parameter will BE ! given the value, IVALUE. If ISET=.FALSE., the ! IWHICH-th parameter will be unchanged, and IVALUE ! is a dummy parameter. ! --Output-- ! The (old) value of the IWHICH-th parameter will be returned ! in the function value, J4SAVE. ! !***SEE ALSO XERMSG !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900205 Minor modifications to prologue. (WRB) ! 900402 Added TYPE section. (WRB) ! 910411 Added KEYWORDS section. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE J4SAVE LOGICAL ISET INTEGER IPARAM(9) SAVE IPARAM DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ DATA IPARAM(5)/1/ DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ !***FIRST EXECUTABLE STATEMENT J4SAVE J4SAVE = IPARAM(IWHICH) if (ISET) IPARAM(IWHICH) = IVALUE return end subroutine JAIRY (X, RX, C, AI, DAI) ! !! JAIRY is subsidiary to BESJ and BESY. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (JAIRY-S, DJAIRY-D) !***AUTHOR Amos, D. E., (SNLA) ! Daniel, S. L., (SNLA) ! Weston, M. K., (SNLA) !***DESCRIPTION ! ! JAIRY computes the Airy function AI(X) ! and its derivative DAI(X) for ASYJY ! ! INPUT ! ! X - Argument, computed by ASYJY, X unrestricted ! RX - RX=SQRT(ABS(X)), computed by ASYJY ! C - C=2.*(ABS(X)**1.5)/3., computed by ASYJY ! ! OUTPUT ! ! AI - Value of function AI(X) ! DAI - Value of the derivative DAI(X) ! !***SEE ALSO BESJ, BESY !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE JAIRY ! INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4, M4D, N1, N1D, N2, & N2D, N3, N3D, N4, N4D REAL A, AI, AJN, AJP, AK1, AK2, AK3, B, C, CCV, CON2, CON3, & CON4, CON5, CV, DA, DAI, DAJN, DAJP, DAK1, DAK2, DAK3, DB, EC, & E1, E2, FPI12, F1, F2, RTRX, RX, SCV, T, TEMP1, TEMP2, TT, X DIMENSION AJP(19), AJN(19), A(15), B(15) DIMENSION AK1(14), AK2(23), AK3(14) DIMENSION DAJP(19), DAJN(19), DA(15), DB(15) DIMENSION DAK1(14), DAK2(24), DAK3(14) SAVE N1, N2, N3, N4, M1, M2, M3, M4, FPI12, CON2, & CON3, CON4, CON5,AK1, AK2, AK3, AJP, AJN, A, B, & N1D, N2D, N3D, N4D, M1D, M2D, M3D, M4D, & DAK1, DAK2, DAK3, DAJP, DAJN, DA, DB DATA N1,N2,N3,N4/14,23,19,15/ DATA M1,M2,M3,M4/12,21,17,13/ DATA FPI12,CON2,CON3,CON4,CON5/ & 1.30899693899575E+00, 5.03154716196777E+00, 3.80004589867293E-01, & 8.33333333333333E-01, 8.66025403784439E-01/ DATA AK1(1), AK1(2), AK1(3), AK1(4), AK1(5), AK1(6), AK1(7), & AK1(8), AK1(9), AK1(10),AK1(11),AK1(12),AK1(13), & AK1(14) / 2.20423090987793E-01,-1.25290242787700E-01, & 1.03881163359194E-02, 8.22844152006343E-04,-2.34614345891226E-04, & 1.63824280172116E-05, 3.06902589573189E-07,-1.29621999359332E-07, & 8.22908158823668E-09, 1.53963968623298E-11,-3.39165465615682E-11, & 2.03253257423626E-12,-1.10679546097884E-14,-5.16169497785080E-15/ DATA AK2(1), AK2(2), AK2(3), AK2(4), AK2(5), AK2(6), AK2(7), & AK2(8), AK2(9), AK2(10),AK2(11),AK2(12),AK2(13),AK2(14), & AK2(15),AK2(16),AK2(17),AK2(18),AK2(19),AK2(20),AK2(21), & AK2(22),AK2(23) / 2.74366150869598E-01, 5.39790969736903E-03, & -1.57339220621190E-03, 4.27427528248750E-04,-1.12124917399925E-04, & 2.88763171318904E-05,-7.36804225370554E-06, 1.87290209741024E-06, & -4.75892793962291E-07, 1.21130416955909E-07,-3.09245374270614E-08, & 7.92454705282654E-09,-2.03902447167914E-09, 5.26863056595742E-10, & -1.36704767639569E-10, 3.56141039013708E-11,-9.31388296548430E-12, & 2.44464450473635E-12,-6.43840261990955E-13, 1.70106030559349E-13, & -4.50760104503281E-14, 1.19774799164811E-14,-3.19077040865066E-15/ DATA AK3(1), AK3(2), AK3(3), AK3(4), AK3(5), AK3(6), AK3(7), & AK3(8), AK3(9), AK3(10),AK3(11),AK3(12),AK3(13), & AK3(14) / 2.80271447340791E-01,-1.78127042844379E-03, & 4.03422579628999E-05,-1.63249965269003E-06, 9.21181482476768E-08, & -6.52294330229155E-09, 5.47138404576546E-10,-5.24408251800260E-11, & 5.60477904117209E-12,-6.56375244639313E-13, 8.31285761966247E-14, & -1.12705134691063E-14, 1.62267976598129E-15,-2.46480324312426E-16/ DATA AJP(1), AJP(2), AJP(3), AJP(4), AJP(5), AJP(6), AJP(7), & AJP(8), AJP(9), AJP(10),AJP(11),AJP(12),AJP(13),AJP(14), & AJP(15),AJP(16),AJP(17),AJP(18), & AJP(19) / 7.78952966437581E-02,-1.84356363456801E-01, & 3.01412605216174E-02, 3.05342724277608E-02,-4.95424702513079E-03, & -1.72749552563952E-03, 2.43137637839190E-04, 5.04564777517082E-05, & -6.16316582695208E-06,-9.03986745510768E-07, 9.70243778355884E-08, & 1.09639453305205E-08,-1.04716330588766E-09,-9.60359441344646E-11, & 8.25358789454134E-12, 6.36123439018768E-13,-4.96629614116015E-14, & -3.29810288929615E-15, 2.35798252031104E-16/ DATA AJN(1), AJN(2), AJN(3), AJN(4), AJN(5), AJN(6), AJN(7), & AJN(8), AJN(9), AJN(10),AJN(11),AJN(12),AJN(13),AJN(14), & AJN(15),AJN(16),AJN(17),AJN(18), & AJN(19) / 3.80497887617242E-02,-2.45319541845546E-01, & 1.65820623702696E-01, 7.49330045818789E-02,-2.63476288106641E-02, & -5.92535597304981E-03, 1.44744409589804E-03, 2.18311831322215E-04, & -4.10662077680304E-05,-4.66874994171766E-06, 7.15218807277160E-07, & 6.52964770854633E-08,-8.44284027565946E-09,-6.44186158976978E-10, & 7.20802286505285E-11, 4.72465431717846E-12,-4.66022632547045E-13, & -2.67762710389189E-14, 2.36161316570019E-15/ DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), & A(8), A(9), A(10), A(11), A(12), A(13), A(14), & A(15) / 4.90275424742791E-01, 1.57647277946204E-03, & -9.66195963140306E-05, 1.35916080268815E-07, 2.98157342654859E-07, & -1.86824767559979E-08,-1.03685737667141E-09, 3.28660818434328E-10, & -2.57091410632780E-11,-2.32357655300677E-12, 9.57523279048255E-13, & -1.20340828049719E-13,-2.90907716770715E-15, 4.55656454580149E-15, & -9.99003874810259E-16/ 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) / 2.78593552803079E-01,-3.52915691882584E-03, & -2.31149677384994E-05, 4.71317842263560E-06,-1.12415907931333E-07, & -2.00100301184339E-08, 2.60948075302193E-09,-3.55098136101216E-11, & -3.50849978423875E-11, 5.83007187954202E-12,-2.04644828753326E-13, & -1.10529179476742E-13, 2.87724778038775E-14,-2.88205111009939E-15, & -3.32656311696166E-16/ DATA N1D,N2D,N3D,N4D/14,24,19,15/ DATA M1D,M2D,M3D,M4D/12,22,17,13/ DATA DAK1(1), DAK1(2), DAK1(3), DAK1(4), DAK1(5), DAK1(6), & DAK1(7), DAK1(8), DAK1(9), DAK1(10),DAK1(11),DAK1(12), & DAK1(13),DAK1(14)/ 2.04567842307887E-01,-6.61322739905664E-02, & -8.49845800989287E-03, 3.12183491556289E-03,-2.70016489829432E-04, & -6.35636298679387E-06, 3.02397712409509E-06,-2.18311195330088E-07, & -5.36194289332826E-10, 1.13098035622310E-09,-7.43023834629073E-11, & 4.28804170826891E-13, 2.23810925754539E-13,-1.39140135641182E-14/ DATA DAK2(1), DAK2(2), DAK2(3), DAK2(4), DAK2(5), DAK2(6), & DAK2(7), DAK2(8), DAK2(9), DAK2(10),DAK2(11),DAK2(12), & DAK2(13),DAK2(14),DAK2(15),DAK2(16),DAK2(17),DAK2(18), & DAK2(19),DAK2(20),DAK2(21),DAK2(22),DAK2(23), & DAK2(24) / 2.93332343883230E-01,-8.06196784743112E-03, & 2.42540172333140E-03,-6.82297548850235E-04, 1.85786427751181E-04, & -4.97457447684059E-05, 1.32090681239497E-05,-3.49528240444943E-06, & 9.24362451078835E-07,-2.44732671521867E-07, 6.49307837648910E-08, & -1.72717621501538E-08, 4.60725763604656E-09,-1.23249055291550E-09, & 3.30620409488102E-10,-8.89252099772401E-11, 2.39773319878298E-11, & -6.48013921153450E-12, 1.75510132023731E-12,-4.76303829833637E-13, & 1.29498241100810E-13,-3.52679622210430E-14, 9.62005151585923E-15, & -2.62786914342292E-15/ DATA DAK3(1), DAK3(2), DAK3(3), DAK3(4), DAK3(5), DAK3(6), & DAK3(7), DAK3(8), DAK3(9), DAK3(10),DAK3(11),DAK3(12), & DAK3(13),DAK3(14)/ 2.84675828811349E-01, 2.53073072619080E-03, & -4.83481130337976E-05, 1.84907283946343E-06,-1.01418491178576E-07, & 7.05925634457153E-09,-5.85325291400382E-10, 5.56357688831339E-11, & -5.90889094779500E-12, 6.88574353784436E-13,-8.68588256452194E-14, & 1.17374762617213E-14,-1.68523146510923E-15, 2.55374773097056E-16/ DATA DAJP(1), DAJP(2), DAJP(3), DAJP(4), DAJP(5), DAJP(6), & DAJP(7), DAJP(8), DAJP(9), DAJP(10),DAJP(11),DAJP(12), & DAJP(13),DAJP(14),DAJP(15),DAJP(16),DAJP(17),DAJP(18), & DAJP(19) / 6.53219131311457E-02,-1.20262933688823E-01, & 9.78010236263823E-03, 1.67948429230505E-02,-1.97146140182132E-03, & -8.45560295098867E-04, 9.42889620701976E-05, 2.25827860945475E-05, & -2.29067870915987E-06,-3.76343991136919E-07, 3.45663933559565E-08, & 4.29611332003007E-09,-3.58673691214989E-10,-3.57245881361895E-11, & 2.72696091066336E-12, 2.26120653095771E-13,-1.58763205238303E-14, & -1.12604374485125E-15, 7.31327529515367E-17/ DATA DAJN(1), DAJN(2), DAJN(3), DAJN(4), DAJN(5), DAJN(6), & DAJN(7), DAJN(8), DAJN(9), DAJN(10),DAJN(11),DAJN(12), & DAJN(13),DAJN(14),DAJN(15),DAJN(16),DAJN(17),DAJN(18), & DAJN(19) / 1.08594539632967E-02, 8.53313194857091E-02, & -3.15277068113058E-01,-8.78420725294257E-02, 5.53251906976048E-02, & 9.41674060503241E-03,-3.32187026018996E-03,-4.11157343156826E-04, & 1.01297326891346E-04, 9.87633682208396E-06,-1.87312969812393E-06, & -1.50798500131468E-07, 2.32687669525394E-08, 1.59599917419225E-09, & -2.07665922668385E-10,-1.24103350500302E-11, 1.39631765331043E-12, & 7.39400971155740E-14,-7.32887475627500E-15/ DATA DA(1), DA(2), DA(3), DA(4), DA(5), DA(6), DA(7), & DA(8), DA(9), DA(10), DA(11), DA(12), DA(13), DA(14), & DA(15) / 4.91627321104601E-01, 3.11164930427489E-03, & 8.23140762854081E-05,-4.61769776172142E-06,-6.13158880534626E-08, & 2.87295804656520E-08,-1.81959715372117E-09,-1.44752826642035E-10, & 4.53724043420422E-11,-3.99655065847223E-12,-3.24089119830323E-13, & 1.62098952568741E-13,-2.40765247974057E-14, 1.69384811284491E-16, & 8.17900786477396E-16/ DATA DB(1), DB(2), DB(3), DB(4), DB(5), DB(6), DB(7), & DB(8), DB(9), DB(10), DB(11), DB(12), DB(13), DB(14), & DB(15) /-2.77571356944231E-01, 4.44212833419920E-03, & -8.42328522190089E-05,-2.58040318418710E-06, 3.42389720217621E-07, & -6.24286894709776E-09,-2.36377836844577E-09, 3.16991042656673E-10, & -4.40995691658191E-12,-5.18674221093575E-12, 9.64874015137022E-13, & -4.90190576608710E-14,-1.77253430678112E-14, 5.55950610442662E-15, & -7.11793337579530E-16/ !***FIRST EXECUTABLE STATEMENT JAIRY if (X < 0.0E0) go to 90 if (C > 5.0E0) go to 60 if (X > 1.20E0) go to 30 T = (X+X-1.2E0)*CON4 TT = T + T J = N1 F1 = AK1(J) F2 = 0.0E0 DO 10 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + AK1(J) F2 = TEMP1 10 CONTINUE AI = T*F1 - F2 + AK1(1) ! J = N1D F1 = DAK1(J) F2 = 0.0E0 DO 20 I=1,M1D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DAK1(J) F2 = TEMP1 20 CONTINUE DAI = -(T*F1-F2+DAK1(1)) return ! 30 CONTINUE T = (X+X-CON2)*CON3 TT = T + T J = N2 F1 = AK2(J) F2 = 0.0E0 DO 40 I=1,M2 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + AK2(J) F2 = TEMP1 40 CONTINUE RTRX = SQRT(RX) EC = EXP(-C) AI = EC*(T*F1-F2+AK2(1))/RTRX J = N2D F1 = DAK2(J) F2 = 0.0E0 DO 50 I=1,M2D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DAK2(J) F2 = TEMP1 50 CONTINUE DAI = -EC*(T*F1-F2+DAK2(1))*RTRX return ! 60 CONTINUE T = 10.0E0/C - 1.0E0 TT = T + T J = N1 F1 = AK3(J) F2 = 0.0E0 DO 70 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + AK3(J) F2 = TEMP1 70 CONTINUE RTRX = SQRT(RX) EC = EXP(-C) AI = EC*(T*F1-F2+AK3(1))/RTRX J = N1D F1 = DAK3(J) F2 = 0.0E0 DO 80 I=1,M1D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DAK3(J) F2 = TEMP1 80 CONTINUE DAI = -RTRX*EC*(T*F1-F2+DAK3(1)) return ! 90 CONTINUE if (C > 5.0E0) go to 120 T = 0.4E0*C - 1.0E0 TT = T + T J = N3 F1 = AJP(J) E1 = AJN(J) F2 = 0.0E0 E2 = 0.0E0 DO 100 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 100 CONTINUE AI = (T*E1-E2+AJN(1)) - X*(T*F1-F2+AJP(1)) J = N3D F1 = DAJP(J) E1 = DAJN(J) F2 = 0.0E0 E2 = 0.0E0 DO 110 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 110 CONTINUE DAI = X*X*(T*F1-F2+DAJP(1)) + (T*E1-E2+DAJN(1)) return ! 120 CONTINUE T = 10.0E0/C - 1.0E0 TT = T + T J = N4 F1 = A(J) E1 = B(J) F2 = 0.0E0 E2 = 0.0E0 DO 130 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 130 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.0E0 E2 = 0.0E0 DO 140 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 140 CONTINUE TEMP1 = T*F1 - F2 + DA(1) TEMP2 = T*E1 - E2 + DB(1) E1 = CCV*CON5 + 0.5E0*SCV E2 = SCV*CON5 - 0.5E0*CCV DAI = (TEMP1*E1-TEMP2*E2)*RTRX return end subroutine LA05AD (A, IND, NZ, IA, N, IP, IW, W, G, U) ! !! LA05AD is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (LA05AS-S, LA05AD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM ! FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE ! CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING ! THE FINAL LETTER =D= IN THE NAMES USED HERE. ! REVISIONS MADE BY R J HANSON, SNLA, AUGUST, 1979. ! REVISED SEP. 13, 1979. ! ! ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES ! IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL ! SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN ! THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES ! DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. ! ! IP(I,1),IP(I,2) POINT TO THE START OF ROW/COL I. ! IW(I,1),IW(I,2) HOLD THE NUMBER OF NON-ZEROS IN ROW/COL I. ! DURING THE MAIN BODY OF THIS SUBROUTINE THE VECTORS IW(.,3),IW(.,5), ! IW(.,7) ARE USED TO HOLD DOUBLY LINKED LISTS OF ROWS THAT HAVE ! NOT BEEN PIVOTAL AND HAVE EQUAL NUMBERS OF NON-ZEROS. ! IW(.,4),IW(.,6),IW(.,8) HOLD SIMILAR LISTS FOR THE COLUMNS. ! IW(I,3),IW(I,4) HOLD FIRST ROW/COLUMN TO HAVE I NON-ZEROS ! OR ZERO if THERE ARE NONE. ! IW(I,5), IW(I,6) HOLD ROW/COL NUMBER OF ROW/COL PRIOR TO ROW/COL I ! IN ITS LIST, OR ZERO if NONE. ! IW(I,7), IW(I,8) HOLD ROW/COL NUMBER OF ROW/COL AFTER ROW/COL I ! IN ITS LIST, OR ZERO if NONE. ! FOR ROWS/COLS THAT HAVE BEEN PIVOTAL IW(I,5),IW(I,6) HOLD NEGATION OF ! POSITION OF ROW/COL I IN THE PIVOTAL ORDERING. ! !***SEE ALSO DSPLP !***ROUTINES CALLED D1MACH, LA05ED, MC20AD, XERMSG, XSETUN !***COMMON BLOCKS LA05DD !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Added D1MACH to list of DOUBLE PRECISION variables. ! 890605 Corrected references to XERRWV. (WRB) ! (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900402 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE LA05AD INTEGER IP(N,2) INTEGER IND(IA,2), IW(N,8) DOUBLE PRECISION A(*), AMAX, AU, AM, D1MACH, EPS, G, U, SMALL, & W(*) LOGICAL FIRST CHARACTER*8 XERN0, XERN1, XERN2 ! COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL ! EPS IS THE RELATIVE ACCURACY OF FLOATING-POINT COMPUTATION SAVE EPS, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT LA05AD if (FIRST) THEN EPS = 2.0D0 * D1MACH(4) end if FIRST = .FALSE. ! ! SET THE OUTPUT UNIT NUMBER FOR THE ERROR PROCESSOR. ! THE USAGE OF THIS ERROR PROCESSOR IS DOCUMENTED IN THE ! SANDIA LABS. TECH. REPT. SAND78-1189, BY R E JONES. call XSETUN(LP) if (U > 1.0D0) U = 1.0D0 if (U < EPS) U = EPS if (N < 1) go to 670 G = 0. DO 50 I=1,N W(I) = 0. DO 40 J=1,5 IW(I,J) = 0 40 CONTINUE 50 CONTINUE ! ! FLUSH OUT SMALL ENTRIES, COUNT ELEMENTS IN ROWS AND COLUMNS L = 1 LENU = NZ DO 80 IDUMMY=1,NZ if (L > LENU) go to 90 DO 60 K=L,LENU if (ABS(A(K)) <= SMALL) go to 70 I = IND(K,1) J = IND(K,2) G = MAX(ABS(A(K)),G) if (I < 1 .OR. I > N) go to 680 if (J < 1 .OR. J > N) go to 680 IW(I,1) = IW(I,1) + 1 IW(J,2) = IW(J,2) + 1 60 CONTINUE go to 90 70 L = K A(L) = A(LENU) IND(L,1) = IND(LENU,1) IND(L,2) = IND(LENU,2) LENU = LENU - 1 80 CONTINUE ! 90 LENL = 0 LROW = LENU LCOL = LROW ! MCP IS THE MAXIMUM NUMBER OF COMPRESSES PERMITTED BEFORE AN ! ERROR RETURN RESULTS. MCP = MAX(N/10,20) NCP = 0 ! CHECK FOR NULL ROW OR COLUMN AND INITIALIZE IP(I,2) TO POINT ! JUST BEYOND WHERE THE LAST COMPONENT OF COLUMN I OF A WILL ! BE STORED. K = 1 DO 110 IR=1,N K = K + IW(IR,2) IP(IR,2) = K DO 100 L=1,2 if (IW(IR,L) <= 0) go to 700 100 CONTINUE 110 CONTINUE ! REORDER BY ROWS ! CHECK FOR DOUBLE ENTRIES WHILE USING THE NEWLY CONSTRUCTED ! ROW FILE TO CONSTRUCT THE COLUMN FILE. NOTE THAT BY PUTTING ! THE ENTRIES IN BACKWARDS AND DECREASING IP(J,2) EACH TIME IT ! IS USED WE AUTOMATICALLY LEAVE IT POINTING TO THE FIRST ELEMENT. call MC20AD(N, LENU, A, IND(1,2), IP, IND(1,1), 0) KL = LENU DO 130 II=1,N IR = N + 1 - II KP = IP(IR,1) DO 120 K=KP,KL J = IND(K,2) if (IW(J,5) == IR) go to 660 IW(J,5) = IR KR = IP(J,2) - 1 IP(J,2) = KR IND(KR,1) = IR 120 CONTINUE KL = KP - 1 130 CONTINUE ! ! SET UP LINKED LISTS OF ROWS AND COLS WITH EQUAL NUMBERS OF NON-ZEROS. DO 150 L=1,2 DO 140 I=1,N NZ = IW(I,L) IN = IW(NZ,L+2) IW(NZ,L+2) = I IW(I,L+6) = IN IW(I,L+4) = 0 if (IN /= 0) IW(IN,L+4) = I 140 CONTINUE 150 CONTINUE ! ! ! START OF MAIN ELIMINATION LOOP. DO 590 IPV=1,N ! FIND PIVOT. JCOST IS MARKOWITZ COST OF CHEAPEST PIVOT FOUND SO FAR, ! WHICH IS IN ROW IPP AND COLUMN JP. JCOST = N*N ! LOOP ON LENGTH OF COLUMN TO BE SEARCHED DO 240 NZ=1,N if (JCOST <= (NZ-1)**2) go to 250 J = IW(NZ,4) ! SEARCH COLUMNS WITH NZ NON-ZEROS. DO 190 IDUMMY=1,N if (J <= 0) go to 200 KP = IP(J,2) KL = KP + IW(J,2) - 1 DO 180 K=KP,KL I = IND(K,1) KCOST = (NZ-1)*(IW(I,1)-1) if (KCOST >= JCOST) go to 180 if (NZ == 1) go to 170 ! FIND LARGEST ELEMENT IN ROW OF POTENTIAL PIVOT. AMAX = 0. K1 = IP(I,1) K2 = IW(I,1) + K1 - 1 DO 160 KK=K1,K2 AMAX = MAX(AMAX,ABS(A(KK))) if (IND(KK,2) == J) KJ = KK 160 CONTINUE ! PERFORM STABILITY TEST. if (ABS(A(KJ)) < AMAX*U) go to 180 170 JCOST = KCOST IPP = I JP = J if (JCOST <= (NZ-1)**2) go to 250 180 CONTINUE J = IW(J,8) 190 CONTINUE ! SEARCH ROWS WITH NZ NON-ZEROS. 200 I = IW(NZ,3) DO 230 IDUMMY=1,N if (I <= 0) go to 240 AMAX = 0. KP = IP(I,1) KL = KP + IW(I,1) - 1 ! FIND LARGEST ELEMENT IN THE ROW DO 210 K=KP,KL AMAX = MAX(ABS(A(K)),AMAX) 210 CONTINUE AU = AMAX*U DO 220 K=KP,KL ! PERFORM STABILITY TEST. if (ABS(A(K)) < AU) go to 220 J = IND(K,2) KCOST = (NZ-1)*(IW(J,2)-1) if (KCOST >= JCOST) go to 220 JCOST = KCOST IPP = I JP = J if (JCOST <= (NZ-1)**2) go to 250 220 CONTINUE I = IW(I,7) 230 CONTINUE 240 CONTINUE ! ! PIVOT FOUND. ! REMOVE ROWS AND COLUMNS INVOLVED IN ELIMINATION FROM ORDERING VECTORS. 250 KP = IP(JP,2) KL = IW(JP,2) + KP - 1 DO 290 L=1,2 DO 280 K=KP,KL I = IND(K,L) IL = IW(I,L+4) IN = IW(I,L+6) if (IL == 0) go to 260 IW(IL,L+6) = IN go to 270 260 NZ = IW(I,L) IW(NZ,L+2) = IN 270 if (IN > 0) IW(IN,L+4) = IL 280 CONTINUE KP = IP(IPP,1) KL = KP + IW(IPP,1) - 1 290 CONTINUE ! STORE PIVOT IW(IPP,5) = -IPV IW(JP,6) = -IPV ! ELIMINATE PIVOTAL ROW FROM COLUMN FILE AND FIND PIVOT IN ROW FILE. DO 320 K=KP,KL J = IND(K,2) KPC = IP(J,2) IW(J,2) = IW(J,2) - 1 KLC = KPC + IW(J,2) DO 300 KC=KPC,KLC if (IPP == IND(KC,1)) go to 310 300 CONTINUE 310 IND(KC,1) = IND(KLC,1) IND(KLC,1) = 0 if (J == JP) KR = K 320 CONTINUE ! BRING PIVOT TO FRONT OF PIVOTAL ROW. AU = A(KR) A(KR) = A(KP) A(KP) = AU IND(KR,2) = IND(KP,2) IND(KP,2) = JP ! ! PERFORM ELIMINATION ITSELF, LOOPING ON NON-ZEROS IN PIVOT COLUMN. NZC = IW(JP,2) if (NZC == 0) go to 550 DO 540 NC=1,NZC KC = IP(JP,2) + NC - 1 IR = IND(KC,1) ! SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED. KR = IP(IR,1) KRL = KR + IW(IR,1) - 1 DO 330 KNP=KR,KRL if (JP == IND(KNP,2)) go to 340 330 CONTINUE ! BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW. 340 AM = A(KNP) A(KNP) = A(KR) A(KR) = AM IND(KNP,2) = IND(KR,2) IND(KR,2) = JP AM = -A(KR)/A(KP) ! COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW. if (LROW+IW(IR,1)+IW(IPP,1)+LENL <= IA) go to 350 if (NCP >= MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL > IA) GO & TO 710 call LA05ED(A, IND(1,2), IP, N, IW, IA, .TRUE.) KP = IP(IPP,1) KR = IP(IR,1) 350 KRL = KR + IW(IR,1) - 1 KQ = KP + 1 KPL = KP + IW(IPP,1) - 1 ! PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W. if (KQ > KPL) go to 370 DO 360 K=KQ,KPL J = IND(K,2) W(J) = A(K) 360 CONTINUE 370 IP(IR,1) = LROW + 1 ! ! TRANSFER MODIFIED ELEMENTS. IND(KR,2) = 0 KR = KR + 1 if (KR > KRL) go to 430 DO 420 KS=KR,KRL J = IND(KS,2) AU = A(KS) + AM*W(J) IND(KS,2) = 0 ! if ELEMENT IS VERY SMALL REMOVE IT FROM U. if (ABS(AU) <= SMALL) go to 380 G = MAX(G,ABS(AU)) LROW = LROW + 1 A(LROW) = AU IND(LROW,2) = J go to 410 380 LENU = LENU - 1 ! REMOVE ELEMENT FROM COL FILE. K = IP(J,2) KL = K + IW(J,2) - 1 IW(J,2) = KL - K DO 390 KK=K,KL if (IND(KK,1) == IR) go to 400 390 CONTINUE 400 IND(KK,1) = IND(KL,1) IND(KL,1) = 0 410 W(J) = 0. 420 CONTINUE ! ! SCAN PIVOT ROW FOR FILLS. 430 if (KQ > KPL) go to 520 DO 510 KS=KQ,KPL J = IND(KS,2) AU = AM*W(J) if (ABS(AU) <= SMALL) go to 500 LROW = LROW + 1 A(LROW) = AU IND(LROW,2) = J LENU = LENU + 1 ! ! CREATE FILL IN COLUMN FILE. NZ = IW(J,2) K = IP(J,2) KL = K + NZ - 1 if (NZ == 0) go to 460 ! if POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY. if (KL /= LCOL) go to 440 if (LCOL+LENL >= IA) go to 460 LCOL = LCOL + 1 go to 450 440 if (IND(KL+1,1) /= 0) go to 460 450 IND(KL+1,1) = IR go to 490 ! NEW ENTRY HAS TO BE CREATED. 460 if (LCOL+LENL+NZ+1 < IA) go to 470 ! COMPRESS COLUMN FILE if THERE IS NOT ROOM FOR NEW ENTRY. if (NCP >= MCP .OR. LENU+LENL+NZ+1 >= IA) go to 710 call LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) K = IP(J,2) KL = K + NZ - 1 ! TRANSFER OLD ENTRY INTO NEW. 470 IP(J,2) = LCOL + 1 if (KL < K) go to 485 DO 480 KK=K,KL LCOL = LCOL + 1 IND(LCOL,1) = IND(KK,1) IND(KK,1) = 0 480 CONTINUE 485 CONTINUE ! ADD NEW ELEMENT. LCOL = LCOL + 1 IND(LCOL,1) = IR 490 G = MAX(G,ABS(AU)) IW(J,2) = NZ + 1 500 W(J) = 0. 510 CONTINUE 520 IW(IR,1) = LROW + 1 - IP(IR,1) ! ! STORE MULTIPLIER if (LENL+LCOL+1 <= IA) go to 530 ! COMPRESS COL FILE if NECESSARY. if (NCP >= MCP) go to 710 call LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) 530 K = IA - LENL LENL = LENL + 1 A(K) = AM IND(K,1) = IPP IND(K,2) = IR LENU = LENU - 1 540 CONTINUE ! ! INSERT ROWS AND COLUMNS INVOLVED IN ELIMINATION IN LINKED LISTS ! OF EQUAL NUMBERS OF NON-ZEROS. 550 K1 = IP(JP,2) K2 = IW(JP,2) + K1 - 1 IW(JP,2) = 0 DO 580 L=1,2 if (K2 < K1) go to 570 DO 560 K=K1,K2 IR = IND(K,L) if (L == 1) IND(K,L) = 0 NZ = IW(IR,L) if (NZ <= 0) go to 720 IN = IW(NZ,L+2) IW(IR,L+6) = IN IW(IR,L+4) = 0 IW(NZ,L+2) = IR if (IN /= 0) IW(IN,L+4) = IR 560 CONTINUE 570 K1 = IP(IPP,1) + 1 K2 = IW(IPP,1) + K1 - 2 580 CONTINUE 590 CONTINUE ! ! RESET COLUMN FILE TO REFER TO U AND STORE ROW/COL NUMBERS IN ! PIVOTAL ORDER IN IW(.,3),IW(.,4) DO 600 I=1,N J = -IW(I,5) IW(J,3) = I J = -IW(I,6) IW(J,4) = I IW(I,2) = 0 600 CONTINUE DO 620 I=1,N KP = IP(I,1) KL = IW(I,1) + KP - 1 DO 610 K=KP,KL J = IND(K,2) IW(J,2) = IW(J,2) + 1 610 CONTINUE 620 CONTINUE K = 1 DO 630 I=1,N K = K + IW(I,2) IP(I,2) = K 630 CONTINUE LCOL = K - 1 DO 650 II=1,N I = IW(II,3) KP = IP(I,1) KL = IW(I,1) + KP - 1 DO 640 K=KP,KL J = IND(K,2) KN = IP(J,2) - 1 IP(J,2) = KN IND(KN,1) = I 640 CONTINUE 650 CONTINUE return ! ! THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS. ! 660 if (LP > 0) THEN WRITE (XERN1, '(I8)') IR WRITE (XERN2, '(I8)') J call XERMSG ('SLATEC', 'LA05AD', 'MORE THAN ONE MATRIX ' // & 'ENTRY. HERE ROW = ' // XERN1 // ' AND COL = ' // XERN2, & -4, 1) end if G = -4. return ! 670 if (LP > 0) call XERMSG ('SLATEC', 'LA05AD', & 'THE ORDER OF THE SYSTEM, N, IS NOT POSITIVE.', -1, 1) G = -1.0D0 return ! 680 if (LP > 0) THEN WRITE (XERN0, '(I8)') K WRITE (XERN1, '(I8)') I WRITE (XERN2, '(I8)') J call XERMSG ('SLATEC', 'LA05AD', 'ELEMENT K = ' // XERN0 // & ' IS OUT OF BOUNDS.$$HERE ROW = ' // XERN1 // & ' AND COL = ' // XERN2, -3, 1) end if G = -3. return ! 700 if (LP > 0) THEN WRITE (XERN1, '(I8)') L call XERMSG ('SLATEC', 'LA05AD', 'ROW OR COLUMN HAS NO ' // & 'ELEMENTS. HERE INDEX = ' // XERN1, -2, 1) end if G = -2. return ! 710 if (LP > 0) call XERMSG ('SLATEC', 'LA05AD', & 'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1) G = -7. return ! 720 IPV = IPV + 1 IW(IPV,1) = IR DO 730 I=1,N II = -IW(I,L+4) if (II > 0) IW(II,1) = I 730 CONTINUE ! if (LP > 0) THEN XERN1 = 'ROWS' if (L == 2) XERN1 = 'COLUMNS' call XERMSG ('SLATEC', 'LA05AD', 'DEPENDANT ' // XERN1, -5, 1) ! 740 WRITE (XERN1, '(I8)') IW(I,1) XERN2 = ' ' if (I+1 <= IPV) WRITE (XERN2, '(I8)') IW(I+1,1) call XERMSG ('SLATEC', 'LA05AD', & 'DEPENDENT VECTOR INDICES ARE ' // XERN1 // ' AND ' // & XERN2, -5, 1) I = I + 2 if (I <= IPV) go to 740 end if G = -5. return end subroutine LA05AS (A, IND, NZ, IA, N, IP, IW, W, G, U) ! !! LA05AS is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (LA05AS-S, LA05AD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM ! FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE ! CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING ! THE FINAL LETTER =S= IN THE NAMES USED HERE. ! REVISIONS MADE BY R J HANSON, SNLA, AUGUST, 1979. ! REVISED SEP. 13, 1979. ! ! ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES ! IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL ! SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN ! THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES ! SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. ! ! IP(I,1),IP(I,2) POINT TO THE START OF ROW/COL I. ! IW(I,1),IW(I,2) HOLD THE NUMBER OF NON-ZEROS IN ROW/COL I. ! DURING THE MAIN BODY OF THIS SUBROUTINE THE VECTORS IW(.,3),IW(.,5), ! IW(.,7) ARE USED TO HOLD DOUBLY LINKED LISTS OF ROWS THAT HAVE ! NOT BEEN PIVOTAL AND HAVE EQUAL NUMBERS OF NON-ZEROS. ! IW(.,4),IW(.,6),IW(.,8) HOLD SIMILAR LISTS FOR THE COLUMNS. ! IW(I,3),IW(I,4) HOLD FIRST ROW/COLUMN TO HAVE I NON-ZEROS ! OR ZERO if THERE ARE NONE. ! IW(I,5), IW(I,6) HOLD ROW/COL NUMBER OF ROW/COL PRIOR TO ROW/COL I ! IN ITS LIST, OR ZERO if NONE. ! IW(I,7), IW(I,8) HOLD ROW/COL NUMBER OF ROW/COL AFTER ROW/COL I ! IN ITS LIST, OR ZERO if NONE. ! FOR ROWS/COLS THAT HAVE BEEN PIVOTAL IW(I,5),IW(I,6) HOLD NEGATION OF ! POSITION OF ROW/COL I IN THE PIVOTAL ORDERING. ! !***SEE ALSO SPLP !***ROUTINES CALLED LA05ES, MC20AS, R1MACH, XERMSG, XSETUN !***COMMON BLOCKS LA05DS !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Corrected references to XERRWV. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900402 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE LA05AS INTEGER IP(N,2) INTEGER IND(IA,2), IW(N,8) REAL A(*), AMAX, AU, AM, G, U, SMALL, W(*) LOGICAL FIRST CHARACTER*8 XERN0, XERN1, XERN2 ! COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL ! EPS IS THE RELATIVE ACCURACY OF FLOATING-POINT COMPUTATION SAVE EPS, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT LA05AS if (FIRST) THEN EPS = 2.0E0 * R1MACH(4) end if FIRST = .FALSE. ! ! SET THE OUTPUT UNIT NUMBER FOR THE ERROR PROCESSOR. ! THE USAGE OF THIS ERROR PROCESSOR IS DOCUMENTED IN THE ! SANDIA LABS. TECH. REPT. SAND78-1189, BY R E JONES. call XSETUN(LP) if (U > 1.0E0) U = 1.0E0 if (U < EPS) U = EPS if (N < 1) go to 670 G = 0. DO 50 I=1,N W(I) = 0. DO 40 J=1,5 IW(I,J) = 0 40 CONTINUE 50 CONTINUE ! ! FLUSH OUT SMALL ENTRIES, COUNT ELEMENTS IN ROWS AND COLUMNS L = 1 LENU = NZ DO 80 IDUMMY=1,NZ if (L > LENU) go to 90 DO 60 K=L,LENU if (ABS(A(K)) <= SMALL) go to 70 I = IND(K,1) J = IND(K,2) G = MAX(ABS(A(K)),G) if (I < 1 .OR. I > N) go to 680 if (J < 1 .OR. J > N) go to 680 IW(I,1) = IW(I,1) + 1 IW(J,2) = IW(J,2) + 1 60 CONTINUE go to 90 70 L = K A(L) = A(LENU) IND(L,1) = IND(LENU,1) IND(L,2) = IND(LENU,2) LENU = LENU - 1 80 CONTINUE ! 90 LENL = 0 LROW = LENU LCOL = LROW ! MCP IS THE MAXIMUM NUMBER OF COMPRESSES PERMITTED BEFORE AN ! ERROR RETURN RESULTS. MCP = MAX(N/10,20) NCP = 0 ! CHECK FOR NULL ROW OR COLUMN AND INITIALIZE IP(I,2) TO POINT ! JUST BEYOND WHERE THE LAST COMPONENT OF COLUMN I OF A WILL ! BE STORED. K = 1 DO 110 IR=1,N K = K + IW(IR,2) IP(IR,2) = K DO 100 L=1,2 if (IW(IR,L) <= 0) go to 700 100 CONTINUE 110 CONTINUE ! REORDER BY ROWS ! CHECK FOR DOUBLE ENTRIES WHILE USING THE NEWLY CONSTRUCTED ! ROW FILE TO CONSTRUCT THE COLUMN FILE. NOTE THAT BY PUTTING ! THE ENTRIES IN BACKWARDS AND DECREASING IP(J,2) EACH TIME IT ! IS USED WE AUTOMATICALLY LEAVE IT POINTING TO THE FIRST ELEMENT. call MC20AS(N, LENU, A, IND(1,2), IP, IND(1,1), 0) KL = LENU DO 130 II=1,N IR = N + 1 - II KP = IP(IR,1) DO 120 K=KP,KL J = IND(K,2) if (IW(J,5) == IR) go to 660 IW(J,5) = IR KR = IP(J,2) - 1 IP(J,2) = KR IND(KR,1) = IR 120 CONTINUE KL = KP - 1 130 CONTINUE ! ! SET UP LINKED LISTS OF ROWS AND COLS WITH EQUAL NUMBERS OF NON-ZEROS. DO 150 L=1,2 DO 140 I=1,N NZ = IW(I,L) IN = IW(NZ,L+2) IW(NZ,L+2) = I IW(I,L+6) = IN IW(I,L+4) = 0 if (IN /= 0) IW(IN,L+4) = I 140 CONTINUE 150 CONTINUE ! ! ! START OF MAIN ELIMINATION LOOP. DO 590 IPV=1,N ! FIND PIVOT. JCOST IS MARKOWITZ COST OF CHEAPEST PIVOT FOUND SO FAR, ! WHICH IS IN ROW IPP AND COLUMN JP. JCOST = N*N ! LOOP ON LENGTH OF COLUMN TO BE SEARCHED DO 240 NZ=1,N if (JCOST <= (NZ-1)**2) go to 250 J = IW(NZ,4) ! SEARCH COLUMNS WITH NZ NON-ZEROS. DO 190 IDUMMY=1,N if (J <= 0) go to 200 KP = IP(J,2) KL = KP + IW(J,2) - 1 DO 180 K=KP,KL I = IND(K,1) KCOST = (NZ-1)*(IW(I,1)-1) if (KCOST >= JCOST) go to 180 if (NZ == 1) go to 170 ! FIND LARGEST ELEMENT IN ROW OF POTENTIAL PIVOT. AMAX = 0. K1 = IP(I,1) K2 = IW(I,1) + K1 - 1 DO 160 KK=K1,K2 AMAX = MAX(AMAX,ABS(A(KK))) if (IND(KK,2) == J) KJ = KK 160 CONTINUE ! PERFORM STABILITY TEST. if (ABS(A(KJ)) < AMAX*U) go to 180 170 JCOST = KCOST IPP = I JP = J if (JCOST <= (NZ-1)**2) go to 250 180 CONTINUE J = IW(J,8) 190 CONTINUE ! SEARCH ROWS WITH NZ NON-ZEROS. 200 I = IW(NZ,3) DO 230 IDUMMY=1,N if (I <= 0) go to 240 AMAX = 0. KP = IP(I,1) KL = KP + IW(I,1) - 1 ! FIND LARGEST ELEMENT IN THE ROW DO 210 K=KP,KL AMAX = MAX(ABS(A(K)),AMAX) 210 CONTINUE AU = AMAX*U DO 220 K=KP,KL ! PERFORM STABILITY TEST. if (ABS(A(K)) < AU) go to 220 J = IND(K,2) KCOST = (NZ-1)*(IW(J,2)-1) if (KCOST >= JCOST) go to 220 JCOST = KCOST IPP = I JP = J if (JCOST <= (NZ-1)**2) go to 250 220 CONTINUE I = IW(I,7) 230 CONTINUE 240 CONTINUE ! ! PIVOT FOUND. ! REMOVE ROWS AND COLUMNS INVOLVED IN ELIMINATION FROM ORDERING VECTORS. 250 KP = IP(JP,2) KL = IW(JP,2) + KP - 1 DO 290 L=1,2 DO 280 K=KP,KL I = IND(K,L) IL = IW(I,L+4) IN = IW(I,L+6) if (IL == 0) go to 260 IW(IL,L+6) = IN go to 270 260 NZ = IW(I,L) IW(NZ,L+2) = IN 270 if (IN > 0) IW(IN,L+4) = IL 280 CONTINUE KP = IP(IPP,1) KL = KP + IW(IPP,1) - 1 290 CONTINUE ! STORE PIVOT IW(IPP,5) = -IPV IW(JP,6) = -IPV ! ELIMINATE PIVOTAL ROW FROM COLUMN FILE AND FIND PIVOT IN ROW FILE. DO 320 K=KP,KL J = IND(K,2) KPC = IP(J,2) IW(J,2) = IW(J,2) - 1 KLC = KPC + IW(J,2) DO 300 KC=KPC,KLC if (IPP == IND(KC,1)) go to 310 300 CONTINUE 310 IND(KC,1) = IND(KLC,1) IND(KLC,1) = 0 if (J == JP) KR = K 320 CONTINUE ! BRING PIVOT TO FRONT OF PIVOTAL ROW. AU = A(KR) A(KR) = A(KP) A(KP) = AU IND(KR,2) = IND(KP,2) IND(KP,2) = JP ! ! PERFORM ELIMINATION ITSELF, LOOPING ON NON-ZEROS IN PIVOT COLUMN. NZC = IW(JP,2) if (NZC == 0) go to 550 DO 540 NC=1,NZC KC = IP(JP,2) + NC - 1 IR = IND(KC,1) ! SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED. KR = IP(IR,1) KRL = KR + IW(IR,1) - 1 DO 330 KNP=KR,KRL if (JP == IND(KNP,2)) go to 340 330 CONTINUE ! BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW. 340 AM = A(KNP) A(KNP) = A(KR) A(KR) = AM IND(KNP,2) = IND(KR,2) IND(KR,2) = JP AM = -A(KR)/A(KP) ! COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW. if (LROW+IW(IR,1)+IW(IPP,1)+LENL <= IA) go to 350 if (NCP >= MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL > IA) GO & TO 710 call LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.) KP = IP(IPP,1) KR = IP(IR,1) 350 KRL = KR + IW(IR,1) - 1 KQ = KP + 1 KPL = KP + IW(IPP,1) - 1 ! PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W. if (KQ > KPL) go to 370 DO 360 K=KQ,KPL J = IND(K,2) W(J) = A(K) 360 CONTINUE 370 IP(IR,1) = LROW + 1 ! ! TRANSFER MODIFIED ELEMENTS. IND(KR,2) = 0 KR = KR + 1 if (KR > KRL) go to 430 DO 420 KS=KR,KRL J = IND(KS,2) AU = A(KS) + AM*W(J) IND(KS,2) = 0 ! if ELEMENT IS VERY SMALL REMOVE IT FROM U. if (ABS(AU) <= SMALL) go to 380 G = MAX(G,ABS(AU)) LROW = LROW + 1 A(LROW) = AU IND(LROW,2) = J go to 410 380 LENU = LENU - 1 ! REMOVE ELEMENT FROM COL FILE. K = IP(J,2) KL = K + IW(J,2) - 1 IW(J,2) = KL - K DO 390 KK=K,KL if (IND(KK,1) == IR) go to 400 390 CONTINUE 400 IND(KK,1) = IND(KL,1) IND(KL,1) = 0 410 W(J) = 0. 420 CONTINUE ! ! SCAN PIVOT ROW FOR FILLS. 430 if (KQ > KPL) go to 520 DO 510 KS=KQ,KPL J = IND(KS,2) AU = AM*W(J) if (ABS(AU) <= SMALL) go to 500 LROW = LROW + 1 A(LROW) = AU IND(LROW,2) = J LENU = LENU + 1 ! ! CREATE FILL IN COLUMN FILE. NZ = IW(J,2) K = IP(J,2) KL = K + NZ - 1 if (NZ == 0) go to 460 ! if POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY. if (KL /= LCOL) go to 440 if (LCOL+LENL >= IA) go to 460 LCOL = LCOL + 1 go to 450 440 if (IND(KL+1,1) /= 0) go to 460 450 IND(KL+1,1) = IR go to 490 ! NEW ENTRY HAS TO BE CREATED. 460 if (LCOL+LENL+NZ+1 < IA) go to 470 ! COMPRESS COLUMN FILE if THERE IS NOT ROOM FOR NEW ENTRY. if (NCP >= MCP .OR. LENU+LENL+NZ+1 >= IA) go to 710 call LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) K = IP(J,2) KL = K + NZ - 1 ! TRANSFER OLD ENTRY INTO NEW. 470 IP(J,2) = LCOL + 1 if (KL < K) go to 485 DO 480 KK=K,KL LCOL = LCOL + 1 IND(LCOL,1) = IND(KK,1) IND(KK,1) = 0 480 CONTINUE 485 CONTINUE ! ADD NEW ELEMENT. LCOL = LCOL + 1 IND(LCOL,1) = IR 490 G = MAX(G,ABS(AU)) IW(J,2) = NZ + 1 500 W(J) = 0. 510 CONTINUE 520 IW(IR,1) = LROW + 1 - IP(IR,1) ! ! STORE MULTIPLIER if (LENL+LCOL+1 <= IA) go to 530 ! COMPRESS COL FILE if NECESSARY. if (NCP >= MCP) go to 710 call LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) 530 K = IA - LENL LENL = LENL + 1 A(K) = AM IND(K,1) = IPP IND(K,2) = IR LENU = LENU - 1 540 CONTINUE ! ! INSERT ROWS AND COLUMNS INVOLVED IN ELIMINATION IN LINKED LISTS ! OF EQUAL NUMBERS OF NON-ZEROS. 550 K1 = IP(JP,2) K2 = IW(JP,2) + K1 - 1 IW(JP,2) = 0 DO 580 L=1,2 if (K2 < K1) go to 570 DO 560 K=K1,K2 IR = IND(K,L) if (L == 1) IND(K,L) = 0 NZ = IW(IR,L) if (NZ <= 0) go to 720 IN = IW(NZ,L+2) IW(IR,L+6) = IN IW(IR,L+4) = 0 IW(NZ,L+2) = IR if (IN /= 0) IW(IN,L+4) = IR 560 CONTINUE 570 K1 = IP(IPP,1) + 1 K2 = IW(IPP,1) + K1 - 2 580 CONTINUE 590 CONTINUE ! ! RESET COLUMN FILE TO REFER TO U AND STORE ROW/COL NUMBERS IN ! PIVOTAL ORDER IN IW(.,3),IW(.,4) DO 600 I=1,N J = -IW(I,5) IW(J,3) = I J = -IW(I,6) IW(J,4) = I IW(I,2) = 0 600 CONTINUE DO 620 I=1,N KP = IP(I,1) KL = IW(I,1) + KP - 1 DO 610 K=KP,KL J = IND(K,2) IW(J,2) = IW(J,2) + 1 610 CONTINUE 620 CONTINUE K = 1 DO 630 I=1,N K = K + IW(I,2) IP(I,2) = K 630 CONTINUE LCOL = K - 1 DO 650 II=1,N I = IW(II,3) KP = IP(I,1) KL = IW(I,1) + KP - 1 DO 640 K=KP,KL J = IND(K,2) KN = IP(J,2) - 1 IP(J,2) = KN IND(KN,1) = I 640 CONTINUE 650 CONTINUE return ! ! THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS. ! 660 if (LP > 0) THEN WRITE (XERN1, '(I8)') IR WRITE (XERN2, '(I8)') J call XERMSG ('SLATEC', 'LA05AS', 'MORE THAN ONE MATRIX ' // & 'ENTRY. HERE ROW = ' // XERN1 // ' AND COL = ' // XERN2, & -4, 1) end if G = -4. return ! 670 if (LP > 0) call XERMSG ('SLATEC', 'LA05AS', & 'THE ORDER OF THE SYSTEM, N, IS NOT POSITIVE.', -1, 1) G = -1.0E0 return ! 680 if (LP > 0) THEN WRITE (XERN0, '(I8)') K WRITE (XERN1, '(I8)') I WRITE (XERN2, '(I8)') J call XERMSG ('SLATEC', 'LA05AS', 'ELEMENT K = ' // XERN0 // & ' IS OUT OF BOUNDS.$$HERE ROW = ' // XERN1 // & ' AND COL = ' // XERN2, -3, 1) end if G = -3. return ! 700 if (LP > 0) THEN WRITE (XERN1, '(I8)') L call XERMSG ('SLATEC', 'LA05AS', 'ROW OR COLUMN HAS NO ' // & 'ELEMENTS. HERE INDEX = ' // XERN1, -2, 1) end if G = -2. return ! 710 if (LP > 0) call XERMSG ('SLATEC', 'LA05AS', & 'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1) G = -7. return ! 720 IPV = IPV + 1 IW(IPV,1) = IR DO 730 I=1,N II = -IW(I,L+4) if (II > 0) IW(II,1) = I 730 CONTINUE ! if (LP > 0) THEN XERN1 = 'ROWS' if (L == 2) XERN1 = 'COLUMNS' call XERMSG ('SLATEC', 'LA05AS', 'DEPENDANT ' // XERN1, -5, 1) ! 740 WRITE (XERN1, '(I8)') IW(I,1) XERN2 = ' ' if (I+1 <= IPV) WRITE (XERN2, '(I8)') IW(I+1,1) call XERMSG ('SLATEC', 'LA05AS', & 'DEPENDENT VECTOR INDICES ARE ' // XERN1 // ' AND ' // & XERN2, -5, 1) I = I + 2 if (I <= IPV) go to 740 end if G = -5. return end subroutine LA05BD (A, IND, IA, N, IP, IW, W, G, B, TRANS) ! !! LA05BD is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (LA05BS-S, LA05BD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM ! FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE ! CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING ! THE FINAL LETTER =D= IN THE NAMES USED HERE. ! REVISED SEP. 13, 1979. ! ! ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES ! IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL ! SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN ! THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES ! DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. ! ! IP(I,1),IP(I,2) POINT TO START OF ROW/COLUMN I OF U. ! IW(I,1),IW(I,2) ARE LENGTHS OF ROW/COL I OF U. ! IW(.,3),IW(.,4) HOLD ROW/COL NUMBERS IN PIVOTAL ORDER. ! !***SEE ALSO DSPLP !***ROUTINES CALLED XERMSG, XSETUN !***COMMON BLOCKS LA05DD !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900402 Added TYPE section. (WRB) ! 920410 Corrected second dimension on IW declaration. (WRB) !***END PROLOGUE LA05BD DOUBLE PRECISION A(*), B(*), AM, W(*), G, SMALL LOGICAL TRANS INTEGER IND(IA,2), IW(N,8) INTEGER IP(N,2) COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL !***FIRST EXECUTABLE STATEMENT LA05BD if (G < 0.D0) go to 130 KLL = IA - LENL + 1 if (TRANS) go to 80 ! ! MULTIPLY VECTOR BY INVERSE OF L if (LENL <= 0) go to 20 L1 = IA + 1 DO 10 KK=1,LENL K = L1 - KK I = IND(K,1) if (B(I) == 0.D0) go to 10 J = IND(K,2) B(J) = B(J) + A(K)*B(I) 10 CONTINUE 20 DO 30 I=1,N W(I) = B(I) B(I) = 0.D0 30 CONTINUE ! ! MULTIPLY VECTOR BY INVERSE OF U N1 = N + 1 DO 70 II=1,N I = N1 - II I = IW(I,3) AM = W(I) KP = IP(I,1) if (KP > 0) go to 50 KP = -KP IP(I,1) = KP NZ = IW(I,1) KL = KP - 1 + NZ K2 = KP + 1 DO 40 K=K2,KL J = IND(K,2) AM = AM - A(K)*B(J) 40 CONTINUE 50 if (AM == 0.) go to 70 J = IND(KP,2) B(J) = AM/A(KP) KPC = IP(J,2) KL = IW(J,2) + KPC - 1 if (KL == KPC) go to 70 K2 = KPC + 1 DO 60 K=K2,KL I = IND(K,1) IP(I,1) = -ABS(IP(I,1)) 60 CONTINUE 70 CONTINUE go to 140 ! ! MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF U 80 DO 90 I=1,N W(I) = B(I) B(I) = 0.D0 90 CONTINUE DO 110 II=1,N I = IW(II,4) AM = W(I) if (AM == 0.D0) go to 110 J = IW(II,3) KP = IP(J,1) AM = AM/A(KP) B(J) = AM KL = IW(J,1) + KP - 1 if (KP == KL) go to 110 K2 = KP + 1 DO 100 K=K2,KL I = IND(K,2) W(I) = W(I) - AM*A(K) 100 CONTINUE 110 CONTINUE ! ! MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF L if (KLL > IA) RETURN DO 120 K=KLL,IA J = IND(K,2) if (B(J) == 0.D0) go to 120 I = IND(K,1) B(I) = B(I) + A(K)*B(J) 120 CONTINUE go to 140 ! 130 call XSETUN(LP) if (LP > 0) call XERMSG ('SLATEC', 'LA05BD', & 'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2) 140 RETURN end subroutine LA05BS (A, IND, IA, N, IP, IW, W, G, B, TRANS) ! !! LA05BS is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (LA05BS-S, LA05BD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM ! FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE ! CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING ! THE FINAL LETTER =S= IN THE NAMES USED HERE. ! REVISED SEP. 13, 1979. ! ! ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES ! IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL ! SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN ! THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES ! SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. ! ! IP(I,1),IP(I,2) POINT TO START OF ROW/COLUMN I OF U. ! IW(I,1),IW(I,2) ARE LENGTHS OF ROW/COL I OF U. ! IW(.,3),IW(.,4) HOLD ROW/COL NUMBERS IN PIVOTAL ORDER. ! !***SEE ALSO SPLP !***ROUTINES CALLED XERMSG, XSETUN !***COMMON BLOCKS LA05DS !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900402 Added TYPE section. (WRB) ! 920410 Corrected second dimension on IW declaration. (WRB) !***END PROLOGUE LA05BS REAL A(IA), B(*), AM, W(*), G, SMALL LOGICAL TRANS INTEGER IND(IA,2), IW(N,8) INTEGER IP(N,2) COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL !***FIRST EXECUTABLE STATEMENT LA05BS if (G < 0.) go to 130 KLL = IA - LENL + 1 if (TRANS) go to 80 ! ! MULTIPLY VECTOR BY INVERSE OF L if (LENL <= 0) go to 20 L1 = IA + 1 DO 10 KK=1,LENL K = L1 - KK I = IND(K,1) if (B(I) == 0.) go to 10 J = IND(K,2) B(J) = B(J) + A(K)*B(I) 10 CONTINUE 20 DO 30 I=1,N W(I) = B(I) B(I) = 0. 30 CONTINUE ! ! MULTIPLY VECTOR BY INVERSE OF U N1 = N + 1 DO 70 II=1,N I = N1 - II I = IW(I,3) AM = W(I) KP = IP(I,1) if (KP > 0) go to 50 KP = -KP IP(I,1) = KP NZ = IW(I,1) KL = KP - 1 + NZ K2 = KP + 1 DO 40 K=K2,KL J = IND(K,2) AM = AM - A(K)*B(J) 40 CONTINUE 50 if (AM == 0.) go to 70 J = IND(KP,2) B(J) = AM/A(KP) KPC = IP(J,2) KL = IW(J,2) + KPC - 1 if (KL == KPC) go to 70 K2 = KPC + 1 DO 60 K=K2,KL I = IND(K,1) IP(I,1) = -ABS(IP(I,1)) 60 CONTINUE 70 CONTINUE go to 140 ! ! MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF U 80 DO 90 I=1,N W(I) = B(I) B(I) = 0. 90 CONTINUE DO 110 II=1,N I = IW(II,4) AM = W(I) if (AM == 0.) go to 110 J = IW(II,3) KP = IP(J,1) AM = AM/A(KP) B(J) = AM KL = IW(J,1) + KP - 1 if (KP == KL) go to 110 K2 = KP + 1 DO 100 K=K2,KL I = IND(K,2) W(I) = W(I) - AM*A(K) 100 CONTINUE 110 CONTINUE ! ! MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF L if (KLL > IA) RETURN DO 120 K=KLL,IA J = IND(K,2) if (B(J) == 0.) go to 120 I = IND(K,1) B(I) = B(I) + A(K)*B(J) 120 CONTINUE go to 140 ! 130 call XSETUN(LP) if (LP > 0) call XERMSG ('SLATEC', 'LA05BS', & 'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2) 140 RETURN end subroutine LA05CD (A, IND, IA, N, IP, IW, W, G, U, MM) ! !! LA05CD is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (LA05CS-D, LA05CD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM ! FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE ! CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING ! THE FINAL LETTER =D= IN THE NAMES USED HERE. ! REVISED SEP. 13, 1979. ! ! ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES ! IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL ! SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN ! THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES ! DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. ! !***SEE ALSO DSPLP !***ROUTINES CALLED LA05ED, XERMSG, XSETUN !***COMMON BLOCKS LA05DD !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900402 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920410 Corrected second dimension on IW declaration. (WRB) ! 920422 Changed upper limit on DO from LAST to LAST-1. (WRB) !***END PROLOGUE LA05CD DOUBLE PRECISION A(*), G, U, AM, W(*), SMALL, AU INTEGER IND(IA,2), IW(N,8) INTEGER IP(N,2) CHARACTER*8 XERN1 ! COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL !***FIRST EXECUTABLE STATEMENT LA05CD call XSETUN(LP) if (G < 0.0D0) go to 620 JM = MM ! MCP LIMITS THE VALUE OF NCP PERMITTED BEFORE AN ERROR RETURN RESULTS. MCP = NCP + 20 ! REMOVE OLD COLUMN LENU = LENU - IW(JM,2) KP = IP(JM,2) IM = IND(KP,1) KL = KP + IW(JM,2) - 1 IW(JM,2) = 0 DO 30 K=KP,KL I = IND(K,1) IND(K,1) = 0 KR = IP(I,1) NZ = IW(I,1) - 1 IW(I,1) = NZ KRL = KR + NZ DO 10 KM=KR,KRL if (IND(KM,2) == JM) go to 20 10 CONTINUE 20 A(KM) = A(KRL) IND(KM,2) = IND(KRL,2) IND(KRL,2) = 0 30 CONTINUE ! ! INSERT NEW COLUMN DO 110 II=1,N I = IW(II,3) if (I == IM) M = II if (ABS(W(I)) <= SMALL) go to 100 LENU = LENU + 1 LAST = II if (LCOL+LENL < IA) go to 40 ! COMPRESS COLUMN FILE if NECESSARY. if (NCP >= MCP .OR. LENL+LENU >= IA) go to 610 call LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) 40 LCOL = LCOL + 1 NZ = IW(JM,2) if (NZ == 0) IP(JM,2) = LCOL IW(JM,2) = NZ + 1 IND(LCOL,1) = I NZ = IW(I,1) KPL = IP(I,1) + NZ if (KPL > LROW) go to 50 if (IND(KPL,2) == 0) go to 90 ! NEW ENTRY HAS TO BE CREATED. 50 if (LENL+LROW+NZ < IA) go to 60 if (NCP >= MCP .OR. LENL+LENU+NZ >= IA) go to 610 ! COMPRESS ROW FILE if NECESSARY. call LA05ED(A, IND(1,2), IP, N, IW, IA, .TRUE.) 60 KP = IP(I,1) IP(I,1) = LROW + 1 if (NZ == 0) go to 80 KPL = KP + NZ - 1 DO 70 K=KP,KPL LROW = LROW + 1 A(LROW) = A(K) IND(LROW,2) = IND(K,2) IND(K,2) = 0 70 CONTINUE 80 LROW = LROW + 1 KPL = LROW ! PLACE NEW ELEMENT AT END OF ROW. 90 IW(I,1) = NZ + 1 A(KPL) = W(I) IND(KPL,2) = JM 100 W(I) = 0.0D0 110 CONTINUE if (IW(IM,1) == 0 .OR. IW(JM,2) == 0 .OR. M > LAST) go to 590 ! ! FIND COLUMN SINGLETONS, OTHER THAN THE SPIKE. NON-SINGLETONS ARE ! MARKED WITH W(J)=1. ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED ! FOR WORKSPACE. INS = M M1 = M W(JM) = 1.0D0 DO 140 II=M,LAST I = IW(II,3) J = IW(II,4) if (W(J) == 0.) go to 130 KP = IP(I,1) KL = KP + IW(I,1) - 1 DO 120 K=KP,KL J = IND(K,2) W(J) = 1.0D0 120 CONTINUE IW(INS,4) = I INS = INS + 1 go to 140 ! PLACE SINGLETONS IN NEW POSITION. 130 IW(M1,3) = I M1 = M1 + 1 140 CONTINUE ! PLACE NON-SINGLETONS IN NEW POSITION. IJ = M + 1 DO 150 II=M1,LAST-1 IW(II,3) = IW(IJ,4) IJ = IJ + 1 150 CONTINUE ! PLACE SPIKE AT END. IW(LAST,3) = IM ! ! FIND ROW SINGLETONS, APART FROM SPIKE ROW. NON-SINGLETONS ARE MARKED ! WITH W(I)=2. AGAIN ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED ! FOR WORKSPACE. LAST1 = LAST JNS = LAST W(IM) = 2.0D0 J = JM DO 180 IJ=M1,LAST II = LAST + M1 - IJ I = IW(II,3) if (W(I) /= 2.0D0) go to 170 K = IP(I,1) if (II /= LAST) J = IND(K,2) KP = IP(J,2) KL = KP + IW(J,2) - 1 IW(JNS,4) = I JNS = JNS - 1 DO 160 K=KP,KL I = IND(K,1) W(I) = 2.0D0 160 CONTINUE go to 180 170 IW(LAST1,3) = I LAST1 = LAST1 - 1 180 CONTINUE DO 190 II=M1,LAST1 JNS = JNS + 1 I = IW(JNS,4) W(I) = 3.0D0 IW(II,3) = I 190 CONTINUE ! ! DEAL WITH SINGLETON SPIKE COLUMN. NOTE THAT BUMP ROWS ARE MARKED BY ! W(I)=3. DO 230 II=M1,LAST1 KP = IP(JM,2) KL = KP + IW(JM,2) - 1 IS = 0 DO 200 K=KP,KL L = IND(K,1) if (W(L) /= 3.0D0) go to 200 if (IS /= 0) go to 240 I = L KNP = K IS = 1 200 CONTINUE if (IS == 0) go to 590 ! MAKE A(I,JM) A PIVOT. IND(KNP,1) = IND(KP,1) IND(KP,1) = I KP = IP(I,1) DO 210 K=KP,IA if (IND(K,2) == JM) go to 220 210 CONTINUE 220 AM = A(KP) A(KP) = A(K) A(K) = AM IND(K,2) = IND(KP,2) IND(KP,2) = JM JM = IND(K,2) IW(II,4) = I W(I) = 2.0D0 230 CONTINUE II = LAST1 go to 260 240 IN = M1 DO 250 IJ=II,LAST1 IW(IJ,4) = IW(IN,3) IN = IN + 1 250 CONTINUE 260 LAST2 = LAST1 - 1 if (M1 == LAST1) go to 570 DO 270 I=M1,LAST2 IW(I,3) = IW(I,4) 270 CONTINUE M1 = II if (M1 == LAST1) go to 570 ! ! CLEAR W DO 280 I=1,N W(I) = 0.0D0 280 CONTINUE ! ! PERFORM ELIMINATION IR = IW(LAST1,3) DO 560 II=M1,LAST1 IPP = IW(II,3) KP = IP(IPP,1) KR = IP(IR,1) JP = IND(KP,2) if (II == LAST1) JP = JM ! SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED. ! AND BRING IT TO FRONT OF ITS ROW KRL = KR + IW(IR,1) - 1 DO 290 KNP=KR,KRL if (JP == IND(KNP,2)) go to 300 290 CONTINUE if (II-LAST1) 560, 590, 560 ! BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW. 300 AM = A(KNP) A(KNP) = A(KR) A(KR) = AM IND(KNP,2) = IND(KR,2) IND(KR,2) = JP if (II == LAST1) go to 310 if (ABS(A(KP)) < U*ABS(AM)) go to 310 if (ABS(AM) < U*ABS(A(KP))) go to 340 if (IW(IPP,1) <= IW(IR,1)) go to 340 ! PERFORM INTERCHANGE 310 IW(LAST1,3) = IPP IW(II,3) = IR IR = IPP IPP = IW(II,3) K = KR KR = KP KP = K KJ = IP(JP,2) DO 320 K=KJ,IA if (IND(K,1) == IPP) go to 330 320 CONTINUE 330 IND(K,1) = IND(KJ,1) IND(KJ,1) = IPP 340 if (A(KP) == 0.0D0) go to 590 if (II == LAST1) go to 560 AM = -A(KR)/A(KP) ! COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW. if (LROW+IW(IR,1)+IW(IPP,1)+LENL <= IA) go to 350 if (NCP >= MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL > IA) go to & 610 call LA05ED(A, IND(1,2), IP, N, IW, IA, .TRUE.) KP = IP(IPP,1) KR = IP(IR,1) 350 KRL = KR + IW(IR,1) - 1 KQ = KP + 1 KPL = KP + IW(IPP,1) - 1 ! PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W. if (KQ > KPL) go to 370 DO 360 K=KQ,KPL J = IND(K,2) W(J) = A(K) 360 CONTINUE 370 IP(IR,1) = LROW + 1 ! ! TRANSFER MODIFIED ELEMENTS. IND(KR,2) = 0 KR = KR + 1 if (KR > KRL) go to 430 DO 420 KS=KR,KRL J = IND(KS,2) AU = A(KS) + AM*W(J) IND(KS,2) = 0 ! if ELEMENT IS VERY SMALL REMOVE IT FROM U. if (ABS(AU) <= SMALL) go to 380 G = MAX(G,ABS(AU)) LROW = LROW + 1 A(LROW) = AU IND(LROW,2) = J go to 410 380 LENU = LENU - 1 ! REMOVE ELEMENT FROM COL FILE. K = IP(J,2) KL = K + IW(J,2) - 1 IW(J,2) = KL - K DO 390 KK=K,KL if (IND(KK,1) == IR) go to 400 390 CONTINUE 400 IND(KK,1) = IND(KL,1) IND(KL,1) = 0 410 W(J) = 0.0D0 420 CONTINUE ! ! SCAN PIVOT ROW FOR FILLS. 430 if (KQ > KPL) go to 520 DO 510 KS=KQ,KPL J = IND(KS,2) AU = AM*W(J) if (ABS(AU) <= SMALL) go to 500 LROW = LROW + 1 A(LROW) = AU IND(LROW,2) = J LENU = LENU + 1 ! ! CREATE FILL IN COLUMN FILE. NZ = IW(J,2) K = IP(J,2) KL = K + NZ - 1 ! if POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY. if (KL /= LCOL) go to 440 if (LCOL+LENL >= IA) go to 460 LCOL = LCOL + 1 go to 450 440 if (IND(KL+1,1) /= 0) go to 460 450 IND(KL+1,1) = IR go to 490 ! NEW ENTRY HAS TO BE CREATED. 460 if (LCOL+LENL+NZ+1 < IA) go to 470 ! COMPRESS COLUMN FILE if THERE IS NOT ROOM FOR NEW ENTRY. if (NCP >= MCP .OR. LENU+LENL+NZ+1 >= IA) go to 610 call LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) K = IP(J,2) KL = K + NZ - 1 ! TRANSFER OLD ENTRY INTO NEW. 470 IP(J,2) = LCOL + 1 DO 480 KK=K,KL LCOL = LCOL + 1 IND(LCOL,1) = IND(KK,1) IND(KK,1) = 0 480 CONTINUE ! ADD NEW ELEMENT. LCOL = LCOL + 1 IND(LCOL,1) = IR 490 G = MAX(G,ABS(AU)) IW(J,2) = NZ + 1 500 W(J) = 0.0D0 510 CONTINUE 520 IW(IR,1) = LROW + 1 - IP(IR,1) ! ! STORE MULTIPLIER if (LENL+LCOL+1 <= IA) go to 530 ! COMPRESS COL FILE if NECESSARY. if (NCP >= MCP) go to 610 call LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) 530 K = IA - LENL LENL = LENL + 1 A(K) = AM IND(K,1) = IPP IND(K,2) = IR ! CREATE BLANK IN PIVOTAL COLUMN. KP = IP(JP,2) NZ = IW(JP,2) - 1 KL = KP + NZ DO 540 K=KP,KL if (IND(K,1) == IR) go to 550 540 CONTINUE 550 IND(K,1) = IND(KL,1) IW(JP,2) = NZ IND(KL,1) = 0 LENU = LENU - 1 560 CONTINUE ! ! CONSTRUCT COLUMN PERMUTATION AND STORE IT IN IW(.,4) 570 DO 580 II=M,LAST I = IW(II,3) K = IP(I,1) J = IND(K,2) IW(II,4) = J 580 CONTINUE return ! ! THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS. ! 590 if (LP > 0) THEN WRITE (XERN1, '(I8)') MM call XERMSG ('SLATEC', 'LA05CD', 'SINGULAR MATRIX AFTER ' // & 'REPLACEMENT OF COLUMN. INDEX = ' // XERN1, -6, 1) end if G = -6.0D0 return ! 610 if (LP > 0) call XERMSG ('SLATEC', 'LA05CD', & 'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1) G = -7.0D0 return ! 620 if (LP > 0) call XERMSG ('SLATEC', 'LA05CD', & 'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2) G = -8.0D0 return end subroutine LA05CS (A, IND, IA, N, IP, IW, W, G, U, MM) ! !! LA05CS is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (LA05CS-S, LA05CD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM ! FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE ! CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING ! THE FINAL LETTER =S= IN THE NAMES USED HERE. ! REVISED SEP. 13, 1979. ! ! ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES ! IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL ! SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN ! THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES ! SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. ! !***SEE ALSO SPLP !***ROUTINES CALLED LA05ES, XERMSG, XSETUN !***COMMON BLOCKS LA05DS !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Corrected references to XERRWV. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900402 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920410 Corrected second dimension on IW declaration. (WRB) ! 920422 Changed upper limit on DO from LAST to LAST-1. (WRB) !***END PROLOGUE LA05CS REAL A(*), G, U, AM, W(*), SMALL, AU INTEGER IND(IA,2), IW(N,8) INTEGER IP(N,2) CHARACTER*8 XERN1 ! COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL !***FIRST EXECUTABLE STATEMENT LA05CS call XSETUN(LP) if (G < 0.0E0) go to 620 JM = MM ! MCP LIMITS THE VALUE OF NCP PERMITTED BEFORE AN ERROR RETURN RESULTS. MCP = NCP + 20 ! REMOVE OLD COLUMN LENU = LENU - IW(JM,2) KP = IP(JM,2) IM = IND(KP,1) KL = KP + IW(JM,2) - 1 IW(JM,2) = 0 DO 30 K=KP,KL I = IND(K,1) IND(K,1) = 0 KR = IP(I,1) NZ = IW(I,1) - 1 IW(I,1) = NZ KRL = KR + NZ DO 10 KM=KR,KRL if (IND(KM,2) == JM) go to 20 10 CONTINUE 20 A(KM) = A(KRL) IND(KM,2) = IND(KRL,2) IND(KRL,2) = 0 30 CONTINUE ! ! INSERT NEW COLUMN DO 110 II=1,N I = IW(II,3) if (I == IM) M = II if (ABS(W(I)) <= SMALL) go to 100 LENU = LENU + 1 LAST = II if (LCOL+LENL < IA) go to 40 ! COMPRESS COLUMN FILE if NECESSARY. if (NCP >= MCP .OR. LENL+LENU >= IA) go to 610 call LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) 40 LCOL = LCOL + 1 NZ = IW(JM,2) if (NZ == 0) IP(JM,2) = LCOL IW(JM,2) = NZ + 1 IND(LCOL,1) = I NZ = IW(I,1) KPL = IP(I,1) + NZ if (KPL > LROW) go to 50 if (IND(KPL,2) == 0) go to 90 ! NEW ENTRY HAS TO BE CREATED. 50 if (LENL+LROW+NZ < IA) go to 60 if (NCP >= MCP .OR. LENL+LENU+NZ >= IA) go to 610 ! COMPRESS ROW FILE if NECESSARY. call LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.) 60 KP = IP(I,1) IP(I,1) = LROW + 1 if (NZ == 0) go to 80 KPL = KP + NZ - 1 DO 70 K=KP,KPL LROW = LROW + 1 A(LROW) = A(K) IND(LROW,2) = IND(K,2) IND(K,2) = 0 70 CONTINUE 80 LROW = LROW + 1 KPL = LROW ! PLACE NEW ELEMENT AT END OF ROW. 90 IW(I,1) = NZ + 1 A(KPL) = W(I) IND(KPL,2) = JM 100 W(I) = 0.0E0 110 CONTINUE if (IW(IM,1) == 0 .OR. IW(JM,2) == 0 .OR. M > LAST) go to 590 ! ! FIND COLUMN SINGLETONS, OTHER THAN THE SPIKE. NON-SINGLETONS ARE ! MARKED WITH W(J)=1. ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED ! FOR WORKSPACE. INS = M M1 = M W(JM) = 1.0E0 DO 140 II=M,LAST I = IW(II,3) J = IW(II,4) if (W(J) == 0.0E0) go to 130 KP = IP(I,1) KL = KP + IW(I,1) - 1 DO 120 K=KP,KL J = IND(K,2) W(J) = 1.0E0 120 CONTINUE IW(INS,4) = I INS = INS + 1 go to 140 ! PLACE SINGLETONS IN NEW POSITION. 130 IW(M1,3) = I M1 = M1 + 1 140 CONTINUE ! PLACE NON-SINGLETONS IN NEW POSITION. IJ = M + 1 DO 150 II=M1,LAST-1 IW(II,3) = IW(IJ,4) IJ = IJ + 1 150 CONTINUE ! PLACE SPIKE AT END. IW(LAST,3) = IM ! ! FIND ROW SINGLETONS, APART FROM SPIKE ROW. NON-SINGLETONS ARE MARKED ! WITH W(I)=2. AGAIN ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED ! FOR WORKSPACE. LAST1 = LAST JNS = LAST W(IM) = 2.0E0 J = JM DO 180 IJ=M1,LAST II = LAST + M1 - IJ I = IW(II,3) if (W(I) /= 2.0E0) go to 170 K = IP(I,1) if (II /= LAST) J = IND(K,2) KP = IP(J,2) KL = KP + IW(J,2) - 1 IW(JNS,4) = I JNS = JNS - 1 DO 160 K=KP,KL I = IND(K,1) W(I) = 2.0E0 160 CONTINUE go to 180 170 IW(LAST1,3) = I LAST1 = LAST1 - 1 180 CONTINUE DO 190 II=M1,LAST1 JNS = JNS + 1 I = IW(JNS,4) W(I) = 3.0E0 IW(II,3) = I 190 CONTINUE ! ! DEAL WITH SINGLETON SPIKE COLUMN. NOTE THAT BUMP ROWS ARE MARKED BY ! W(I)=3.0E0 DO 230 II=M1,LAST1 KP = IP(JM,2) KL = KP + IW(JM,2) - 1 IS = 0 DO 200 K=KP,KL L = IND(K,1) if (W(L) /= 3.0E0) go to 200 if (IS /= 0) go to 240 I = L KNP = K IS = 1 200 CONTINUE if (IS == 0) go to 590 ! MAKE A(I,JM) A PIVOT. IND(KNP,1) = IND(KP,1) IND(KP,1) = I KP = IP(I,1) DO 210 K=KP,IA if (IND(K,2) == JM) go to 220 210 CONTINUE 220 AM = A(KP) A(KP) = A(K) A(K) = AM IND(K,2) = IND(KP,2) IND(KP,2) = JM JM = IND(K,2) IW(II,4) = I W(I) = 2.0E0 230 CONTINUE II = LAST1 go to 260 240 IN = M1 DO 250 IJ=II,LAST1 IW(IJ,4) = IW(IN,3) IN = IN + 1 250 CONTINUE 260 LAST2 = LAST1 - 1 if (M1 == LAST1) go to 570 DO 270 I=M1,LAST2 IW(I,3) = IW(I,4) 270 CONTINUE M1 = II if (M1 == LAST1) go to 570 ! ! CLEAR W DO 280 I=1,N W(I) = 0.0E0 280 CONTINUE ! ! PERFORM ELIMINATION IR = IW(LAST1,3) DO 560 II=M1,LAST1 IPP = IW(II,3) KP = IP(IPP,1) KR = IP(IR,1) JP = IND(KP,2) if (II == LAST1) JP = JM ! SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED. ! AND BRING IT TO FRONT OF ITS ROW KRL = KR + IW(IR,1) - 1 DO 290 KNP=KR,KRL if (JP == IND(KNP,2)) go to 300 290 CONTINUE if (II-LAST1) 560, 590, 560 ! BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW. 300 AM = A(KNP) A(KNP) = A(KR) A(KR) = AM IND(KNP,2) = IND(KR,2) IND(KR,2) = JP if (II == LAST1) go to 310 if (ABS(A(KP)) < U*ABS(AM)) go to 310 if (ABS(AM) < U*ABS(A(KP))) go to 340 if (IW(IPP,1) <= IW(IR,1)) go to 340 ! PERFORM INTERCHANGE 310 IW(LAST1,3) = IPP IW(II,3) = IR IR = IPP IPP = IW(II,3) K = KR KR = KP KP = K KJ = IP(JP,2) DO 320 K=KJ,IA if (IND(K,1) == IPP) go to 330 320 CONTINUE 330 IND(K,1) = IND(KJ,1) IND(KJ,1) = IPP 340 if (A(KP) == 0.0E0) go to 590 if (II == LAST1) go to 560 AM = -A(KR)/A(KP) ! COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW. if (LROW+IW(IR,1)+IW(IPP,1)+LENL <= IA) go to 350 if (NCP >= MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL > IA) go to & 610 call LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.) KP = IP(IPP,1) KR = IP(IR,1) 350 KRL = KR + IW(IR,1) - 1 KQ = KP + 1 KPL = KP + IW(IPP,1) - 1 ! PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W. if (KQ > KPL) go to 370 DO 360 K=KQ,KPL J = IND(K,2) W(J) = A(K) 360 CONTINUE 370 IP(IR,1) = LROW + 1 ! ! TRANSFER MODIFIED ELEMENTS. IND(KR,2) = 0 KR = KR + 1 if (KR > KRL) go to 430 DO 420 KS=KR,KRL J = IND(KS,2) AU = A(KS) + AM*W(J) IND(KS,2) = 0 ! if ELEMENT IS VERY SMALL REMOVE IT FROM U. if (ABS(AU) <= SMALL) go to 380 G = MAX(G,ABS(AU)) LROW = LROW + 1 A(LROW) = AU IND(LROW,2) = J go to 410 380 LENU = LENU - 1 ! REMOVE ELEMENT FROM COL FILE. K = IP(J,2) KL = K + IW(J,2) - 1 IW(J,2) = KL - K DO 390 KK=K,KL if (IND(KK,1) == IR) go to 400 390 CONTINUE 400 IND(KK,1) = IND(KL,1) IND(KL,1) = 0 410 W(J) = 0.0E0 420 CONTINUE ! ! SCAN PIVOT ROW FOR FILLS. 430 if (KQ > KPL) go to 520 DO 510 KS=KQ,KPL J = IND(KS,2) AU = AM*W(J) if (ABS(AU) <= SMALL) go to 500 LROW = LROW + 1 A(LROW) = AU IND(LROW,2) = J LENU = LENU + 1 ! ! CREATE FILL IN COLUMN FILE. NZ = IW(J,2) K = IP(J,2) KL = K + NZ - 1 ! if POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY. if (KL /= LCOL) go to 440 if (LCOL+LENL >= IA) go to 460 LCOL = LCOL + 1 go to 450 440 if (IND(KL+1,1) /= 0) go to 460 450 IND(KL+1,1) = IR go to 490 ! NEW ENTRY HAS TO BE CREATED. 460 if (LCOL+LENL+NZ+1 < IA) go to 470 ! COMPRESS COLUMN FILE if THERE IS NOT ROOM FOR NEW ENTRY. if (NCP >= MCP .OR. LENU+LENL+NZ+1 >= IA) go to 610 call LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) K = IP(J,2) KL = K + NZ - 1 ! TRANSFER OLD ENTRY INTO NEW. 470 IP(J,2) = LCOL + 1 DO 480 KK=K,KL LCOL = LCOL + 1 IND(LCOL,1) = IND(KK,1) IND(KK,1) = 0 480 CONTINUE ! ADD NEW ELEMENT. LCOL = LCOL + 1 IND(LCOL,1) = IR 490 G = MAX(G,ABS(AU)) IW(J,2) = NZ + 1 500 W(J) = 0.0E0 510 CONTINUE 520 IW(IR,1) = LROW + 1 - IP(IR,1) ! ! STORE MULTIPLIER if (LENL+LCOL+1 <= IA) go to 530 ! COMPRESS COL FILE if NECESSARY. if (NCP >= MCP) go to 610 call LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.) 530 K = IA - LENL LENL = LENL + 1 A(K) = AM IND(K,1) = IPP IND(K,2) = IR ! CREATE BLANK IN PIVOTAL COLUMN. KP = IP(JP,2) NZ = IW(JP,2) - 1 KL = KP + NZ DO 540 K=KP,KL if (IND(K,1) == IR) go to 550 540 CONTINUE 550 IND(K,1) = IND(KL,1) IW(JP,2) = NZ IND(KL,1) = 0 LENU = LENU - 1 560 CONTINUE ! ! CONSTRUCT COLUMN PERMUTATION AND STORE IT IN IW(.,4) 570 DO 580 II=M,LAST I = IW(II,3) K = IP(I,1) J = IND(K,2) IW(II,4) = J 580 CONTINUE return ! ! THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS. ! 590 if (LP > 0) THEN WRITE (XERN1, '(I8)') MM call XERMSG ('SLATEC', 'LA05CS', 'SINGULAR MATRIX AFTER ' // & 'REPLACEMENT OF COLUMN. INDEX = ' // XERN1, -6, 1) end if G = -6.0E0 return ! 610 if (LP > 0) call XERMSG ('SLATEC', 'LA05CS', & 'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1) G = -7.0E0 return ! 620 if (LP > 0) call XERMSG ('SLATEC', 'LA05CS', & 'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2) G = -8.0E0 return end subroutine LA05ED (A, IRN, IP, N, IW, IA, REALS) ! !! LA05ED is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (LA05ES-S, LA05ED-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM ! FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE ! CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING ! THE FINAL LETTER =D= IN THE NAMES USED HERE. ! REVISED SEP. 13, 1979. ! ! ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES ! IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL ! SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN ! THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES ! DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. ! !***SEE ALSO DSPLP !***ROUTINES CALLED (NONE) !***COMMON BLOCKS LA05DD !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE LA05ED LOGICAL REALS DOUBLE PRECISION A(*),SMALL INTEGER IRN(*), IW(*) INTEGER IP(*) COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL !***FIRST EXECUTABLE STATEMENT LA05ED NCP = NCP + 1 ! COMPRESS FILE OF POSITIVE INTEGERS. ENTRY J STARTS AT IRN(IP(J)) ! AND CONTAINS IW(J) INTEGERS,J=1,N. OTHER COMPONENTS OF IRN ARE ZERO. ! LENGTH OF COMPRESSED FILE PLACED IN LROW if REALS IS .TRUE. OR LCOL ! OTHERWISE. ! if REALS IS .TRUE. ARRAY A CONTAINS A FILE ASSOCIATED WITH IRN ! AND THIS IS COMPRESSED TOO. ! A,IRN,IP,IW,IA ARE INPUT/OUTPUT VARIABLES. ! N,REALS ARE INPUT/UNCHANGED VARIABLES. ! DO 10 J=1,N ! STORE THE LAST ELEMENT OF ENTRY J IN IW(J) THEN OVERWRITE IT BY -J. NZ = IW(J) if (NZ <= 0) go to 10 K = IP(J) + NZ - 1 IW(J) = IRN(K) IRN(K) = -J 10 CONTINUE ! KN IS THE POSITION OF NEXT ENTRY IN COMPRESSED FILE. KN = 0 IPI = 0 KL = LCOL if (REALS) KL = LROW ! LOOP THROUGH THE OLD FILE SKIPPING ZERO (DUMMY) ELEMENTS AND ! MOVING GENUINE ELEMENTS FORWARD. THE ENTRY NUMBER BECOMES ! KNOWN ONLY WHEN ITS END IS DETECTED BY THE PRESENCE OF A NEGATIVE ! INTEGER. DO 30 K=1,KL if (IRN(K) == 0) go to 30 KN = KN + 1 if (REALS) A(KN) = A(K) if (IRN(K) >= 0) go to 20 ! END OF ENTRY. RESTORE IRN(K), SET POINTER TO START OF ENTRY AND ! STORE CURRENT KN IN IPI READY FOR USE WHEN NEXT LAST ENTRY ! IS DETECTED. J = -IRN(K) IRN(K) = IW(J) IP(J) = IPI + 1 IW(J) = KN - IPI IPI = KN 20 IRN(KN) = IRN(K) 30 CONTINUE if (REALS) LROW = KN if (.NOT.REALS) LCOL = KN return end subroutine LA05ES (A, IRN, IP, N, IW, IA, REALS) ! !! LA05ES is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (LA05ES-S, LA05ED-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM ! FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE ! CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING ! THE FINAL LETTER =S= IN THE NAMES USED HERE. ! REVISED SEP. 13, 1979. ! ! ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES ! IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL ! SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN ! THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES ! SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. ! !***SEE ALSO SPLP !***ROUTINES CALLED (NONE) !***COMMON BLOCKS LA05DS !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE LA05ES LOGICAL REALS REAL A(*) INTEGER IRN(*), IW(*) INTEGER IP(*) COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL !***FIRST EXECUTABLE STATEMENT LA05ES NCP = NCP + 1 ! COMPRESS FILE OF POSITIVE INTEGERS. ENTRY J STARTS AT IRN(IP(J)) ! AND CONTAINS IW(J) INTEGERS,J=1,N. OTHER COMPONENTS OF IRN ARE ZERO. ! LENGTH OF COMPRESSED FILE PLACED IN LROW if REALS IS .TRUE. OR LCOL ! OTHERWISE. ! if REALS IS .TRUE. ARRAY A CONTAINS A REAL FILE ASSOCIATED WITH IRN ! AND THIS IS COMPRESSED TOO. ! A,IRN,IP,IW,IA ARE INPUT/OUTPUT VARIABLES. ! N,REALS ARE INPUT/UNCHANGED VARIABLES. ! DO 10 J=1,N ! STORE THE LAST ELEMENT OF ENTRY J IN IW(J) THEN OVERWRITE IT BY -J. NZ = IW(J) if (NZ <= 0) go to 10 K = IP(J) + NZ - 1 IW(J) = IRN(K) IRN(K) = -J 10 CONTINUE ! KN IS THE POSITION OF NEXT ENTRY IN COMPRESSED FILE. KN = 0 IPI = 0 KL = LCOL if (REALS) KL = LROW ! LOOP THROUGH THE OLD FILE SKIPPING ZERO (DUMMY) ELEMENTS AND ! MOVING GENUINE ELEMENTS FORWARD. THE ENTRY NUMBER BECOMES ! KNOWN ONLY WHEN ITS END IS DETECTED BY THE PRESENCE OF A NEGATIVE ! INTEGER. DO 30 K=1,KL if (IRN(K) == 0) go to 30 KN = KN + 1 if (REALS) A(KN) = A(K) if (IRN(K) >= 0) go to 20 ! END OF ENTRY. RESTORE IRN(K), SET POINTER TO START OF ENTRY AND ! STORE CURRENT KN IN IPI READY FOR USE WHEN NEXT LAST ENTRY ! IS DETECTED. J = -IRN(K) IRN(K) = IW(J) IP(J) = IPI + 1 IW(J) = KN - IPI IPI = KN 20 IRN(KN) = IRN(K) 30 CONTINUE if (REALS) LROW = KN if (.NOT.REALS) LCOL = KN return end subroutine LLSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, NP, & KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO) ! !! LLSIA solves a linear least squares problems by performing a QR ... ! factorization of the matrix using Householder ! transformations. Emphasis is put on detecting possible ! rank deficiency. ! !***LIBRARY SLATEC !***CATEGORY D9, D5 !***TYPE SINGLE PRECISION (LLSIA-S, DLLSIA-D) !***KEYWORDS LINEAR LEAST SQUARES, QR FACTORIZATION !***AUTHOR Manteuffel, T. A., (LANL) !***DESCRIPTION ! ! LLSIA computes the least squares solution(s) to the problem AX=B ! where A is an M by N matrix with M >= N and B is the M by NB ! matrix of right hand sides. User input bounds on the uncertainty ! in the elements of A are used to detect numerical rank deficiency. ! The algorithm employs a row and column pivot strategy to ! minimize the growth of uncertainty and round-off errors. ! ! LLSIA requires (MDA+6)*N + (MDB+1)*NB + M dimensioned space ! ! ****************************************************************** ! * * ! * WARNING - All input arrays are changed on exit. * ! * * ! ****************************************************************** ! SUBROUTINE LLSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, ! 1 KRANK,KSURE,RNORM,W,LW,IWORK,LIW,INFO) ! ! Input.. ! ! A(,) Linear coefficient matrix of AX=B, with MDA the ! MDA,M,N actual first dimension of A in the calling program. ! M is the row dimension (no. of EQUATIONS of the ! problem) and N the col dimension (no. of UNKNOWNS). ! Must have MDA >= M and M >= N. ! ! B(,) Right hand side(s), with MDB the actual first ! MDB,NB dimension of B in the calling program. NB is the ! number of M by 1 right hand sides. Must have ! MDB >= M. If NB = 0, B is never accessed. ! ! ****************************************************************** ! * * ! * Note - Use of RE and AE are what make this * ! * code significantly different from * ! * other linear least squares solvers. * ! * However, the inexperienced user is * ! * advised to set RE=0.,AE=0.,KEY=0. * ! * * ! ****************************************************************** ! RE(),AE(),KEY ! RE() RE() is a vector of length N such that RE(I) is ! the maximum relative uncertainty in column I of ! the matrix A. The values of RE() must be between ! 0 and 1. A minimum of 10*machine precision will ! be enforced. ! ! AE() AE() is a vector of length N such that AE(I) is ! the maximum absolute uncertainty in column I of ! the matrix A. The values of AE() must be greater ! than or equal to 0. ! ! KEY For ease of use, RE and AE may be input as either ! vectors or scalars. If a scalar is input, the algo- ! rithm will use that value for each column of A. ! The parameter key indicates whether scalars or ! vectors are being input. ! KEY=0 RE scalar AE scalar ! KEY=1 RE vector AE scalar ! KEY=2 RE scalar AE vector ! KEY=3 RE vector AE vector ! ! MODE The integer mode indicates how the routine ! is to react if rank deficiency is detected. ! If MODE = 0 return immediately, no solution ! 1 compute truncated solution ! 2 compute minimal length solution ! The inexperienced user is advised to set MODE=0 ! ! NP The first NP columns of A will not be interchanged ! with other columns even though the pivot strategy ! would suggest otherwise. ! The inexperienced user is advised to set NP=0. ! ! WORK() A real work array dimensioned 5*N. However, if ! RE or AE have been specified as vectors, dimension ! WORK 4*N. If both RE and AE have been specified ! as vectors, dimension WORK 3*N. ! ! LW Actual dimension of WORK ! ! IWORK() Integer work array dimensioned at least N+M. ! ! LIW Actual dimension of IWORK. ! ! INFO Is a flag which provides for the efficient ! solution of subsequent problems involving the ! same A but different B. ! If INFO = 0 original call ! INFO = 1 subsequent calls ! On subsequent calls, the user must supply A, KRANK, ! LW, IWORK, LIW, and the first 2*N locations of WORK ! as output by the original call to LLSIA. MODE must ! be equal to the value of MODE in the original call. ! If MODE < 2, only the first N locations of WORK ! are accessed. AE, RE, KEY, and NP are not accessed. ! ! Output.. ! ! A(,) Contains the upper triangular part of the reduced ! matrix and the transformation information. It togeth ! with the first N elements of WORK (see below) ! completely specify the QR factorization of A. ! ! B(,) Contains the N by NB solution matrix for X. ! ! KRANK,KSURE The numerical rank of A, based upon the relative ! and absolute bounds on uncertainty, is bounded ! above by KRANK and below by KSURE. The algorithm ! returns a solution based on KRANK. KSURE provides ! an indication of the precision of the rank. ! ! RNORM() Contains the Euclidean length of the NB residual ! vectors B(I)-AX(I), I=1,NB. ! ! WORK() The first N locations of WORK contain values ! necessary to reproduce the Householder ! transformation. ! ! IWORK() The first N locations contain the order in ! which the columns of A were used. The next ! M locations contain the order in which the ! rows of A were used. ! ! INFO Flag to indicate status of computation on completion ! -1 Parameter error(s) ! 0 - Rank deficient, no solution ! 1 - Rank deficient, truncated solution ! 2 - Rank deficient, minimal length solution ! 3 - Numerical rank 0, zero solution ! 4 - Rank < NP ! 5 - Full rank ! !***REFERENCES T. Manteuffel, An interval analysis approach to rank ! determination in linear least squares problems, ! Report SAND80-0655, Sandia Laboratories, June 1980. !***ROUTINES CALLED R1MACH, U11LS, U12LS, XERMSG !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Fixed an error message. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE LLSIA DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*) INTEGER IWORK(*) ! !***FIRST EXECUTABLE STATEMENT LLSIA if ( INFO < 0 .OR. INFO > 1) go to 514 IT=INFO INFO=-1 if ( NB == 0 .AND. IT == 1) go to 501 if ( M < 1) go to 502 if ( N < 1) go to 503 if ( N > M) go to 504 if ( MDA < M) go to 505 if ( LIW < M+N) go to 506 if ( MODE < 0 .OR. MODE > 3) go to 515 if ( NB == 0) go to 4 if ( NB < 0) go to 507 if ( MDB < M) go to 508 if ( IT == 0) go to 4 go to 400 4 if ( KEY < 0.OR.KEY > 3) go to 509 if ( KEY == 0 .AND. LW < 5*N) go to 510 if ( KEY == 1 .AND. LW < 4*N) go to 510 if ( KEY == 2 .AND. LW < 4*N) go to 510 if ( KEY == 3 .AND. LW < 3*N) go to 510 if ( NP < 0 .OR. NP > N) go to 516 ! EPS=10.*R1MACH(4) N1=1 N2=N1+N N3=N2+N N4=N3+N N5=N4+N ! if ( KEY == 1) go to 100 if ( KEY == 2) go to 200 if ( KEY == 3) go to 300 ! if ( RE(1) < 0.0) go to 511 if ( RE(1) > 1.0) go to 512 if ( RE(1) < EPS) RE(1)=EPS if ( AE(1) < 0.0) go to 513 DO 20 I=1,N W(N4-1+I)=RE(1) W(N5-1+I)=AE(1) 20 CONTINUE call U11LS(A,MDA,M,N,W(N4),W(N5),MODE,NP,KRANK,KSURE, & W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) go to 400 ! 100 CONTINUE if ( AE(1) < 0.0) go to 513 DO 120 I=1,N if ( RE(I) < 0.0) go to 511 if ( RE(I) > 1.0) go to 512 if ( RE(I) < EPS) RE(I)=EPS W(N4-1+I)=AE(1) 120 CONTINUE call U11LS(A,MDA,M,N,RE,W(N4),MODE,NP,KRANK,KSURE, & W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) go to 400 ! 200 CONTINUE if ( RE(1) < 0.0) go to 511 if ( RE(1) > 1.0) go to 512 if ( RE(1) < EPS) RE(1)=EPS DO 220 I=1,N W(N4-1+I)=RE(1) if ( AE(I) < 0.0) go to 513 220 CONTINUE call U11LS(A,MDA,M,N,W(N4),AE,MODE,NP,KRANK,KSURE, & W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) go to 400 ! 300 CONTINUE DO 320 I=1,N if ( RE(I) < 0.0) go to 511 if ( RE(I) > 1.0) go to 512 if ( RE(I) < EPS) RE(I)=EPS if ( AE(I) < 0.0) go to 513 320 CONTINUE call U11LS(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE, & W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2)) ! ! DETERMINE INFO ! 400 if ( KRANK /= N) go to 402 INFO=5 go to 410 402 if ( KRANK /= 0) go to 404 INFO=3 go to 410 404 if ( KRANK >= NP) go to 406 INFO=4 return 406 INFO=MODE if ( MODE == 0) RETURN 410 if ( NB == 0) RETURN ! ! SOLUTION PHASE ! N1=1 N2=N1+N N3=N2+N if ( INFO == 2) go to 420 if ( LW < N2-1) go to 510 call U12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK, & RNORM,W(N1),W(N1),IWORK(N1),IWORK(N2)) return ! 420 if ( LW < N3-1) go to 510 call U12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK, & RNORM,W(N1),W(N2),IWORK(N1),IWORK(N2)) return ! ! ERROR MESSAGES ! 501 call XERMSG ('SLATEC', 'LLSIA', & 'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0) return 502 call XERMSG ('SLATEC', 'LLSIA', 'M < 1', 2, 1) return 503 call XERMSG ('SLATEC', 'LLSIA', 'N < 1', 2, 1) return 504 call XERMSG ('SLATEC', 'LLSIA', 'N > M', 2, 1) return 505 call XERMSG ('SLATEC', 'LLSIA', 'MDA < M', 2, 1) return 506 call XERMSG ('SLATEC', 'LLSIA', 'LIW < M+N', 2, 1) return 507 call XERMSG ('SLATEC', 'LLSIA', 'NB < 0', 2, 1) return 508 call XERMSG ('SLATEC', 'LLSIA', 'MDB < M', 2, 1) return 509 call XERMSG ('SLATEC', 'LLSIA', 'KEY OUT OF RANGE', 2, 1) return 510 call XERMSG ('SLATEC', 'LLSIA', 'INSUFFICIENT WORK SPACE', 8, 1) INFO=-1 return 511 call XERMSG ('SLATEC', 'LLSIA', 'RE(I) < 0', 2, 1) return 512 call XERMSG ('SLATEC', 'LLSIA', 'RE(I) > 1', 2, 1) return 513 call XERMSG ('SLATEC', 'LLSIA', 'AE(I) < 0', 2, 1) return 514 call XERMSG ('SLATEC', 'LLSIA', 'INFO OUT OF RANGE', 2, 1) return 515 call XERMSG ('SLATEC', 'LLSIA', 'MODE OUT OF RANGE', 2, 1) return 516 call XERMSG ('SLATEC', 'LLSIA', 'NP OUT OF RANGE', 2, 1) return end subroutine LMPAR (N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, X, & SIGMA, WA1, WA2) ! !! LMPAR is subsidiary to SNLS1 and SNLS1E. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (LMPAR-S, DMPAR-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an M by N matrix A, an N by N nonsingular DIAGONAL ! matrix D, an M-vector B, and a positive number DELTA, ! the problem is to determine a value for the parameter ! PAR such that if X solves the system ! ! A*X = B , SQRT(PAR)*D*X = 0 , ! ! in the least squares sense, and DXNORM is the Euclidean ! norm of D*X, then either PAR is zero and ! ! (DXNORM-DELTA) <= 0.1*DELTA , ! ! or PAR is positive and ! ! ABS(DXNORM-DELTA) <= 0.1*DELTA . ! ! This subroutine completes the solution of the problem ! if it is provided with the necessary information from the ! QR factorization, with column pivoting, of A. That is, if ! A*P = Q*R, where P is a permutation matrix, Q has orthogonal ! columns, and R is an upper triangular matrix with diagonal ! elements of nonincreasing magnitude, then LMPAR expects ! the full upper triangle of R, the permutation matrix P, ! and the first N components of (Q TRANSPOSE)*B. On output ! LMPAR also provides an upper triangular matrix S such that ! ! T T T ! P *(A *A + PAR*D*D)*P = S *S . ! ! S is employed within LMPAR and may be of separate interest. ! ! Only a few iterations are generally needed for convergence ! of the algorithm. If, however, the limit of 10 iterations ! is reached, then the output PAR will contain the best ! value obtained so far. ! ! The subroutine statement is ! ! SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SIGMA, ! WA1,WA2) ! ! where ! ! N is a positive integer input variable set to the order of R. ! ! R is an N by N array. On input the full upper triangle ! must contain the full upper triangle of the matrix R. ! On output the full upper triangle is unaltered, and the ! strict lower triangle contains the strict upper triangle ! (transposed) of the upper triangular matrix S. ! ! LDR is a positive integer input variable not less than N ! which specifies the leading dimension of the array R. ! ! IPVT is an integer input array of length N which defines the ! permutation matrix P such that A*P = Q*R. Column J of P ! is column IPVT(J) of the identity matrix. ! ! DIAG is an input array of length N which must contain the ! diagonal elements of the matrix D. ! ! QTB is an input array of length N which must contain the first ! N elements of the vector (Q TRANSPOSE)*B. ! ! DELTA is a positive input variable which specifies an upper ! bound on the Euclidean norm of D*X. ! ! PAR is a nonnegative variable. On input PAR contains an ! initial estimate of the Levenberg-Marquardt parameter. ! On output PAR contains the final estimate. ! ! X is an output array of length N which contains the least ! squares solution of the system A*X = B, SQRT(PAR)*D*X = 0, ! for the output PAR. ! ! SIGMA is an output array of length N which contains the ! diagonal elements of the upper triangular matrix S. ! ! WA1 and WA2 are work arrays of length N. ! !***SEE ALSO SNLS1, SNLS1E !***ROUTINES CALLED ENORM, QRSOLV, R1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE LMPAR INTEGER N,LDR INTEGER IPVT(*) REAL DELTA,PAR REAL R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA1(*),WA2(*) INTEGER I,ITER,J,JM1,JP1,K,L,NSING REAL DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,SUM,TEMP,ZERO REAL R1MACH,ENORM SAVE P1, P001, ZERO DATA P1,P001,ZERO /1.0E-1,1.0E-3,0.0E0/ !***FIRST EXECUTABLE STATEMENT LMPAR DWARF = R1MACH(1) ! ! COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. if THE ! JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. ! NSING = N DO 10 J = 1, N WA1(J) = QTB(J) if (R(J,J) == ZERO .AND. NSING == N) NSING = J - 1 if (NSING < N) WA1(J) = ZERO 10 CONTINUE if (NSING < 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 < 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 ! ! INITIALIZE THE ITERATION COUNTER. ! EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST ! FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. ! ITER = 0 DO 70 J = 1, N WA2(J) = DIAG(J)*X(J) 70 CONTINUE DXNORM = ENORM(N,WA2) FP = DXNORM - DELTA if (FP <= P1*DELTA) go to 220 ! ! if THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON ! STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF ! THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. ! PARL = ZERO if (NSING < 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 < 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 ! ! CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. ! 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 == ZERO) PARU = DWARF/MIN(DELTA,P1) ! ! if THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), ! SET PAR TO THE CLOSER ENDPOINT. ! PAR = MAX(PAR,PARL) PAR = MIN(PAR,PARU) if (PAR == ZERO) PAR = GNORM/DXNORM ! ! BEGINNING OF AN ITERATION. ! 150 CONTINUE ITER = ITER + 1 ! ! EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. ! if (PAR == ZERO) PAR = MAX(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,SIGMA,WA2) DO 170 J = 1, N WA2(J) = DIAG(J)*X(J) 170 CONTINUE DXNORM = ENORM(N,WA2) TEMP = FP FP = DXNORM - DELTA ! ! if THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE ! OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL ! IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. ! if (ABS(FP) <= P1*DELTA & .OR. PARL == ZERO .AND. FP <= TEMP & .AND. TEMP < ZERO .OR. ITER == 10) go to 220 ! ! COMPUTE THE NEWTON CORRECTION. ! 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)/SIGMA(J) TEMP = WA1(J) JP1 = J + 1 if (N < 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 ! ! DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. ! if (FP > ZERO) PARL = MAX(PARL,PAR) if (FP < ZERO) PARU = MIN(PARU,PAR) ! ! COMPUTE AN IMPROVED ESTIMATE FOR PAR. ! PAR = MAX(PARL,PAR+PARC) ! ! END OF AN ITERATION. ! go to 150 220 CONTINUE ! ! TERMINATION. ! if (ITER == 0) PAR = ZERO return end subroutine LPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, IS) ! !! LPDP is subsidiary to LSEI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (LPDP-S, DLPDP-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), ! where N=N1+N2. This is a slight overestimate for WS(*). ! ! Determine an N1-vector W, and ! an N2-vector Z ! which minimizes the Euclidean length of W ! subject to G*W+H*Z >= Y. ! This is the least projected distance problem, LPDP. ! The matrices G and H are of respective ! dimensions M by N1 and M by N2. ! ! Called by subprogram LSI( ). ! ! The matrix ! (G H Y) ! ! occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*). ! ! The solution (W) is returned in X(*). ! (Z) ! ! The value of MODE indicates the status of ! the computation after returning to the user. ! ! MODE=1 The solution was successfully obtained. ! ! MODE=2 The inequalities are inconsistent. ! !***SEE ALSO LSEI !***ROUTINES CALLED SCOPY, SDOT, SNRM2, SSCAL, WNNLS !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE LPDP ! ! SUBROUTINES CALLED ! ! WNNLS SOLVES A NONNEGATIVELY CONSTRAINED LINEAR LEAST ! SQUARES PROBLEM WITH LINEAR EQUALITY CONSTRAINTS. ! PART OF THIS PACKAGE. ! !++ ! SDOT, SUBROUTINES FROM THE BLAS PACKAGE. ! SSCAL,SNRM2, SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308. ! SCOPY ! REAL A(MDA,*), PRGOPT(*), WS(*), WNORM, X(*) INTEGER IS(*) REAL FAC, ONE, RNORM, SC, YNORM, ZERO REAL SDOT, SNRM2 SAVE ZERO, ONE, FAC DATA ZERO, ONE /0.E0,1.E0/, FAC /0.1E0/ !***FIRST EXECUTABLE STATEMENT LPDP N = N1 + N2 MODE = 1 if (.NOT.(M <= 0)) go to 20 if (.NOT.(N > 0)) go to 10 X(1) = ZERO call SCOPY(N, X, 0, X, 1) 10 WNORM = ZERO return 20 NP1 = N + 1 ! ! SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. DO 40 I=1,M SC = SNRM2(N,A(I,1),MDA) if (.NOT.(SC /= ZERO)) go to 30 SC = ONE/SC call SSCAL(NP1, SC, A(I,1), MDA) 30 CONTINUE 40 CONTINUE ! ! SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). YNORM = SNRM2(M,A(1,NP1),1) if (.NOT.(YNORM /= ZERO)) go to 50 SC = ONE/YNORM call SSCAL(M, SC, A(1,NP1), 1) ! ! SCALE COLS OF MATRIX H. 50 J = N1 + 1 60 if (.NOT.(J <= N)) go to 70 SC = SNRM2(M,A(1,J),1) if (SC /= 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 > 0)) go to 130 ! ! COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). IW = 0 DO 80 I=1,M ! ! MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. call SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) IW = IW + N2 ! ! MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. call SCOPY(N1, A(I,1), MDA, WS(IW+1), 1) IW = IW + N1 ! ! 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 ! ! SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U >= 0. THE ! MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR ! F = TRANSPOSE OF (0,...,0,1). IX = IW + 1 IW = IW + M ! ! DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ). IS(1) = 0 IS(2) = 0 call WNNLS(WS, NP1, N2, NP1-N2, M, 0, PRGOPT, WS(IX), RNORM, & MODEW, IS, WS(IW+1)) ! ! 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) /= ONE .AND. RNORM > 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 ! ! 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 120 110 MODE = 2 return 120 CONTINUE 130 if (.NOT.(N2 > 0)) go to 180 ! ! 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 ! ! SOLVE RV=S SUBJECT TO V >= 0. THE MATRIX R =(TRANSPOSE ! OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE ! OF (0,...,0,1)). ! ! DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ). IS(1) = 0 IS(2) = 0 call WNNLS(WS, N2+1, 0, N2+1, M, 0, PRGOPT, WS(IX), RNORM, MODEW, & IS, WS(IW+1)) ! ! COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1) if (.NOT.(ONE+FAC*ABS(SC) /= ONE .AND. RNORM > 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 170 160 MODE = 2 return 170 CONTINUE ! ! ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. 180 call SSCAL(N, YNORM, X, 1) WNORM = SNRM2(N1,X,1) return end LOGICAL FUNCTION LSAME (CA, CB) ! !! LSAME tests two characters to determine if they are the same ... ! letter, except for case. ! !***LIBRARY SLATEC !***CATEGORY R, N3 !***TYPE LOGICAL (LSAME-L) !***KEYWORDS CHARACTER COMPARISON, LEVEL 2 BLAS, LEVEL 3 BLAS !***AUTHOR Hanson, R., (SNLA) ! Du Croz, J., (NAG) !***DESCRIPTION ! ! LSAME tests if CA is the same letter as CB regardless of case. ! CB is assumed to be an upper case letter. LSAME returns .TRUE. if ! CA is either the same as CB or the equivalent lower case letter. ! ! N.B. This version of the code is correct for both ASCII and EBCDIC ! systems. Installers must modify the routine for other ! character-codes. ! ! For CDC systems using 6-12 bit representations, the system- ! specific code in comments must be activated. ! ! Parameters ! ========== ! ! CA - CHARACTER*1 ! CB - CHARACTER*1 ! On entry, CA and CB specify characters to be compared. ! Unchanged on exit. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 860720 DATE WRITTEN ! 910606 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) ! 910607 Modified to handle ASCII and EBCDIC codes. (WRB) ! 930201 Tests for equality and equivalence combined. (RWC and WRB) !***END PROLOGUE LSAME ! .. Scalar Arguments .. CHARACTER CA*1, CB*1 ! .. Local Scalars .. INTEGER IOFF LOGICAL FIRST ! .. Intrinsic Functions .. INTRINSIC ICHAR ! .. Save statement .. SAVE FIRST, IOFF ! .. Data statements .. DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT LSAME if (FIRST) IOFF = ICHAR('a') - ICHAR('A') ! FIRST = .FALSE. ! ! Test if the characters are equal or equivalent. ! LSAME = (CA == CB) .OR. (ICHAR(CA)-IOFF == ICHAR(CB)) ! return ! ! The following comments contain code for CDC systems using 6-12 bit ! representations. ! ! .. Parameters .. ! INTEGER ICIRFX ! PARAMETER ( ICIRFX=62 ) ! .. Scalar Arguments .. ! CHARACTER*1 CB ! .. Array Arguments .. ! CHARACTER*1 CA(*) ! .. Local Scalars .. ! INTEGER IVAL ! .. Intrinsic Functions .. ! INTRINSIC ICHAR, CHAR ! .. Executable Statements .. ! INTRINSIC ICHAR, CHAR ! ! See if the first character in string CA equals string CB. ! ! LSAME = CA(1) == CB .AND. CA(1) /= CHAR(ICIRFX) ! ! if (LSAME) RETURN ! ! The characters are not identical. Now check them for equivalence. ! Look for the 'escape' character, circumflex, followed by the ! letter. ! ! IVAL = ICHAR(CA(2)) ! if (IVAL >= ICHAR('A') .AND. IVAL <= ICHAR('Z')) THEN ! LSAME = CA(1) == CHAR(ICIRFX) .AND. CA(2) == CB ! ENDIF ! ! return ! ! End of LSAME. ! end subroutine LSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, & MODE, WS, IP) ! !! LSEI solves a linearly constrained least squares problem with ... ! equality and inequality constraints, and optionally compute ! a covariance matrix. ! !***LIBRARY SLATEC !***CATEGORY K1A2A, D9 !***TYPE SINGLE PRECISION (LSEI-S, DLSEI-D) !***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, ! EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, ! QUADRATIC PROGRAMMING !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! Abstract ! ! This subprogram solves a linearly constrained least squares ! problem with both equality and inequality constraints, and, if the ! user requests, obtains a covariance matrix of the solution ! parameters. ! ! Suppose there are given matrices E, A and G of respective ! dimensions ME by N, MA by N and MG by N, and vectors F, B and H of ! respective lengths ME, MA and MG. This subroutine solves the ! linearly constrained least squares problem ! ! EX = F, (E ME by N) (equations to be exactly ! satisfied) ! AX = B, (A MA by N) (equations to be ! approximately satisfied, ! least squares sense) ! GX >= H,(G MG by N) (inequality constraints) ! ! The inequalities GX >= H mean that every component of the ! product GX must be >= the corresponding component of H. ! ! In case the equality constraints cannot be satisfied, a ! generalized inverse solution residual vector length is obtained ! for F-EX. This is the minimal length possible for F-EX. ! ! Any values ME >= 0, MA >= 0, or MG >= 0 are permitted. The ! rank of the matrix E is estimated during the computation. We call ! this value KRANKE. It is an output parameter in IP(1) defined ! below. Using a generalized inverse solution of EX=F, a reduced ! least squares problem with inequality constraints is obtained. ! The tolerances used in these tests for determining the rank ! of E and the rank of the reduced least squares problem are ! given in Sandia Tech. Rept. SAND-78-1290. They can be ! modified by the user if new values are provided in ! the option list of the array PRGOPT(*). ! ! The user must dimension all arrays appearing in the call list.. ! W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) ! where K=MAX(MA+MG,N). This allows for a solution of a range of ! problems in the given working space. The dimension of WS(*) ! given is a necessary overestimate. Once a particular problem ! has been run, the output parameter IP(3) gives the actual ! dimension required for that problem. ! ! The parameters for LSEI( ) are ! ! Input.. ! ! W(*,*),MDW, The array W(*,*) is doubly subscripted with ! ME,MA,MG,N first dimensioning parameter equal to MDW. ! For this discussion let us call M = ME+MA+MG. Then ! MDW must satisfy MDW >= M. The condition ! MDW < M is an error. ! ! The array W(*,*) contains the matrices and vectors ! ! (E F) ! (A B) ! (G H) ! ! in rows and columns 1,...,M and 1,...,N+1 ! respectively. ! ! The integers ME, MA, and MG are the ! respective matrix row dimensions ! of E, A and G. Each matrix has N columns. ! ! PRGOPT(*) This real-valued array is the option vector. ! If the user is satisfied with the nominal ! subprogram features set ! ! PRGOPT(1)=1 (or PRGOPT(1)=1.0) ! ! Otherwise PRGOPT(*) is a linked list consisting of ! groups of data of the following form ! ! LINK ! KEY ! DATA SET ! ! The parameters LINK and KEY are each one word. ! The DATA SET can be comprised of several words. ! The number of items depends on the value of KEY. ! The value of LINK points to the first ! entry of the next group of data within ! PRGOPT(*). The exception is when there are ! no more options to change. In that ! case, LINK=1 and the values KEY and DATA SET ! are not referenced. The general layout of ! PRGOPT(*) is as follows. ! ! ...PRGOPT(1) = LINK1 (link to first entry of next group) ! . PRGOPT(2) = KEY1 (key to the option change) ! . PRGOPT(3) = data value (data value for this change) ! . . ! . . ! . . ! ...PRGOPT(LINK1) = LINK2 (link to the first entry of ! . next group) ! . PRGOPT(LINK1+1) = KEY2 (key to the option change) ! . PRGOPT(LINK1+2) = data value ! ... . ! . . ! . . ! ...PRGOPT(LINK) = 1 (no more options to change) ! ! Values of LINK that are nonpositive are errors. ! A value of LINK > NLINK=100000 is also an error. ! This helps prevent using invalid but positive ! values of LINK that will probably extend ! beyond the program limits of PRGOPT(*). ! Unrecognized values of KEY are ignored. The ! order of the options is arbitrary and any number ! of options can be changed with the following ! restriction. To prevent cycling in the ! processing of the option array, a count of the ! number of options changed is maintained. ! Whenever this count exceeds NOPT=1000, an error ! message is printed and the subprogram returns. ! ! Options.. ! ! KEY=1 ! Compute in W(*,*) the N by N ! covariance matrix of the solution variables ! as an output parameter. Nominally the ! covariance matrix will not be computed. ! (This requires no user input.) ! The data set for this option is a single value. ! It must be nonzero when the covariance matrix ! is desired. If it is zero, the covariance ! matrix is not computed. When the covariance matrix ! is computed, the first dimensioning parameter ! of the array W(*,*) must satisfy MDW >= MAX(M,N). ! ! KEY=10 ! Suppress scaling of the inverse of the ! normal matrix by the scale factor RNORM**2/ ! MAX(1, no. of degrees of freedom). This option ! only applies when the option for computing the ! covariance matrix (KEY=1) is used. With KEY=1 and ! KEY=10 used as options the unscaled inverse of the ! normal matrix is returned in W(*,*). ! The data set for this option is a single value. ! When it is nonzero no scaling is done. When it is ! zero scaling is done. The nominal case is to do ! scaling so if option (KEY=1) is used alone, the ! matrix will be scaled on output. ! ! KEY=2 ! Scale the nonzero columns of the ! entire data matrix. ! (E) ! (A) ! (G) ! ! to have length one. The data set for this ! option is a single value. It must be ! nonzero if unit length column scaling ! is desired. ! ! KEY=3 ! Scale columns of the entire data matrix ! (E) ! (A) ! (G) ! ! with a user-provided diagonal matrix. ! The data set for this option consists ! of the N diagonal scaling factors, one for ! each matrix column. ! ! KEY=4 ! Change the rank determination tolerance for ! the equality constraint equations from ! the nominal value of SQRT(SRELPR). This quantity can ! be no smaller than SRELPR, the arithmetic- ! storage precision. The quantity SRELPR is the ! largest positive number such that T=1.+SRELPR ! satisfies T == 1. The quantity used ! here is internally restricted to be at ! least SRELPR. The data set for this option ! is the new tolerance. ! ! KEY=5 ! Change the rank determination tolerance for ! the reduced least squares equations from ! the nominal value of SQRT(SRELPR). This quantity can ! be no smaller than SRELPR, the arithmetic- ! storage precision. The quantity used ! here is internally restricted to be at ! least SRELPR. The data set for this option ! is the new tolerance. ! ! For example, suppose we want to change ! the tolerance for the reduced least squares ! problem, compute the covariance matrix of ! the solution parameters, and provide ! column scaling for the data matrix. For ! these options the dimension of PRGOPT(*) ! must be at least N+9. The Fortran statements ! defining these options would be as follows: ! ! PRGOPT(1)=4 (link to entry 4 in PRGOPT(*)) ! PRGOPT(2)=1 (covariance matrix key) ! PRGOPT(3)=1 (covariance matrix wanted) ! ! PRGOPT(4)=7 (link to entry 7 in PRGOPT(*)) ! PRGOPT(5)=5 (least squares equas. tolerance key) ! PRGOPT(6)=... (new value of the tolerance) ! ! PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*)) ! PRGOPT(8)=3 (user-provided column scaling key) ! ! call SCOPY (N, D, 1, PRGOPT(9), 1) (Copy the N ! scaling factors from the user array D(*) ! to PRGOPT(9)-PRGOPT(N+8)) ! ! PRGOPT(N+9)=1 (no more options to change) ! ! The contents of PRGOPT(*) are not modified ! by the subprogram. ! The options for WNNLS( ) can also be included ! in this array. The values of KEY recognized ! by WNNLS( ) are 6, 7 and 8. Their functions ! are documented in the usage instructions for ! subroutine WNNLS( ). Normally these options ! do not need to be modified when using LSEI( ). ! ! IP(1), The amounts of working storage actually ! IP(2) allocated for the working arrays WS(*) and ! IP(*), respectively. These quantities are ! compared with the actual amounts of storage ! needed by LSEI( ). Insufficient storage ! allocated for either WS(*) or IP(*) is an ! error. This feature was included in LSEI( ) ! because miscalculating the storage formulas ! for WS(*) and IP(*) might very well lead to ! subtle and hard-to-find execution errors. ! ! The length of WS(*) must be at least ! ! LW = 2*(ME+N)+K+(MG+2)*(N+7) ! ! where K = max(MA+MG,N) ! This test will not be made if IP(1) <= 0. ! ! The length of IP(*) must be at least ! ! LIP = MG+2*N+2 ! This test will not be made if IP(2) <= 0. ! ! Output.. ! ! X(*),RNORME, The array X(*) contains the solution parameters ! RNORML if the integer output flag MODE = 0 or 1. ! The definition of MODE is given directly below. ! When MODE = 0 or 1, RNORME and RNORML ! respectively contain the residual vector ! Euclidean lengths of F - EX and B - AX. When ! MODE=1 the equality constraint equations EX=F ! are contradictory, so RNORME /= 0. The residual ! vector F-EX has minimal Euclidean length. For ! MODE >= 2, none of these parameters is defined. ! ! MODE Integer flag that indicates the subprogram ! status after completion. If MODE >= 2, no ! solution has been computed. ! ! MODE = ! ! 0 Both equality and inequality constraints ! are compatible and have been satisfied. ! ! 1 Equality constraints are contradictory. ! A generalized inverse solution of EX=F was used ! to minimize the residual vector length F-EX. ! In this sense, the solution is still meaningful. ! ! 2 Inequality constraints are contradictory. ! ! 3 Both equality and inequality constraints ! are contradictory. ! ! The following interpretation of ! MODE=1,2 or 3 must be made. The ! sets consisting of all solutions ! of the equality constraints EX=F ! and all vectors satisfying GX >= H ! have no points in common. (In ! particular this does not say that ! each individual set has no points ! at all, although this could be the ! case.) ! ! 4 Usage error occurred. The value ! of MDW is < ME+MA+MG, MDW is ! < N and a covariance matrix is ! requested, or the option vector ! PRGOPT(*) is not properly defined, ! or the lengths of the working arrays ! WS(*) and IP(*), when specified in ! IP(1) and IP(2) respectively, are not ! long enough. ! ! W(*,*) The array W(*,*) contains the N by N symmetric ! covariance matrix of the solution parameters, ! provided this was requested on input with ! the option vector PRGOPT(*) and the output ! flag is returned with MODE = 0 or 1. ! ! IP(*) The integer working array has three entries ! that provide rank and working array length ! information after completion. ! ! IP(1) = rank of equality constraint ! matrix. Define this quantity ! as KRANKE. ! ! IP(2) = rank of reduced least squares ! problem. ! ! IP(3) = the amount of storage in the ! working array WS(*) that was ! actually used by the subprogram. ! The formula given above for the length ! of WS(*) is a necessary overestimate. ! If exactly the same problem matrices ! are used in subsequent executions, ! the declared dimension of WS(*) can ! be reduced to this output value. ! User Designated ! Working Arrays.. ! ! WS(*),IP(*) These are respectively type real ! and type integer working arrays. ! Their required minimal lengths are ! given above. ! !***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for ! linear least squares problems with equality and ! nonnegativity constraints, Report SAND77-0552, Sandia ! Laboratories, June 1978. ! K. H. Haskell and R. J. Hanson, Selected algorithms for ! the linearly constrained least squares problem - a ! users guide, Report SAND78-1290, Sandia Laboratories, ! August 1979. ! K. H. Haskell and R. J. Hanson, An algorithm for ! linear least squares problems with equality and ! nonnegativity constraints, Mathematical Programming ! 21 (1981), pp. 98-118. ! R. J. Hanson and K. H. Haskell, Two algorithms for the ! linearly constrained least squares problem, ACM ! Transactions on Mathematical Software, September 1982. !***ROUTINES CALLED H12, LSI, R1MACH, SASUM, SAXPY, SCOPY, SDOT, SNRM2, ! SSCAL, SSWAP, XERMSG !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and extensively revised (WRB & RWC) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE LSEI INTEGER IP(3), MA, MDW, ME, MG, MODE, N REAL PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*) ! EXTERNAL H12, LSI, R1MACH, SASUM, SAXPY, SCOPY, SDOT, SNRM2, & SSCAL, SSWAP, XERMSG REAL R1MACH, SASUM, SDOT, SNRM2 ! REAL ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, SN, & SNMAX, SRELPR, T, TAU, UJ, UP, VJ, XNORM, XNRME INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M, & MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1, & NTIMES LOGICAL COV, FIRST CHARACTER*8 XERN1, XERN2, XERN3, XERN4 SAVE FIRST, SRELPR ! DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT LSEI ! ! Set the nominal tolerance used in the code for the equality ! constraint equations. ! if (FIRST) SRELPR = R1MACH(4) FIRST = .FALSE. TAU = SQRT(SRELPR) ! ! Check that enough storage was allocated in WS(*) and IP(*). ! MODE = 4 if (MIN(N,ME,MA,MG) < 0) THEN WRITE (XERN1, '(I8)') N WRITE (XERN2, '(I8)') ME WRITE (XERN3, '(I8)') MA WRITE (XERN4, '(I8)') MG call XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' // & ' MA, MG MUST BE >= 0$$ENTERED ROUTINE WITH' // & '$$N = ' // XERN1 // & '$$ME = ' // XERN2 // & '$$MA = ' // XERN3 // & '$$MG = ' // XERN4, 2, 1) return end if ! if (IP(1) > 0) THEN LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7) if (IP(1) < LCHK) THEN WRITE (XERN1, '(I8)') LCHK call XERMSG ('SLATEC', 'LSEI', 'INSUFFICIENT STORAGE ' // & 'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1) return ENDIF end if ! if (IP(2) > 0) THEN LCHK = MG + 2*N + 2 if (IP(2) < LCHK) THEN WRITE (XERN1, '(I8)') LCHK call XERMSG ('SLATEC', 'LSEI', 'INSUFFICIENT STORAGE ' // & 'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1) return ENDIF end if ! ! Compute number of possible right multiplying Householder ! transformations. ! M = ME + MA + MG if (N <= 0 .OR. M <= 0) THEN MODE = 0 RNORME = 0 RNORML = 0 return end if ! if (MDW < M) THEN call XERMSG ('SLATEC', 'LSEI', 'MDW < ME+MA+MG IS AN ERROR', & 2, 1) return end if ! NP1 = N + 1 KRANKE = MIN(ME,N) N1 = 2*KRANKE + 1 N2 = N1 + N ! ! Set nominal values. ! ! The nominal column scaling used in the code is ! the identity scaling. ! call SCOPY (N, 1.E0, 0, WS(N1), 1) ! ! No covariance matrix is nominally computed. ! COV = .FALSE. ! ! Process option vector. ! Define bound for number of options to change. ! NOPT = 1000 NTIMES = 0 ! ! Define bound for positive values of LINK. ! NLINK = 100000 LAST = 1 LINK = PRGOPT(1) if (LINK == 0 .OR. LINK > NLINK) THEN call XERMSG ('SLATEC', 'LSEI', & 'THE OPTION VECTOR IS UNDEFINED', 2, 1) return end if ! 100 if (LINK > 1) THEN NTIMES = NTIMES + 1 if (NTIMES > NOPT) THEN call XERMSG ('SLATEC', 'LSEI', & 'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1) return ENDIF ! KEY = PRGOPT(LAST+1) if (KEY == 1) THEN COV = PRGOPT(LAST+2) /= 0.E0 ELSEIF (KEY == 2 .AND. PRGOPT(LAST+2) /= 0.E0) THEN DO 110 J = 1,N T = SNRM2(M,W(1,J),1) if (T /= 0.E0) T = 1.E0/T WS(J+N1-1) = T 110 CONTINUE ELSEIF (KEY == 3) THEN call SCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1) ELSEIF (KEY == 4) THEN TAU = MAX(SRELPR,PRGOPT(LAST+2)) ENDIF ! NEXT = PRGOPT(LINK) if (NEXT <= 0 .OR. NEXT > NLINK) THEN call XERMSG ('SLATEC', 'LSEI', & 'THE OPTION VECTOR IS UNDEFINED', 2, 1) return ENDIF ! LAST = LINK LINK = NEXT go to 100 end if ! DO 120 J = 1,N call SSCAL (M, WS(N1+J-1), W(1,J), 1) 120 CONTINUE ! if (COV .AND. MDW < N) THEN call XERMSG ('SLATEC', 'LSEI', & 'MDW < N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1) return end if ! ! Problem definition and option vector OK. ! MODE = 0 ! ! Compute norm of equality constraint matrix and right side. ! ENORM = 0.E0 DO 130 J = 1,N ENORM = MAX(ENORM,SASUM(ME,W(1,J),1)) 130 CONTINUE ! FNORM = SASUM(ME,W(1,NP1),1) SNMAX = 0.E0 RNMAX = 0.E0 DO 150 I = 1,KRANKE ! ! Compute maximum ratio of vector lengths. Partition is at ! column I. ! DO 140 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 (RN == 0.E0 .AND. SN > SNMAX) THEN SNMAX = SN IMAX = K ELSEIF (K == I .OR. SN*RNMAX > RN*SNMAX) THEN SNMAX = SN RNMAX = RN IMAX = K ENDIF 140 CONTINUE ! ! Interchange rows if necessary. ! if (I /= IMAX) call SSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW) if (SNMAX > RNMAX*TAU**2) THEN ! ! Eliminate elements 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) ELSE KRANKE = I - 1 go to 160 ENDIF 150 CONTINUE ! ! Save diagonal terms of lower trapezoidal matrix. ! 160 call SCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1) ! ! Use Householder transformation from left to achieve ! KRANKE by KRANKE upper triangular form. ! if (KRANKE < ME) THEN DO 170 K = KRANKE,1,-1 ! ! Apply transformation to matrix cols. 1,...,K-1. ! call H12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, K-1) ! ! Apply to rt side vector. ! call H12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, 1, & 1) 170 CONTINUE end if ! ! Solve for variables 1,...,KRANKE in new coordinates. ! call SCOPY (KRANKE, W(1, NP1), 1, X, 1) DO 180 I = 1,KRANKE X(I) = (X(I)-SDOT(I-1,W(I,1),MDW,X,1))/W(I,I) 180 CONTINUE ! ! Compute residuals for reduced problem. ! MEP1 = ME + 1 RNORML = 0.E0 DO 190 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 (RN <= SN*TAU**2 .AND. KRANKE < N) & call SCOPY (N-KRANKE, 0.E0, 0, W(I,KRANKE+1), MDW) 190 CONTINUE ! ! Compute equality constraint equations residual length. ! RNORME = SNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) ! ! Move reduced problem data upward if KRANKE < ME. ! if (KRANKE < ME) THEN DO 200 J = 1,NP1 call SCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) 200 CONTINUE end if ! ! Compute solution of reduced problem. ! call LSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, & X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) ! ! Test for consistency of equality constraints. ! if (ME > 0) THEN MDEQC = 0 XNRME = SASUM(KRANKE,W(1,NP1),1) if (RNORME > TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 MODE = MODE + MDEQC ! ! Check if solution to equality constraints satisfies inequality ! constraints when there are no degrees of freedom left. ! if (KRANKE == N .AND. MG > 0) THEN XNORM = SASUM(N,X,1) MAPKE1 = MA + KRANKE + 1 MEND = MA + KRANKE + MG DO 210 I = MAPKE1,MEND SIZE = SASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) if (W(I,NP1) > TAU*SIZE) THEN MODE = MODE + 2 go to 290 ENDIF 210 CONTINUE ENDIF end if ! ! Replace diagonal terms of lower trapezoidal matrix. ! if (KRANKE > 0) THEN call SCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1) ! ! Reapply transformation to put solution in original coordinates. ! DO 220 I = KRANKE,1,-1 call H12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) 220 CONTINUE ! ! Compute covariance matrix of equality constrained problem. ! if (COV) THEN DO 270 J = MIN(KRANKE,N-1),1,-1 RB = WS(J)*W(J,J) if (RB /= 0.E0) RB = 1.E0/RB JP1 = J + 1 DO 230 I = JP1,N W(I,J) = RB*SDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW) 230 CONTINUE ! GAM = 0.5E0*RB*SDOT(N-J,W(JP1,J),1,W(J,JP1),MDW) call SAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) DO 250 I = JP1,N DO 240 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) 240 CONTINUE 250 CONTINUE UJ = WS(J) VJ = GAM*UJ W(J,J) = UJ*VJ + UJ*VJ DO 260 I = JP1,N W(J,I) = UJ*W(I,J) + VJ*W(J,I) 260 CONTINUE call SCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1) 270 CONTINUE ENDIF end if ! ! Apply the scaling to the covariance matrix. ! if (COV) THEN DO 280 I = 1,N call SSCAL (N, WS(I+N1-1), W(I,1), MDW) call SSCAL (N, WS(I+N1-1), W(1,I), 1) 280 CONTINUE end if ! ! Rescale solution vector. ! 290 if (MODE <= 1) THEN DO 300 J = 1,N X(J) = X(J)*WS(N1+J-1) 300 CONTINUE end if ! IP(1) = KRANKE IP(3) = IP(3) + 2*KRANKE + N return end subroutine LSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, IP) ! !! LSI is subsidiary to LSEI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (LSI-S, DLSI-D) !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! This is a companion subprogram to LSEI. The documentation for ! LSEI has complete usage instructions. ! ! Solve.. ! AX = B, A MA by N (least squares equations) ! subject to.. ! ! GX >= H, G MG by N (inequality constraints) ! ! Input.. ! ! W(*,*) contains (A B) in rows 1,...,MA+MG, cols 1,...,N+1. ! (G H) ! ! MDW,MA,MG,N ! contain (resp) var. dimension of W(*,*), ! and matrix dimensions. ! ! PRGOPT(*), ! Program option vector. ! ! OUTPUT.. ! ! X(*),RNORM ! ! Solution vector(unless MODE=2), length of AX-B. ! ! MODE ! =0 Inequality constraints are compatible. ! =2 Inequality constraints contradictory. ! ! WS(*), ! Working storage of dimension K+N+(MG+2)*(N+7), ! where K=MAX(MA+MG,N). ! IP(MG+2*N+1) ! Integer working storage ! !***ROUTINES CALLED H12, HFTI, LPDP, R1MACH, SASUM, SAXPY, SCOPY, SDOT, ! SSCAL, SSWAP !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and extensively revised (WRB & RWC) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 920422 Changed call to HFTI to include variable MA. (WRB) !***END PROLOGUE LSI INTEGER IP(*), MA, MDW, MG, MODE, N REAL PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*) ! EXTERNAL H12, HFTI, LPDP, R1MACH, SASUM, SAXPY, SCOPY, SDOT, & SSCAL, SSWAP REAL R1MACH, SASUM, SDOT ! REAL ANORM, FAC, GAM, RB, SRELPR, TAU, TOL, XNORM INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1, & MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1 LOGICAL COV, FIRST, SCLCOV ! SAVE SRELPR, FIRST DATA FIRST /.TRUE./ ! !***FIRST EXECUTABLE STATEMENT LSI ! ! Set the nominal tolerance used in the code. ! if (FIRST) SRELPR = R1MACH(4) FIRST = .FALSE. TOL = SQRT(SRELPR) ! MODE = 0 RNORM = 0.E0 M = MA + MG NP1 = N + 1 KRANK = 0 if (N <= 0 .OR. M <= 0) go to 370 ! ! To process option vector. ! COV = .FALSE. SCLCOV = .TRUE. LAST = 1 LINK = PRGOPT(1) ! 100 if (LINK > 1) THEN KEY = PRGOPT(LAST+1) if (KEY == 1) COV = PRGOPT(LAST+2) /= 0.E0 if (KEY == 10) SCLCOV = PRGOPT(LAST+2) == 0.E0 if (KEY == 5) TOL = MAX(SRELPR,PRGOPT(LAST+2)) NEXT = PRGOPT(LINK) LAST = LINK LINK = NEXT go to 100 end if ! ! Compute matrix norm of least squares equations. ! ANORM = 0.E0 DO 110 J = 1,N ANORM = MAX(ANORM,SASUM(MA,W(1,J),1)) 110 CONTINUE ! ! Set tolerance for HFTI( ) rank test. ! TAU = TOL*ANORM ! ! Compute Householder orthogonal decomposition of matrix. ! call SCOPY (N, 0.E0, 0, WS, 1) call SCOPY (MA, W(1, NP1), 1, WS, 1) K = MAX(M,N) MINMAN = MIN(MA,N) N1 = K + 1 N2 = N1 + N call HFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, RNORM, WS(N2), & WS(N1), IP) FAC = 1.E0 GAM = MA - KRANK if (KRANK < MA .AND. SCLCOV) FAC = RNORM**2/GAM ! ! Reduce to LPDP and solve. ! MAP1 = MA + 1 ! ! Compute inequality rt-hand side for LPDP. ! if (MA < M) THEN if (MINMAN > 0) THEN DO 120 I = MAP1,M W(I,NP1) = W(I,NP1) - SDOT(N,W(I,1),MDW,WS,1) 120 CONTINUE ! ! Apply permutations to col. of inequality constraint matrix. ! DO 130 I = 1,MINMAN call SSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1) 130 CONTINUE ! ! Apply Householder transformations to constraint matrix. ! if (KRANK > 0 .AND. KRANK < N) THEN DO 140 I = KRANK,1,-1 call H12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), & W(MAP1,1), MDW, 1, MG) 140 CONTINUE ENDIF ! ! Compute permuted inequality constraint matrix times r-inv. ! DO 160 I = MAP1,M DO 150 J = 1,KRANK W(I,J) = (W(I,J)-SDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) 150 CONTINUE 160 CONTINUE ENDIF ! ! Solve the reduced problem with LPDP algorithm, ! the least projected distance problem. ! call LPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X, & XNORM, MDLPDP, WS(N2), IP(N+1)) ! ! Compute solution in original coordinates. ! if (MDLPDP == 1) THEN DO 170 I = KRANK,1,-1 X(I) = (X(I)-SDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I) 170 CONTINUE ! ! Apply Householder transformation to solution vector. ! if (KRANK < N) THEN DO 180 I = 1,KRANK call H12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1), & X, 1, 1, 1) 180 CONTINUE ENDIF ! ! Repermute variables to their input order. ! if (MINMAN > 0) THEN DO 190 I = MINMAN,1,-1 call SSWAP (1, X(I), 1, X(IP(I)), 1) 190 CONTINUE ! ! Variables are now in original coordinates. ! Add solution of unconstrained problem. ! DO 200 I = 1,N X(I) = X(I) + WS(I) 200 CONTINUE ! ! Compute the residual vector norm. ! RNORM = SQRT(RNORM**2+XNORM**2) ENDIF ELSE MODE = 2 ENDIF ELSE call SCOPY (N, WS, 1, X, 1) end if ! ! Compute covariance matrix based on the orthogonal decomposition ! from HFTI( ). ! if (.NOT.COV .OR. KRANK <= 0) go to 370 KRM1 = KRANK - 1 KRP1 = KRANK + 1 ! ! Copy diagonal terms to working array. ! call SCOPY (KRANK, W, MDW+1, WS(N2), 1) ! ! Reciprocate diagonal terms. ! DO 210 J = 1,KRANK W(J,J) = 1.E0/W(J,J) 210 CONTINUE ! ! Invert the upper triangular QR factor on itself. ! if (KRANK > 1) THEN DO 230 I = 1,KRM1 DO 220 J = I+1,KRANK W(I,J) = -SDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) 220 CONTINUE 230 CONTINUE end if ! ! Compute the inverted factor times its transpose. ! DO 250 I = 1,KRANK DO 240 J = I,KRANK W(I,J) = SDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) 240 CONTINUE 250 CONTINUE ! ! Zero out lower trapezoidal part. ! Copy upper triangular to lower triangular part. ! if (KRANK < N) THEN DO 260 J = 1,KRANK call SCOPY (J, W(1,J), 1, W(J,1), MDW) 260 CONTINUE ! DO 270 I = KRP1,N call SCOPY (I, 0.E0, 0, W(I,1), MDW) 270 CONTINUE ! ! Apply right side transformations to lower triangle. ! N3 = N2 + KRP1 DO 330 I = 1,KRANK L = N1 + I K = N2 + I RB = WS(L-1)*WS(K-1) ! ! If RB >= 0.E0, transformation can be regarded as zero. ! if (RB < 0.E0) THEN RB = 1.E0/RB ! ! Store unscaled rank one Householder update in work array. ! call SCOPY (N, 0.E0, 0, WS(N3), 1) L = N1 + I K = N3 + I WS(K-1) = WS(L-1) ! DO 280 J = KRP1,N WS(N3+J-1) = W(I,J) 280 CONTINUE ! DO 290 J = 1,N WS(J) = RB*(SDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+ & SDOT(N-J+1,W(J,J),1,WS(N3+J-1),1)) 290 CONTINUE ! L = N3 + I GAM = 0.5E0*RB*SDOT(N-I+1,WS(L-1),1,WS(I),1) call SAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1) DO 320 J = I,N DO 300 L = 1,I-1 W(J,L) = W(J,L) + WS(N3+J-1)*WS(L) 300 CONTINUE ! DO 310 L = I,J W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1) 310 CONTINUE 320 CONTINUE ENDIF 330 CONTINUE ! ! Copy lower triangle to upper triangle to symmetrize the ! covariance matrix. ! DO 340 I = 1,N call SCOPY (I, W(I,1), MDW, W(1,I), 1) 340 CONTINUE end if ! ! Repermute rows and columns. ! DO 350 I = MINMAN,1,-1 K = IP(I) if (I /= K) THEN 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) ENDIF 350 CONTINUE ! ! Put in normalized residual sum of squares scale factor ! and symmetrize the resulting covariance matrix. ! DO 360 J = 1,N call SSCAL (J, FAC, W(1,J), 1) call SCOPY (J, W(1,J), 1, W(J,1), MDW) 360 CONTINUE ! 370 IP(1) = KRANK IP(2) = N + MAX(M,N) + (MG+2)*(N+7) return end subroutine LSOD (F, NEQ, T, Y, TOUT, RTOL, ATOL, IDID, YPOUT, YH, & YH1, EWT, SAVF, ACOR, WM, IWM, JAC, INTOUT, TSTOP, TOLFAC, & DELSGN, RPAR, IPAR) ! !! LSOD is subsidiary to DEBDF. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (LSOD-S, DLSOD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DEBDF merely allocates storage for LSOD to relieve the user of ! the inconvenience of a long call list. Consequently LSOD is used ! as described in the comments for DEBDF . ! !***SEE ALSO DEBDF !***ROUTINES CALLED HSTART, INTYD, R1MACH, STOD, VNWRMS, XERMSG !***COMMON BLOCKS DEBDF1 !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE LSOD ! ! LOGICAL INTOUT ! DIMENSION Y(*),YPOUT(*),YH(NEQ,6),YH1(*),EWT(*),SAVF(*), & ACOR(*),WM(*),IWM(*),RTOL(*),ATOL(*),RPAR(*),IPAR(*) CHARACTER*8 XERN1 CHARACTER*16 XERN3, XERN4 ! COMMON /DEBDF1/ TOLD, ROWNS(210), & EL0, H, HMIN, HMXI, HU, X, U, & IQUIT, INIT, LYH, LEWT, LACOR, LSAVF, LWM, KSTEPS, & IBEGIN, ITOL, IINTEG, ITSTOP, IJAC, IBAND, IOWNS(6), & IER, JSTART, KFLAG, LDUM, METH, MITER, MAXORD, N, NQ, NST, & NFE, NJE, NQU ! EXTERNAL F, JAC ! !....................................................................... ! ! THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE ! NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER ! IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE ! WORK. ! SAVE MAXNUM DATA MAXNUM/500/ ! !....................................................................... ! !***FIRST EXECUTABLE STATEMENT LSOD if (IBEGIN == 0) THEN ! ! ON THE FIRST call , PERFORM INITIALIZATION -- ! DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE ! FUNCTION ROUTINE R1MACH. THE USER MUST MAKE SURE THAT THE ! VALUES SET IN R1MACH ARE RELEVANT TO THE COMPUTER BEING USED. ! U = R1MACH(4) ! -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER WM(1) = SQRT(U) ! -- SET TERMINATION FLAG IQUIT = 0 ! -- SET INITIALIZATION INDICATOR INIT = 0 ! -- SET COUNTER FOR ATTEMPTED STEPS KSTEPS = 0 ! -- SET INDICATOR FOR INTERMEDIATE-OUTPUT INTOUT = .FALSE. ! -- SET START INDICATOR FOR STOD CODE JSTART = 0 ! -- SET BDF METHOD INDICATOR METH = 2 ! -- SET MAXIMUM ORDER FOR BDF METHOD MAXORD = 5 ! -- SET ITERATION MATRIX INDICATOR ! if (IJAC == 0 .AND. IBAND == 0) MITER = 2 if (IJAC == 1 .AND. IBAND == 0) MITER = 1 if (IJAC == 0 .AND. IBAND == 1) MITER = 5 if (IJAC == 1 .AND. IBAND == 1) MITER = 4 ! ! -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK N = NEQ NST = 0 NJE = 0 HMXI = 0. NQ = 1 H = 1. ! -- RESET IBEGIN FOR SUBSEQUENT CALLS IBEGIN=1 end if ! !....................................................................... ! ! CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY ! if (NEQ < 1) THEN WRITE (XERN1, '(I8)') NEQ call XERMSG ('SLATEC', 'LSOD', & 'IN DEBDF, THE NUMBER OF EQUATIONS MUST BE A POSITIVE ' // & 'INTEGER.$$YOU HAVE CALLED THE CODE WITH NEQ = ' // XERN1, & 6, 1) IDID=-33 end if ! NRTOLP = 0 NATOLP = 0 DO 60 K = 1,NEQ if (NRTOLP <= 0) THEN if (RTOL(K) < 0.) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') RTOL(K) call XERMSG ('SLATEC', 'LSOD', & 'IN DEBDF, THE RELATIVE ERROR TOLERANCES MUST ' // & 'BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE WITH ' // & 'RTOL(' // XERN1 // ') = ' // XERN3 // '$$IN THE ' // & 'CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' // & 'CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) IDID = -33 if (NATOLP > 0) go to 70 NRTOLP = 1 ELSEIF (NATOLP > 0) THEN go to 50 ENDIF ENDIF ! if (ATOL(K) < 0.) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') ATOL(K) call XERMSG ('SLATEC', 'LSOD', & 'IN DEBDF, THE ABSOLUTE ERROR ' // & 'TOLERANCES MUST BE NON-NEGATIVE.$$YOU HAVE CALLED ' // & 'THE CODE WITH ATOL(' // XERN1 // ') = ' // XERN3 // & '$$IN THE CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' & // 'CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) IDID=-33 if (NRTOLP > 0) go to 70 NATOLP=1 ENDIF 50 if (ITOL == 0) go to 70 60 CONTINUE ! 70 if (ITSTOP == 1) THEN if (SIGN(1.,TOUT-T) /= SIGN(1.,TSTOP-T) .OR. & ABS(TOUT-T) > ABS(TSTOP-T)) THEN WRITE (XERN3, '(1PE15.6)') TOUT WRITE (XERN4, '(1PE15.6)') TSTOP call XERMSG ('SLATEC', 'LSOD', & 'IN DEBDF, YOU HAVE CALLED THE ' // & 'CODE WITH TOUT = ' // XERN3 // '$$BUT YOU HAVE ' // & 'ALSO TOLD THE CODE NOT TO INTEGRATE PAST THE POINT ' // & 'TSTOP = ' // XERN4 // ' BY SETTING INFO(4) = 1. ' // & 'THESE INSTRUCTIONS CONFLICT.', 14, 1) IDID=-33 ENDIF end if ! ! CHECK SOME CONTINUATION POSSIBILITIES ! if (INIT /= 0) THEN if (T == TOUT) THEN WRITE (XERN3, '(1PE15.6)') T call XERMSG ('SLATEC', 'LSOD', & 'IN DEBDF, YOU HAVE CALLED THE CODE WITH T = TOUT = ' // & XERN3 // ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', & 9, 1) IDID=-33 ENDIF ! if (T /= TOLD) THEN WRITE (XERN3, '(1PE15.6)') TOLD WRITE (XERN4, '(1PE15.6)') T call XERMSG ('SLATEC', 'LSOD', & 'IN DEBDF, YOU HAVE CHANGED THE VALUE OF T FROM ' // & XERN3 // ' TO ' // XERN4 // & ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) IDID=-33 ENDIF ! if (INIT /= 1) THEN if (DELSGN*(TOUT-T) < 0.) THEN WRITE (XERN3, '(1PE15.6)') TOUT call XERMSG ('SLATEC', 'LSOD', & 'IN DEBDF, BY CALLING THE CODE WITH TOUT = ' // & XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // & 'DIRECTION OF INTEGRATION.$$' // & 'THIS IS NOT ALLOWED WITHOUT RESTARTING.', 11, 1) IDID=-33 ENDIF ENDIF end if ! if (IDID == (-33)) THEN if (IQUIT /= (-33)) THEN ! INVALID INPUT DETECTED IQUIT=-33 IBEGIN=-1 ELSE call XERMSG ('SLATEC', 'LSOD', & 'IN DEBDF, INVALID INPUT WAS ' // & 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // & 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // & 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) ENDIF return end if ! !....................................................................... ! ! RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS ! ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, ! THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE ! 100*U WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE ! DO 170 K=1,NEQ if (RTOL(K)+ATOL(K) > 0.) go to 160 RTOL(K)=100.*U IDID=-2 160 if (ITOL == 0) go to 180 170 CONTINUE ! 180 if (IDID /= (-2)) go to 190 ! RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A ! SMALL POSITIVE VALUE IBEGIN=-1 return ! ! BRANCH ON STATUS OF INITIALIZATION INDICATOR ! INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE ! AND DIRECTION NOT YET SET ! INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET ! INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED ! 190 if (INIT == 0) go to 200 if (INIT == 1) go to 220 go to 240 ! !....................................................................... ! ! MORE INITIALIZATION -- ! -- EVALUATE INITIAL DERIVATIVES ! 200 INIT=1 call F(T,Y,YH(1,2),RPAR,IPAR) NFE=1 if (T /= TOUT) go to 220 IDID=2 DO 210 L = 1,NEQ 210 YPOUT(L) = YH(L,2) TOLD=T return ! ! -- COMPUTE INITIAL STEP SIZE ! -- SAVE SIGN OF INTEGRATION DIRECTION ! -- SET INDEPENDENT AND DEPENDENT VARIABLES ! X AND YH(*) FOR STOD ! 220 LTOL = 1 DO 225 L=1,NEQ if (ITOL == 1) LTOL = L TOL = RTOL(LTOL)*ABS(Y(L)) + ATOL(LTOL) if (TOL == 0.) go to 380 225 EWT(L) = TOL ! BIG = SQRT(R1MACH(2)) call HSTART (F,NEQ,T,TOUT,Y,YH(1,2),EWT,1,U,BIG, & YH(1,3),YH(1,4),YH(1,5),YH(1,6),RPAR,IPAR,H) ! 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 ! !....................................................................... ! ! ON EACH call SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL ! OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT ! 240 DEL = TOUT - T ABSDEL = ABS(DEL) ! !....................................................................... ! ! if ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN ! 250 if (ABS(X-T) < ABSDEL) go to 270 call INTYD(TOUT,0,YH,NEQ,Y,INTFLG) call INTYD(TOUT,1,YH,NEQ,YPOUT,INTFLG) IDID = 3 if (X /= TOUT) go to 260 IDID = 2 INTOUT = .FALSE. 260 T = TOUT TOLD = T return ! ! if CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, ! EXTRAPOLATE AND RETURN ! 270 if (ITSTOP /= 1) go to 290 if (ABS(TSTOP-X) >= 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 ! 290 if (IINTEG == 0 .OR. .NOT.INTOUT) go to 300 ! ! INTERMEDIATE-OUTPUT MODE ! IDID = 1 go to 500 ! !....................................................................... ! ! MONITOR NUMBER OF STEPS ATTEMPTED ! 300 if (KSTEPS <= MAXNUM) go to 330 ! ! A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED IDID=-1 KSTEPS=0 IBEGIN = -1 go to 500 ! !....................................................................... ! ! LIMIT STEP SIZE AND SET WEIGHT VECTOR ! 330 HMIN = 100.*U*ABS(X) HA = MAX(ABS(H),HMIN) if (ITSTOP /= 1) go to 340 HA = MIN(HA,ABS(TSTOP-X)) 340 H = SIGN(HA,H) LTOL = 1 DO 350 L = 1,NEQ if (ITOL == 1) LTOL = L EWT(L) = RTOL(LTOL)*ABS(YH(L,1)) + ATOL(LTOL) if (EWT(L) <= 0.0) go to 380 350 CONTINUE TOLFAC = U*VNWRMS(NEQ,YH,EWT) if (TOLFAC <= 1.) go to 400 ! ! TOLERANCES TOO SMALL IDID = -2 TOLFAC = 2.*TOLFAC RTOL(1) = TOLFAC*RTOL(1) ATOL(1) = TOLFAC*ATOL(1) if (ITOL == 0) go to 370 DO 360 L = 2,NEQ RTOL(L) = TOLFAC*RTOL(L) 360 ATOL(L) = TOLFAC*ATOL(L) 370 IBEGIN = -1 go to 500 ! ! RELATIVE ERROR CRITERION INAPPROPRIATE 380 IDID = -3 IBEGIN = -1 go to 500 ! !....................................................................... ! ! TAKE A STEP ! 400 call STOD(NEQ,Y,YH,NEQ,YH1,EWT,SAVF,ACOR,WM,IWM,F,JAC,RPAR,IPAR) ! JSTART = -2 INTOUT = .TRUE. if (KFLAG == 0) go to 250 ! !....................................................................... ! if (KFLAG == -1) go to 450 ! ! REPEATED CORRECTOR CONVERGENCE FAILURES IDID = -6 IBEGIN = -1 go to 500 ! ! REPEATED ERROR TEST FAILURES 450 IDID = -7 IBEGIN = -1 ! !....................................................................... ! ! STORE VALUES BEFORE RETURNING TO DEBDF 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 LSSODS (A, X, B, M, N, NRDA, IFLAG, IRANK, ISCALE, Q, & DIAG, KPIVOT, ITER, RESNRM, XNORM, Z, R, DIV, TD, SCALES) ! !! LSSODS is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (LSSODS-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! LSSODS solves the same problem as SODS (in fact, it is called by ! SODS) but is somewhat more flexible in its use. In particular, ! LSSODS allows for iterative refinement of the solution, makes the ! transformation and triangular reduction information more ! accessible, and enables the user to avoid destruction of the ! original matrix A. ! ! Modeled after the ALGOL codes in the articles in the REFERENCES ! section. ! ! ********************************************************************** ! INPUT ! ********************************************************************** ! ! A -- Contains the matrix of M equations in N unknowns and must ! be dimensioned NRDA by N. A remains unchanged ! X -- Solution array of length at least N ! B -- Given constant vector of length M, B remains unchanged ! M -- Number of equations, M greater or equal to 1 ! N -- Number of unknowns, N not larger than M ! NRDA -- Row dimension of A, NRDA greater or equal to M ! IFLAG -- Status indicator ! = 0 for the first call (and for each new problem defined by ! a new matrix A) when the matrix data is treated as exact ! =-K for the first call (and for each new problem defined by ! a new matrix A) when the matrix data is assumed to be ! accurate to about K digits ! = 1 for subsequent calls whenever the matrix A has already ! been decomposed (problems with new vectors B but ! same matrix a can be handled efficiently) ! ISCALE -- Scaling indicator ! =-1 if the matrix A is to be pre-scaled by ! columns when appropriate ! If the scaling indicator is not equal to -1 ! no scaling will be attempted ! For most problems scaling will probably not be necessary ! ITER -- Maximum number of iterative improvement steps to be ! performed, 0 <= ITER <= 10 (SODS uses ITER=0) ! Q -- Matrix used for the transformation, must be dimensioned ! NRDA by N (SODS puts A in the Q location which conserves ! storage but destroys A) ! When iterative improvement of the solution is requested, ! ITER > 0, this additional storage for Q must be ! made available ! DIAG,KPIVOT,Z,R, -- Arrays of length N (except for R which is M) ! DIV,TD,SCALES used for internal storage ! ! ********************************************************************** ! OUTPUT ! ********************************************************************** ! ! IFLAG -- Status indicator ! =1 if solution was obtained ! =2 if improper input is detected ! =3 if rank of matrix is less than N ! if the minimal length least squares solution is ! desired, simply reset IFLAG=1 and call the code again ! ! The next three IFLAG values can occur only when ! the iterative improvement mode is being used. ! =4 if the problem is ill-conditioned and maximal ! machine accuracy is not achievable ! =5 if the problem is very ill-conditioned and the solution ! IS likely to have no correct digits ! =6 if the allowable number of iterative improvement steps ! has been completed without getting convergence ! X -- Least squares solution of A X = B ! IRANK -- Contains the numerically determined matrix rank ! the user must not alter this value on succeeding calls ! with input values of IFLAG=1 ! Q -- Contains the strictly upper triangular part of the reduced ! matrix and the transformation information in the lower ! triangular part ! DIAG -- Contains the diagonal elements of the triangular reduced ! matrix ! KPIVOT -- Contains the pivotal information. The column interchanges ! performed on the original matrix are recorded here ! ITER -- The actual number of iterative corrections used ! RESNRM -- The Euclidean norm of the residual vector B - A X ! XNORM -- The Euclidean norm of the solution vector ! DIV,TD -- Contains transformation information for rank ! deficient problems ! SCALES -- Contains the column scaling parameters ! ! ********************************************************************** ! !***SEE ALSO BVSUP !***REFERENCES G. Golub, Numerical methods for solving linear least ! squares problems, Numerische Mathematik 7, (1965), ! pp. 206-216. ! P. Businger and G. Golub, Linear least squares ! solutions by Householder transformations, Numerische ! Mathematik 7, (1965), pp. 269-276. !***ROUTINES CALLED J4SAVE, OHTROR, ORTHOL, R1MACH, SDOT, SDSDOT, ! XERMAX, XERMSG, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900402 Added TYPE section. (WRB) ! 910408 Updated the REFERENCES section. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE LSSODS DIMENSION A(NRDA,*),X(*),B(*),Q(NRDA,*),DIAG(*), & Z(*),KPIVOT(*),R(*),DIV(*),TD(*),SCALES(*) ! ! ********************************************************************** ! ! MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED ! THE FUNCTION R1MACH. ! !***FIRST EXECUTABLE STATEMENT LSSODS URO = R1MACH(3) ! ! ********************************************************************** ! if (N < 1 .OR. M < N .OR. NRDA < M) go to 1 if (ITER < 0) go to 1 if (IFLAG <= 0) go to 5 if (IFLAG == 1) go to 15 ! ! INVALID INPUT FOR LSSODS 1 IFLAG=2 call XERMSG ('SLATEC', 'LSSODS', 'INVALID INPUT PARAMETERS.', 2, & 1) return ! 5 call XGETF (NFATAL) MAXMES = J4SAVE (4,0,.FALSE.) if (IFLAG == 0) go to 7 NFAT = -1 if ( NFATAL == 0) NFAT=0 call XSETF (NFAT) call XERMAX (1) ! ! COPY MATRIX A INTO MATRIX Q ! 7 DO 10 J=1,N DO 10 K=1,M 10 Q(K,J)=A(K,J) ! ! USE ORTHOGONAL TRANSFORMATIONS TO REDUCE Q TO ! UPPER TRIANGULAR FORM ! call ORTHOL(Q,M,N,NRDA,IFLAG,IRANK,ISCALE,DIAG,KPIVOT,SCALES,Z,TD) ! call XSETF (NFATAL) call XERMAX (MAXMES) if (IRANK == N) go to 12 ! ! FOR RANK DEFICIENT PROBLEMS USE ADDITIONAL ORTHOGONAL ! TRANSFORMATIONS TO FURTHER REDUCE Q ! if (IRANK /= 0) call OHTROR(Q,N,NRDA,DIAG,IRANK,DIV,TD) return ! ! STORE DIVISORS FOR THE TRIANGULAR SOLUTION ! 12 DO 13 K=1,N 13 DIV(K)=DIAG(K) ! 15 IRM=IRANK-1 IRP=IRANK+1 ITERP=MIN(ITER+1,11) ACC=10.*URO ! ! ZERO OUT SOLUTION ARRAY ! DO 20 K=1,N 20 X(K)=0. ! if (IRANK > 0) go to 25 ! ! SPECIAL CASE FOR THE NULL MATRIX ITER=0 XNORM=0. RESNRM=SQRT(SDOT(M,B(1),1,B(1),1)) return ! ! COPY CONSTANT VECTOR INTO R ! 25 DO 30 K=1,M 30 R(K)=B(K) ! ! ********************************************************************** ! SOLUTION SECTION ! ITERATIVE REFINEMENT OF THE RESIDUAL VECTOR ! ********************************************************************** ! DO 100 IT=1,ITERP ITER=IT-1 ! ! APPLY ORTHOGONAL TRANSFORMATION TO R ! DO 35 J=1,IRANK MJ=M-J+1 GAMMA=SDOT(MJ,Q(J,J),1,R(J),1)/(DIAG(J)*Q(J,J)) DO 35 K=J,M 35 R(K)=R(K)+GAMMA*Q(K,J) ! ! BACKWARD SUBSTITUTION FOR TRIANGULAR SYSTEM SOLUTION ! Z(IRANK)=R(IRANK)/DIV(IRANK) if (IRM == 0) go to 45 DO 40 L=1,IRM K=IRANK-L KP=K+1 40 Z(K)=(R(K)-SDOT(L,Q(K,KP),NRDA,Z(KP),1))/DIV(K) ! 45 if (IRANK == N) go to 60 ! ! FOR RANK DEFICIENT PROBLEMS OBTAIN THE ! MINIMAL LENGTH SOLUTION ! NMIR=N-IRANK DO 50 K=IRP,N 50 Z(K)=0. DO 55 K=1,IRANK GAM=((TD(K)*Z(K))+SDOT(NMIR,Q(K,IRP),NRDA,Z(IRP),1))/ & (TD(K)*DIV(K)) Z(K)=Z(K)+GAM*TD(K) DO 55 J=IRP,N 55 Z(J)=Z(J)+GAM*Q(K,J) ! ! REORDER SOLUTION COMPONENTS ACCORDING TO PIVOTAL POINTS ! AND RESCALE ANSWERS AS DICTATED ! 60 DO 65 K=1,N Z(K)=Z(K)*SCALES(K) L=KPIVOT(K) 65 X(L)=X(L)+Z(K) ! ! COMPUTE CORRECTION VECTOR NORM (SOLUTION NORM) ! ZNORM=SQRT(SDOT(N,Z(1),1,Z(1),1)) if (IT == 1) XNORM=ZNORM if (ITERP > 1) go to 80 ! ! NO ITERATIVE CORRECTIONS TO BE PERFORMED, SO COMPUTE ! THE APPROXIMATE RESIDUAL NORM DEFINED BY THE EQUATIONS ! WHICH ARE NOT SATISFIED BY THE SOLUTION ! THEN WE ARE DONE ! MMIR=M-IRANK if (MMIR == 0) go to 70 RESNRM=SQRT(SDOT(MMIR,R(IRP),1,R(IRP),1)) return 70 RESNRM=0. return ! ! COMPUTE RESIDUAL VECTOR FOR THE ITERATIVE IMPROVEMENT PROCESS ! 80 DO 85 K=1,M 85 R(K)=-SDSDOT(N,-B(K),A(K,1),NRDA,X(1),1) RESNRM=SQRT(SDOT(M,R(1),1,R(1),1)) if (IT == 1) go to 100 ! ! TEST FOR CONVERGENCE ! if (ZNORM <= ACC*XNORM) RETURN ! ! COMPARE SUCCESSIVE REFINEMENT VECTOR NORMS ! FOR LOOP TERMINATION CRITERIA ! if (ZNORM <= 0.25*ZNRM0) go to 100 if (IT == 2) go to 90 ! IFLAG=4 call XERMSG ('SLATEC', 'LSSODS', & 'PROBLEM MAY BE ILL-CONDITIONED. MAXIMAL MACHINE ACCURACY ' // & 'IS NOT ACHIEVABLE.', 3, 1) return ! 90 IFLAG=5 call XERMSG ('SLATEC', 'LSSODS', & 'PROBLEM IS VERY ILL-CONDITIONED. ITERATIVE ' // & 'IMPROVEMENT IS INEFFECTIVE.', 8, 1) return ! 100 ZNRM0=ZNORM ! ********************************************************************** ! ! ********************************************************************** IFLAG=6 call XERMSG ('SLATEC', 'LSSODS', & 'CONVERGENCE HAS NOT BEEN OBTAINED WITH ALLOWABLE ' // & 'NUMBER OF ITERATIVE IMPROVEMENT STEPS.', 8, 1) ! return end subroutine LSSUDS (A, X, B, N, M, NRDA, U, NRDU, IFLAG, MLSO, & IRANK, ISCALE, Q, DIAG, KPIVOT, S, DIV, TD, ISFLG, SCALES) ! !! LSSUDS is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (LSSUDS-S, DLSSUD-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! LSSUDS solves the underdetermined system of equations A Z = B, ! where A is N by M and N <= M. In particular, if rank A equals ! IRA, a vector X and a matrix U are determined such that X is the ! UNIQUE solution of smallest length, satisfying A X = B, and the ! columns of U form an orthonormal basis for the null space of A, ! satisfying A U = 0 . Then all solutions Z are given by ! Z = X + C(1)*U(1) + ..... + C(M-IRA)*U(M-IRA) ! where U(J) represents the J-th column of U and the C(J) are ! arbitrary constants. ! If the system of equations are not compatible, only the least ! squares solution of minimal length is computed. ! ! ********************************************************************* ! INPUT ! ********************************************************************* ! ! A -- Contains the matrix of N equations in M unknowns, A remains ! unchanged, must be dimensioned NRDA by M. ! X -- Solution array of length at least M. ! B -- Given constant vector of length N, B remains unchanged. ! N -- Number of equations, N greater or equal to 1. ! M -- Number of unknowns, M greater or equal to N. ! NRDA -- Row dimension of A, NRDA greater or equal to N. ! U -- Matrix used for solution, must be dimensioned NRDU by ! (M - rank of A). ! (storage for U may be ignored when only the minimal length ! solution X is desired) ! NRDU -- Row dimension of U, NRDU greater or equal to M. ! (if only the minimal length solution is wanted, ! NRDU=0 is acceptable) ! IFLAG -- Status indicator ! =0 for the first call (and for each new problem defined by ! a new matrix A) when the matrix data is treated as exact ! =-K for the first call (and for each new problem defined by ! a new matrix A) when the matrix data is assumed to be ! accurate to about K digits. ! =1 for subsequent calls whenever the matrix A has already ! been decomposed (problems with new vectors B but ! same matrix A can be handled efficiently). ! MLSO -- =0 if only the minimal length solution is wanted. ! =1 if the complete solution is wanted, includes the ! linear space defined by the matrix U. ! IRANK -- Variable used for the rank of A, set by the code. ! ISCALE -- Scaling indicator ! =-1 if the matrix A is to be pre-scaled by ! columns when appropriate. ! If the scaling indicator is not equal to -1 ! no scaling will be attempted. ! For most problems scaling will probably not be necessary. ! Q -- Matrix used for the transformation, must be dimensioned ! NRDA by M. ! DIAG,KPIVOT,S, -- Arrays of length at least N used for internal ! DIV,TD,SCALES storage (except for SCALES which is M). ! ISFLG -- Storage for an internal variable. ! ! ********************************************************************* ! OUTPUT ! ********************************************************************* ! ! IFLAG -- Status indicator ! =1 if solution was obtained. ! =2 if improper input is detected. ! =3 if rank of matrix is less than N. ! To continue, simply reset IFLAG=1 and call LSSUDS again. ! =4 if the system of equations appears to be inconsistent. ! However, the least squares solution of minimal length ! was obtained. ! X -- Minimal length least squares solution of A Z = B ! IRANK -- Numerically determined rank of A, must not be altered ! on succeeding calls with input values of IFLAG=1. ! U -- Matrix whose M-IRANK columns are mutually orthogonal unit ! vectors which span the null space of A. This is to be ignored ! when MLSO was set to zero or IFLAG=4 on output. ! Q -- Contains the strictly upper triangular part of the reduced ! matrix and transformation information. ! DIAG -- Contains the diagonal elements of the triangular reduced ! matrix. ! KPIVOT -- Contains the pivotal information. The row interchanges ! performed on the original matrix are recorded here. ! S -- Contains the solution of the lower triangular system. ! DIV,TD -- Contains transformation information for rank ! deficient problems. ! SCALES -- Contains the column scaling parameters. ! ! ********************************************************************* ! !***SEE ALSO BVSUP !***REFERENCES H. A. Watts, Solving linear least squares problems ! using SODS/SUDS/CODS, Sandia Report SAND77-0683, ! Sandia Laboratories, 1977. !***ROUTINES CALLED J4SAVE, OHTROL, ORTHOR, R1MACH, SDOT, XERMAX, ! XERMSG, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Fixed an error message. (RWC) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE LSSUDS DIMENSION A(NRDA,*),X(*),B(*),U(NRDU,*),Q(NRDA,*), & DIAG(*),KPIVOT(*),S(*),DIV(*),TD(*),SCALES(*) ! ! ********************************************************************** ! ! MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED ! BY THE FUNCTION R1MACH. ! !***FIRST EXECUTABLE STATEMENT LSSUDS URO = R1MACH(4) ! ! ********************************************************************** ! if (N < 1 .OR. M < N .OR. NRDA < N) go to 1 if (NRDU /= 0 .AND. NRDU < M) go to 1 if (IFLAG <= 0) go to 5 if (IFLAG == 1) go to 25 ! ! INVALID INPUT FOR LSSUDS 1 IFLAG=2 call XERMSG ('SLATEC', 'LSSUDS', 'INVALID INPUT PARAMETERS.', 2, & 1) return ! 5 call XGETF(NFATAL) MAXMES = J4SAVE (4,0,.FALSE.) ISFLG=-15 if (IFLAG == 0) go to 7 ISFLG=IFLAG NFAT = -1 if (NFATAL == 0) NFAT=0 call XSETF(NFAT) call XERMAX(1) ! ! COPY MATRIX A INTO MATRIX Q ! 7 DO 10 K=1,M DO 10 J=1,N 10 Q(J,K)=A(J,K) ! ! USE ORTHOGONAL TRANSFORMATIONS TO REDUCE Q TO LOWER ! TRIANGULAR FORM ! call ORTHOR(Q,N,M,NRDA,IFLAG,IRANK,ISCALE,DIAG,KPIVOT,SCALES, & DIV,TD) ! call XSETF(NFATAL) call XERMAX(MAXMES) if (IRANK == N) go to 15 ! ! FOR RANK DEFICIENT PROBLEMS USE ADDITIONAL ORTHOGONAL ! TRANSFORMATIONS TO FURTHER REDUCE Q ! if (IRANK /= 0) call OHTROL(Q,N,NRDA,DIAG,IRANK,DIV,TD) return ! ! STORE DIVISORS FOR THE TRIANGULAR SOLUTION ! 15 DO 20 K=1,N 20 DIV(K)=DIAG(K) ! ! 25 if (IRANK > 0) go to 40 ! ! SPECIAL CASE FOR THE NULL MATRIX DO 35 K=1,M X(K)=0. if (MLSO == 0) go to 35 U(K,K)=1. DO 30 J=1,M if (J == K) go to 30 U(J,K)=0. 30 CONTINUE 35 CONTINUE DO 37 K=1,N if (B(K) > 0.) IFLAG=4 37 CONTINUE return ! ! COPY CONSTANT VECTOR INTO S AFTER FIRST INTERCHANGING ! THE ELEMENTS ACCORDING TO THE PIVOTAL SEQUENCE ! 40 DO 45 K=1,N KP=KPIVOT(K) 45 X(K)=B(KP) DO 50 K=1,N 50 S(K)=X(K) ! IRP=IRANK+1 NU=1 if (MLSO == 0) NU=0 if (IRANK == N) go to 60 ! ! FOR RANK DEFICIENT PROBLEMS WE MUST APPLY THE ! ORTHOGONAL TRANSFORMATION TO S ! WE ALSO CHECK TO SEE if THE SYSTEM APPEARS TO BE INCONSISTENT ! NMIR=N-IRANK SS=SDOT(N,S(1),1,S(1),1) DO 55 L=1,IRANK K=IRP-L GAM=((TD(K)*S(K))+SDOT(NMIR,Q(IRP,K),1,S(IRP),1))/ & (TD(K)*DIV(K)) S(K)=S(K)+GAM*TD(K) DO 55 J=IRP,N 55 S(J)=S(J)+GAM*Q(J,K) RES=SDOT(NMIR,S(IRP),1,S(IRP),1) if (RES <= SS*(10.*MAX(10.**ISFLG,10.*URO))**2) go to 60 ! ! INCONSISTENT SYSTEM IFLAG=4 NU=0 ! ! APPLY FORWARD SUBSTITUTION TO SOLVE LOWER TRIANGULAR SYSTEM ! 60 S(1)=S(1)/DIV(1) if (IRANK == 1) go to 70 DO 65 K=2,IRANK 65 S(K)=(S(K)-SDOT(K-1,Q(K,1),NRDA,S(1),1))/DIV(K) ! ! INITIALIZE X VECTOR AND THEN APPLY ORTHOGONAL TRANSFORMATION ! 70 DO 75 K=1,M X(K)=0. if (K <= IRANK) X(K)=S(K) 75 CONTINUE ! DO 80 JR=1,IRANK J=IRP-JR MJ=M-J+1 GAMMA=SDOT(MJ,Q(J,J),NRDA,X(J),1)/(DIAG(J)*Q(J,J)) DO 80 K=J,M 80 X(K)=X(K)+GAMMA*Q(J,K) ! ! RESCALE ANSWERS AS DICTATED ! DO 85 K=1,M 85 X(K)=X(K)*SCALES(K) ! if ((NU == 0) .OR. (M == IRANK)) RETURN ! ! INITIALIZE U MATRIX AND THEN APPLY ORTHOGONAL TRANSFORMATION ! L=M-IRANK DO K=1,L DO I=1,M U(I,K)=0. if (I == IRANK+K) U(I,K)=1. end do DO JR=1,IRANK J=IRP-JR MJ=M-J+1 GAMMA=SDOT(MJ,Q(J,J),NRDA,U(J,K),1)/(DIAG(J)*Q(J,J)) DO I=J,M U(I,K)=U(I,K)+GAMMA*Q(J,I) end do end do end do return end subroutine MACON ! !! MACON is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (MACON-S, DMACON-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Sets up machine constants using R1MACH ! !***SEE ALSO BVSUP !***ROUTINES CALLED R1MACH !***COMMON BLOCKS ML5MCO !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE MACON COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR !***FIRST EXECUTABLE STATEMENT MACON URO=R1MACH(4) SRU=SQRT(URO) DD=-LOG10(URO) LPAR=0.5*DD KE=0.5+0.75*DD EPS=10.**(-2*KE) SQOVFL=SQRT(R1MACH(2)) TWOU=2.0*URO FOURU=4.0*URO return end subroutine MC20AD (NC, MAXA, A, INUM, JPTR, JNUM, JDISP) ! !! MC20AD is subsidiary to DSPLP. ! !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (MC20AS-S, MC20AD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM ! FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE ! CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING ! THE FINAL LETTER =D= IN THE NAMES USED HERE. ! REVISED SEP. 13, 1979. ! ! ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES ! IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL ! SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN ! THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES ! DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. ! !***SEE ALSO DSPLP !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE MC20AD INTEGER INUM(*), JNUM(*) DOUBLE PRECISION A(*),ACE,ACEP DIMENSION JPTR(NC) !***FIRST EXECUTABLE STATEMENT MC20AD NULL = -JDISP !** CLEAR JPTR DO 10 J=1,NC JPTR(J) = 0 10 CONTINUE !** COUNT THE NUMBER OF ELEMENTS IN EACH COLUMN. DO 20 K=1,MAXA J = JNUM(K) + JDISP JPTR(J) = JPTR(J) + 1 20 CONTINUE !** SET THE JPTR ARRAY K = 1 DO 30 J=1,NC KR = K + JPTR(J) JPTR(J) = K K = KR 30 CONTINUE ! !** REORDER THE ELEMENTS INTO COLUMN ORDER. THE ALGORITHM IS AN ! IN-PLACE SORT AND IS OF ORDER MAXA. DO 50 I=1,MAXA ! ESTABLISH THE CURRENT ENTRY. JCE = JNUM(I) + JDISP if (JCE == 0) go to 50 ACE = A(I) ICE = INUM(I) ! CLEAR THE LOCATION VACATED. JNUM(I) = NULL ! CHAIN FROM CURRENT ENTRY TO STORE ITEMS. DO 40 J=1,MAXA ! CURRENT ENTRY NOT IN CORRECT POSITION. DETERMINE CORRECT ! POSITION TO STORE ENTRY. LOC = JPTR(JCE) JPTR(JCE) = JPTR(JCE) + 1 ! SAVE CONTENTS OF THAT LOCATION. ACEP = A(LOC) ICEP = INUM(LOC) JCEP = JNUM(LOC) ! STORE CURRENT ENTRY. A(LOC) = ACE INUM(LOC) = ICE JNUM(LOC) = NULL ! CHECK if NEXT CURRENT ENTRY NEEDS TO BE PROCESSED. if (JCEP == NULL) go to 50 ! IT DOES. COPY INTO CURRENT ENTRY. ACE = ACEP ICE = ICEP JCE = JCEP + JDISP 40 CONTINUE ! 50 CONTINUE ! !** RESET JPTR VECTOR. JA = 1 DO 60 J=1,NC JB = JPTR(J) JPTR(J) = JA JA = JB 60 CONTINUE return end subroutine MC20AS (NC, MAXA, A, INUM, JPTR, JNUM, JDISP) ! !! MC20AS is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (MC20AS-S, MC20AD-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM ! FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE ! CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING ! THE FINAL LETTER =S= IN THE NAMES USED HERE. ! REVISED SEP. 13, 1979. ! ! ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES ! IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL ! SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN ! THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES ! SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. ! !***SEE ALSO SPLP !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE MC20AS INTEGER INUM(*), JNUM(*) REAL A(*) DIMENSION JPTR(NC) !***FIRST EXECUTABLE STATEMENT MC20AS NULL = -JDISP !** CLEAR JPTR DO 10 J=1,NC JPTR(J) = 0 10 CONTINUE !** COUNT THE NUMBER OF ELEMENTS IN EACH COLUMN. DO 20 K=1,MAXA J = JNUM(K) + JDISP JPTR(J) = JPTR(J) + 1 20 CONTINUE !** SET THE JPTR ARRAY K = 1 DO 30 J=1,NC KR = K + JPTR(J) JPTR(J) = K K = KR 30 CONTINUE ! !** REORDER THE ELEMENTS INTO COLUMN ORDER. THE ALGORITHM IS AN ! IN-PLACE SORT AND IS OF ORDER MAXA. DO 50 I=1,MAXA ! ESTABLISH THE CURRENT ENTRY. JCE = JNUM(I) + JDISP if (JCE == 0) go to 50 ACE = A(I) ICE = INUM(I) ! CLEAR THE LOCATION VACATED. JNUM(I) = NULL ! CHAIN FROM CURRENT ENTRY TO STORE ITEMS. DO 40 J=1,MAXA ! CURRENT ENTRY NOT IN CORRECT POSITION. DETERMINE CORRECT ! POSITION TO STORE ENTRY. LOC = JPTR(JCE) JPTR(JCE) = JPTR(JCE) + 1 ! SAVE CONTENTS OF THAT LOCATION. ACEP = A(LOC) ICEP = INUM(LOC) JCEP = JNUM(LOC) ! STORE CURRENT ENTRY. A(LOC) = ACE INUM(LOC) = ICE JNUM(LOC) = NULL ! CHECK if NEXT CURRENT ENTRY NEEDS TO BE PROCESSED. if (JCEP == NULL) go to 50 ! IT DOES. COPY INTO CURRENT ENTRY. ACE = ACEP ICE = ICEP JCE = JCEP + JDISP 40 CONTINUE ! 50 CONTINUE ! !** RESET JPTR VECTOR. JA = 1 DO 60 J=1,NC JB = JPTR(J) JPTR(J) = JA JA = JB 60 CONTINUE return end subroutine MGSBV (M, N, A, IA, NIV, IFLAG, S, P, IP, INHOMO, V, W, & WCND) ! !! MGSBV is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (MGSBV-S, DMGSBV-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! Orthogonalize a set of N real vectors and determine their rank ! ! ********************************************************************** ! INPUT ! ********************************************************************** ! M = Dimension of vectors ! N = No. of vectors ! A = Array whose first N cols contain the vectors ! IA = First dimension of array A (col length) ! NIV = Number of independent vectors needed ! INHOMO = 1 Corresponds to having a non-zero particular solution ! V = Particular solution vector (not included in the pivoting) ! INDPVT = 1 Means pivoting will not be used ! ! ********************************************************************** ! OUTPUT ! ********************************************************************** ! NIV = No. of linear independent vectors in input set ! A = Matrix whose first NIV cols. contain NIV orthogonal vectors ! which span the vector space determined by the input vectors ! IFLAG ! = 0 success ! = 1 incorrect input ! = 2 rank of new vectors less than N ! P = Decomposition matrix. P is upper triangular and ! (old vectors) = (new vectors) * P. ! The old vectors will be reordered due to pivoting ! The dimension of p must be >= N*(N+1)/2. ! ( N*(2*N+1) when N /= NFCC ) ! IP = Pivoting vector. The dimension of IP must be >= N. ! ( 2*N when N /= NFCC ) ! S = Square of norms of incoming vectors ! V = Vector which is orthogonal to the vectors of A ! W = Orthogonalization information for the vector V ! WCND = Worst case (smallest) norm decrement value of the ! vectors being orthogonalized (represents a test ! for linear dependence of the vectors) ! ********************************************************************** ! !***SEE ALSO BVSUP !***ROUTINES CALLED PRVEC, SDOT !***COMMON BLOCKS ML18JR, ML5MCO !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE MGSBV ! DIMENSION A(IA,*),V(*),W(*),P(*),IP(*),S(*) ! ! COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, & ICOCO ! COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR ! !***FIRST EXECUTABLE STATEMENT MGSBV if ( M > 0 .AND. N > 0 .AND. IA >= M) go to 10 IFLAG=1 return ! 10 JP=0 IFLAG=0 NP1=N+1 Y=0.0 M2=M/2 ! ! CALCULATE SQUARE OF NORMS OF INCOMING VECTORS AND SEARCH FOR ! VECTOR WITH LARGEST MAGNITUDE ! J=0 DO 30 I=1,N VL=SDOT(M,A(1,I),1,A(1,I),1) S(I)=VL if (N == NFCC) go to 25 J=2*I-1 P(J)=VL IP(J)=J 25 J=J+1 P(J)=VL IP(J)=J if ( VL <= Y) go to 30 Y=VL IX=I 30 CONTINUE if (INDPVT /= 1) go to 33 IX=1 Y=P(1) 33 LIX=IX if (N /= NFCC) LIX=2*IX-1 P(LIX)=P(1) S(NP1)=0. if (INHOMO == 1) S(NP1)=SDOT(M,V,1,V,1) WCND=1. NIVN=NIV NIV=0 ! if ( Y == 0.0) go to 170 ! ********************************************************************** DO 140 NR=1,N if (NIVN == NIV) go to 150 NIV=NR if ( IX == NR) go to 80 ! ! PIVOTING OF COLUMNS OF P MATRIX ! NN=N LIX=IX LR=NR if (N == NFCC) go to 40 NN=NFCC LIX=2*IX-1 LR=2*NR-1 40 if ( NR == 1) go to 60 KD=LIX-LR KJ=LR NRM1=LR-1 DO 50 J=1,NRM1 PSAVE=P(KJ) JK=KJ+KD P(KJ)=P(JK) P(JK)=PSAVE 50 KJ=KJ+NN-J JY=JK+NMNR JZ=JY-KD P(JY)=P(JZ) 60 IZ=IP(LIX) IP(LIX)=IP(LR) IP(LR)=IZ SV=S(IX) S(IX)=S(NR) S(NR)=SV if (N == NFCC) go to 69 if (NR == 1) go to 67 KJ=LR+1 DO 65 K=1,NRM1 PSAVE=P(KJ) JK=KJ+KD P(KJ)=P(JK) P(JK)=PSAVE 65 KJ=KJ+NFCC-K 67 IZ=IP(LIX+1) IP(LIX+1)=IP(LR+1) IP(LR+1)=IZ ! ! PIVOTING OF COLUMNS OF VECTORS ! 69 DO 70 L=1,M T=A(L,IX) A(L,IX)=A(L,NR) 70 A(L,NR)=T ! ! CALCULATE P(NR,NR) AS NORM SQUARED OF PIVOTAL VECTOR ! 80 JP=JP+1 P(JP)=Y RY=1.0/Y NMNR=N-NR if (N == NFCC) go to 85 NMNR=NFCC-(2*NR-1) JP=JP+1 P(JP)=0. KP=JP+NMNR P(KP)=Y 85 if ( NR == N .OR. NIVN == NIV) go to 125 ! ! CALCULATE ORTHOGONAL PROJECTION VECTORS AND SEARCH FOR LARGEST NORM ! Y=0.0 IP1=NR+1 IX=IP1 ! **************************************** DO 120 J=IP1,N DOT=SDOT(M,A(1,NR),1,A(1,J),1) JP=JP+1 JQ=JP+NMNR if (N /= NFCC) JQ=JQ+NMNR-1 P(JQ)=P(JP)-DOT*(DOT*RY) P(JP)=DOT*RY DO 90 I = 1,M 90 A(I,J)=A(I,J)-P(JP)*A(I,NR) if (N == NFCC) go to 99 KP=JP+NMNR JP=JP+1 PJP=RY*PRVEC(M,A(1,NR),A(1,J)) P(JP)=PJP P(KP)=-PJP KP=KP+1 P(KP)=RY*DOT DO 95 K=1,M2 L=M2+K A(K,J)=A(K,J)-PJP*A(L,NR) 95 A(L,J)=A(L,J)+PJP*A(K,NR) P(JQ)=P(JQ)-PJP*(PJP/RY) ! ! TEST FOR CANCELLATION IN RECURRENCE RELATION ! 99 if ( P(JQ) > S(J)*SRU) go to 100 P(JQ)=SDOT(M,A(1,J),1,A(1,J),1) 100 if ( P(JQ) <= Y) go to 120 Y=P(JQ) IX=J 120 CONTINUE if (N /= NFCC) JP=KP ! **************************************** if ( INDPVT == 1) IX=IP1 ! ! RECOMPUTE NORM SQUARED OF PIVOTAL VECTOR WITH SCALAR PRODUCT ! Y=SDOT(M,A(1,IX),1,A(1,IX),1) if ( Y <= EPS*S(IX)) go to 170 WCND=MIN(WCND,Y/S(IX)) ! ! COMPUTE ORTHOGONAL PROJECTION OF PARTICULAR SOLUTION ! 125 if ( INHOMO /= 1) go to 140 LR=NR if (N /= NFCC) LR=2*NR-1 W(LR)=SDOT(M,A(1,NR),1,V,1)*RY DO 130 I=1,M 130 V(I)=V(I)-W(LR)*A(I,NR) if (N == NFCC) go to 140 LR=2*NR W(LR)=RY*PRVEC(M,V,A(1,NR)) DO 135 K=1,M2 L=M2+K V(K)=V(K)+W(LR)*A(L,NR) 135 V(L)=V(L)-W(LR)*A(K,NR) 140 CONTINUE ! ********************************************************************** ! ! TEST FOR LINEAR DEPENDENCE OF PARTICULAR SOLUTION ! 150 if ( INHOMO /= 1) RETURN if ((N > 1) .AND. (S(NP1) < 1.0)) RETURN VNORM=SDOT(M,V,1,V,1) if (S(NP1) /= 0.) WCND=MIN(WCND,VNORM/S(NP1)) if ( VNORM >= EPS*S(NP1)) RETURN 170 IFLAG=2 WCND=EPS return end subroutine MINFIT (NM, M, N, A, W, IP, B, IERR, RV1) ! !! MINFIT computes the singular value decomposition of a rectangular ... ! matrix and solve the related linear least squares problem. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D9 !***TYPE SINGLE PRECISION (MINFIT-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure MINFIT, ! NUM. MATH. 14, 403-420(1970) by Golub and Reinsch. ! HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). ! ! This subroutine determines, towards the solution of the linear ! T ! system AX=B, the singular value decomposition A=USV of a real ! T ! M by N rectangular matrix, forming U B rather than U. Householder ! bidiagonalization and a variant of the QR algorithm are used. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and B, as declared in the calling ! program dimension statement. Note that NM must be at least ! as large as the maximum of M and N. NM is an INTEGER ! variable. ! ! M is the number of rows of A and B. M is an INTEGER variable. ! ! N is the number of columns of A and the order of V. N is an ! INTEGER variable. ! ! A contains the rectangular coefficient matrix of the system. ! A is a two-dimensional REAL array, dimensioned A(NM,N). ! ! IP is the number of columns of B. IP can be zero. ! ! B contains the constant column matrix of the system if IP is ! not zero. Otherwise, B is not referenced. B is a two- ! dimensional REAL array, dimensioned B(NM,IP). ! ! On OUTPUT ! ! A has been overwritten by the matrix V (orthogonal) of the ! decomposition in its first N rows and columns. If an ! error exit is made, the columns of V corresponding to ! indices of correct singular values should be correct. ! ! W contains the N (non-negative) singular values of A (the ! diagonal elements of S). They are unordered. If an ! error exit is made, the singular values should be correct ! for indices IERR+1, IERR+2, ..., N. W is a one-dimensional ! REAL array, dimensioned W(N). ! ! T ! B has been overwritten by U B. If an error exit is made, ! T ! the rows of U B corresponding to indices of correct singular ! values should be correct. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! K if the K-th singular value has not been ! determined after 30 iterations. ! The singular values should be correct for ! indices IERR+1, IERR+2, ..., N. ! ! RV1 is a one-dimensional REAL array used for temporary storage, ! dimensioned RV1(N). ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE MINFIT ! INTEGER I,J,K,L,M,N,II,IP,I1,KK,K1,LL,L1,M1,NM,ITS,IERR REAL A(NM,*),W(*),B(NM,IP),RV1(*) REAL C,F,G,H,S,X,Y,Z,SCALE,S1 REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT MINFIT IERR = 0 ! .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... G = 0.0E0 SCALE = 0.0E0 S1 = 0.0E0 ! DO 300 I = 1, N L = I + 1 RV1(I) = SCALE * G G = 0.0E0 S = 0.0E0 SCALE = 0.0E0 if (I > M) go to 210 ! DO 120 K = I, M 120 SCALE = SCALE + ABS(A(K,I)) ! if (SCALE == 0.0E0) go to 210 ! DO 130 K = I, M A(K,I) = A(K,I) / SCALE S = S + A(K,I)**2 130 CONTINUE ! F = A(I,I) G = -SIGN(SQRT(S),F) H = F * G - S A(I,I) = F - G if (I == N) go to 160 ! DO 150 J = L, N S = 0.0E0 ! DO 140 K = I, M 140 S = S + A(K,I) * A(K,J) ! F = S / H ! DO 150 K = I, M A(K,J) = A(K,J) + F * A(K,I) 150 CONTINUE ! 160 if (IP == 0) go to 190 ! DO 180 J = 1, IP S = 0.0E0 ! DO 170 K = I, M 170 S = S + A(K,I) * B(K,J) ! F = S / H ! DO 180 K = I, M B(K,J) = B(K,J) + F * A(K,I) 180 CONTINUE ! 190 DO 200 K = I, M 200 A(K,I) = SCALE * A(K,I) ! 210 W(I) = SCALE * G G = 0.0E0 S = 0.0E0 SCALE = 0.0E0 if (I > M .OR. I == N) go to 290 ! DO 220 K = L, N 220 SCALE = SCALE + ABS(A(I,K)) ! if (SCALE == 0.0E0) go to 290 ! DO 230 K = L, N A(I,K) = A(I,K) / SCALE S = S + A(I,K)**2 230 CONTINUE ! F = A(I,L) G = -SIGN(SQRT(S),F) H = F * G - S A(I,L) = F - G ! DO 240 K = L, N 240 RV1(K) = A(I,K) / H ! if (I == M) go to 270 ! DO 260 J = L, M S = 0.0E0 ! DO 250 K = L, N 250 S = S + A(J,K) * A(I,K) ! DO 260 K = L, N A(J,K) = A(J,K) + S * RV1(K) 260 CONTINUE ! 270 DO 280 K = L, N 280 A(I,K) = SCALE * A(I,K) ! 290 S1 = MAX(S1,ABS(W(I))+ABS(RV1(I))) 300 CONTINUE ! .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS. ! FOR I=N STEP -1 UNTIL 1 DO -- .......... DO 400 II = 1, N I = N + 1 - II if (I == N) go to 390 if (G == 0.0E0) go to 360 ! DO 320 J = L, N ! .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... 320 A(J,I) = (A(I,J) / A(I,L)) / G ! DO 350 J = L, N S = 0.0E0 ! DO 340 K = L, N 340 S = S + A(I,K) * A(K,J) ! DO 350 K = L, N A(K,J) = A(K,J) + S * A(K,I) 350 CONTINUE ! 360 DO 380 J = L, N A(I,J) = 0.0E0 A(J,I) = 0.0E0 380 CONTINUE ! 390 A(I,I) = 1.0E0 G = RV1(I) L = I 400 CONTINUE ! if (M >= N .OR. IP == 0) go to 510 M1 = M + 1 ! DO 500 I = M1, N ! DO 500 J = 1, IP B(I,J) = 0.0E0 500 CONTINUE ! .......... DIAGONALIZATION OF THE BIDIAGONAL FORM .......... 510 CONTINUE ! .......... FOR K=N STEP -1 UNTIL 1 DO -- .......... DO 700 KK = 1, N K1 = N - KK K = K1 + 1 ITS = 0 ! .......... TEST FOR SPLITTING. ! FOR L=K STEP -1 UNTIL 1 DO -- .......... 520 DO 530 LL = 1, K L1 = K - LL L = L1 + 1 if (S1 + ABS(RV1(L)) == S1) go to 565 ! .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT ! THROUGH THE BOTTOM OF THE LOOP .......... if (S1 + ABS(W(L1)) == S1) go to 540 530 CONTINUE ! .......... CANCELLATION OF RV1(L) if L GREATER THAN 1 .......... 540 C = 0.0E0 S = 1.0E0 ! DO 560 I = L, K F = S * RV1(I) RV1(I) = C * RV1(I) if (S1 + ABS(F) == S1) go to 565 G = W(I) H = PYTHAG(F,G) W(I) = H C = G / H S = -F / H if (IP == 0) go to 560 ! DO 550 J = 1, IP Y = B(L1,J) Z = B(I,J) B(L1,J) = Y * C + Z * S B(I,J) = -Y * S + Z * C 550 CONTINUE ! 560 CONTINUE ! .......... TEST FOR CONVERGENCE .......... 565 Z = W(K) if (L == K) go to 650 ! .......... SHIFT FROM BOTTOM 2 BY 2 MINOR .......... if (ITS == 30) go to 1000 ITS = ITS + 1 X = W(L) Y = W(K1) G = RV1(K1) H = RV1(K) F = 0.5E0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y) G = PYTHAG(F,1.0E0) F = X - (Z / X) * Z + (H / X) * (Y / (F + SIGN(G,F)) - H) ! .......... NEXT QR TRANSFORMATION .......... C = 1.0E0 S = 1.0E0 ! DO 600 I1 = L, K1 I = I1 + 1 G = RV1(I) Y = W(I) H = S * G G = C * G Z = PYTHAG(F,H) RV1(I1) = Z C = F / Z S = H / Z F = X * C + G * S G = -X * S + G * C H = Y * S Y = Y * C ! DO 570 J = 1, N X = A(J,I1) Z = A(J,I) A(J,I1) = X * C + Z * S A(J,I) = -X * S + Z * C 570 CONTINUE ! Z = PYTHAG(F,H) W(I1) = Z ! .......... ROTATION CAN BE ARBITRARY if Z IS ZERO .......... if (Z == 0.0E0) go to 580 C = F / Z S = H / Z 580 F = C * G + S * Y X = -S * G + C * Y if (IP == 0) go to 600 ! DO 590 J = 1, IP Y = B(I1,J) Z = B(I,J) B(I1,J) = Y * C + Z * S B(I,J) = -Y * S + Z * C 590 CONTINUE ! 600 CONTINUE ! RV1(L) = 0.0E0 RV1(K) = F W(K) = X go to 520 ! .......... CONVERGENCE .......... 650 if (Z >= 0.0E0) go to 700 ! .......... W(K) IS MADE NON-NEGATIVE .......... W(K) = -Z ! DO 690 J = 1, N 690 A(J,K) = -A(J,K) ! 700 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO A ! SINGULAR VALUE AFTER 30 ITERATIONS .......... 1000 IERR = K 1001 RETURN end subroutine MINSO4 (USOL, IDMN, ZN, ZM, PERTB) ! !! MINSO4 is subsidiary to SEPX4. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (MINSO4-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine orthogonalizes the array USOL with respect to ! the constant array in a weighted least squares norm. ! ! Entry at MINSO4 occurs when the final solution is ! to be minimized with respect to the weighted ! least squares norm. ! !***SEE ALSO SEPX4 !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SPL4 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE MINSO4 ! COMMON /SPL4/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION USOL(IDMN,*) ,ZN(*) ,ZM(*) !***FIRST EXECUTABLE STATEMENT MINSO4 ISTR = 1 IFNL = K JSTR = 1 JFNL = L ! ! COMPUTE WEIGHTED INNER PRODUCTS ! 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 ! ! SET PERTURBATION PARAMETER ! PERTRB = UTE/ETE ! ! SUBTRACT OFF CONSTANT PERTRB ! 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) ! !! MINSOL is subsidiary to SEPELI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (MINSOL-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine orthogonalizes the array USOL with respect to ! the constant array in a weighted least squares norm. ! ! Entry at MINSOL occurs when the final solution is ! to be minimized with respect to the weighted ! least squares norm. ! !***SEE ALSO SEPELI !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SPLPCM !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE MINSOL ! COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION USOL(IDMN,*) ,ZN(*) ,ZM(*) !***FIRST EXECUTABLE STATEMENT MINSOL ISTR = 1 IFNL = K JSTR = 1 JFNL = L ! ! COMPUTE WEIGHTED INNER PRODUCTS ! 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 ! ! SET PERTURBATION PARAMETER ! PERTRB = UTE/ETE ! ! SUBTRACT OFF CONSTANT PERTRB ! DO 40 I=ISTR,IFNL DO 30 J=JSTR,JFNL USOL(I,J) = USOL(I,J)-PERTRB 30 CONTINUE 40 CONTINUE return end subroutine MPADD2 (X, Y, Z, Y1, TRUNC) ! !! MPADD2 is subsidiary to DQDOTA and DQDOTI. ! !***LIBRARY SLATEC !***TYPE ALL (MPADD2-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Called by MPADD, MPSUB etc. ! X, Y and Z are MP numbers, Y1 and TRUNC are integers. ! To force call by reference rather than value/result, Y1 is ! declared as an array, but only Y1(1) is ever used. ! Sets Z = X + Y1(1)*ABS(Y), where Y1(1) = +- Y(1). ! If TRUNC == 0, R*-rounding is used; otherwise, truncation. ! R*-rounding is defined in the Kuki and Cody reference. ! ! The arguments X(*), Y(*), and Z(*) are all INTEGER arrays of size ! 30. See the comments in the routine MPBLAS for the reason for this ! choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***REFERENCES H. Kuki and W. J. Cody, A statistical study of floating ! point number systems, Communications of the ACM 16, 4 ! (April 1973), pp. 223-230. ! R. P. Brent, On the precision attainable with various ! floating-point number systems, IEEE Transactions on ! Computers C-22, 6 (June 1973), pp. 601-607. ! R. P. Brent, A Fortran multiple-precision arithmetic ! package, ACM Transactions on Mathematical Software 4, ! 1 (March 1978), pp. 57-70. ! R. P. Brent, MP, a Fortran multiple-precision arithmetic ! package, Algorithm 524, ACM Transactions on Mathema- ! tical Software 4, 1 (March 1978), pp. 71-81. !***ROUTINES CALLED MPADD3, MPCHK, MPERR, MPNZR, MPSTR !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 920528 Added a REFERENCES section revised. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPADD2 COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, X(*), Y(*), Z(*), Y1(*), TRUNC INTEGER S, ED, RS, RE !***FIRST EXECUTABLE STATEMENT MPADD2 if (X(1) /= 0) go to 20 10 call MPSTR(Y, Z) Z(1) = Y1(1) return 20 if (Y1(1) /= 0) go to 40 30 call MPSTR (X, Z) return ! COMPARE SIGNS 40 S = X(1)*Y1(1) if (ABS(S) <= 1) go to 60 call MPCHK (1, 4) WRITE (LUN, 50) 50 FORMAT (' *** SIGN NOT 0, +1 OR -1 IN call TO MPADD2,', & ' POSSIBLE OVERWRITING PROBLEM ***') call MPERR Z(1) = 0 return ! COMPARE EXPONENTS 60 ED = X(2) - Y(2) MED = ABS(ED) if (ED) 90, 70, 120 ! EXPONENTS EQUAL SO COMPARE SIGNS, THEN FRACTIONS if NEC. 70 if (S > 0) go to 100 DO 80 J = 1, T if (X(J+2) - Y(J+2)) 100, 80, 130 80 CONTINUE ! RESULT IS ZERO Z(1) = 0 return ! HERE EXPONENT(Y) >= EXPONENT(X) 90 if (MED > T) go to 10 100 RS = Y1(1) RE = Y(2) call MPADD3 (X, Y, S, MED, RE) ! NORMALIZE, ROUND OR TRUNCATE, AND RETURN 110 call MPNZR (RS, RE, Z, TRUNC) return ! ABS(X) > ABS(Y) 120 if (MED > T) go to 30 130 RS = X(1) RE = X(2) call MPADD3 (Y, X, S, MED, RE) go to 110 end subroutine MPADD3 (X, Y, S, MED, RE) ! !! MPADD3 is subsidiary to DQDOTA and DQDOTI. ! !***LIBRARY SLATEC !***TYPE ALL (MPADD3-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Called by MPADD2; does inner loops of addition ! ! The arguments X(*) and Y(*) and the variable R in COMMON are all ! INTEGER arrays of size 30. See the comments in the routine MPBLAS ! for the reason for this choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED (NONE) !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPADD3 COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, X(*), Y(*), S, RE, C, TED !***FIRST EXECUTABLE STATEMENT MPADD3 TED = T + MED I2 = T + 4 I = I2 C = 0 ! CLEAR GUARD DIGITS TO RIGHT OF X DIGITS 10 if (I <= TED) go to 20 R(I) = 0 I = I - 1 go to 10 20 if (S < 0) go to 130 ! HERE DO ADDITION, EXPONENT(Y) >= EXPONENT(X) if (I < T) go to 40 30 J = I - MED R(I) = X(J+2) I = I - 1 if (I > T) go to 30 40 if (I <= MED) go to 60 J = I - MED C = Y(I+2) + X(J+2) + C if (C < B) go to 50 ! CARRY GENERATED HERE R(I) = C - B C = 1 I = I - 1 go to 40 ! NO CARRY GENERATED HERE 50 R(I) = C C = 0 I = I - 1 go to 40 60 if (I <= 0) go to 90 C = Y(I+2) + C if (C < B) go to 70 R(I) = 0 C = 1 I = I - 1 go to 60 70 R(I) = C I = I - 1 ! NO CARRY POSSIBLE HERE 80 if (I <= 0) RETURN R(I) = Y(I+2) I = I - 1 go to 80 90 if (C == 0) RETURN ! MUST SHIFT RIGHT HERE AS CARRY OFF END I2P = I2 + 1 DO 100 J = 2, I2 I = I2P - J 100 R(I+1) = R(I) R(1) = 1 RE = RE + 1 return ! HERE DO SUBTRACTION, ABS(Y) > ABS(X) 110 J = I - MED R(I) = C - X(J+2) C = 0 if (R(I) >= 0) go to 120 ! BORROW GENERATED HERE C = -1 R(I) = R(I) + B 120 I = I - 1 130 if (I > T) go to 110 140 if (I <= MED) go to 160 J = I - MED C = Y(I+2) + C - X(J+2) if (C >= 0) go to 150 ! BORROW GENERATED HERE R(I) = C + B C = -1 I = I - 1 go to 140 ! NO BORROW GENERATED HERE 150 R(I) = C C = 0 I = I - 1 go to 140 160 if (I <= 0) RETURN C = Y(I+2) + C if (C >= 0) go to 70 R(I) = C + B C = -1 I = I - 1 go to 160 end subroutine MPADD (X, Y, Z) ! !! MPADD is subsidiary to DQDOTA and DQDOTI. ! !***LIBRARY SLATEC !***TYPE ALL (MPADD-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Adds X and Y, forming result in Z, where X, Y and Z are 'mp' ! (multiple precision) numbers. Four guard digits are used, ! and then R*-rounding. ! !***SEE ALSO DQDOTA, DQDOTI !***ROUTINES CALLED MPADD2 !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE MPADD INTEGER X(*), Y(*), Z(*) !***FIRST EXECUTABLE STATEMENT MPADD call MPADD2 (X, Y, Z, Y, 0) return end subroutine MPBLAS (I1) ! !! MPBLAS is subsidiary to DQDOTA and DQDOTI. ! !***LIBRARY SLATEC !***TYPE ALL (MPBLAS-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine is called to set up Brent's 'mp' package ! for use by the extended precision inner products from the BLAS. ! ! In the SLATEC library we require the Extended Precision MP number ! to have a mantissa twice as long as Double Precision numbers. ! The calculation of MPT (and MPMXR which is the actual array size) ! in this routine will give 2x (or slightly more) on the machine ! that we are running on. The INTEGER array size of 30 was chosen ! to be slightly longer than the longest INTEGER array needed on ! any machine that we are currently aware of. ! !***SEE ALSO DQDOTA, DQDOTI !***REFERENCES R. P. Brent, A Fortran multiple-precision arithmetic ! package, ACM Transactions on Mathematical Software 4, ! 1 (March 1978), pp. 57-70. ! R. P. Brent, MP, a Fortran multiple-precision arithmetic ! package, Algorithm 524, ACM Transactions on Mathema- ! tical Software 4, 1 (March 1978), pp. 71-81. !***ROUTINES CALLED I1MACH, XERMSG !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8, and calculate ! size for Quad Precision for 2x DP. (RWC) !***END PROLOGUE MPBLAS COMMON /MPCOM/ MPB, MPT, MPM, MPLUN, MPMXR, MPR(30) !***FIRST EXECUTABLE STATEMENT MPBLAS I1 = 1 ! ! For full extended precision accuracy, MPB should be as large as ! possible, subject to the restrictions in Brent's paper. ! ! Statements below are for an integer wordlength of 48, 36, 32, ! 24, 18, and 16. Pick one, or generate a new one. ! 48 MPB = 4194304 ! 36 MPB = 65536 ! 32 MPB = 16384 ! 24 MPB = 1024 ! 18 MPB = 128 ! 16 MPB = 64 ! MPBEXP = I1MACH(8)/2-2 MPB = 2**MPBEXP ! ! Set up remaining parameters ! UNIT FOR ERROR MESSAGES MPLUN = I1MACH(4) ! NUMBER OF MP DIGITS MPT = (2*I1MACH(14)+MPBEXP-1)/MPBEXP ! DIMENSION OF R MPMXR = MPT+4 ! if (MPMXR > 30) THEN call XERMSG('SLATEC', 'MPBLAS', & 'Array space not sufficient for Quad Precision 2x ' // & 'Double Precision, Proceeding.', 1, 1) MPT = 26 MPMXR = 30 end if ! EXPONENT RANGE MPM = MIN(32767,I1MACH(9)/4-1) return end subroutine MPCDM (DX, Z) ! !! MPCDM is subsidiary to DQDOTA and DQDOTI. ! !***LIBRARY SLATEC !***TYPE ALL (MPCDM-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Converts double-precision number DX to multiple-precision Z. ! Some numbers will not convert exactly on machines with base ! other than two, four or sixteen. This routine is not called ! by any other routine in 'mp', so may be omitted if double- ! precision is not available. ! ! The argument Z(*) and the variable R in COMMON are both INTEGER ! arrays of size 30. See the comments in the routine MPBLAS for the ! for the reason for this choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED MPCHK, MPDIVI, MPMULI, MPNZR !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPCDM DOUBLE PRECISION DB, DJ, DX COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, Z(*), RS, RE, TP !***FIRST EXECUTABLE STATEMENT MPCDM call MPCHK (1, 4) I2 = T + 4 ! CHECK SIGN if (DX) 20, 10, 30 ! if DX = 0D0 RETURN 0 10 Z(1) = 0 return ! DX < 0D0 20 RS = -1 DJ = -DX go to 40 ! DX > 0D0 30 RS = 1 DJ = DX 40 IE = 0 50 if (DJ < 1D0) go to 60 ! INCREASE IE AND DIVIDE DJ BY 16. IE = IE + 1 DJ = 0.0625D0*DJ go to 50 60 if (DJ >= 0.0625D0) go to 70 IE = IE - 1 DJ = 16D0*DJ go to 60 ! NOW DJ IS DY DIVIDED BY SUITABLE POWER OF 16 ! SET EXPONENT TO 0 70 RE = 0 DB = DBLE(B) ! CONVERSION LOOP (ASSUME DOUBLE-PRECISION OPS. EXACT) DO 80 I = 1, I2 DJ = DB*DJ R(I) = INT(DJ) 80 DJ = DJ - DBLE(R(I)) ! NORMALIZE RESULT call MPNZR (RS, RE, Z, 0) IB = MAX(7*B*B, 32767)/16 TP = 1 ! NOW MULTIPLY BY 16**IE if (IE) 90, 130, 110 90 K = -IE DO 100 I = 1, K TP = 16*TP if ((TP <= IB).AND.(TP /= B).AND.(I < K)) go to 100 call MPDIVI (Z, TP, Z) TP = 1 100 CONTINUE return 110 DO 120 I = 1, IE TP = 16*TP if ((TP <= IB).AND.(TP /= B).AND.(I < IE)) go to 120 call MPMULI (Z, TP, Z) TP = 1 120 CONTINUE 130 RETURN end subroutine MPCHK (I, J) ! !! MPCHK is subsidiary to DQDOTA and DQDOTI. ! !***LIBRARY SLATEC !***TYPE ALL (MPCHK-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Checks legality of B, T, M, MXR and LUN which should be set ! in COMMON. The condition on MXR (the dimension of the EP arrays) ! is that MXR >= (I*T + J) ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED I1MACH, MPERR !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 891009 Removed unreferenced statement label. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPCHK COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R !***FIRST EXECUTABLE STATEMENT MPCHK LUN = I1MACH(4) ! NOW CHECK LEGALITY OF B, T AND M if (B > 1) go to 40 WRITE (LUN, 30) B 30 FORMAT (' *** B =', I10, ' ILLEGAL IN call TO MPCHK,'/ & ' PERHAPS NOT SET BEFORE call TO AN MP ROUTINE ***') call MPERR 40 if (T > 1) go to 60 WRITE (LUN, 50) T 50 FORMAT (' *** T =', I10, ' ILLEGAL IN call TO MPCHK,'/ & ' PERHAPS NOT SET BEFORE call TO AN MP ROUTINE ***') call MPERR 60 if (M > T) go to 80 WRITE (LUN, 70) 70 FORMAT (' *** M <= T IN call TO MPCHK,'/ & ' PERHAPS NOT SET BEFORE call TO AN MP ROUTINE ***') call MPERR ! 8*B*B-1 SHOULD BE REPRESENTABLE, if NOT WILL OVERFLOW ! AND MAY BECOME NEGATIVE, SO CHECK FOR THIS 80 IB = 4*B*B - 1 if ((IB > 0).AND.((2*IB+1) > 0)) go to 100 WRITE (LUN, 90) 90 FORMAT (' *** B TOO LARGE IN call TO MPCHK ***') call MPERR ! CHECK THAT SPACE IN COMMON IS SUFFICIENT 100 MX = I*T + J if (MXR >= MX) RETURN ! HERE COMMON IS TOO SMALL, SO GIVE ERROR MESSAGE. WRITE (LUN, 110) I, J, MX, MXR, T 110 FORMAT (' *** MXR TOO SMALL OR NOT SET TO DIM(R) BEFORE CALL', & ' TO AN MP ROUTINE *** ' / & ' *** MXR SHOULD BE AT LEAST', I3, '*T +', I4, ' =', I6, ' ***' & / ' *** ACTUALLY MXR =', I10, ', AND T =', I10, ' ***') call MPERR return end subroutine MPCMD (X, DZ) ! !! MPCMD is subsidiary to DQDOTA and DQDOTI. ! !***LIBRARY SLATEC !***TYPE ALL (MPCMD-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Converts multiple-precision X to double-precision DZ. Assumes ! X is in allowable range for double-precision numbers. There is ! some loss of accuracy if the exponent is large. ! ! The argument X(*) is INTEGER array of size 30. See the comments in ! the routine MPBLAS for the reason for this choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED MPCHK, MPERR !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPCMD DOUBLE PRECISION DB, DZ, DZ2 COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, X(*), TM !***FIRST EXECUTABLE STATEMENT MPCMD ! call MPCHK (1, 4) DZ = 0.0D+00 if ( X(1) == 0 ) then RETURN end if DB = DBLE ( B ) DO I = 1, T DZ = DB*DZ + DBLE(X(I+2)) TM = I ! ! CHECK if FULL DOUBLE-PRECISION ACCURACY ATTAINED ! DZ2 = DZ + 1.0D+00 ! ! TEST BELOW NOT ALWAYS EQUIVALENT TO - if (DZ2 <= DZ), ! FOR EXAMPLE ON CYBER 76. ! if ( ( DZ2 - DZ ) <= 0.0D+00 ) then exit end if end do ! ! NOW ALLOW FOR EXPONENT ! DZ = DZ*(DB**(X(2)-TM)) ! ! CHECK REASONABLENESS OF RESULT. ! if ( DZ <= 0.0D+00 ) then WRITE ( LUN, '(a)' ) ' *** FLOATING-POINT OVER/UNDER-FLOW IN MPCMD ***' call MPERR return end if ! ! LHS SHOULD BE <= 0.5 BUT ALLOW FOR SOME ERROR IN LOG ! if ( ABS(DBLE(X(2))-(LOG(DZ) / LOG(DBLE(B))+0.5D0)) > 0.6D0 ) then WRITE ( LUN, '(a)' ) ' *** FLOATING-POINT OVER/UNDER-FLOW IN MPCMD ***' call MPERR return end if if ( X(1) < 0 ) then DZ = -DZ end if return end subroutine MPDIVI (X, IY, Z) ! !! MPDIVI is subsidiary to DQDOTA and DQDOTI. ! !***LIBRARY SLATEC !***TYPE ALL (MPDIVI-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Divides 'mp' X by the single-precision integer IY giving 'mp' Z. ! This is much faster than division by an 'mp' number. ! ! The arguments X(*) and Z(*), and the variable R in COMMON are all ! INTEGER arrays of size 30. See the comments in the routine MPBLAS ! for the reason for this choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED MPCHK, MPERR, MPNZR, MPSTR, MPUNFL !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPDIVI COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, X(*), Z(*), RS, RE, R1, C, C2, B2 !***FIRST EXECUTABLE STATEMENT MPDIVI RS = X(1) J = IY if (J) 30, 10, 40 10 WRITE (LUN, 20) 20 FORMAT (' *** ATTEMPTED DIVISION BY ZERO IN call TO MPDIVI ***') go to 230 30 J = -J RS = -RS 40 RE = X(2) ! CHECK FOR ZERO DIVIDEND if (RS == 0) go to 120 ! CHECK FOR DIVISION BY B if (J /= B) go to 50 call MPSTR (X, Z) if (RE <= (-M)) go to 240 Z(1) = RS Z(2) = RE - 1 return ! CHECK FOR DIVISION BY 1 OR -1 50 if (J /= 1) go to 60 call MPSTR (X, Z) Z(1) = RS return 60 C = 0 I2 = T + 4 I = 0 ! if J*B NOT REPRESENTABLE AS AN INTEGER HAVE TO SIMULATE ! LONG DIVISION. ASSUME AT LEAST 16-BIT WORD. B2 = MAX(8*B,32767/B) if (J >= B2) go to 130 ! LOOK FOR FIRST NONZERO DIGIT IN QUOTIENT 70 I = I + 1 C = B*C if (I <= T) C = C + X(I+2) R1 = C/J if (R1) 210, 70, 80 ! ADJUST EXPONENT AND GET T+4 DIGITS IN QUOTIENT 80 RE = RE + 1 - I R(1) = R1 C = B*(C - J*R1) KH = 2 if (I >= T) go to 100 KH = 1 + T - I DO 90 K = 2, KH I = I + 1 C = C + X(I+2) R(K) = C/J 90 C = B*(C - J*R(K)) if (C < 0) go to 210 KH = KH + 1 100 DO 110 K = KH, I2 R(K) = C/J 110 C = B*(C - J*R(K)) if (C < 0) go to 210 ! NORMALIZE AND ROUND RESULT 120 call MPNZR (RS, RE, Z, 0) return ! HERE NEED SIMULATED DOUBLE-PRECISION DIVISION 130 C2 = 0 J1 = J/B J2 = J - J1*B J11 = J1 + 1 ! LOOK FOR FIRST NONZERO DIGIT 140 I = I + 1 C = B*C + C2 C2 = 0 if (I <= T) C2 = X(I+2) if (C-J1) 140, 150, 160 150 if (C2 < J2) go to 140 ! COMPUTE T+4 QUOTIENT DIGITS 160 RE = RE + 1 - I K = 1 go to 180 ! MAIN LOOP FOR LARGE ABS(IY) CASE 170 K = K + 1 if (K > I2) go to 120 I = I + 1 ! GET APPROXIMATE QUOTIENT FIRST 180 IR = C/J11 ! NOW REDUCE SO OVERFLOW DOES NOT OCCUR IQ = C - IR*J1 if (IQ < B2) go to 190 ! HERE IQ*B WOULD POSSIBLY OVERFLOW SO INCREASE IR IR = IR + 1 IQ = IQ - J1 190 IQ = IQ*B - IR*J2 if (IQ >= 0) go to 200 ! HERE IQ NEGATIVE SO IR WAS TOO LARGE IR = IR - 1 IQ = IQ + J 200 if (I <= T) IQ = IQ + X(I+2) IQJ = IQ/J ! R(K) = QUOTIENT, C = REMAINDER R(K) = IQJ + IR C = IQ - J*IQJ if (C >= 0) go to 170 ! CARRY NEGATIVE SO OVERFLOW MUST HAVE OCCURRED 210 call MPCHK (1, 4) WRITE (LUN, 220) 220 FORMAT (' *** INTEGER OVERFLOW IN MPDIVI, B TOO LARGE ***') 230 call MPERR Z(1) = 0 return ! UNDERFLOW HERE 240 call MPUNFL(Z) return end subroutine MPERR ! !! MPERR is subsidiary to DQDOTA and DQDOTI. ! !***LIBRARY SLATEC !***TYPE ALL (MPERR-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This routine is called when a fatal error condition is ! encountered, and after a message has been written on ! logical unit LUN. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED (NONE) !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPERR COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R !***FIRST EXECUTABLE STATEMENT MPERR call XERMSG('SLATEC', 'MPERR', & ' *** EXECUTION TERMINATED BY call TO MPERR' // & ' IN MP VERSION 770217 ***', 1, 2) ! ! AT PRESENT JUST STOP, BUT COULD DUMP B, T, ETC. HERE. ! ACTION COULD EASILY BE CONTROLLED BY A FLAG IN LABELLED COMMON. ! ANSI VERSION USES STOP, UNIVAC 1108 VERSION USES ! RETURN 0 IN ORDER TO GIVE A TRACE-BACK. ! FOR DEBUGGING PURPOSES IT MAY BE USEFUL SIMPLY TO ! RETURN HERE. MOST MP ROUTINES RETURN WITH RESULT ! ZERO AFTER CALLING MPERR. STOP end subroutine MPMAXR (X) ! !! MPMAXR sets X to the largest possible 'mp' number. ! !***LIBRARY SLATEC !***TYPE ALL (MPMAXR-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Sets X to the largest possible positive 'mp' number. ! ! The argument X(*) is an INTEGER arrays of size 30. See the comments ! in the routine MPBLAS for the reason for this choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED MPCHK !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPMAXR COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, X(*) !***FIRST EXECUTABLE STATEMENT MPMAXR call MPCHK (1, 4) IT = B - 1 ! SET FRACTION DIGITS TO B-1 DO 10 I = 1, T 10 X(I+2) = IT ! SET SIGN AND EXPONENT X(1) = 1 X(2) = M return end subroutine MPMLP (U, V, W, J) ! !! MPMLP performs the inner multiplication loop for MPMUL. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DQDOTA and DQDOTI !***LIBRARY SLATEC !***TYPE ALL (MPMLP-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Performs inner multiplication loop for MPMUL. Carries are not pro- ! pagated in inner loop, which saves time at the expense of space. ! !***SEE ALSO DQDOTA, DQDOTI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE MPMLP INTEGER U(*), V(*), W !***FIRST EXECUTABLE STATEMENT MPMLP DO 10 I = 1, J 10 U(I) = U(I) + W*V(I) return end subroutine MPMUL2 (X, IY, Z, TRUNC) ! !! MPMUL2 multiplies an 'mp' number by a single precision integer. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DQDOTA and DQDOTI !***LIBRARY SLATEC !***TYPE ALL (MPMUL2-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Multiplies 'mp' X by single-precision integer IY giving 'mp' Z. ! Multiplication by 1 may be used to normalize a number even if some ! digits are greater than B-1. Result is rounded if TRUNC == 0, ! otherwise truncated. ! ! The arguments X(*) and Z(*), and the variable R in COMMON are all ! INTEGER arrays of size 30. See the comments in the routine MPBLAS ! for the reason for this choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED MPCHK, MPERR, MPNZR, MPOVFL, MPSTR !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPMUL2 COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, X(*), Z(*), TRUNC, RE, RS INTEGER C, C1, C2, RI, T1, T3, T4 !***FIRST EXECUTABLE STATEMENT MPMUL2 RS = X(1) if (RS == 0) go to 10 J = IY if (J) 20, 10, 50 ! RESULT ZERO 10 Z(1) = 0 return 20 J = -J RS = -RS ! CHECK FOR MULTIPLICATION BY B if (J /= B) go to 50 if (X(2) < M) go to 40 call MPCHK (1, 4) WRITE (LUN, 30) 30 FORMAT (' *** OVERFLOW OCCURRED IN MPMUL2 ***') call MPOVFL (Z) return 40 call MPSTR (X, Z) Z(1) = RS Z(2) = X(2) + 1 return ! SET EXPONENT TO EXPONENT(X) + 4 50 RE = X(2) + 4 ! FORM PRODUCT IN ACCUMULATOR C = 0 T1 = T + 1 T3 = T + 3 T4 = T + 4 ! if J*B NOT REPRESENTABLE AS AN INTEGER WE HAVE TO SIMULATE ! DOUBLE-PRECISION MULTIPLICATION. if (J >= MAX(8*B, 32767/B)) go to 110 DO 60 IJ = 1, T I = T1 - IJ RI = J*X(I+2) + C C = RI/B 60 R(I+4) = RI - B*C ! CHECK FOR INTEGER OVERFLOW if (RI < 0) go to 130 ! HAVE TO TREAT FIRST FOUR WORDS OF R SEPARATELY DO 70 IJ = 1, 4 I = 5 - IJ RI = C C = RI/B 70 R(I) = RI - B*C if (C == 0) go to 100 ! HAVE TO SHIFT RIGHT HERE AS CARRY OFF END 80 DO 90 IJ = 1, T3 I = T4 - IJ 90 R(I+1) = R(I) RI = C C = RI/B R(1) = RI - B*C RE = RE + 1 if (C) 130, 100, 80 ! NORMALIZE AND ROUND OR TRUNCATE RESULT 100 call MPNZR (RS, RE, Z, TRUNC) return ! HERE J IS TOO LARGE FOR SINGLE-PRECISION MULTIPLICATION 110 J1 = J/B J2 = J - J1*B ! FORM PRODUCT DO 120 IJ = 1, T4 C1 = C/B C2 = C - B*C1 I = T1 - IJ IX = 0 if (I > 0) IX = X(I+2) RI = J2*IX + C2 IS = RI/B C = J1*IX + C1 + IS 120 R(I+4) = RI - B*IS if (C) 130, 100, 80 ! CAN ONLY GET HERE if INTEGER OVERFLOW OCCURRED 130 call MPCHK (1, 4) WRITE (LUN, 140) 140 FORMAT (' *** INTEGER OVERFLOW IN MPMUL2, B TOO LARGE ***') call MPERR go to 10 end subroutine MPMUL (X, Y, Z) ! !! MPMUL multiples two 'mp' numbers. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DQDOTA and DQDOTI !***LIBRARY SLATEC !***TYPE ALL (MPMUL-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Multiplies X and Y, returning result in Z, for 'mp' X, Y and Z. ! The simple o(t**2) algorithm is used, with four guard digits and ! R*-rounding. Advantage is taken of zero digits in X, but not in Y. ! Asymptotically faster algorithms are known (see Knuth, VOL. 2), ! but are difficult to implement in FORTRAN in an efficient and ! machine-independent manner. In comments to other 'mp' routines, ! M(t) is the time to perform t-digit 'mp' multiplication. Thus ! M(t) = o(t**2) with the present version of MPMUL, but ! M(t) = o(t.log(t).log(log(t))) is theoretically possible. ! ! The arguments X(*), Y(*), and Z(*), and the variable R in COMMON are ! all INTEGER arrays of size 30. See the comments in the routine ! MPBLAS for the reason for this choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED MPCHK, MPERR, MPMLP, MPNZR !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPMUL COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, X(*), Y(*), Z(*), RS, RE, XI, C, RI !***FIRST EXECUTABLE STATEMENT MPMUL call MPCHK (1, 4) I2 = T + 4 I2P = I2 + 1 ! FORM SIGN OF PRODUCT RS = X(1)*Y(1) if (RS /= 0) go to 10 ! SET RESULT TO ZERO Z(1) = 0 return ! FORM EXPONENT OF PRODUCT 10 RE = X(2) + Y(2) ! CLEAR ACCUMULATOR DO 20 I = 1, I2 20 R(I) = 0 ! PERFORM MULTIPLICATION C = 8 DO 40 I = 1, T XI = X(I+2) ! FOR SPEED, PUT THE NUMBER WITH MANY ZEROS FIRST if (XI == 0) go to 40 call MPMLP (R(I+1), Y(3), XI, MIN (T, I2 - I)) C = C - 1 if (C > 0) go to 40 ! CHECK FOR LEGAL BASE B DIGIT if ((XI < 0).OR.(XI >= B)) go to 90 ! PROPAGATE CARRIES AT END AND EVERY EIGHTH TIME, ! FASTER THAN DOING IT EVERY TIME. DO 30 J = 1, I2 J1 = I2P - J RI = R(J1) + C if (RI < 0) go to 70 C = RI/B 30 R(J1) = RI - B*C if (C /= 0) go to 90 C = 8 40 CONTINUE if (C == 8) go to 60 if ((XI < 0).OR.(XI >= B)) go to 90 C = 0 DO 50 J = 1, I2 J1 = I2P - J RI = R(J1) + C if (RI < 0) go to 70 C = RI/B 50 R(J1) = RI - B*C if (C /= 0) go to 90 ! NORMALIZE AND ROUND RESULT 60 call MPNZR (RS, RE, Z, 0) return 70 WRITE (LUN, 80) 80 FORMAT (' *** INTEGER OVERFLOW IN MPMUL, B TOO LARGE ***') go to 110 90 WRITE (LUN, 100) 100 FORMAT (' *** ILLEGAL BASE B DIGIT IN call TO MPMUL,', & ' POSSIBLE OVERWRITING PROBLEM ***') 110 call MPERR Z(1) = 0 return end subroutine MPMULI (X, IY, Z) ! !! MPMULI multiplies 'mp' X by a single precision integer. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DQDOTA and DQDOTI !***LIBRARY SLATEC !***TYPE ALL (MPMULI-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Multiplies 'mp' X by single-precision integer IY giving 'mp' Z. ! This is faster than using MPMUL. Result is ROUNDED. ! Multiplication by 1 may be used to normalize a number ! even if the last digit is B. ! !***SEE ALSO DQDOTA, DQDOTI !***ROUTINES CALLED MPMUL2 !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE MPMULI INTEGER X(*), Z(*) !***FIRST EXECUTABLE STATEMENT MPMULI call MPMUL2 (X, IY, Z, 0) return end subroutine MPNZR (RS, RE, Z, TRUNC) ! !! MPNZR is subsidiary to DQDOTA and DQDOTI. ! !***LIBRARY SLATEC !***TYPE ALL (MPNZR-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Modified for use with BLAS. Blank COMMON changed to named COMMON. ! Assumes long (i.e. (t+4)-DIGIT) fraction in R, sign = RS, exponent ! = RE. Normalizes, and returns 'mp' result in Z. Integer arguments ! RS and RE are not preserved. R*-rounding is used if TRUNC == 0 ! ! The argument Z(*) and the variable R in COMMON are INTEGER arrays ! of size 30. See the comments in the routine MPBLAS for the reason ! for this choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED MPERR, MPOVFL, MPUNFL !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPNZR COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, Z(*), RE, RS, TRUNC, B2 !***FIRST EXECUTABLE STATEMENT MPNZR I2 = T + 4 if (RS /= 0) go to 20 ! STORE ZERO IN Z 10 Z(1) = 0 return ! CHECK THAT SIGN = +-1 20 if (ABS(RS) <= 1) go to 40 WRITE (LUN, 30) 30 FORMAT (' *** SIGN NOT 0, +1 OR -1 IN call TO MPNZR,', & ' POSSIBLE OVERWRITING PROBLEM ***') call MPERR go to 10 ! LOOK FOR FIRST NONZERO DIGIT 40 DO 50 I = 1, I2 IS = I - 1 if (R(I) > 0) go to 60 50 CONTINUE ! FRACTION ZERO go to 10 60 if (IS == 0) go to 90 ! NORMALIZE RE = RE - IS I2M = I2 - IS DO 70 J = 1, I2M K = J + IS 70 R(J) = R(K) I2P = I2M + 1 DO 80 J = I2P, I2 80 R(J) = 0 ! CHECK TO SEE if TRUNCATION IS DESIRED 90 if (TRUNC /= 0) go to 150 ! SEE if ROUNDING NECESSARY ! TREAT EVEN AND ODD BASES DIFFERENTLY B2 = B/2 if ((2*B2) /= B) go to 130 ! B EVEN. ROUND if R(T+1) >= B2 UNLESS R(T) ODD AND ALL ZEROS ! AFTER R(T+2). if (R(T+1) - B2) 150, 100, 110 100 if (MOD(R(T),2) == 0) go to 110 if ((R(T+2)+R(T+3)+R(T+4)) == 0) go to 150 ! ROUND 110 DO 120 J = 1, T I = T + 1 - J R(I) = R(I) + 1 if (R(I) < B) go to 150 120 R(I) = 0 ! EXCEPTIONAL CASE, ROUNDED UP TO .10000... RE = RE + 1 R(1) = 1 go to 150 ! ODD BASE, ROUND if R(T+1)... > 1/2 130 DO 140 I = 1, 4 IT = T + I if (R(IT) - B2) 150, 140, 110 140 CONTINUE ! CHECK FOR OVERFLOW 150 if (RE <= M) go to 170 WRITE (LUN, 160) 160 FORMAT (' *** OVERFLOW OCCURRED IN MPNZR ***') call MPOVFL (Z) return ! CHECK FOR UNDERFLOW 170 if (RE < (-M)) go to 190 ! STORE RESULT IN Z Z(1) = RS Z(2) = RE DO 180 I = 1, T 180 Z(I+2) = R(I) return ! UNDERFLOW HERE 190 call MPUNFL (Z) return end subroutine MPOVFL (X) ! !! MPOVFL is called on multiple precision overflow. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DQDOTA and DQDOTI !***LIBRARY SLATEC !***TYPE ALL (MPOVFL-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Called on multiple-precision overflow, i.e. when the ! exponent of 'mp' number X would exceed M. At present execution is ! terminated with an error message after calling MPMAXR(X), but it ! would be possible to return, possibly updating a counter and ! terminating execution after a preset number of overflows. Action ! could easily be determined by a flag in labelled common. ! ! The argument X(*) is an INTEGER array of size 30. See the comments ! in the routine MPBLAS for the reason for this choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED MPCHK, MPERR, MPMAXR !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPOVFL COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, X(*) !***FIRST EXECUTABLE STATEMENT MPOVFL call MPCHK (1, 4) ! SET X TO LARGEST POSSIBLE POSITIVE NUMBER call MPMAXR (X) WRITE (LUN, 10) 10 FORMAT (' *** call TO MPOVFL, MP OVERFLOW OCCURRED ***') ! TERMINATE EXECUTION BY CALLING MPERR call MPERR return end subroutine MPSTR (X, Y) ! !! MPSTR copies Y = X for multiple precision arguments. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DQDOTA and DQDOTI !***LIBRARY SLATEC !***TYPE ALL (MPSTR-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Sets Y = X for 'mp' X and Y. ! ! The arguments X(*) and Y(*) are INTEGER arrays of size 30. See the ! comments in the routine MPBLAS for the reason for this choice. ! !***SEE ALSO DQDOTA, DQDOTI, MPBLAS !***ROUTINES CALLED (NONE) !***COMMON BLOCKS MPCOM !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! ?????? Modified for use with BLAS. Blank COMMON changed to named ! COMMON. R given dimension 12. ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 930124 Increased Array size in MPCON for SUN -r8. (RWC) !***END PROLOGUE MPSTR COMMON /MPCOM/ B, T, M, LUN, MXR, R(30) INTEGER B, T, R, X(*), Y(*) !***FIRST EXECUTABLE STATEMENT MPSTR DO 10 I = 1, T+2 Y(I) = X(I) 10 CONTINUE return end subroutine MPUNFL (X) ! !! MPUNFL is called to handle multiple precision underflow. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DQDOTA and DQDOTI !***LIBRARY SLATEC !***TYPE ALL (MPUNFL-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Called on multiple-precision underflow, i.e. when the ! exponent of 'mp' number X would be less than -M. ! !***SEE ALSO DQDOTA, DQDOTI !***ROUTINES CALLED MPCHK !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE MPUNFL INTEGER X(*) !***FIRST EXECUTABLE STATEMENT MPUNFL call MPCHK (1, 4) ! THE UNDERFLOWING NUMBER IS SET TO ZERO ! AN ALTERNATIVE WOULD BE TO call MPMINR (X) AND RETURN, ! POSSIBLY UPDATING A COUNTER AND TERMINATING EXECUTION ! AFTER A PRESET NUMBER OF UNDERFLOWS. ACTION COULD EASILY ! BE DETERMINED BY A FLAG IN LABELLED COMMON. X(1) = 0 return end function NUMXER (NERR) ! !! NUMXER returns the most recent error number. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE INTEGER (NUMXER-I) !***KEYWORDS ERROR NUMBER, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! NUMXER returns the most recent error number, ! in both NUMXER and the parameter NERR. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED J4SAVE !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 910411 Made user-callable and added KEYWORDS section. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE NUMXER !***FIRST EXECUTABLE STATEMENT NUMXER NERR = J4SAVE(1,0,.FALSE.) NUMXER = NERR return end subroutine OHTROL (Q, N, NRDA, DIAG, IRANK, DIV, TD) !! OHTROL !***SUBSIDIARY !***PURPOSE Subsidiary to BVSUP !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (OHTROL-S, DOHTRL-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! For a rank deficient problem, additional orthogonal ! HOUSEHOLDER transformations are applied to the left side ! of Q to further reduce the triangular form. ! Thus, after application of the routines ORTHOR and OHTROL ! to the original matrix, the result is a nonsingular ! triangular matrix while the remainder of the matrix ! has been zeroed out. ! !***SEE ALSO BVSUP !***ROUTINES CALLED SDOT !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE OHTROL DIMENSION Q(NRDA,*),DIAG(*),DIV(*),TD(*) !***FIRST EXECUTABLE STATEMENT OHTROL NMIR=N-IRANK IRP=IRANK+1 DO 30 K=1,IRANK KIR=IRP-K DIAGK=DIAG(KIR) SIG=(DIAGK*DIAGK)+SDOT(NMIR,Q(IRP,KIR),1,Q(IRP,KIR),1) DD=SIGN(SQRT(SIG),-DIAGK) DIV(KIR)=DD TDV=DIAGK-DD TD(KIR)=TDV if (K == IRANK) go to 30 KIRM=KIR-1 SQD=DD*DIAGK-SIG DO 20 J=1,KIRM QS=((TDV*Q(KIR,J))+SDOT(NMIR,Q(IRP,J),1,Q(IRP,KIR),1)) & /SQD Q(KIR,J)=Q(KIR,J)+QS*TDV DO 10 L=IRP,N 10 Q(L,J)=Q(L,J)+QS*Q(L,KIR) 20 CONTINUE 30 CONTINUE return end subroutine OHTROR (Q, N, NRDA, DIAG, IRANK, DIV, TD) ! !! OHTROR further reduces a triangular form after ORTHOL has been applied. ! !***SUBSIDIARY !***PURPOSE Subsidiary to BVSUP !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (OHTROR-S) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! For a rank deficient problem, additional orthogonal ! HOUSEHOLDER transformations are applied to the right side ! of Q to further reduce the triangular form. ! Thus, after application of the routines ORTHOL and OHTROR ! to the original matrix, the result is a nonsingular ! triangular matrix while the remainder of the matrix ! has been zeroed out. ! !***SEE ALSO BVSUP !***ROUTINES CALLED SDOT !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE OHTROR DIMENSION Q(NRDA,*),DIAG(*),DIV(*),TD(*) !***FIRST EXECUTABLE STATEMENT OHTROR NMIR=N-IRANK IRP=IRANK+1 DO 30 K=1,IRANK KIR=IRP-K DIAGK=DIAG(KIR) SIG=(DIAGK*DIAGK)+SDOT(NMIR,Q(KIR,IRP),NRDA,Q(KIR,IRP),NRDA) DD=SIGN(SQRT(SIG),-DIAGK) DIV(KIR)=DD TDV=DIAGK-DD TD(KIR)=TDV if (K == IRANK) go to 30 KIRM=KIR-1 SQD=DD*DIAGK-SIG DO 20 J=1,KIRM QS=((TDV*Q(J,KIR))+SDOT(NMIR,Q(J,IRP),NRDA,Q(KIR,IRP),NRDA)) & /SQD Q(J,KIR)=Q(J,KIR)+QS*TDV DO 10 L=IRP,N 10 Q(J,L)=Q(J,L)+QS*Q(KIR,L) 20 CONTINUE 30 CONTINUE return end subroutine ORTBAK (NM, LOW, IGH, A, ORT, M, Z) ! !! ORTBAK forms the eigenvectors of a general real matrix from the ... ! eigenvectors of the upper Hessenberg matrix output from ORTHES. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (ORTBAK-S, CORTB-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure ORTBAK, ! NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). ! ! This subroutine forms the eigenvectors of a REAL GENERAL ! matrix by back transforming those of the corresponding ! upper Hessenberg matrix determined by ORTHES. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine BALANC. If BALANC has not been ! used, set LOW=1 and IGH equal to the order of the matrix. ! ! A contains some information about the orthogonal trans- ! formations used in the reduction to Hessenberg form by ! ORTHES in its strict lower triangle. A is a two-dimensional ! REAL array, dimensioned A(NM,IGH). ! ! ORT contains further information about the orthogonal trans- ! formations used in the reduction by ORTHES. Only elements ! LOW through IGH are used. ORT is a one-dimensional REAL ! array, dimensioned ORT(IGH). ! ! M is the number of columns of Z to be back transformed. ! M is an INTEGER variable. ! ! Z contains the real and imaginary parts of the eigenvectors to ! be back transformed in its first M columns. Z is a two- ! dimensional REAL array, dimensioned Z(NM,M). ! ! On OUTPUT ! ! Z contains the real and imaginary parts of the transformed ! eigenvectors in its first M columns. ! ! ORT has been used for temporary storage as is not restored. ! ! NOTE that ORTBAK preserves vector Euclidean norms. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ORTBAK ! INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 REAL A(NM,*),ORT(*),Z(NM,*) REAL G ! !***FIRST EXECUTABLE STATEMENT ORTBAK if (M == 0) go to 200 LA = IGH - 1 KP1 = LOW + 1 if (LA < KP1) go to 200 ! .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = KP1, LA MP = LOW + IGH - MM if (A(MP,MP-1) == 0.0E0) go to 140 MP1 = MP + 1 ! DO 100 I = MP1, IGH 100 ORT(I) = A(I,MP-1) ! DO 130 J = 1, M G = 0.0E0 ! DO 110 I = MP, IGH 110 G = G + ORT(I) * Z(I,J) ! .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. ! DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... G = (G / ORT(MP)) / A(MP,MP-1) ! DO 120 I = MP, IGH 120 Z(I,J) = Z(I,J) + G * ORT(I) ! 130 CONTINUE ! 140 CONTINUE ! 200 RETURN end subroutine ORTHES (NM, N, LOW, IGH, A, ORT) ! !! ORTHES reduces a real general matrix to upper Hessenberg form ... ! using orthogonal similarity transformations. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B2 !***TYPE SINGLE PRECISION (ORTHES-S, CORTH-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure ORTHES, ! NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). ! ! Given a REAL GENERAL matrix, this subroutine ! reduces a submatrix situated in rows and columns ! LOW through IGH to upper Hessenberg form by ! orthogonal similarity transformations. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, A, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine BALANC. If BALANC has not been ! used, set LOW=1 and IGH equal to the order of the matrix, N. ! ! A contains the general matrix to be reduced to upper ! Hessenberg form. A is a two-dimensional REAL array, ! dimensioned A(NM,N). ! ! On OUTPUT ! ! A contains the upper Hessenberg matrix. Some information about ! the orthogonal transformations used in the reduction ! is stored in the remaining triangle under the Hessenberg ! matrix. ! ! ORT contains further information about the orthogonal trans- ! formations used in the reduction. Only elements LOW+1 ! through IGH are used. ORT is a one-dimensional REAL array, ! dimensioned ORT(IGH). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ORTHES ! INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW REAL A(NM,*),ORT(*) REAL F,G,H,SCALE ! !***FIRST EXECUTABLE STATEMENT ORTHES LA = IGH - 1 KP1 = LOW + 1 if (LA < KP1) go to 200 ! DO 180 M = KP1, LA H = 0.0E0 ORT(M) = 0.0E0 SCALE = 0.0E0 ! .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... DO 90 I = M, IGH 90 SCALE = SCALE + ABS(A(I,M-1)) ! if (SCALE == 0.0E0) go to 180 MP = M + IGH ! .......... 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 ! G = -SIGN(SQRT(H),ORT(M)) H = H - ORT(M) * G ORT(M) = ORT(M) - G ! .......... FORM (I-(U*UT)/H) * A .......... DO 130 J = M, N F = 0.0E0 ! .......... 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 ! F = F / H ! DO 120 I = M, IGH 120 A(I,J) = A(I,J) - F * ORT(I) ! 130 CONTINUE ! .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... DO 160 I = 1, IGH F = 0.0E0 ! .......... 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 ! F = F / H ! DO 150 J = M, IGH 150 A(I,J) = A(I,J) - F * ORT(J) ! 160 CONTINUE ! ORT(M) = SCALE * ORT(M) A(M,M-1) = SCALE * G 180 CONTINUE ! 200 RETURN end subroutine ORTHO4 (USOL, IDMN, ZN, ZM, PERTRB) ! !! ORTHO4 is subsidiary to SEPX4. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (ORTHO4-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine orthogonalizes the array USOL with respect to ! the constant array in a weighted least squares norm. ! !***SEE ALSO SEPX4 !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SPL4 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE ORTHO4 ! COMMON /SPL4/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION USOL(IDMN,*) ,ZN(*) ,ZM(*) !***FIRST EXECUTABLE STATEMENT ORTHO4 ISTR = IS IFNL = MS JSTR = JS JFNL = NS ! ! COMPUTE WEIGHTED INNER PRODUCTS ! 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 ! ! SET PERTURBATION PARAMETER ! PERTRB = UTE/ETE ! ! SUBTRACT OFF CONSTANT PERTRB ! DO 40 I=ISTR,IFNL DO 30 J=JSTR,JFNL USOL(I,J) = USOL(I,J)-PERTRB 30 CONTINUE 40 CONTINUE return end subroutine ORTHOG (USOL, IDMN, ZN, ZM, PERTRB) ! !! ORTHOG is subsidiary to SEPELI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (ORTHOG-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine orthogonalizes the array USOL with respect to ! the constant array in a weighted least squares norm. ! !***SEE ALSO SEPELI !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SPLPCM !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE ORTHOG ! COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION USOL(IDMN,*) ,ZN(*) ,ZM(*) !***FIRST EXECUTABLE STATEMENT ORTHOG ISTR = IS IFNL = MS JSTR = JS JFNL = NS ! ! COMPUTE WEIGHTED INNER PRODUCTS ! 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 ! ! SET PERTURBATION PARAMETER ! PERTRB = UTE/ETE ! ! SUBTRACT OFF CONSTANT PERTRB ! DO 40 I=ISTR,IFNL DO 30 J=JSTR,JFNL USOL(I,J) = USOL(I,J)-PERTRB 30 CONTINUE 40 CONTINUE return end subroutine ORTHOL (A, M, N, NRDA, IFLAG, IRANK, ISCALE, DIAG, & KPIVOT, SCALES, COLS, CS) ! !! ORTHOL reduces a matrix to upper triangular form by Householder. ! !***SUBSIDIARY !***PURPOSE Subsidiary to BVSUP !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (ORTHOL-S) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! Reduction of the matrix A to upper triangular form by a sequence of ! orthogonal HOUSEHOLDER transformations pre-multiplying A ! ! Modeled after the ALGOL codes in the articles in the REFERENCES ! section. ! ! ********************************************************************** ! INPUT ! ********************************************************************** ! ! A -- Contains the matrix to be decomposed, must be dimensioned ! NRDA by N ! M -- Number of rows in the matrix, M greater or equal to N ! N -- Number of columns in the matrix, N greater or equal to 1 ! IFLAG -- Indicates the uncertainty in the matrix data ! = 0 when the data is to be treated as exact ! =-K when the data is assumed to be accurate to about ! K digits ! ISCALE -- Scaling indicator ! =-1 if the matrix A is to be pre-scaled by ! columns when appropriate. ! Otherwise no scaling will be attempted ! NRDA -- Row dimension of A, NRDA greater or equal to M ! DIAG,KPIVOT,COLS -- Arrays of length at least n used internally ! ,CS,SCALES ! ! ********************************************************************** ! OUTPUT ! ********************************************************************** ! ! IFLAG - Status indicator ! =1 for successful decomposition ! =2 if improper input is detected ! =3 if rank of the matrix is less than N ! A -- Contains the reduced matrix in the strictly upper triangular ! part and transformation information in the lower part ! IRANK -- Contains the numerically determined matrix rank ! DIAG -- Contains the diagonal elements of the reduced ! triangular matrix ! KPIVOT -- Contains the pivotal information, the column ! interchanges performed on the original matrix are ! recorded here. ! SCALES -- Contains the column scaling parameters ! ! ********************************************************************** ! !***SEE ALSO BVSUP !***REFERENCES G. Golub, Numerical methods for solving linear least ! squares problems, Numerische Mathematik 7, (1965), ! pp. 206-216. ! P. Businger and G. Golub, Linear least squares ! solutions by Householder transformations, Numerische ! Mathematik 7, (1965), pp. 269-276. !***ROUTINES CALLED CSCALE, R1MACH, SDOT, XERMSG !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900402 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ORTHOL DIMENSION A(NRDA,*),DIAG(*),KPIVOT(*),COLS(*),CS(*),SCALES(*) ! ! ********************************************************************** ! ! MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED ! BY THE FUNCTION R1MACH. ! !***FIRST EXECUTABLE STATEMENT ORTHOL URO = R1MACH(3) ! ! ********************************************************************** ! if (M >= N .AND. N >= 1 .AND. NRDA >= M) go to 1 IFLAG=2 call XERMSG ('SLATEC', 'ORTHOL', 'INVALID INPUT PARAMETERS.', 2, & 1) return ! 1 ACC=10.*URO if (IFLAG < 0) ACC=MAX(ACC,10.**IFLAG) SRURO=SQRT(URO) IFLAG=1 IRANK=N ! ! COMPUTE NORM**2 OF JTH COLUMN AND A MATRIX NORM ! ANORM=0. DO 2 J=1,N KPIVOT(J)=J COLS(J)=SDOT(M,A(1,J),1,A(1,J),1) CS(J)=COLS(J) ANORM=ANORM+COLS(J) 2 CONTINUE ! ! PERFORM COLUMN SCALING ON A WHEN SPECIFIED ! call CSCALE(A,NRDA,M,N,COLS,CS,DUM,DUM,ANORM,SCALES,ISCALE,0) ! ANORM=SQRT(ANORM) ! ! ! CONSTRUCTION OF UPPER TRIANGULAR MATRIX AND RECORDING OF ! ORTHOGONAL TRANSFORMATIONS ! ! DO 50 K=1,N MK=M-K+1 if (K == N) go to 25 KP=K+1 ! ! SEARCHING FOR PIVOTAL COLUMN ! DO 10 J=K,N if (COLS(J) >= SRURO*CS(J)) go to 5 COLS(J)=SDOT(MK,A(K,J),1,A(K,J),1) CS(J)=COLS(J) 5 if (J == K) go to 7 if (SIGMA >= 0.99*COLS(J)) go to 10 7 SIGMA=COLS(J) JCOL=J 10 CONTINUE if (JCOL == K) go to 25 ! ! PERFORM COLUMN INTERCHANGE ! L=KPIVOT(K) KPIVOT(K)=KPIVOT(JCOL) KPIVOT(JCOL)=L COLS(JCOL)=COLS(K) COLS(K)=SIGMA CSS=CS(K) CS(K)=CS(JCOL) CS(JCOL)=CSS SC=SCALES(K) SCALES(K)=SCALES(JCOL) SCALES(JCOL)=SC DO 20 L=1,M ASAVE=A(L,K) A(L,K)=A(L,JCOL) 20 A(L,JCOL)=ASAVE ! ! CHECK RANK OF THE MATRIX ! 25 SIG=SDOT(MK,A(K,K),1,A(K,K),1) DIAGK=SQRT(SIG) if (DIAGK > ACC*ANORM) go to 30 ! ! RANK DEFICIENT PROBLEM IFLAG=3 IRANK=K-1 call XERMSG ('SLATEC', 'ORTHOL', & 'RANK OF MATRIX IS LESS THAN THE NUMBER OF COLUMNS.', 1, 1) return ! ! CONSTRUCT AND APPLY TRANSFORMATION TO MATRIX A ! 30 AKK=A(K,K) if (AKK > 0.) DIAGK=-DIAGK DIAG(K)=DIAGK A(K,K)=AKK-DIAGK if (K == N) go to 50 SAD=DIAGK*AKK-SIG DO 40 J=KP,N AS=SDOT(MK,A(K,K),1,A(K,J),1)/SAD DO 35 L=K,M 35 A(L,J)=A(L,J)+AS*A(L,K) 40 COLS(J)=COLS(J)-A(K,J)**2 50 CONTINUE ! ! return end subroutine ORTHOR (A, N, M, NRDA, IFLAG, IRANK, ISCALE, DIAG, & KPIVOT, SCALES, ROWS, RS) ! !! ORTHOR reduces a matrix to lower triangular form by Householder. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (ORTHOR-S, DORTHR-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! Reduction of the matrix A to lower triangular form by a sequence of ! orthogonal HOUSEHOLDER transformations post-multiplying A ! ! Modeled after the ALGOL codes in the articles in the REFERENCES ! section. ! ! ********************************************************************** ! INPUT ! ********************************************************************** ! ! A -- Contains the matrix to be decomposed, must be dimensioned ! NRDA by N ! N -- Number of rows in the matrix, N greater or equal to 1 ! M -- Number of columns in the matrix, M greater or equal to N ! IFLAG -- Indicates the uncertainty in the matrix data ! = 0 when the data is to be treated as exact ! =-K when the data is assumed to be accurate to about ! K digits ! ISCALE -- Scaling indicator ! =-1 if the matrix is to be pre-scaled by ! columns when appropriate. ! Otherwise no scaling will be attempted ! NRDA -- Row dimension of A, NRDA greater or equal to N ! DIAG,KPIVOT,ROWS -- Arrays of length at least N used internally ! ,RS,SCALES (except for SCALES which is M) ! ! ********************************************************************** ! OUTPUT ! ********************************************************************** ! ! IFLAG - status indicator ! =1 for successful decomposition ! =2 if improper input is detected ! =3 if rank of the matrix is less than N ! A -- contains the reduced matrix in the strictly lower triangular ! part and transformation information ! IRANK -- contains the numerically determined matrix rank ! DIAG -- contains the diagonal elements of the reduced ! triangular matrix ! KPIVOT -- Contains the pivotal information, the column ! interchanges performed on the original matrix are ! recorded here. ! SCALES -- contains the column scaling parameters ! ! ********************************************************************** ! !***SEE ALSO BVSUP !***REFERENCES G. Golub, Numerical methods for solving linear least ! squares problems, Numerische Mathematik 7, (1965), ! pp. 206-216. ! P. Businger and G. Golub, Linear least squares ! solutions by Householder transformations, Numerische ! Mathematik 7, (1965), pp. 269-276. !***ROUTINES CALLED CSCALE, R1MACH, SDOT, XERMSG !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ORTHOR DIMENSION A(NRDA,*),DIAG(*),KPIVOT(*),ROWS(*),RS(*),SCALES(*) ! ! END OF ABSTRACT ! ! ********************************************************************** ! ! MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED ! BY THE FUNCTION R1MACH. ! ! ********************************************************************** ! !***FIRST EXECUTABLE STATEMENT ORTHOR URO = R1MACH(4) if (M >= N .AND. N >= 1 .AND. NRDA >= N) go to 1 IFLAG=2 call XERMSG ('SLATEC', 'ORTHOR', 'INVALID INPUT PARAMETERS.', 2, & 1) return ! 1 ACC=10.*URO if (IFLAG < 0) ACC=MAX(ACC,10.**IFLAG) SRURO=SQRT(URO) IFLAG=1 IRANK=N ! ! COMPUTE NORM**2 OF JTH ROW AND A MATRIX NORM ! ANORM=0. DO 2 J=1,N KPIVOT(J)=J ROWS(J)=SDOT(M,A(J,1),NRDA,A(J,1),NRDA) RS(J)=ROWS(J) ANORM=ANORM+ROWS(J) 2 CONTINUE ! ! PERFORM COLUMN SCALING ON A WHEN SPECIFIED ! call CSCALE(A,NRDA,N,M,SCALES,DUM,ROWS,RS,ANORM,SCALES,ISCALE,1) ! ANORM=SQRT(ANORM) ! ! ! CONSTRUCTION OF LOWER TRIANGULAR MATRIX AND RECORDING OF ! ORTHOGONAL TRANSFORMATIONS ! ! DO 50 K=1,N MK=M-K+1 if (K == N) go to 25 KP=K+1 ! ! SEARCHING FOR PIVOTAL ROW ! DO 10 J=K,N if (ROWS(J) >= SRURO*RS(J)) go to 5 ROWS(J)=SDOT(MK,A(J,K),NRDA,A(J,K),NRDA) RS(J)=ROWS(J) 5 if (J == K) go to 7 if (SIGMA >= 0.99*ROWS(J)) go to 10 7 SIGMA=ROWS(J) JROW=J 10 CONTINUE if (JROW == K) go to 25 ! ! PERFORM ROW INTERCHANGE ! L=KPIVOT(K) KPIVOT(K)=KPIVOT(JROW) KPIVOT(JROW)=L ROWS(JROW)=ROWS(K) ROWS(K)=SIGMA RSS=RS(K) RS(K)=RS(JROW) RS(JROW)=RSS DO 20 L=1,M ASAVE=A(K,L) A(K,L)=A(JROW,L) 20 A(JROW,L)=ASAVE ! ! CHECK RANK OF THE MATRIX ! 25 SIG=SDOT(MK,A(K,K),NRDA,A(K,K),NRDA) DIAGK=SQRT(SIG) if (DIAGK > ACC*ANORM) go to 30 ! ! RANK DEFICIENT PROBLEM IFLAG=3 IRANK=K-1 call XERMSG ('SLATEC', 'ORTHOR', & 'RANK OF MATRIX IS LESS THAN THE NUMBER OF ROWS.', 1, 1) return ! ! CONSTRUCT AND APPLY TRANSFORMATION TO MATRIX A ! 30 AKK=A(K,K) if (AKK > 0.) DIAGK=-DIAGK DIAG(K)=DIAGK A(K,K)=AKK-DIAGK if (K == N) go to 50 SAD=DIAGK*AKK-SIG DO 40 J=KP,N AS=SDOT(MK,A(K,K),NRDA,A(J,K),NRDA)/SAD DO 35 L=K,M 35 A(J,L)=A(J,L)+AS*A(K,L) 40 ROWS(J)=ROWS(J)-A(J,K)**2 50 CONTINUE ! ! return end subroutine ORTRAN (NM, N, LOW, IGH, A, ORT, Z) ! !! ORTRAN accumulates orthogonal similarity transformations in the ... ! reduction of real general matrix by ORTHES. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (ORTRAN-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure ORTRANS, ! NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). ! ! This subroutine accumulates the orthogonal similarity ! transformations used in the reduction of a REAL GENERAL ! matrix to upper Hessenberg form by ORTHES. ! ! On INPUT ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! LOW and IGH are two INTEGER variables determined by the ! balancing subroutine BALANC. If BALANC has not been ! used, set LOW=1 and IGH equal to the order of the matrix, N. ! ! A contains some information about the orthogonal trans- ! formations used in the reduction to Hessenberg form by ! ORTHES in its strict lower triangle. A is a two-dimensional ! REAL array, dimensioned A(NM,IGH). ! ! ORT contains further information about the orthogonal trans- ! formations used in the reduction by ORTHES. Only elements ! LOW through IGH are used. ORT is a one-dimensional REAL ! array, dimensioned ORT(IGH). ! ! On OUTPUT ! ! Z contains the transformation matrix produced in the reduction ! by ORTHES to the upper Hessenberg form. Z is a two- ! dimensional REAL array, dimensioned Z(NM,N). ! ! ORT has been used for temporary storage as is not restored. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ORTRAN ! INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 REAL A(NM,*),ORT(*),Z(NM,*) REAL G ! ! .......... INITIALIZE Z TO IDENTITY MATRIX .......... !***FIRST EXECUTABLE STATEMENT ORTRAN DO 80 I = 1, N ! DO 60 J = 1, N 60 Z(I,J) = 0.0E0 ! Z(I,I) = 1.0E0 80 CONTINUE ! KL = IGH - LOW - 1 if (KL < 1) go to 200 ! .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = 1, KL MP = IGH - MM if (A(MP,MP-1) == 0.0E0) go to 140 MP1 = MP + 1 ! DO 100 I = MP1, IGH 100 ORT(I) = A(I,MP-1) ! DO 130 J = MP, IGH G = 0.0E0 ! DO 110 I = MP, IGH 110 G = G + ORT(I) * Z(I,J) ! .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. ! DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... G = (G / ORT(MP)) / A(MP,MP-1) ! DO 120 I = MP, IGH 120 Z(I,J) = Z(I,J) + G * ORT(I) ! 130 CONTINUE ! 140 CONTINUE ! 200 RETURN end subroutine PASSB2 (IDO, L1, CC, CH, WA1) ! !! PASSB2 calculates the fast Fourier transform of subvectors of length two. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (PASSB2-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PASSB2 DIMENSION CC(IDO,2,*), CH(IDO,L1,2), WA1(*) !***FIRST EXECUTABLE STATEMENT PASSB2 if (IDO > 2) go to 102 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(1,2,K) CH(1,K,2) = CC(1,1,K)-CC(1,2,K) CH(2,K,1) = CC(2,1,K)+CC(2,2,K) CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 101 CONTINUE return 102 if ( IDO/2 < L1) go to 105 DO 104 K=1,L1 !DIR$ IVDEP DO 103 I=2,IDO,2 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 103 CONTINUE 104 CONTINUE return 105 DO 107 I=2,IDO,2 !DIR$ IVDEP DO 106 K=1,L1 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 106 CONTINUE 107 CONTINUE return end subroutine PASSB3 (IDO, L1, CC, CH, WA1, WA2) ! !! PASSB3 calculates the fast Fourier transform of subvectors of length three. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (PASSB3-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variable TAUI by using ! FORTRAN intrinsic function SQRT instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PASSB3 DIMENSION CC(IDO,3,*), CH(IDO,L1,3), WA1(*), WA2(*) !***FIRST EXECUTABLE STATEMENT PASSB3 TAUR = -.5 TAUI = .5*SQRT(3.) if (IDO /= 2) go to 102 DO 101 K=1,L1 TR2 = CC(1,2,K)+CC(1,3,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 TI2 = CC(2,2,K)+CC(2,3,K) CI2 = CC(2,1,K)+TAUR*TI2 CH(2,K,1) = CC(2,1,K)+TI2 CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 CH(2,K,2) = CI2+CR3 CH(2,K,3) = CI2-CR3 101 CONTINUE return 102 if ( IDO/2 < L1) go to 105 DO 104 K=1,L1 !DIR$ IVDEP DO 103 I=2,IDO,2 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 103 CONTINUE 104 CONTINUE return 105 DO 107 I=2,IDO,2 !DIR$ IVDEP DO 106 K=1,L1 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 106 CONTINUE 107 CONTINUE return end subroutine PASSB4 (IDO, L1, CC, CH, WA1, WA2, WA3) ! !! PASSB4 calculates the fast Fourier transform of subvectors of length four. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (PASSB4-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PASSB4 DIMENSION CC(IDO,4,*), CH(IDO,L1,4), WA1(*), WA2(*), WA3(*) !***FIRST EXECUTABLE STATEMENT PASSB4 if (IDO /= 2) go to 102 DO 101 K=1,L1 TI1 = CC(2,1,K)-CC(2,3,K) TI2 = CC(2,1,K)+CC(2,3,K) TR4 = CC(2,4,K)-CC(2,2,K) TI3 = CC(2,2,K)+CC(2,4,K) TR1 = CC(1,1,K)-CC(1,3,K) TR2 = CC(1,1,K)+CC(1,3,K) TI4 = CC(1,2,K)-CC(1,4,K) TR3 = CC(1,2,K)+CC(1,4,K) CH(1,K,1) = TR2+TR3 CH(1,K,3) = TR2-TR3 CH(2,K,1) = TI2+TI3 CH(2,K,3) = TI2-TI3 CH(1,K,2) = TR1+TR4 CH(1,K,4) = TR1-TR4 CH(2,K,2) = TI1+TI4 CH(2,K,4) = TI1-TI4 101 CONTINUE return 102 if ( IDO/2 < L1) go to 105 DO 104 K=1,L1 !DIR$ IVDEP DO 103 I=2,IDO,2 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,4,K)-CC(I,2,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,2,K)-CC(I-1,4,K) TR3 = CC(I-1,2,K)+CC(I-1,4,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-1)*CR2-WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 103 CONTINUE 104 CONTINUE return 105 DO 107 I=2,IDO,2 !DIR$ IVDEP DO 106 K=1,L1 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,4,K)-CC(I,2,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,2,K)-CC(I-1,4,K) TR3 = CC(I-1,2,K)+CC(I-1,4,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-1)*CR2-WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 106 CONTINUE 107 CONTINUE return end subroutine PASSB5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4) ! !! PASSB5 calculates the fast Fourier transform of subvectors of length five. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (PASSB5-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variables PI, TI11, TI12, ! TR11, TR12 by using FORTRAN intrinsic functions ATAN ! and SIN instead of DATA statements. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PASSB5 DIMENSION CC(IDO,5,*), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*), & WA4(*) !***FIRST EXECUTABLE STATEMENT PASSB5 PI = 4.*ATAN(1.) TR11 = SIN(.1*PI) TI11 = SIN(.4*PI) TR12 = -SIN(.3*PI) TI12 = SIN(.2*PI) if (IDO /= 2) go to 102 DO 101 K=1,L1 TI5 = CC(2,2,K)-CC(2,5,K) TI2 = CC(2,2,K)+CC(2,5,K) TI4 = CC(2,3,K)-CC(2,4,K) TI3 = CC(2,3,K)+CC(2,4,K) TR5 = CC(1,2,K)-CC(1,5,K) TR2 = CC(1,2,K)+CC(1,5,K) TR4 = CC(1,3,K)-CC(1,4,K) TR3 = CC(1,3,K)+CC(1,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CH(2,K,1) = CC(2,1,K)+TI2+TI3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(2,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 CH(1,K,2) = CR2-CI5 CH(1,K,5) = CR2+CI5 CH(2,K,2) = CI2+CR5 CH(2,K,3) = CI3+CR4 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(2,K,4) = CI3-CR4 CH(2,K,5) = CI2-CR5 101 CONTINUE return 102 if ( IDO/2 < L1) go to 105 DO 104 K=1,L1 !DIR$ IVDEP DO 103 I=2,IDO,2 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-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-1)*DR2-WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 103 CONTINUE 104 CONTINUE return 105 DO 107 I=2,IDO,2 !DIR$ IVDEP DO 106 K=1,L1 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-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-1)*DR2-WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 106 CONTINUE 107 CONTINUE return end subroutine PASSB (NAC, IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) ! !! PASSB calculates fast Fourier transforms of subvectors of arbitrary length. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (PASSB-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PASSB DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), WA(*), & C2(IDL1,*), CH2(IDL1,*) !***FIRST EXECUTABLE STATEMENT PASSB IDOT = IDO/2 IPP2 = IP+2 IPPH = (IP+1)/2 IDP = IP*IDO ! if (IDO < L1) go to 106 DO 103 J=2,IPPH JC = IPP2-J DO 102 K=1,L1 !DIR$ IVDEP DO 101 I=1,IDO CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 101 CONTINUE 102 CONTINUE 103 CONTINUE DO 105 K=1,L1 !DIR$ IVDEP DO 104 I=1,IDO CH(I,K,1) = CC(I,1,K) 104 CONTINUE 105 CONTINUE go to 112 106 DO 109 J=2,IPPH JC = IPP2-J DO 108 I=1,IDO !DIR$ IVDEP DO 107 K=1,L1 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 107 CONTINUE 108 CONTINUE 109 CONTINUE DO 111 I=1,IDO !DIR$ IVDEP DO 110 K=1,L1 CH(I,K,1) = CC(I,1,K) 110 CONTINUE 111 CONTINUE 112 IDL = 2-IDO INC = 0 DO 116 L=2,IPPH LC = IPP2-L IDL = IDL+IDO !DIR$ IVDEP DO 113 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) C2(IK,LC) = WA(IDL)*CH2(IK,IP) 113 CONTINUE IDLJ = IDL INC = INC+IDO DO 115 J=3,IPPH JC = IPP2-J IDLJ = IDLJ+INC if (IDLJ > IDP) IDLJ = IDLJ-IDP WAR = WA(IDLJ-1) WAI = WA(IDLJ) !DIR$ IVDEP DO 114 IK=1,IDL1 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) 114 CONTINUE 115 CONTINUE 116 CONTINUE DO 118 J=2,IPPH !DIR$ IVDEP DO 117 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 117 CONTINUE 118 CONTINUE DO 120 J=2,IPPH JC = IPP2-J !DIR$ IVDEP DO 119 IK=2,IDL1,2 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 119 CONTINUE 120 CONTINUE NAC = 1 if (IDO == 2) RETURN NAC = 0 DO 121 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 121 CONTINUE DO 123 J=2,IP !DIR$ IVDEP DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J) C1(2,K,J) = CH(2,K,J) 122 CONTINUE 123 CONTINUE if (IDOT > L1) go to 127 IDIJ = 0 DO 126 J=2,IP IDIJ = IDIJ+2 DO 125 I=4,IDO,2 IDIJ = IDIJ+2 !DIR$ IVDEP DO 124 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) 124 CONTINUE 125 CONTINUE 126 CONTINUE return 127 IDJ = 2-IDO DO 130 J=2,IP IDJ = IDJ+IDO DO 129 K=1,L1 IDIJ = IDJ !DIR$ IVDEP DO 128 I=4,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) 128 CONTINUE 129 CONTINUE 130 CONTINUE return end subroutine PASSF2 (IDO, L1, CC, CH, WA1) ! !! PASSF2 calculates the fast Fourier transform of subvectors of length two. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (PASSF2-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PASSF2 DIMENSION CC(IDO,2,*), CH(IDO,L1,2), WA1(*) !***FIRST EXECUTABLE STATEMENT PASSF2 if (IDO > 2) go to 102 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(1,2,K) CH(1,K,2) = CC(1,1,K)-CC(1,2,K) CH(2,K,1) = CC(2,1,K)+CC(2,2,K) CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 101 CONTINUE return 102 if ( IDO/2 < L1) go to 105 DO 104 K=1,L1 !DIR$ IVDEP DO 103 I=2,IDO,2 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 103 CONTINUE 104 CONTINUE return 105 DO 107 I=2,IDO,2 !DIR$ IVDEP DO 106 K=1,L1 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 106 CONTINUE 107 CONTINUE return end subroutine PASSF3 (IDO, L1, CC, CH, WA1, WA2) ! !! PASSF3 calculates the fast Fourier transform of subvectors of length three. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (PASSF3-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variable TAUI by using ! FORTRAN intrinsic function SQRT instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PASSF3 DIMENSION CC(IDO,3,*), CH(IDO,L1,3), WA1(*), WA2(*) !***FIRST EXECUTABLE STATEMENT PASSF3 TAUR = -.5 TAUI = -.5*SQRT(3.) if (IDO /= 2) go to 102 DO 101 K=1,L1 TR2 = CC(1,2,K)+CC(1,3,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 TI2 = CC(2,2,K)+CC(2,3,K) CI2 = CC(2,1,K)+TAUR*TI2 CH(2,K,1) = CC(2,1,K)+TI2 CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 CH(2,K,2) = CI2+CR3 CH(2,K,3) = CI2-CR3 101 CONTINUE return 102 if ( IDO/2 < L1) go to 105 DO 104 K=1,L1 !DIR$ IVDEP DO 103 I=2,IDO,2 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 103 CONTINUE 104 CONTINUE return 105 DO 107 I=2,IDO,2 !DIR$ IVDEP DO 106 K=1,L1 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 106 CONTINUE 107 CONTINUE return end subroutine PASSF4 (IDO, L1, CC, CH, WA1, WA2, WA3) ! !! PASSF4 calculates the fast Fourier transform of subvectors of length four. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (PASSF4-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PASSF4 DIMENSION CC(IDO,4,*), CH(IDO,L1,4), WA1(*), WA2(*), WA3(*) !***FIRST EXECUTABLE STATEMENT PASSF4 if (IDO /= 2) go to 102 DO 101 K=1,L1 TI1 = CC(2,1,K)-CC(2,3,K) TI2 = CC(2,1,K)+CC(2,3,K) TR4 = CC(2,2,K)-CC(2,4,K) TI3 = CC(2,2,K)+CC(2,4,K) TR1 = CC(1,1,K)-CC(1,3,K) TR2 = CC(1,1,K)+CC(1,3,K) TI4 = CC(1,4,K)-CC(1,2,K) TR3 = CC(1,2,K)+CC(1,4,K) CH(1,K,1) = TR2+TR3 CH(1,K,3) = TR2-TR3 CH(2,K,1) = TI2+TI3 CH(2,K,3) = TI2-TI3 CH(1,K,2) = TR1+TR4 CH(1,K,4) = TR1-TR4 CH(2,K,2) = TI1+TI4 CH(2,K,4) = TI1-TI4 101 CONTINUE return 102 if ( IDO/2 < L1) go to 105 DO 104 K=1,L1 !DIR$ IVDEP DO 103 I=2,IDO,2 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,2,K)-CC(I,4,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,4,K)-CC(I-1,2,K) TR3 = CC(I-1,2,K)+CC(I-1,4,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-1)*CR2+WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 103 CONTINUE 104 CONTINUE return 105 DO 107 I=2,IDO,2 !DIR$ IVDEP DO 106 K=1,L1 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,2,K)-CC(I,4,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,4,K)-CC(I-1,2,K) TR3 = CC(I-1,2,K)+CC(I-1,4,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-1)*CR2+WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 106 CONTINUE 107 CONTINUE return end subroutine PASSF5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4) ! !! PASSF5 calculates the fast Fourier transform of subvectors of length five. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (PASSF5-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variables PI, TI11, TI12, ! TR11, TR12 by using FORTRAN intrinsic functions ATAN ! and SIN instead of DATA statements. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PASSF5 DIMENSION CC(IDO,5,*), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*), & WA4(*) !***FIRST EXECUTABLE STATEMENT PASSF5 PI = 4.*ATAN(1.) TR11 = SIN(.1*PI) TI11 = -SIN(.4*PI) TR12 = -SIN(.3*PI) TI12 = -SIN(.2*PI) if (IDO /= 2) go to 102 DO 101 K=1,L1 TI5 = CC(2,2,K)-CC(2,5,K) TI2 = CC(2,2,K)+CC(2,5,K) TI4 = CC(2,3,K)-CC(2,4,K) TI3 = CC(2,3,K)+CC(2,4,K) TR5 = CC(1,2,K)-CC(1,5,K) TR2 = CC(1,2,K)+CC(1,5,K) TR4 = CC(1,3,K)-CC(1,4,K) TR3 = CC(1,3,K)+CC(1,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CH(2,K,1) = CC(2,1,K)+TI2+TI3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(2,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 CH(1,K,2) = CR2-CI5 CH(1,K,5) = CR2+CI5 CH(2,K,2) = CI2+CR5 CH(2,K,3) = CI3+CR4 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(2,K,4) = CI3-CR4 CH(2,K,5) = CI2-CR5 101 CONTINUE return 102 if ( IDO/2 < L1) go to 105 DO 104 K=1,L1 !DIR$ IVDEP DO 103 I=2,IDO,2 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-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-1)*DR2+WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 103 CONTINUE 104 CONTINUE return 105 DO 107 I=2,IDO,2 !DIR$ IVDEP DO 106 K=1,L1 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-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-1)*DR2+WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 106 CONTINUE 107 CONTINUE return end subroutine PASSF (NAC, IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) ! !! PASSF calculates fast Fourier transforms of subvectors of arbitrary length. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (PASSF-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PASSF DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), WA(*), & C2(IDL1,*), CH2(IDL1,*) !***FIRST EXECUTABLE STATEMENT PASSF IDOT = IDO/2 IPP2 = IP+2 IPPH = (IP+1)/2 IDP = IP*IDO ! if (IDO < L1) go to 106 DO 103 J=2,IPPH JC = IPP2-J DO 102 K=1,L1 !DIR$ IVDEP DO 101 I=1,IDO CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 101 CONTINUE 102 CONTINUE 103 CONTINUE DO 105 K=1,L1 !DIR$ IVDEP DO 104 I=1,IDO CH(I,K,1) = CC(I,1,K) 104 CONTINUE 105 CONTINUE go to 112 106 DO 109 J=2,IPPH JC = IPP2-J DO 108 I=1,IDO !DIR$ IVDEP DO 107 K=1,L1 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 107 CONTINUE 108 CONTINUE 109 CONTINUE DO 111 I=1,IDO !DIR$ IVDEP DO 110 K=1,L1 CH(I,K,1) = CC(I,1,K) 110 CONTINUE 111 CONTINUE 112 IDL = 2-IDO INC = 0 DO 116 L=2,IPPH LC = IPP2-L IDL = IDL+IDO !DIR$ IVDEP DO 113 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) C2(IK,LC) = -WA(IDL)*CH2(IK,IP) 113 CONTINUE IDLJ = IDL INC = INC+IDO DO 115 J=3,IPPH JC = IPP2-J IDLJ = IDLJ+INC if (IDLJ > IDP) IDLJ = IDLJ-IDP WAR = WA(IDLJ-1) WAI = WA(IDLJ) !DIR$ IVDEP DO 114 IK=1,IDL1 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) 114 CONTINUE 115 CONTINUE 116 CONTINUE DO 118 J=2,IPPH !DIR$ IVDEP DO 117 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 117 CONTINUE 118 CONTINUE DO 120 J=2,IPPH JC = IPP2-J !DIR$ IVDEP DO 119 IK=2,IDL1,2 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 119 CONTINUE 120 CONTINUE NAC = 1 if (IDO == 2) RETURN NAC = 0 !DIR$ IVDEP DO 121 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 121 CONTINUE DO 123 J=2,IP !DIR$ IVDEP DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J) C1(2,K,J) = CH(2,K,J) 122 CONTINUE 123 CONTINUE if (IDOT > L1) go to 127 IDIJ = 0 DO 126 J=2,IP IDIJ = IDIJ+2 DO 125 I=4,IDO,2 IDIJ = IDIJ+2 !DIR$ IVDEP DO 124 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) 124 CONTINUE 125 CONTINUE 126 CONTINUE return 127 IDJ = 2-IDO DO 130 J=2,IP IDJ = IDJ+IDO DO 129 K=1,L1 IDIJ = IDJ !DIR$ IVDEP DO 128 I=4,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) 128 CONTINUE 129 CONTINUE 130 CONTINUE return end subroutine PCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, & NDIM, KORD, IERR) ! !! PCHBS is a Piecewise Cubic Hermite to B-Spline converter. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3 !***TYPE SINGLE PRECISION (PCHBS-S, DPCHBS-D) !***KEYWORDS B-SPLINES, CONVERSION, CUBIC HERMITE INTERPOLATION, ! PIECEWISE CUBIC INTERPOLATION !***AUTHOR Fritsch, F. N., (LLNL) ! Computing and Mathematics Research Division ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! *Usage: ! ! INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR ! PARAMETER (INCFD = ...) ! REAL X(nmax), F(INCFD,nmax), D(INCFD,nmax), T(2*nmax+4), ! * BCOEF(2*nmax) ! ! call PCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, ! * NDIM, KORD, IERR) ! ! *Arguments: ! ! N:IN is the number of data points, N.ge.2 . (not checked) ! ! X:IN is the real array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. (not checked) ! nmax, the dimension of X, must be .ge.N. ! ! F:IN is the real array of dependent variable values. ! F(1+(I-1)*INCFD) is the value corresponding to X(I). ! nmax, the second dimension of F, must be .ge.N. ! ! D:IN is the real array of derivative values at the data points. ! D(1+(I-1)*INCFD) is the value corresponding to X(I). ! nmax, the second dimension of D, must be .ge.N. ! ! INCFD:IN is the increment between successive values in F and D. ! This argument is provided primarily for 2-D applications. ! It may have the value 1 for one-dimensional applications, ! in which case F and D may be singly-subscripted arrays. ! ! KNOTYP:IN is a flag to control the knot sequence. ! The knot sequence T is normally computed from X by putting ! a double knot at each X and setting the end knot pairs ! according to the value of KNOTYP: ! KNOTYP = 0: Quadruple knots at X(1) and X(N). (default) ! KNOTYP = 1: Replicate lengths of extreme subintervals: ! T( 1 ) = T( 2 ) = X(1) - (X(2)-X(1)) ; ! T(M+4) = T(M+3) = X(N) + (X(N)-X(N-1)). ! KNOTYP = 2: Periodic placement of boundary knots: ! T( 1 ) = T( 2 ) = X(1) - (X(N)-X(N-1)); ! T(M+4) = T(M+3) = X(N) + (X(2)-X(1)) . ! Here M=NDIM=2*N. ! If the input value of KNOTYP is negative, however, it is ! assumed that NKNOTS and T were set in a previous call. ! This option is provided for improved efficiency when used ! in a parametric setting. ! ! NKNOTS:INOUT is the number of knots. ! If KNOTYP >= 0, then NKNOTS will be set to NDIM+4. ! If KNOTYP < 0, then NKNOTS is an input variable, and an ! error return will be taken if it is not equal to NDIM+4. ! ! T:INOUT is the array of 2*N+4 knots for the B-representation. ! If KNOTYP >= 0, T will be returned by PCHBS with the ! interior double knots equal to the X-values and the ! boundary knots set as indicated above. ! If KNOTYP < 0, it is assumed that T was set by a ! previous call to PCHBS. (This routine does **not** ! verify that T forms a legitimate knot sequence.) ! ! BCOEF:OUT is the array of 2*N B-spline coefficients. ! ! NDIM:OUT is the dimension of the B-spline space. (Set to 2*N.) ! ! KORD:OUT is the order of the B-spline. (Set to 4.) ! ! IERR:OUT is an error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -4 if KNOTYP > 2 . ! IERR = -5 if KNOTYP < 0 and NKNOTS /= (2*N+4). ! ! *Description: ! PCHBS computes the B-spline representation of the PCH function ! determined by N,X,F,D. To be compatible with the rest of PCHIP, ! PCHBS includes INCFD, the increment between successive values of ! the F- and D arrays. ! ! The output is the B-representation for the function: NKNOTS, T, ! BCOEF, NDIM, KORD. ! ! *Caution: ! Since it is assumed that the input PCH function has been ! computed by one of the other routines in the package PCHIP, ! input arguments N, X, INCFD are **not** checked for validity. ! ! *Restrictions/assumptions: ! 1. N >= 2 . (not checked) ! 2. X(i) < X(i+1), i=1,...,N . (not checked) ! 3. INCFD > 0 . (not checked) ! 4. KNOTYP <= 2 . (error return if not) ! *5. NKNOTS = NDIM+4 = 2*N+4 . (error return if not) ! *6. T(2*k+1) = T(2*k) = X(k), k=1,...,N . (not checked) ! ! * Indicates this applies only if KNOTYP < 0 . ! ! *Portability: ! Argument INCFD is used only to cause the compiler to generate ! efficient code for the subscript expressions (1+(I-1)*INCFD) . ! The normal usage, in which PCHBS is called with one-dimensional ! arrays F and D, is probably non-Fortran 77, in the strict sense, ! but it works on all systems on which PCHBS has been tested. ! ! *See Also: ! PCHIC, PCHIM, or PCHSP can be used to determine an interpolating ! PCH function from a set of data. ! The B-spline routine BVALU can be used to evaluate the ! B-representation that is output by PCHBS. ! (See BSPDOC for more information.) ! !***REFERENCES F. N. Fritsch, "Representations for parametric cubic ! splines," Computer Aided Geometric Design 6 (1989), ! pp.79-82. !***ROUTINES CALLED PCHKT, XERMSG !***REVISION HISTORY (YYMMDD) ! 870701 DATE WRITTEN ! 900405 Converted Fortran to upper case. ! 900405 Removed requirement that X be dimensioned N+1. ! 900406 Modified to make PCHKT a subsidiary routine to simplify ! usage. In the process, added argument INCFD to be com- ! patible with the rest of PCHIP. ! 900410 Converted prologue to SLATEC 4.0 format. ! 900410 Added calls to XERMSG and changed constant 3. to 3 to ! reduce single/double differences. ! 900411 Added reference. ! 900501 Corrected declarations. ! 930317 Minor cosmetic changes. (FNF) ! 930514 Corrected problems with dimensioning of arguments and ! clarified DESCRIPTION. (FNF) ! 930604 Removed NKNOTS from PCHKT call list. (FNF) !***END PROLOGUE PCHBS ! !*Internal Notes: ! !**End ! ! Declare arguments. ! INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR REAL X(*), F(INCFD,*), D(INCFD,*), T(*), BCOEF(*) ! ! Declare local variables. ! INTEGER K, KK REAL DOV3, HNEW, HOLD CHARACTER*8 LIBNAM, SUBNAM !***FIRST EXECUTABLE STATEMENT PCHBS ! ! Initialize. ! NDIM = 2*N KORD = 4 IERR = 0 LIBNAM = 'SLATEC' SUBNAM = 'PCHBS' ! ! Check argument validity. Set up knot sequence if OK. ! if ( KNOTYP > 2 ) THEN IERR = -1 call XERMSG (LIBNAM, SUBNAM, 'KNOTYP GREATER THAN 2', IERR, 1) return end if if ( KNOTYP < 0 ) THEN if ( NKNOTS /= NDIM+4 ) THEN IERR = -2 call XERMSG (LIBNAM, SUBNAM, & 'KNOTYP < 0 AND NKNOTS /= (2*N+4)', IERR, 1) return ENDIF ELSE ! Set up knot sequence. NKNOTS = NDIM + 4 call PCHKT (N, X, KNOTYP, T) end if ! ! Compute B-spline coefficients. ! HNEW = T(3) - T(1) DO 40 K = 1, N KK = 2*K HOLD = HNEW ! The following requires mixed mode arithmetic. DOV3 = D(1,K)/3 BCOEF(KK-1) = F(1,K) - HOLD*DOV3 ! The following assumes T(2*K+1) = X(K). HNEW = T(KK+3) - T(KK+1) BCOEF(KK) = F(1,K) + HNEW*DOV3 40 CONTINUE ! ! Terminate. ! return end subroutine PCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) ! !! PCHCE sets boundary conditions for PCHIC. ! !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHCE-S, DPCHCE-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHCE: PCHIC End Derivative Setter. ! ! Called by PCHIC to set end derivatives as requested by the user. ! It must be called after interior derivative values have been set. ! ----- ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the D array. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER IC(2), N, IERR ! REAL VC(2), X(N), H(N), SLOPE(N), D(INCFD,N) ! ! call PCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) ! ! Parameters: ! ! IC -- (input) integer array of length 2 specifying desired ! boundary conditions: ! IC(1) = IBEG, desired condition at beginning of data. ! IC(2) = IEND, desired condition at end of data. ! ( see prologue to PCHIC for details. ) ! ! VC -- (input) real array of length 2 specifying desired boundary ! values. VC(1) need be set only if IC(1) = 2 or 3 . ! VC(2) need be set only if IC(2) = 2 or 3 . ! ! N -- (input) number of data points. (assumes N >= 2) ! ! X -- (input) real array of independent variable values. (the ! elements of X are assumed to be strictly increasing.) ! ! H -- (input) real array of interval lengths. ! SLOPE -- (input) real array of data slopes. ! If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: ! H(I) = X(I+1)-X(I), ! SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. ! ! D -- (input) real array of derivative values at the data points. ! The value corresponding to X(I) must be stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! (output) the value of D at X(1) and/or X(N) is changed, if ! necessary, to produce the requested boundary conditions. ! no other entries in D are changed. ! ! INCFD -- (input) increment between successive values in D. ! This argument is provided primarily for 2-D applications. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning errors: ! IERR = 1 if IBEG < 0 and D(1) had to be adjusted for ! monotonicity. ! IERR = 2 if IEND < 0 and D(1+(N-1)*INCFD) had to be ! adjusted for monotonicity. ! IERR = 3 if both of the above are true. ! ! ------- ! WARNING: This routine does no validity-checking of arguments. ! ------- ! ! Fortran intrinsics used: ABS. ! !***SEE ALSO PCHIC !***ROUTINES CALLED PCHDF, PCHST, XERMSG !***REVISION HISTORY (YYMMDD) ! 820218 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 870707 Minor corrections made to prologue.. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR section in prologue. (WRB) ! 930503 Improved purpose. (FNF) !***END PROLOGUE PCHCE ! ! Programming notes: ! 1. The function PCHST(ARG1,ARG2) is assumed to return zero if ! either argument is zero, +1 if they are of the same sign, and ! -1 if they are of opposite sign. ! 2. One could reduce the number of arguments and amount of local ! storage, at the expense of reduced code clarity, by passing in ! the array WK (rather than splitting it into H and SLOPE) and ! increasing its length enough to incorporate STEMP and XTEMP. ! 3. The two monotonicity checks only use the sufficient conditions. ! Thus, it is possible (but unlikely) for a boundary condition to ! be changed, even though the original interpolant was monotonic. ! (At least the result is a continuous function of the data.) !**End ! ! DECLARE ARGUMENTS. ! INTEGER IC(2), N, INCFD, IERR REAL VC(2), X(*), H(*), SLOPE(*), D(INCFD,*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER IBEG, IEND, IERF, INDEX, J, K REAL HALF, STEMP(3), THREE, TWO, XTEMP(4), ZERO SAVE ZERO, HALF, TWO, THREE REAL PCHDF, PCHST ! ! INITIALIZE. ! DATA ZERO /0./, HALF /0.5/, TWO /2./, THREE /3./ ! !***FIRST EXECUTABLE STATEMENT PCHCE IBEG = IC(1) IEND = IC(2) IERR = 0 ! ! SET TO DEFAULT BOUNDARY CONDITIONS if N IS TOO SMALL. ! if ( ABS(IBEG) > N ) IBEG = 0 if ( ABS(IEND) > N ) IEND = 0 ! ! TREAT BEGINNING BOUNDARY CONDITION. ! if (IBEG == 0) go to 2000 K = ABS(IBEG) if (K == 1) THEN ! BOUNDARY VALUE PROVIDED. D(1,1) = VC(1) ELSE if (K == 2) THEN ! BOUNDARY SECOND DERIVATIVE PROVIDED. D(1,1) = HALF*( (THREE*SLOPE(1) - D(1,2)) - HALF*VC(1)*H(1) ) ELSE if (K < 5) THEN ! USE K-POINT DERIVATIVE FORMULA. ! PICK UP FIRST K POINTS, IN REVERSE ORDER. DO 10 J = 1, K INDEX = K-J+1 ! INDEX RUNS FROM K DOWN TO 1. XTEMP(J) = X(INDEX) if (J < K) STEMP(J) = SLOPE(INDEX-1) 10 CONTINUE ! ----------------------------- D(1,1) = PCHDF (K, XTEMP, STEMP, IERF) ! ----------------------------- if (IERF /= 0) go to 5001 ELSE ! USE 'NOT A KNOT' CONDITION. D(1,1) = ( THREE*(H(1)*SLOPE(2) + H(2)*SLOPE(1)) & - TWO*(H(1)+H(2))*D(1,2) - H(1)*D(1,3) ) / H(2) end if ! if (IBEG > 0) go to 2000 ! ! CHECK D(1,1) FOR COMPATIBILITY WITH MONOTONICITY. ! if (SLOPE(1) == ZERO) THEN if (D(1,1) /= ZERO) THEN D(1,1) = ZERO IERR = IERR + 1 ENDIF ELSE if ( PCHST(D(1,1),SLOPE(1)) < ZERO) THEN D(1,1) = ZERO IERR = IERR + 1 ELSE if ( ABS(D(1,1)) > THREE*ABS(SLOPE(1)) ) THEN D(1,1) = THREE*SLOPE(1) IERR = IERR + 1 end if ! ! TREAT END BOUNDARY CONDITION. ! 2000 CONTINUE if (IEND == 0) go to 5000 K = ABS(IEND) if (K == 1) THEN ! BOUNDARY VALUE PROVIDED. D(1,N) = VC(2) ELSE if (K == 2) THEN ! BOUNDARY SECOND DERIVATIVE PROVIDED. D(1,N) = HALF*( (THREE*SLOPE(N-1) - D(1,N-1)) + & HALF*VC(2)*H(N-1) ) ELSE if (K < 5) THEN ! USE K-POINT DERIVATIVE FORMULA. ! PICK UP LAST K POINTS. DO 2010 J = 1, K INDEX = N-K+J ! INDEX RUNS FROM N+1-K UP TO N. XTEMP(J) = X(INDEX) if (J < K) STEMP(J) = SLOPE(INDEX) 2010 CONTINUE ! ----------------------------- D(1,N) = PCHDF (K, XTEMP, STEMP, IERF) ! ----------------------------- if (IERF /= 0) go to 5001 ELSE ! USE 'NOT A KNOT' CONDITION. D(1,N) = ( THREE*(H(N-1)*SLOPE(N-2) + H(N-2)*SLOPE(N-1)) & - TWO*(H(N-1)+H(N-2))*D(1,N-1) - H(N-1)*D(1,N-2) ) & / H(N-2) end if ! if (IEND > 0) go to 5000 ! ! CHECK D(1,N) FOR COMPATIBILITY WITH MONOTONICITY. ! if (SLOPE(N-1) == ZERO) THEN if (D(1,N) /= ZERO) THEN D(1,N) = ZERO IERR = IERR + 2 ENDIF ELSE if ( PCHST(D(1,N),SLOPE(N-1)) < ZERO) THEN D(1,N) = ZERO IERR = IERR + 2 ELSE if ( ABS(D(1,N)) > THREE*ABS(SLOPE(N-1)) ) THEN D(1,N) = THREE*SLOPE(N-1) IERR = IERR + 2 end if ! ! NORMAL RETURN. ! 5000 CONTINUE return ! ! ERROR RETURN. ! 5001 CONTINUE ! ERROR RETURN FROM PCHDF. ! *** THIS CASE SHOULD NEVER OCCUR *** IERR = -1 call XERMSG ('SLATEC', 'PCHCE', 'ERROR RETURN FROM PCHDF', IERR, & 1) return end subroutine PCHCI (N, H, SLOPE, D, INCFD) ! !! PCHCI sets interior derivatives for PCHIC. ! !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHCI-S, DPCHCI-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHCI: PCHIC Initial Derivative Setter. ! ! Called by PCHIC to set derivatives needed to determine a monotone ! piecewise cubic Hermite interpolant to the data. ! ! Default boundary conditions are provided which are compatible ! with monotonicity. If the data are only piecewise monotonic, the ! interpolant will have an extremum at each point where monotonicity ! switches direction. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the D array. ! ! The resulting piecewise cubic Hermite function should be identical ! (within roundoff error) to that produced by PCHIM. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N ! REAL H(N), SLOPE(N), D(INCFD,N) ! ! call PCHCI (N, H, SLOPE, D, INCFD) ! ! Parameters: ! ! N -- (input) number of data points. ! If N=2, simply does linear interpolation. ! ! H -- (input) real array of interval lengths. ! SLOPE -- (input) real array of data slopes. ! If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: ! H(I) = X(I+1)-X(I), ! SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. ! ! D -- (output) real array of derivative values at the data points. ! If the data are monotonic, these values will determine a ! a monotone cubic Hermite function. ! The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! No other entries in D are changed. ! ! INCFD -- (input) increment between successive values in D. ! This argument is provided primarily for 2-D applications. ! ! ------- ! WARNING: This routine does no validity-checking of arguments. ! ------- ! ! Fortran intrinsics used: ABS, MAX, MIN. ! !***SEE ALSO PCHIC !***ROUTINES CALLED PCHST !***REVISION HISTORY (YYMMDD) ! 820218 DATE WRITTEN ! 820601 Modified end conditions to be continuous functions of ! data when monotonicity switches in next interval. ! 820602 1. Modified formulas so end conditions are less prone ! to over/underflow problems. ! 2. Minor modification to HSUM calculation. ! 820805 Converted to SLATEC library version. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR section in prologue. (WRB) ! 930503 Improved purpose. (FNF) !***END PROLOGUE PCHCI ! ! Programming notes: ! 1. The function PCHST(ARG1,ARG2) is assumed to return zero if ! either argument is zero, +1 if they are of the same sign, and ! -1 if they are of opposite sign. !**End ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD REAL H(*), SLOPE(*), D(INCFD,*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, NLESS1 REAL DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, HSUM, HSUMT3, THREE, & W1, W2, ZERO SAVE ZERO, THREE REAL PCHST ! ! INITIALIZE. ! DATA ZERO /0./, THREE /3./ !***FIRST EXECUTABLE STATEMENT PCHCI NLESS1 = N - 1 DEL1 = SLOPE(1) ! ! SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. ! if (NLESS1 > 1) go to 10 D(1,1) = DEL1 D(1,N) = DEL1 go to 5000 ! ! NORMAL CASE (N >= 3). ! 10 CONTINUE DEL2 = SLOPE(2) ! ! SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE ! SHAPE-PRESERVING. ! HSUM = H(1) + H(2) W1 = (H(1) + HSUM)/HSUM W2 = -H(1)/HSUM D(1,1) = W1*DEL1 + W2*DEL2 if ( PCHST(D(1,1),DEL1) <= ZERO) THEN D(1,1) = ZERO ELSE if ( PCHST(DEL1,DEL2) < ZERO) THEN ! NEED DO THIS CHECK ONLY if MONOTONICITY SWITCHES. DMAX = THREE*DEL1 if (ABS(D(1,1)) > ABS(DMAX)) D(1,1) = DMAX end if ! ! LOOP THROUGH INTERIOR POINTS. ! DO 50 I = 2, NLESS1 if (I == 2) go to 40 ! HSUM = H(I-1) + H(I) DEL1 = DEL2 DEL2 = SLOPE(I) 40 CONTINUE ! ! SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. ! D(1,I) = ZERO if ( PCHST(DEL1,DEL2) <= ZERO) go to 50 ! ! USE BRODLIE MODIFICATION OF BUTLAND FORMULA. ! HSUMT3 = HSUM+HSUM+HSUM W1 = (HSUM + H(I-1))/HSUMT3 W2 = (HSUM + H(I) )/HSUMT3 DMAX = MAX( ABS(DEL1), ABS(DEL2) ) DMIN = MIN( ABS(DEL1), ABS(DEL2) ) DRAT1 = DEL1/DMAX DRAT2 = DEL2/DMAX D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) ! 50 CONTINUE ! ! SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE ! SHAPE-PRESERVING. ! W1 = -H(N-1)/HSUM W2 = (H(N-1) + HSUM)/HSUM D(1,N) = W1*DEL1 + W2*DEL2 if ( PCHST(D(1,N),DEL2) <= ZERO) THEN D(1,N) = ZERO ELSE if ( PCHST(DEL1,DEL2) < ZERO) THEN ! NEED DO THIS CHECK ONLY if MONOTONICITY SWITCHES. DMAX = THREE*DEL2 if (ABS(D(1,N)) > ABS(DMAX)) D(1,N) = DMAX end if ! ! NORMAL RETURN. ! 5000 CONTINUE return end subroutine PCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) ! !! PCHCM checks a cubic Hermite function for monotonicity. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3 !***TYPE SINGLE PRECISION (PCHCM-S, DPCHCM-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, ! PCHIP, PIECEWISE CUBIC INTERPOLATION, UTILITY ROUTINE !***AUTHOR Fritsch, F. N., (LLNL) ! Computing & Mathematics Research Division ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! *Usage: ! ! PARAMETER (INCFD = ...) ! INTEGER N, ISMON(N), IERR ! REAL X(N), F(INCFD,N), D(INCFD,N) ! LOGICAL SKIP ! ! call PCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) ! ! *Arguments: ! ! N:IN is the number of data points. (Error return if N < 2 .) ! ! X:IN is a real array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F:IN is a real array of function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! D:IN is a real array of derivative values. D(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! INCFD:IN is the increment between successive values in F and D. ! (Error return if INCFD < 1 .) ! ! SKIP:INOUT is a logical variable which should be set to ! .TRUE. if the user wishes to skip checks for validity of ! preceding parameters, or to .FALSE. otherwise. ! This will save time in case these checks have already ! been performed. ! SKIP will be set to .TRUE. on normal return. ! ! ISMON:OUT is an integer array indicating on which intervals the ! PCH function defined by N, X, F, D is monotonic. ! For data interval [X(I),X(I+1)], ! ISMON(I) = -3 if function is probably decreasing; ! ISMON(I) = -1 if function is strictly decreasing; ! ISMON(I) = 0 if function is constant; ! ISMON(I) = 1 if function is strictly increasing; ! ISMON(I) = 2 if function is non-monotonic; ! ISMON(I) = 3 if function is probably increasing. ! If ABS(ISMON)=3, this means that the D values are near ! the boundary of the monotonicity region. A small ! increase produces non-monotonicity; decrease, strict ! monotonicity. ! The above applies to I=1(1)N-1. ISMON(N) indicates whether ! the entire function is monotonic on [X(1),X(N)]. ! ! IERR:OUT is an error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! (The ISMON-array has not been changed in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! ! *Description: ! ! PCHCM: Piecewise Cubic Hermite -- Check Monotonicity. ! ! Checks the piecewise cubic Hermite function defined by N,X,F,D ! for monotonicity. ! ! To provide compatibility with PCHIM and PCHIC, includes an ! increment between successive values of the F- and D arrays. ! ! *Cautions: ! This provides the same capability as old PCHMC, except that a ! new output value, -3, was added February 1989. (Formerly, -3 ! and +3 were lumped together in the single value 3.) Codes that ! flag nonmonotonicity by "IF (ISMON == 2)" need not be changed. ! Codes that check via "IF (ISMON >= 3)" should change the test to ! "IF (IABS(ISMON) >= 3)". Codes that declare monotonicity via ! "IF (ISMON <= 1)" should change to "IF (IABS(ISMON) <= 1)". ! !***REFERENCES F. N. Fritsch and R. E. Carlson, Monotone piecewise ! cubic interpolation, SIAM Journal on Numerical Ana- ! lysis 17, 2 (April 1980), pp. 238-246. !***ROUTINES CALLED CHFCM, XERMSG !***REVISION HISTORY (YYMMDD) ! 820518 DATE WRITTEN ! 820804 Converted to SLATEC library version. ! 831201 Reversed order of subscripts of F and D, so that the ! routine will work properly when INCFD > 1 . (Bug!) ! 870707 Minor cosmetic changes to prologue. ! 890208 Added possible ISMON value of -3 and modified code so ! that 1,3,-1 produces ISMON(N)=2, rather than 3. ! 890306 Added caution about changed output. ! 890407 Changed name from PCHMC to PCHCM, as requested at the ! March 1989 SLATEC CML meeting, and made a few other ! minor modifications necessitated by this change. ! 890407 Converted to new SLATEC format. ! 890407 Modified DESCRIPTION to LDOC format. ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920429 Revised format and order of references. (WRB,FNF) !***END PROLOGUE PCHCM ! ! Fortran intrinsics used: ISIGN. ! Other routines used: CHFCM, XERMSG. ! ! ---------------------------------------------------------------------- ! ! Programming notes: ! ! An alternate organization would have separate loops for computing ! ISMON(i), i=1,...,NSEG, and for the computation of ISMON(N). The ! first loop can be readily parallelized, since the NSEG calls to ! CHFCM are independent. The second loop can be cut short if ! ISMON(N) is ever equal to 2, for it cannot be changed further. ! ! To produce a double precision version, simply: ! a. Change PCHCM to DPCHCM wherever it occurs, ! b. Change CHFCM to DCHFCM wherever it occurs, and ! c. Change the real declarations to double precision. ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, ISMON(N), IERR REAL X(N), F(INCFD,N), D(INCFD,N) LOGICAL SKIP ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, NSEG REAL DELTA INTEGER CHFCM ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT PCHCM if (SKIP) go to 5 ! if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE SKIP = .TRUE. ! ! FUNCTION DEFINITION IS OK -- GO ON. ! 5 CONTINUE NSEG = N - 1 DO 90 I = 1, NSEG DELTA = (F(1,I+1)-F(1,I))/(X(I+1)-X(I)) ! ------------------------------- ISMON(I) = CHFCM (D(1,I), D(1,I+1), DELTA) ! ------------------------------- if (I == 1) THEN ISMON(N) = ISMON(1) ELSE ! Need to figure out cumulative monotonicity from following ! "multiplication table": ! ! + I S M O N (I) ! + -3 -1 0 1 3 2 ! +------------------------+ ! I -3 I -3 -3 -3 2 2 2 I ! S -1 I -3 -1 -1 2 2 2 I ! M 0 I -3 -1 0 1 3 2 I ! O 1 I 2 2 1 1 3 2 I ! N 3 I 2 2 3 3 3 2 I ! (N) 2 I 2 2 2 2 2 2 I ! +------------------------+ ! Note that the 2 row and column are out of order so as not ! to obscure the symmetry in the rest of the table. ! ! No change needed if equal or constant on this interval or ! already declared nonmonotonic. if ( (ISMON(I) /= ISMON(N)) .AND. (ISMON(I) /= 0) & .AND. (ISMON(N) /= 2) ) THEN if ( (ISMON(I) == 2) .OR. (ISMON(N) == 0) ) THEN ISMON(N) = ISMON(I) ELSE if (ISMON(I)*ISMON(N) < 0) THEN ! This interval has opposite sense from curve so far. ISMON(N) = 2 ELSE ! At this point, both are nonzero with same sign, and ! we have already eliminated case both +-1. ISMON(N) = ISIGN (3, ISMON(N)) ENDIF ENDIF ENDIF 90 CONTINUE ! ! NORMAL RETURN. ! IERR = 0 return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'PCHCM', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'PCHCM', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'PCHCM', 'X-ARRAY NOT STRICTLY INCREASING' & , IERR, 1) return end subroutine PCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) ! !! PCHCS adjusts derivative values for PCHIC. ! !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHCS-S, DPCHCS-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHCS: PCHIC Monotonicity Switch Derivative Setter. ! ! Called by PCHIC to adjust the values of D in the vicinity of a ! switch in direction of monotonicity, to produce a more "visually ! pleasing" curve than that given by PCHIM . ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, IERR ! REAL SWITCH, H(N), SLOPE(N), D(INCFD,N) ! ! call PCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) ! ! Parameters: ! ! SWITCH -- (input) indicates the amount of control desired over ! local excursions from data. ! ! N -- (input) number of data points. (assumes N > 2 .) ! ! H -- (input) real array of interval lengths. ! SLOPE -- (input) real array of data slopes. ! If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: ! H(I) = X(I+1)-X(I), ! SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. ! ! D -- (input) real array of derivative values at the data points, ! as determined by PCHCI. ! (output) derivatives in the vicinity of switches in direction ! of monotonicity may be adjusted to produce a more "visually ! pleasing" curve. ! The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! No other entries in D are changed. ! ! INCFD -- (input) increment between successive values in D. ! This argument is provided primarily for 2-D applications. ! ! IERR -- (output) error flag. should be zero. ! If negative, trouble in PCHSW. (should never happen.) ! ! ------- ! WARNING: This routine does no validity-checking of arguments. ! ------- ! ! Fortran intrinsics used: ABS, MAX, MIN. ! !***SEE ALSO PCHIC !***ROUTINES CALLED PCHST, PCHSW !***REVISION HISTORY (YYMMDD) ! 820218 DATE WRITTEN ! 820617 Redesigned to (1) fix problem with lack of continuity ! approaching a flat-topped peak (2) be cleaner and ! easier to verify. ! Eliminated subroutines PCHSA and PCHSX in the process. ! 820622 1. Limited fact to not exceed one, so computed D is a ! convex combination of PCHCI value and PCHSD value. ! 2. Changed fudge from 1 to 4 (based on experiments). ! 820623 Moved PCHSD to an inline function (eliminating MSWTYP). ! 820805 Converted to SLATEC library version. ! 870813 Minor cosmetic changes. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR section in prologue. (WRB) ! 930503 Improved purpose. (FNF) !***END PROLOGUE PCHCS ! ! Programming notes: ! 1. The function PCHST(ARG1,ARG2) is assumed to return zero if ! either argument is zero, +1 if they are of the same sign, and ! -1 if they are of opposite sign. !**End ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, IERR REAL SWITCH, H(*), SLOPE(*), D(INCFD,*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, INDX, K, NLESS1 REAL DEL(3), DEXT, DFLOC, DFMX, FACT, FUDGE, ONE, SLMAX, & WTAVE(2), ZERO SAVE ZERO, ONE, FUDGE REAL PCHST ! ! DEFINE INLINE FUNCTION FOR WEIGHTED AVERAGE OF SLOPES. ! REAL PCHSD, S1, S2, H1, H2 PCHSD(S1,S2,H1,H2) = (H2/(H1+H2))*S1 + (H1/(H1+H2))*S2 ! ! INITIALIZE. ! DATA ZERO /0./, ONE /1./ DATA FUDGE /4./ !***FIRST EXECUTABLE STATEMENT PCHCS IERR = 0 NLESS1 = N - 1 ! ! LOOP OVER SEGMENTS. ! DO 900 I = 2, NLESS1 if ( PCHST(SLOPE(I-1),SLOPE(I)) ) 100, 300, 900 ! -------------------------- ! 100 CONTINUE ! !....... SLOPE SWITCHES MONOTONICITY AT I-TH POINT ..................... ! ! DO NOT CHANGE D if 'UP-DOWN-UP'. if (I > 2) THEN if ( PCHST(SLOPE(I-2),SLOPE(I)) > ZERO) go to 900 ! -------------------------- ENDIF if (I < NLESS1) THEN if ( PCHST(SLOPE(I+1),SLOPE(I-1)) > ZERO) go to 900 ! ---------------------------- ENDIF ! ! ....... COMPUTE PROVISIONAL VALUE FOR D(1,I). ! DEXT = PCHSD (SLOPE(I-1), SLOPE(I), H(I-1), H(I)) ! ! ....... DETERMINE WHICH INTERVAL CONTAINS THE EXTREMUM. ! if ( PCHST(DEXT, SLOPE(I-1)) ) 200, 900, 250 ! ----------------------- ! 200 CONTINUE ! DEXT AND SLOPE(I-1) HAVE OPPOSITE SIGNS -- ! EXTREMUM IS IN (X(I-1),X(I)). K = I-1 ! SET UP TO COMPUTE NEW VALUES FOR D(1,I-1) AND D(1,I). WTAVE(2) = DEXT if (K > 1) & WTAVE(1) = PCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) go to 400 ! 250 CONTINUE ! DEXT AND SLOPE(I) HAVE OPPOSITE SIGNS -- ! EXTREMUM IS IN (X(I),X(I+1)). K = I ! SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). WTAVE(1) = DEXT if (K < NLESS1) & WTAVE(2) = PCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) go to 400 ! 300 CONTINUE ! !....... AT LEAST ONE OF SLOPE(I-1) AND SLOPE(I) IS ZERO -- ! CHECK FOR FLAT-TOPPED PEAK ....................... ! if (I == NLESS1) go to 900 if ( PCHST(SLOPE(I-1), SLOPE(I+1)) >= ZERO) go to 900 ! ----------------------------- ! ! WE HAVE FLAT-TOPPED PEAK ON (X(I),X(I+1)). K = I ! SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). WTAVE(1) = PCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) WTAVE(2) = PCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) ! 400 CONTINUE ! !....... AT THIS POINT WE HAVE DETERMINED THAT THERE WILL BE AN EXTREMUM ! ON (X(K),X(K+1)), WHERE K=I OR I-1, AND HAVE SET ARRAY WTAVE-- ! WTAVE(1) IS A WEIGHTED AVERAGE OF SLOPE(K-1) AND SLOPE(K), ! if K > 1 ! WTAVE(2) IS A WEIGHTED AVERAGE OF SLOPE(K) AND SLOPE(K+1), ! if K < N-1 ! SLMAX = ABS(SLOPE(K)) if (K > 1) SLMAX = MAX( SLMAX, ABS(SLOPE(K-1)) ) if (K < NLESS1) SLMAX = MAX( SLMAX, ABS(SLOPE(K+1)) ) ! if (K > 1) DEL(1) = SLOPE(K-1) / SLMAX DEL(2) = SLOPE(K) / SLMAX if (K < NLESS1) DEL(3) = SLOPE(K+1) / SLMAX ! if ((K > 1) .AND. (K < NLESS1)) THEN ! NORMAL CASE -- EXTREMUM IS NOT IN A BOUNDARY INTERVAL. FACT = FUDGE* ABS(DEL(3)*(DEL(1)-DEL(2))*(WTAVE(2)/SLMAX)) D(1,K) = D(1,K) + MIN(FACT,ONE)*(WTAVE(1) - D(1,K)) FACT = FUDGE* ABS(DEL(1)*(DEL(3)-DEL(2))*(WTAVE(1)/SLMAX)) D(1,K+1) = D(1,K+1) + MIN(FACT,ONE)*(WTAVE(2) - D(1,K+1)) ELSE ! SPECIAL CASE K=1 (WHICH CAN OCCUR ONLY if I=2) OR ! K=NLESS1 (WHICH CAN OCCUR ONLY if I=NLESS1). FACT = FUDGE* ABS(DEL(2)) D(1,I) = MIN(FACT,ONE) * WTAVE(I-K+1) ! NOTE THAT I-K+1 = 1 if K=I (=NLESS1), ! I-K+1 = 2 if K=I-1(=1). ENDIF ! ! !....... ADJUST if NECESSARY TO LIMIT EXCURSIONS FROM DATA. ! if (SWITCH <= ZERO) go to 900 ! DFLOC = H(K)*ABS(SLOPE(K)) if (K > 1) DFLOC = MAX( DFLOC, H(K-1)*ABS(SLOPE(K-1)) ) if (K < NLESS1) DFLOC = MAX( DFLOC, H(K+1)*ABS(SLOPE(K+1)) ) DFMX = SWITCH*DFLOC INDX = I-K+1 ! INDX = 1 if K=I, 2 IF K=I-1. ! --------------------------------------------------------------- call PCHSW (DFMX, INDX, D(1,K), D(1,K+1), H(K), SLOPE(K), IERR) ! --------------------------------------------------------------- if (IERR /= 0) return ! !....... END OF SEGMENT LOOP. ! 900 CONTINUE ! return end FUNCTION PCHDF (K, X, S, IERR) ! !! PCHDF computes divided differences for PCHCE and PCHSP. ! !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHDF-S, DPCHDF-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHDF: PCHIP Finite Difference Formula ! ! Uses a divided difference formulation to compute a K-point approx- ! imation to the derivative at X(K) based on the data in X and S. ! ! Called by PCHCE and PCHSP to compute 3- and 4-point boundary ! derivative approximations. ! ! ---------------------------------------------------------------------- ! ! On input: ! K is the order of the desired derivative approximation. ! K must be at least 3 (error return if not). ! X contains the K values of the independent variable. ! X need not be ordered, but the values **MUST** be ! distinct. (Not checked here.) ! S contains the associated slope values: ! S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1. ! (Note that S need only be of length K-1.) ! ! On return: ! S will be destroyed. ! IERR will be set to -1 if K < 2 . ! PCHDF will be set to the desired derivative approximation if ! IERR=0 or to zero if IERR=-1. ! ! ---------------------------------------------------------------------- ! !***SEE ALSO PCHCE, PCHSP !***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- ! Verlag, New York, 1978, pp. 10-16. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 820503 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 870813 Minor cosmetic changes. ! 890411 Added SAVE statements (Vers. 3.2). ! 890411 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) ! 920429 Revised format and order of references. (WRB,FNF) ! 930503 Improved purpose. (FNF) !***END PROLOGUE PCHDF ! !**End ! ! DECLARE ARGUMENTS. ! REAL PCHDF INTEGER K, IERR REAL X(K), S(K) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, J REAL VALUE, ZERO SAVE ZERO DATA ZERO /0./ ! ! CHECK FOR LEGAL VALUE OF K. ! !***FIRST EXECUTABLE STATEMENT PCHDF if (K < 3) go to 5001 ! ! COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL. ! DO 10 J = 2, K-1 DO 9 I = 1, K-J S(I) = (S(I+1)-S(I))/(X(I+J)-X(I)) 9 CONTINUE 10 CONTINUE ! ! EVALUATE DERIVATIVE AT X(K). ! VALUE = S(1) DO 20 I = 2, K-1 VALUE = S(I) + VALUE*(X(K)-X(I)) 20 CONTINUE ! ! NORMAL RETURN. ! IERR = 0 PCHDF = VALUE return ! ! ERROR RETURN. ! 5001 CONTINUE ! K < 3 RETURN. IERR = -1 call XERMSG ('SLATEC', 'PCHDF', 'K LESS THAN THREE', IERR, 1) PCHDF = ZERO return !------------- LAST LINE OF PCHDF FOLLOWS ------------------------------ end subroutine PCHDOC ! !! PCHDOC is documentation for PCHIP, for piecewise cubic Hermite interpolation. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E1A, Z !***TYPE ALL (PCHDOC-A) !***KEYWORDS CUBIC HERMITE INTERPOLATION, DOCUMENTATION, ! MONOTONE INTERPOLATION, PCHIP, ! PIECEWISE CUBIC INTERPOLATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! PCHIP: Piecewise Cubic Hermite Interpolation Package ! ! This document describes the contents of PCHIP, which is a ! Fortran package for piecewise cubic Hermite interpolation of data. ! It features software to produce a monotone and "visually pleasing" ! interpolant to monotone data. As is demonstrated in Reference 4, ! such an interpolant may be more reasonable than a cubic spline if ! the data contains both "steep" and "flat" sections. Interpola- ! tion of cumulative probability distribution functions is another ! application. (See References 2-4 for examples.) ! ! ! All piecewise cubic functions in PCHIP are represented in ! cubic Hermite form; that is, f(x) is determined by its values ! F(I) and derivatives D(I) at the breakpoints X(I), I=1(1)N. ! Throughout the package a PCH function is represented by the ! five variables N, X, F, D, INCFD: ! N - number of data points; ! X - abscissa values for the data points; ! F - ordinates (function values) for the data points; ! D - slopes (derivative values) at the data points; ! INCFD - increment between successive elements in the F- and ! D arrays (more on this later). ! These appear together and in the same order in all calls. ! ! The double precision equivalents of the PCHIP routines are ! obtained from the single precision names by prefixing the ! single precision names with a D. For example, the double ! precision equivalent of PCHIM is DPCHIM. ! ! The contents of the package are as follows: ! ! 1. Determine Derivative Values. ! ! NOTE: These routines provide alternate ways of determining D ! if these values are not already known. ! ! PCHIM -- Piecewise Cubic Hermite Interpolation to Monotone ! data. ! Used if the data are monotonic or if the user wants ! to guarantee that the interpolant stays within the ! limits of the data. (See Reference 3.) ! ! PCHIC -- Piecewise Cubic Hermite Interpolation Coefficients. ! Used if neither of the above conditions holds, or if ! the user wishes control over boundary derivatives. ! Will generally reproduce monotonicity on subintervals ! over which the data are monotonic. ! ! PCHSP -- Piecewise Cubic Hermite Spline. ! Produces a cubic spline interpolator in cubic Hermite ! form. Provided primarily for easy comparison of the ! spline with other piecewise cubic interpolants. (A ! modified version of de Boor's CUBSPL, Reference 1.) ! ! 2. Evaluate, Differentiate, or Integrate Resulting PCH Function. ! ! NOTE: If derivative values are available from some other ! source, these routines can be used without calling ! any of the previous routines. ! ! CHFEV -- Cubic Hermite Function EValuator. ! Evaluates a single cubic Hermite function at an array ! of points. Used when the interval is known, as in ! graphing applications. Called by PCHFE. ! ! PCHFE -- Piecewise Cubic Hermite Function Evaluator. ! Used when the interval is unknown or the evaluation ! array spans more than one data interval. ! ! CHFDV -- Cubic Hermite Function and Derivative Evaluator. ! Evaluates a single cubic Hermite function and its ! first derivative at an array of points. Used when ! the interval is known, as in graphing applications. ! Called by PCHFD. ! ! PCHFD -- Piecewise Cubic Hermite Function and Derivative ! Evaluator. ! Used when the interval is unknown or the evaluation ! array spans more than one data interval. ! ! PCHID -- Piecewise Cubic Hermite Integrator, Data Limits. ! Computes the definite integral of a piecewise cubic ! Hermite function when the integration limits are data ! points. ! ! PCHIA -- Piecewise Cubic Hermite Integrator, Arbitrary Limits. ! Computes the definite integral of a piecewise cubic ! Hermite function over an arbitrary finite interval. ! ! 3. Utility routines. ! ! PCHBS -- Piecewise Cubic Hermite to B-Spline converter. ! Converts a PCH function to B-representation, so that ! it can be used with other elements of the B-spline ! package (see BSPDOC). ! ! PCHCM -- Piecewise Cubic Hermite, Check Monotonicity of. ! Checks the monotonicity of an arbitrary PCH function. ! Might be used with PCHSP to build a polyalgorithm for ! piecewise C-2 interpolation. ! ! 4. Internal routines. ! ! CHFIE -- Cubic Hermite Function Integral Evaluator. ! (Real function called by PCHIA.) ! ! CHFCM -- Cubic Hermite Function, Check Monotonicity of. ! (Integer function called by PCHCM.) ! ! PCHCE -- PCHIC End Derivative Setter. ! (Called by PCHIC.) ! ! PCHCI -- PCHIC Initial Derivative Setter. ! (Called by PCHIC.) ! ! PCHCS -- PCHIC Monotonicity Switch Derivative Setter. ! (Called by PCHIC.) ! ! PCHDF -- PCHIP Finite Difference Formula. ! (Real function called by PCHCE and PCHSP.) ! ! PCHST -- PCHIP Sign Testing Routine. ! (Real function called by various PCHIP routines.) ! ! PCHSW -- PCHCS Switch Excursion Adjuster. ! (Called by PCHCS.) ! ! The calling sequences for these routines are described in the ! prologues of the respective routines. ! ! ! INCFD, the increment between successive elements in the F- ! and D arrays is included in the representation of a PCH function ! in this package to facilitate two-dimensional applications. For ! "normal" usage INCFD=1, and F and D are one-dimensional arrays. ! one would call PCHxx (where "xx" is "IM", "IC", or "SP") with ! ! N, X, F, D, 1 . ! ! Suppose, however, that one has data on a rectangular mesh, ! ! F2D(I,J) = value at (X(I), Y(J)), I=1(1)NX, ! J=1(1)NY. ! Assume the following dimensions: ! ! REAL X(NXMAX), Y(NYMAX) ! REAL F2D(NXMAX,NYMAX), FX(NXMAX,NYMAX), FY(NXMAX,NYMAX) ! ! where 2 <= NX <= NXMAX AND 2 <= NY <= NYMAX . To interpolate ! in X along the line Y = Y(J), call PCHxx with ! ! NX, X, F2D(1,J), FX(1,J), 1 . ! ! To interpolate along the line X = X(I), call PCHxx with ! ! NY, Y, F2D(I,1), FY(I,1), NXMAX . ! ! (This example assumes the usual columnwise storage of 2-D arrays ! in Fortran.) ! !***REFERENCES 1. Carl de Boor, A Practical Guide to Splines, Springer- ! Verlag, New York, 1978 (esp. Chapter IV, pp.49-62). ! 2. F. N. Fritsch, Piecewise Cubic Hermite Interpolation ! Package, Report UCRL-87285, Lawrence Livermore Natio- ! nal Laboratory, July 1982. [Poster presented at the ! SIAM 30th Anniversary Meeting, 19-23 July 1982.] ! 3. F. N. Fritsch and J. Butland, A method for construc- ! ting local monotone piecewise cubic interpolants, SIAM ! Journal on Scientific and Statistical Computing 5, 2 ! (June 1984), pp. 300-304. ! 4. F. N. Fritsch and R. E. Carlson, Monotone piecewise ! cubic interpolation, SIAM Journal on Numerical Ana- ! lysis 17, 2 (April 1980), pp. 238-246. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811106 DATE WRITTEN ! 870930 Updated Reference 3. ! 890414 Changed PCHMC and CHFMC to PCHCM and CHFCM, respectively, ! and augmented description of PCHCM. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910826 1. Revised purpose, clarified role of argument INCFD, ! corrected error in example, and removed redundant ! reference list. ! 2. Added description of PCHBS. (FNF) ! 920429 Revised format and order of references. (WRB,FNF) ! 930505 Changed CHFIV to CHFIE. (FNF) !***END PROLOGUE PCHDOC !----------------------------------------------------------------------- ! THIS IS A DUMMY SUBROUTINE, AND SHOULD NEVER BE CALLED. ! !***FIRST EXECUTABLE STATEMENT PCHDOC return !------------- LAST LINE OF PCHDOC FOLLOWS ----------------------------- end subroutine PCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) ! !! PCHFD evaluates a piecewise cubic Hermite function and its first ... ! derivative at an array of points. May be used by itself ! for Hermite interpolation, or as an evaluator for PCHIM ! or PCHIC. If only function values are required, use ! PCHFE instead. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3, H1 !***TYPE SINGLE PRECISION (PCHFD-S, DPCHFD-D) !***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, ! HERMITE INTERPOLATION, PCHIP, PIECEWISE CUBIC EVALUATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! PCHFD: Piecewise Cubic Hermite Function and Derivative ! evaluator ! ! Evaluates the cubic Hermite function defined by N, X, F, D, to- ! gether with its first derivative, at the points XE(J), J=1(1)NE. ! ! If only function values are required, use PCHFE, instead. ! ! To provide compatibility with PCHIM and PCHIC, includes an ! increment between successive values of the F- and D arrays. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, NE, IERR ! REAL X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE), DE(NE) ! LOGICAL SKIP ! ! call PCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) ! ! Parameters: ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real array of function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! INCFD -- (input) increment between successive values in F and D. ! (Error return if INCFD < 1 .) ! ! SKIP -- (input/output) logical variable which should be set to ! .TRUE. if the user wishes to skip checks for validity of ! preceding parameters, or to .FALSE. otherwise. ! This will save time in case these checks have already ! been performed (say, in PCHIM or PCHIC). ! SKIP will be set to .TRUE. on normal return. ! ! NE -- (input) number of evaluation points. (Error return if ! NE < 1 .) ! ! XE -- (input) real array of points at which the functions are to ! be evaluated. ! ! ! NOTES: ! 1. The evaluation will be most efficient if the elements ! of XE are increasing relative to X; ! that is, XE(J) >= X(I) ! implies XE(K) >= X(I), all K >= J . ! 2. If any of the XE are outside the interval [X(1),X(N)], ! values are extrapolated from the nearest extreme cubic, ! and a warning error is returned. ! ! FE -- (output) real array of values of the cubic Hermite function ! defined by N, X, F, D at the points XE. ! ! DE -- (output) real array of values of the first derivative of ! the same function at the points XE. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning error: ! IERR > 0 means that extrapolation was performed at ! IERR points. ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! IERR = -4 if NE < 1 . ! (Output arrays have not been changed in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! IERR = -5 if an error has occurred in the lower-level ! routine CHFDV. NB: this should never happen. ! Notify the author **IMMEDIATELY** if it does. ! !***REFERENCES (NONE) !***ROUTINES CALLED CHFDV, XERMSG !***REVISION HISTORY (YYMMDD) ! 811020 DATE WRITTEN ! 820803 Minor cosmetic changes for release 1. ! 870707 Minor cosmetic changes to prologue. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE PCHFD ! Programming notes: ! ! 1. To produce a double precision version, simply: ! a. Change PCHFD to DPCHFD, and CHFDV to DCHFDV, wherever they ! occur, ! b. Change the real declaration to double precision, ! ! 2. Most of the coding between the call to CHFDV and the end of ! the IR-loop could be eliminated if it were permissible to ! assume that XE is ordered relative to X. ! ! 3. CHFDV does not assume that X1 is less than X2. thus, it would ! be possible to write a version of PCHFD that assumes a strict- ! ly decreasing X-array by simply running the IR-loop backwards ! (and reversing the order of appropriate tests). ! ! 4. The present code has a minor bug, which I have decided is not ! worth the effort that would be required to fix it. ! If XE contains points in [X(N-1),X(N)], followed by points < ! X(N-1), followed by points > X(N), the extrapolation points ! will be counted (at least) twice in the total returned in IERR. ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, NE, IERR REAL X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*), DE(*) LOGICAL SKIP ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT PCHFD if (SKIP) go to 5 ! if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! ! FUNCTION DEFINITION IS OK, GO ON. ! 5 CONTINUE if ( NE < 1 ) go to 5004 IERR = 0 SKIP = .TRUE. ! ! LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) ! ( INTERVAL IS X(IL) <= X < X(IR) . ) JFIRST = 1 IR = 2 10 CONTINUE ! ! SKIP OUT OF LOOP if HAVE PROCESSED ALL EVALUATION POINTS. ! if (JFIRST > NE) go to 5000 ! ! LOCATE ALL POINTS IN INTERVAL. ! DO 20 J = JFIRST, NE if (XE(J) >= X(IR)) go to 30 20 CONTINUE J = NE + 1 go to 40 ! ! HAVE LOCATED FIRST POINT BEYOND INTERVAL. ! 30 CONTINUE if (IR == N) J = NE + 1 ! 40 CONTINUE NJ = J - JFIRST ! ! SKIP EVALUATION if NO POINTS IN INTERVAL. ! if (NJ == 0) go to 50 ! ! EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . ! ! ---------------------------------------------------------------- call CHFDV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR), & NJ, XE(JFIRST), FE(JFIRST), DE(JFIRST), NEXT, IERC) ! ---------------------------------------------------------------- if (IERC < 0) go to 5005 ! if (NEXT(2) == 0) go to 42 ! if (NEXT(2) > 0) THEN ! IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE ! RIGHT OF X(IR). ! if (IR < N) go to 41 ! if (IR == N) THEN ! THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(2) go to 42 41 CONTINUE ! ELSE ! WE SHOULD NEVER HAVE GOTTEN HERE. go to 5005 ! ENDIF ! ENDIF 42 CONTINUE ! if (NEXT(1) == 0) go to 49 ! if (NEXT(1) > 0) THEN ! IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE ! LEFT OF X(IR-1). ! if (IR > 2) go to 43 ! if (IR == 2) THEN ! THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(1) go to 49 43 CONTINUE ! ELSE ! XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST ! EVALUATION INTERVAL. ! ! FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). DO 44 I = JFIRST, J-1 if (XE(I) < X(IR-1)) go to 45 44 CONTINUE ! NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR ! IN CHFDV. go to 5005 ! 45 CONTINUE ! RESET J. (THIS WILL BE THE NEW JFIRST.) J = I ! ! NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. DO 46 I = 1, IR-1 if (XE(J) < X(I)) go to 47 46 CONTINUE ! NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J) < X(IR-1). ! 47 CONTINUE ! AT THIS POINT, EITHER XE(J) < X(1) ! OR X(I-1) <= XE(J) < X(I) . ! RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE ! CYCLING. IR = MAX(1, I-1) ! ENDIF ! ENDIF 49 CONTINUE ! JFIRST = J ! ! END OF IR-LOOP. ! 50 CONTINUE IR = IR + 1 if (IR <= N) go to 10 ! ! NORMAL RETURN. ! 5000 CONTINUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'PCHFD', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'PCHFD', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'PCHFD', 'X-ARRAY NOT STRICTLY INCREASING' & , IERR, 1) return ! 5004 CONTINUE ! NE < 1 RETURN. IERR = -4 call XERMSG ('SLATEC', 'PCHFD', & 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) return ! 5005 CONTINUE ! ERROR RETURN FROM CHFDV. ! *** THIS CASE SHOULD NEVER OCCUR *** IERR = -5 call XERMSG ('SLATEC', 'PCHFD', & 'ERROR RETURN FROM CHFDV -- FATAL', IERR, 2) return !------------- LAST LINE OF PCHFD FOLLOWS ------------------------------ end subroutine PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) ! !! PCHFE evaluates a piecewise cubic Hermite function at an array of points. ... ! May be used by itself for Hermite interpolation, ! or as an evaluator for PCHIM or PCHIC. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3 !***TYPE SINGLE PRECISION (PCHFE-S, DPCHFE-D) !***KEYWORDS CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP, ! PIECEWISE CUBIC EVALUATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! PCHFE: Piecewise Cubic Hermite Function Evaluator ! ! Evaluates the cubic Hermite function defined by N, X, F, D at ! the points XE(J), J=1(1)NE. ! ! To provide compatibility with PCHIM and PCHIC, includes an ! increment between successive values of the F- and D arrays. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, NE, IERR ! REAL X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE) ! LOGICAL SKIP ! ! call PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) ! ! Parameters: ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real array of function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! INCFD -- (input) increment between successive values in F and D. ! (Error return if INCFD < 1 .) ! ! SKIP -- (input/output) logical variable which should be set to ! .TRUE. if the user wishes to skip checks for validity of ! preceding parameters, or to .FALSE. otherwise. ! This will save time in case these checks have already ! been performed (say, in PCHIM or PCHIC). ! SKIP will be set to .TRUE. on normal return. ! ! NE -- (input) number of evaluation points. (Error return if ! NE < 1 .) ! ! XE -- (input) real array of points at which the function is to be ! evaluated. ! ! NOTES: ! 1. The evaluation will be most efficient if the elements ! of XE are increasing relative to X; ! that is, XE(J) >= X(I) ! implies XE(K) >= X(I), all K >= J . ! 2. If any of the XE are outside the interval [X(1),X(N)], ! values are extrapolated from the nearest extreme cubic, ! and a warning error is returned. ! ! FE -- (output) real array of values of the cubic Hermite function ! defined by N, X, F, D at the points XE. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning error: ! IERR > 0 means that extrapolation was performed at ! IERR points. ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! IERR = -4 if NE < 1 . ! (The FE-array has not been changed in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! !***REFERENCES (NONE) !***ROUTINES CALLED CHFEV, XERMSG !***REVISION HISTORY (YYMMDD) ! 811020 DATE WRITTEN ! 820803 Minor cosmetic changes for release 1. ! 870707 Minor cosmetic changes to prologue. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE PCHFE ! Programming notes: ! ! 1. To produce a double precision version, simply: ! a. Change PCHFE to DPCHFE, and CHFEV to DCHFEV, wherever they ! occur, ! b. Change the real declaration to double precision, ! ! 2. Most of the coding between the call to CHFEV and the end of ! the IR-loop could be eliminated if it were permissible to ! assume that XE is ordered relative to X. ! ! 3. CHFEV does not assume that X1 is less than X2. thus, it would ! be possible to write a version of PCHFE that assumes a strict- ! ly decreasing X-array by simply running the IR-loop backwards ! (and reversing the order of appropriate tests). ! ! 4. The present code has a minor bug, which I have decided is not ! worth the effort that would be required to fix it. ! If XE contains points in [X(N-1),X(N)], followed by points < ! X(N-1), followed by points > X(N), the extrapolation points ! will be counted (at least) twice in the total returned in IERR. ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, NE, IERR REAL X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*) LOGICAL SKIP ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT PCHFE if (SKIP) go to 5 ! if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! ! FUNCTION DEFINITION IS OK, GO ON. ! 5 CONTINUE if ( NE < 1 ) go to 5004 IERR = 0 SKIP = .TRUE. ! ! LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) ! ( INTERVAL IS X(IL) <= X < X(IR) . ) JFIRST = 1 IR = 2 10 CONTINUE ! ! SKIP OUT OF LOOP if HAVE PROCESSED ALL EVALUATION POINTS. ! if (JFIRST > NE) go to 5000 ! ! LOCATE ALL POINTS IN INTERVAL. ! DO 20 J = JFIRST, NE if (XE(J) >= X(IR)) go to 30 20 CONTINUE J = NE + 1 go to 40 ! ! HAVE LOCATED FIRST POINT BEYOND INTERVAL. ! 30 CONTINUE if (IR == N) J = NE + 1 ! 40 CONTINUE NJ = J - JFIRST ! ! SKIP EVALUATION if NO POINTS IN INTERVAL. ! if (NJ == 0) go to 50 ! ! EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . ! ! ---------------------------------------------------------------- call CHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR), & NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC) ! ---------------------------------------------------------------- if (IERC < 0) go to 5005 ! if (NEXT(2) == 0) go to 42 ! if (NEXT(2) > 0) THEN ! IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE ! RIGHT OF X(IR). ! if (IR < N) go to 41 ! if (IR == N) THEN ! THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(2) go to 42 41 CONTINUE ! ELSE ! WE SHOULD NEVER HAVE GOTTEN HERE. go to 5005 ! ENDIF ! ENDIF 42 CONTINUE ! if (NEXT(1) == 0) go to 49 ! if (NEXT(1) > 0) THEN ! IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE ! LEFT OF X(IR-1). ! if (IR > 2) go to 43 ! if (IR == 2) THEN ! THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(1) go to 49 43 CONTINUE ! ELSE ! XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST ! EVALUATION INTERVAL. ! ! FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). DO 44 I = JFIRST, J-1 if (XE(I) < X(IR-1)) go to 45 44 CONTINUE ! NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR ! IN CHFEV. go to 5005 ! 45 CONTINUE ! RESET J. (THIS WILL BE THE NEW JFIRST.) J = I ! ! NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. DO 46 I = 1, IR-1 if (XE(J) < X(I)) go to 47 46 CONTINUE ! NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J) < X(IR-1). ! 47 CONTINUE ! AT THIS POINT, EITHER XE(J) < X(1) ! OR X(I-1) <= XE(J) < X(I) . ! RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE ! CYCLING. IR = MAX(1, I-1) ! ENDIF ! ENDIF 49 CONTINUE ! JFIRST = J ! ! END OF IR-LOOP. ! 50 CONTINUE IR = IR + 1 if (IR <= N) go to 10 ! ! NORMAL RETURN. ! 5000 CONTINUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'PCHFE', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'PCHFE', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'PCHFE', 'X-ARRAY NOT STRICTLY INCREASING' & , IERR, 1) return ! 5004 CONTINUE ! NE < 1 RETURN. IERR = -4 call XERMSG ('SLATEC', 'PCHFE', & 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) return ! 5005 CONTINUE ! ERROR RETURN FROM CHFEV. ! *** THIS CASE SHOULD NEVER OCCUR *** IERR = -5 call XERMSG ('SLATEC', 'PCHFE', & 'ERROR RETURN FROM CHFEV -- FATAL', IERR, 2) return !------------- LAST LINE OF PCHFE FOLLOWS ------------------------------ end FUNCTION PCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR) ! !! PCHIA evaluates the definite integral of a piecewise cubic Hermite ... ! function over an arbitrary interval. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3, H2A1B2 !***TYPE SINGLE PRECISION (PCHIA-S, DPCHIA-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, ! QUADRATURE !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! PCHIA: Piecewise Cubic Hermite Integrator, Arbitrary limits ! ! Evaluates the definite integral of the cubic Hermite function ! defined by N, X, F, D over the interval [A, B]. ! ! To provide compatibility with PCHIM and PCHIC, includes an ! increment between successive values of the F- and D arrays. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, IERR ! REAL X(N), F(INCFD,N), D(INCFD,N), A, B ! REAL VALUE, PCHIA ! LOGICAL SKIP ! ! VALUE = PCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR) ! ! Parameters: ! ! VALUE -- (output) value of the requested integral. ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real array of function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! INCFD -- (input) increment between successive values in F and D. ! (Error return if INCFD < 1 .) ! ! SKIP -- (input/output) logical variable which should be set to ! .TRUE. if the user wishes to skip checks for validity of ! preceding parameters, or to .FALSE. otherwise. ! This will save time in case these checks have already ! been performed (say, in PCHIM or PCHIC). ! SKIP will be set to .TRUE. on return with IERR >= 0 . ! ! A,B -- (input) the limits of integration. ! NOTE: There is no requirement that [A,B] be contained in ! [X(1),X(N)]. However, the resulting integral value ! will be highly suspect, if not. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning errors: ! IERR = 1 if A is outside the interval [X(1),X(N)]. ! IERR = 2 if B is outside the interval [X(1),X(N)]. ! IERR = 3 if both of the above are true. (Note that this ! means that either [A,B] contains data interval ! or the intervals do not intersect at all.) ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! (VALUE will be zero in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! IERR = -4 in case of an error return from PCHID (which ! should never occur). ! !***REFERENCES (NONE) !***ROUTINES CALLED CHFIE, PCHID, XERMSG !***REVISION HISTORY (YYMMDD) ! 820730 DATE WRITTEN ! 820804 Converted to SLATEC library version. ! 870707 Corrected double precision conversion instructions. ! 870813 Minor cosmetic changes. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 930503 Corrected to set VALUE=0 when IERR.lt.0. (FNF) ! 930504 Changed CHFIV to CHFIE. (FNF) !***END PROLOGUE PCHIA ! ! Programming notes: ! 1. The error flag from PCHID is tested, because a logic flaw ! could conceivably result in IERD=-4, which should be reported. !**End ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, IERR REAL PCHIA REAL X(*), F(INCFD,*), D(INCFD,*), A, B LOGICAL SKIP ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, IA, IB, IERD, IL, IR REAL VALUE, XA, XB, ZERO SAVE ZERO REAL CHFIE, PCHID ! ! INITIALIZE. ! DATA ZERO /0./ !***FIRST EXECUTABLE STATEMENT PCHIA VALUE = ZERO ! ! VALIDITY-CHECK ARGUMENTS. ! if (SKIP) go to 5 ! if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! ! FUNCTION DEFINITION IS OK, GO ON. ! 5 CONTINUE SKIP = .TRUE. IERR = 0 if ( (A < X(1)) .OR. (A > X(N)) ) IERR = IERR + 1 if ( (B < X(1)) .OR. (B > X(N)) ) IERR = IERR + 2 ! ! COMPUTE INTEGRAL VALUE. ! if (A /= B) THEN XA = MIN (A, B) XB = MAX (A, B) if (XB <= X(2)) THEN ! INTERVAL IS TO LEFT OF X(2), SO USE FIRST CUBIC. ! -------------------------------------- VALUE = CHFIE (X(1),X(2), F(1,1),F(1,2), & D(1,1),D(1,2), A, B) ! -------------------------------------- ELSE if (XA >= X(N-1)) THEN ! INTERVAL IS TO RIGHT OF X(N-1), SO USE LAST CUBIC. ! ----------------------------------------- VALUE = CHFIE(X(N-1),X(N), F(1,N-1),F(1,N), & D(1,N-1),D(1,N), A, B) ! ----------------------------------------- ELSE ! 'NORMAL' CASE -- XA < XB, XA < X(N-1), XB > X(2). ! ......LOCATE IA AND IB SUCH THAT ! X(IA-1) < XA <= X(IA) <= X(IB) <= XB <= X(IB+1) IA = 1 DO 10 I = 1, N-1 if (XA > X(I)) IA = I + 1 10 CONTINUE ! IA = 1 IMPLIES XA < X(1) . OTHERWISE, ! IA IS LARGEST INDEX SUCH THAT X(IA-1) < XA,. ! IB = N DO 20 I = N, IA, -1 if (XB < X(I)) IB = I - 1 20 CONTINUE ! IB = N IMPLIES XB > X(N) . OTHERWISE, ! IB IS SMALLEST INDEX SUCH THAT XB < X(IB+1) . ! ! ......COMPUTE THE INTEGRAL. if (IB < IA) THEN ! THIS MEANS IB = IA-1 AND ! (A,B) IS A SUBSET OF (X(IB),X(IA)). ! ------------------------------------------ VALUE = CHFIE (X(IB),X(IA), F(1,IB),F(1,IA), & D(1,IB),D(1,IA), A, B) ! ------------------------------------------ ELSE ! ! FIRST COMPUTE INTEGRAL OVER (X(IA),X(IB)). ! (Case (IB == IA) is taken care of by initialization ! of VALUE to ZERO.) if (IB > IA) THEN ! --------------------------------------------- VALUE = PCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERD) ! --------------------------------------------- if (IERD < 0) go to 5004 ENDIF ! ! THEN ADD ON INTEGRAL OVER (XA,X(IA)). if (XA < X(IA)) THEN IL = MAX(1, IA-1) IR = IL + 1 ! ------------------------------------- VALUE = VALUE + CHFIE (X(IL),X(IR), F(1,IL),F(1,IR), & D(1,IL),D(1,IR), XA, X(IA)) ! ------------------------------------- ENDIF ! ! THEN ADD ON INTEGRAL OVER (X(IB),XB). if (XB > X(IB)) THEN IR = MIN (IB+1, N) IL = IR - 1 ! ------------------------------------- VALUE = VALUE + CHFIE (X(IL),X(IR), F(1,IL),F(1,IR), & D(1,IL),D(1,IR), X(IB), XB) ! ------------------------------------- ENDIF ! ! FINALLY, ADJUST SIGN if NECESSARY. if (A > B) VALUE = -VALUE ENDIF ENDIF end if ! ! NORMAL RETURN. ! 5000 CONTINUE PCHIA = VALUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'PCHIA', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) go to 5000 ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'PCHIA', 'INCREMENT LESS THAN ONE', IERR, & 1) go to 5000 ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'PCHIA', & 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) go to 5000 ! 5004 CONTINUE ! TROUBLE IN PCHID. (SHOULD NEVER OCCUR.) IERR = -4 call XERMSG ('SLATEC', 'PCHIA', 'TROUBLE IN PCHID', IERR, 1) go to 5000 !------------- LAST LINE OF PCHIA FOLLOWS ------------------------------ end subroutine PCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, & IERR) ! !! PCHIC sets derivatives needed to determine a piecewise monotone ... ! piecewise cubic Hermite interpolant to given data. ! User control is available over boundary conditions and/or ! treatment of points where monotonicity switches direction. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E1A !***TYPE SINGLE PRECISION (PCHIC-S, DPCHIC-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, ! PCHIP, PIECEWISE CUBIC INTERPOLATION, ! SHAPE-PRESERVING INTERPOLATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! PCHIC: Piecewise Cubic Hermite Interpolation Coefficients. ! ! Sets derivatives needed to determine a piecewise monotone piece- ! wise cubic interpolant to the data given in X and F satisfying the ! boundary conditions specified by IC and VC. ! ! The treatment of points where monotonicity switches direction is ! controlled by argument SWITCH. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the F- and D arrays. ! ! The resulting piecewise cubic Hermite function may be evaluated ! by PCHFE or PCHFD. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER IC(2), N, NWK, IERR ! REAL VC(2), SWITCH, X(N), F(INCFD,N), D(INCFD,N), WK(NWK) ! ! call PCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, IERR) ! ! Parameters: ! ! IC -- (input) integer array of length 2 specifying desired ! boundary conditions: ! IC(1) = IBEG, desired condition at beginning of data. ! IC(2) = IEND, desired condition at end of data. ! ! IBEG = 0 for the default boundary condition (the same as ! used by PCHIM). ! If IBEG /= 0, then its sign indicates whether the boundary ! derivative is to be adjusted, if necessary, to be ! compatible with monotonicity: ! IBEG > 0 if no adjustment is to be performed. ! IBEG < 0 if the derivative is to be adjusted for ! monotonicity. ! ! Allowable values for the magnitude of IBEG are: ! IBEG = 1 if first derivative at X(1) is given in VC(1). ! IBEG = 2 if second derivative at X(1) is given in VC(1). ! IBEG = 3 to use the 3-point difference formula for D(1). ! (Reverts to the default b.c. if N < 3 .) ! IBEG = 4 to use the 4-point difference formula for D(1). ! (Reverts to the default b.c. if N < 4 .) ! IBEG = 5 to set D(1) so that the second derivative is con- ! tinuous at X(2). (Reverts to the default b.c. if N < 4.) ! This option is somewhat analogous to the "not a knot" ! boundary condition provided by PCHSP. ! ! NOTES (IBEG): ! 1. An error return is taken if ABS(IBEG) > 5 . ! 2. Only in case IBEG <= 0 is it guaranteed that the ! interpolant will be monotonic in the first interval. ! If the returned value of D(1) lies between zero and ! 3*SLOPE(1), the interpolant will be monotonic. This ! is **NOT** checked if IBEG > 0 . ! 3. If IBEG < 0 and D(1) had to be changed to achieve mono- ! tonicity, a warning error is returned. ! ! IEND may take on the same values as IBEG, but applied to ! derivative at X(N). In case IEND = 1 or 2, the value is ! given in VC(2). ! ! NOTES (IEND): ! 1. An error return is taken if ABS(IEND) > 5 . ! 2. Only in case IEND <= 0 is it guaranteed that the ! interpolant will be monotonic in the last interval. ! If the returned value of D(1+(N-1)*INCFD) lies between ! zero and 3*SLOPE(N-1), the interpolant will be monotonic. ! This is **NOT** checked if IEND > 0 . ! 3. If IEND < 0 and D(1+(N-1)*INCFD) had to be changed to ! achieve monotonicity, a warning error is returned. ! ! VC -- (input) real array of length 2 specifying desired boundary ! values, as indicated above. ! VC(1) need be set only if IC(1) = 1 or 2 . ! VC(2) need be set only if IC(2) = 1 or 2 . ! ! SWITCH -- (input) indicates desired treatment of points where ! direction of monotonicity switches: ! Set SWITCH to zero if interpolant is required to be mono- ! tonic in each interval, regardless of monotonicity of data. ! NOTES: ! 1. This will cause D to be set to zero at all switch ! points, thus forcing extrema there. ! 2. The result of using this option with the default boun- ! dary conditions will be identical to using PCHIM, but ! will generally cost more compute time. ! This option is provided only to facilitate comparison ! of different switch and/or boundary conditions. ! Set SWITCH nonzero to use a formula based on the 3-point ! difference formula in the vicinity of switch points. ! If SWITCH is positive, the interpolant on each interval ! containing an extremum is controlled to not deviate from ! the data by more than SWITCH*DFLOC, where DFLOC is the ! maximum of the change of F on this interval and its two ! immediate neighbors. ! If SWITCH is negative, no such control is to be imposed. ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real array of dependent variable values to be inter- ! polated. F(1+(I-1)*INCFD) is value corresponding to X(I). ! ! D -- (output) real array of derivative values at the data points. ! These values will determine a monotone cubic Hermite func- ! tion on each subinterval on which the data are monotonic, ! except possibly adjacent to switches in monotonicity. ! The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! No other entries in D are changed. ! ! INCFD -- (input) increment between successive values in F and D. ! This argument is provided primarily for 2-D applications. ! (Error return if INCFD < 1 .) ! ! WK -- (scratch) real array of working storage. The user may wish ! to know that the returned values are: ! WK(I) = H(I) = X(I+1) - X(I) ; ! WK(N-1+I) = SLOPE(I) = (F(1,I+1) - F(1,I)) / H(I) ! for I = 1(1)N-1. ! ! NWK -- (input) length of work array. ! (Error return if NWK < 2*(N-1) .) ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning errors: ! IERR = 1 if IBEG < 0 and D(1) had to be adjusted for ! monotonicity. ! IERR = 2 if IEND < 0 and D(1+(N-1)*INCFD) had to be ! adjusted for monotonicity. ! IERR = 3 if both of the above are true. ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! IERR = -4 if ABS(IBEG) > 5 . ! IERR = -5 if ABS(IEND) > 5 . ! IERR = -6 if both of the above are true. ! IERR = -7 if NWK < 2*(N-1) . ! (The D array has not been changed in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! !***REFERENCES 1. F. N. Fritsch, Piecewise Cubic Hermite Interpolation ! Package, Report UCRL-87285, Lawrence Livermore Nation- ! al Laboratory, July 1982. [Poster presented at the ! SIAM 30th Anniversary Meeting, 19-23 July 1982.] ! 2. F. N. Fritsch and J. Butland, A method for construc- ! ting local monotone piecewise cubic interpolants, SIAM ! Journal on Scientific and Statistical Computing 5, 2 ! (June 1984), pp. 300-304. ! 3. F. N. Fritsch and R. E. Carlson, Monotone piecewise ! cubic interpolation, SIAM Journal on Numerical Ana- ! lysis 17, 2 (April 1980), pp. 238-246. !***ROUTINES CALLED PCHCE, PCHCI, PCHCS, XERMSG !***REVISION HISTORY (YYMMDD) ! 820218 DATE WRITTEN ! 820804 Converted to SLATEC library version. ! 870813 Updated Reference 2. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920429 Revised format and order of references. (WRB,FNF) !***END PROLOGUE PCHIC ! Programming notes: ! ! To produce a double precision version, simply: ! a. Change PCHIC to DPCHIC wherever it occurs, ! b. Change PCHCE to DPCHCE wherever it occurs, ! c. Change PCHCI to DPCHCI wherever it occurs, ! d. Change PCHCS to DPCHCS wherever it occurs, ! e. Change the real declarations to double precision, and ! f. Change the constant ZERO to double precision. ! ! DECLARE ARGUMENTS. ! INTEGER IC(2), N, INCFD, NWK, IERR REAL VC(2), SWITCH, X(*), F(INCFD,*), D(INCFD,*), WK(NWK) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, IBEG, IEND, NLESS1 REAL ZERO SAVE ZERO DATA ZERO /0./ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT PCHIC if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! IBEG = IC(1) IEND = IC(2) IERR = 0 if (ABS(IBEG) > 5) IERR = IERR - 1 if (ABS(IEND) > 5) IERR = IERR - 2 if (IERR < 0) go to 5004 ! ! FUNCTION DEFINITION IS OK -- GO ON. ! NLESS1 = N - 1 if ( NWK < 2*NLESS1 ) go to 5007 ! ! SET UP H AND SLOPE ARRAYS. ! DO 20 I = 1, NLESS1 WK(I) = X(I+1) - X(I) WK(NLESS1+I) = (F(1,I+1) - F(1,I)) / WK(I) 20 CONTINUE ! ! SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. ! if (NLESS1 > 1) go to 1000 D(1,1) = WK(2) D(1,N) = WK(2) go to 3000 ! ! NORMAL CASE (N >= 3) . ! 1000 CONTINUE ! ! SET INTERIOR DERIVATIVES AND DEFAULT END CONDITIONS. ! ! -------------------------------------- call PCHCI (N, WK(1), WK(N), D, INCFD) ! -------------------------------------- ! ! SET DERIVATIVES AT POINTS WHERE MONOTONICITY SWITCHES DIRECTION. ! if (SWITCH == ZERO) go to 3000 ! ---------------------------------------------------- call PCHCS (SWITCH, N, WK(1), WK(N), D, INCFD, IERR) ! ---------------------------------------------------- if (IERR /= 0) go to 5008 ! ! SET END CONDITIONS. ! 3000 CONTINUE if ( (IBEG == 0) .AND. (IEND == 0) ) go to 5000 ! ------------------------------------------------------- call PCHCE (IC, VC, N, X, WK(1), WK(N), D, INCFD, IERR) ! ------------------------------------------------------- if (IERR < 0) go to 5009 ! ! NORMAL RETURN. ! 5000 CONTINUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'PCHIC', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'PCHIC', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'PCHIC', 'X-ARRAY NOT STRICTLY INCREASING' & , IERR, 1) return ! 5004 CONTINUE ! IC OUT OF RANGE RETURN. IERR = IERR - 3 call XERMSG ('SLATEC', 'PCHIC', 'IC OUT OF RANGE', IERR, 1) return ! 5007 CONTINUE ! NWK < 2*(N-1) return. IERR = -7 call XERMSG ('SLATEC', 'PCHIC', 'WORK ARRAY TOO SMALL', IERR, 1) return ! 5008 CONTINUE ! ERROR RETURN FROM PCHCS. IERR = -8 call XERMSG ('SLATEC', 'PCHIC', 'ERROR RETURN FROM PCHCS', IERR, & 1) return ! 5009 CONTINUE ! ERROR RETURN FROM PCHCE. ! *** THIS CASE SHOULD NEVER OCCUR *** IERR = -9 call XERMSG ('SLATEC', 'PCHIC', 'ERROR RETURN FROM PCHCE', IERR, & 1) return !------------- LAST LINE OF PCHIC FOLLOWS ------------------------------ end FUNCTION PCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERR) ! !! PCHID evaluates the definite integral of a piecewise cubic Hermite ... ! function over an interval whose endpoints are data points. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3, H2A1B2 !***TYPE SINGLE PRECISION (PCHID-S, DPCHID-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, ! QUADRATURE !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! PCHID: Piecewise Cubic Hermite Integrator, Data limits ! ! Evaluates the definite integral of the cubic Hermite function ! defined by N, X, F, D over the interval [X(IA), X(IB)]. ! ! To provide compatibility with PCHIM and PCHIC, includes an ! increment between successive values of the F- and D arrays. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, IA, IB, IERR ! REAL X(N), F(INCFD,N), D(INCFD,N) ! LOGICAL SKIP ! ! VALUE = PCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERR) ! ! Parameters: ! ! VALUE -- (output) value of the requested integral. ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real array of function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! INCFD -- (input) increment between successive values in F and D. ! (Error return if INCFD < 1 .) ! ! SKIP -- (input/output) logical variable which should be set to ! .TRUE. if the user wishes to skip checks for validity of ! preceding parameters, or to .FALSE. otherwise. ! This will save time in case these checks have already ! been performed (say, in PCHIM or PCHIC). ! SKIP will be set to .TRUE. on return with IERR = 0 or -4. ! ! IA,IB -- (input) indices in X-array for the limits of integration. ! both must be in the range [1,N]. (Error return if not.) ! No restrictions on their relative values. ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! IERR = -4 if IA or IB is out of range. ! (VALUE will be zero in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 820723 DATE WRITTEN ! 820804 Converted to SLATEC library version. ! 870813 Minor cosmetic changes. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 930504 Corrected to set VALUE=0 when IERR.ne.0. (FNF) !***END PROLOGUE PCHID ! ! Programming notes: ! 1. This routine uses a special formula that is valid only for ! integrals whose limits coincide with data values. This is ! mathematically equivalent to, but much more efficient than, ! calls to CHFIE. !**End ! ! DECLARE ARGUMENTS. ! REAL PCHID INTEGER N, INCFD, IA, IB, IERR REAL X(*), F(INCFD,*), D(INCFD,*) LOGICAL SKIP ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, IUP, LOW REAL H, HALF, SIX, SUM, VALUE, ZERO SAVE ZERO, HALF, SIX ! ! INITIALIZE. ! DATA ZERO /0./, HALF /0.5/, SIX /6./ !***FIRST EXECUTABLE STATEMENT PCHID VALUE = ZERO ! ! VALIDITY-CHECK ARGUMENTS. ! if (SKIP) go to 5 ! if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! ! FUNCTION DEFINITION IS OK, GO ON. ! 5 CONTINUE SKIP = .TRUE. if ((IA < 1) .OR. (IA > N)) go to 5004 if ((IB < 1) .OR. (IB > N)) go to 5004 IERR = 0 ! ! COMPUTE INTEGRAL VALUE. ! if (IA /= IB) THEN LOW = MIN(IA, IB) IUP = MAX(IA, IB) - 1 SUM = ZERO DO 10 I = LOW, IUP H = X(I+1) - X(I) SUM = SUM + H*( (F(1,I) + F(1,I+1)) + & (D(1,I) - D(1,I+1))*(H/SIX) ) 10 CONTINUE VALUE = HALF * SUM if (IA > IB) VALUE = -VALUE end if ! ! NORMAL RETURN. ! 5000 CONTINUE PCHID = VALUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'PCHID', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) go to 5000 ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'PCHID', 'INCREMENT LESS THAN ONE', IERR, & 1) go to 5000 ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'PCHID', & 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) go to 5000 ! 5004 CONTINUE ! IA OR IB OUT OF RANGE RETURN. IERR = -4 call XERMSG ('SLATEC', 'PCHID', 'IA OR IB OUT OF RANGE', IERR, 1) go to 5000 !------------- LAST LINE OF PCHID FOLLOWS ------------------------------ end subroutine PCHIM (N, X, F, D, INCFD, IERR) ! !! PCHIM sets derivatives needed to determine a monotone piecewise ... ! cubic Hermite interpolant to given data. Boundary values ! are provided which are compatible with monotonicity. The ! interpolant will have an extremum at each point where mono- ! tonicity switches direction. (See PCHIC if user control is ! desired over boundary or switch conditions.) ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E1A !***TYPE SINGLE PRECISION (PCHIM-S, DPCHIM-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, ! PCHIP, PIECEWISE CUBIC INTERPOLATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! PCHIM: Piecewise Cubic Hermite Interpolation to ! Monotone data. ! ! Sets derivatives needed to determine a monotone piecewise cubic ! Hermite interpolant to the data given in X and F. ! ! Default boundary conditions are provided which are compatible ! with monotonicity. (See PCHIC if user control of boundary con- ! ditions is desired.) ! ! If the data are only piecewise monotonic, the interpolant will ! have an extremum at each point where monotonicity switches direc- ! tion. (See PCHIC if user control is desired in such cases.) ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the F- and D arrays. ! ! The resulting piecewise cubic Hermite function may be evaluated ! by PCHFE or PCHFD. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER N, IERR ! REAL X(N), F(INCFD,N), D(INCFD,N) ! ! call PCHIM (N, X, F, D, INCFD, IERR) ! ! Parameters: ! ! N -- (input) number of data points. (Error return if N < 2 .) ! If N=2, simply does linear interpolation. ! ! X -- (input) real array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real array of dependent variable values to be inter- ! polated. F(1+(I-1)*INCFD) is value corresponding to X(I). ! PCHIM is designed for monotonic data, but it will work for ! any F-array. It will force extrema at points where mono- ! tonicity switches direction. If some other treatment of ! switch points is desired, PCHIC should be used instead. ! ----- ! D -- (output) real array of derivative values at the data points. ! If the data are monotonic, these values will determine a ! a monotone cubic Hermite function. ! The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! No other entries in D are changed. ! ! INCFD -- (input) increment between successive values in F and D. ! This argument is provided primarily for 2-D applications. ! (Error return if INCFD < 1 .) ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! Warning error: ! IERR > 0 means that IERR switches in the direction ! of monotonicity were detected. ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! (The D array has not been changed in any of these cases.) ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! !***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- ! ting local monotone piecewise cubic interpolants, SIAM ! Journal on Scientific and Statistical Computing 5, 2 ! (June 1984), pp. 300-304. ! 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise ! cubic interpolation, SIAM Journal on Numerical Ana- ! lysis 17, 2 (April 1980), pp. 238-246. !***ROUTINES CALLED PCHST, XERMSG !***REVISION HISTORY (YYMMDD) ! 811103 DATE WRITTEN ! 820201 1. Introduced PCHST to reduce possible over/under- ! flow problems. ! 2. Rearranged derivative formula for same reason. ! 820602 1. Modified end conditions to be continuous functions ! of data when monotonicity switches in next interval. ! 2. Modified formulas so end conditions are less prone ! of over/underflow problems. ! 820803 Minor cosmetic changes for release 1. ! 870813 Updated Reference 1. ! 890411 Added SAVE statements (Vers. 3.2). ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920429 Revised format and order of references. (WRB,FNF) !***END PROLOGUE PCHIM ! Programming notes: ! ! 1. The function PCHST(ARG1,ARG2) is assumed to return zero if ! either argument is zero, +1 if they are of the same sign, and ! -1 if they are of opposite sign. ! 2. To produce a double precision version, simply: ! a. Change PCHIM to DPCHIM wherever it occurs, ! b. Change PCHST to DPCHST wherever it occurs, ! c. Change all references to the Fortran intrinsics to their ! double precision equivalents, ! d. Change the real declarations to double precision, and ! e. Change the constants ZERO and THREE to double precision. ! ! DECLARE ARGUMENTS. ! INTEGER N, INCFD, IERR REAL X(*), F(INCFD,*), D(INCFD,*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER I, NLESS1 REAL DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, & H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO SAVE ZERO, THREE REAL PCHST DATA ZERO /0./, THREE /3./ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT PCHIM if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 I = 2, N if ( X(I) <= X(I-1) ) go to 5003 1 CONTINUE ! ! FUNCTION DEFINITION IS OK, GO ON. ! IERR = 0 NLESS1 = N - 1 H1 = X(2) - X(1) DEL1 = (F(1,2) - F(1,1))/H1 DSAVE = DEL1 ! ! SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. ! if (NLESS1 > 1) go to 10 D(1,1) = DEL1 D(1,N) = DEL1 go to 5000 ! ! NORMAL CASE (N >= 3). ! 10 CONTINUE H2 = X(3) - X(2) DEL2 = (F(1,3) - F(1,2))/H2 ! ! SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE ! SHAPE-PRESERVING. ! HSUM = H1 + H2 W1 = (H1 + HSUM)/HSUM W2 = -H1/HSUM D(1,1) = W1*DEL1 + W2*DEL2 if ( PCHST(D(1,1),DEL1) <= ZERO) THEN D(1,1) = ZERO ELSE if ( PCHST(DEL1,DEL2) < ZERO) THEN ! NEED DO THIS CHECK ONLY if MONOTONICITY SWITCHES. DMAX = THREE*DEL1 if (ABS(D(1,1)) > ABS(DMAX)) D(1,1) = DMAX end if ! ! LOOP THROUGH INTERIOR POINTS. ! DO 50 I = 2, NLESS1 if (I == 2) go to 40 ! H1 = H2 H2 = X(I+1) - X(I) HSUM = H1 + H2 DEL1 = DEL2 DEL2 = (F(1,I+1) - F(1,I))/H2 40 CONTINUE ! ! SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. ! D(1,I) = ZERO if ( PCHST(DEL1,DEL2) ) 42, 41, 45 ! ! COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. ! 41 CONTINUE if (DEL2 == ZERO) go to 50 if ( PCHST(DSAVE,DEL2) < ZERO) IERR = IERR + 1 DSAVE = DEL2 go to 50 ! 42 CONTINUE IERR = IERR + 1 DSAVE = DEL2 go to 50 ! ! USE BRODLIE MODIFICATION OF BUTLAND FORMULA. ! 45 CONTINUE HSUMT3 = HSUM+HSUM+HSUM W1 = (HSUM + H1)/HSUMT3 W2 = (HSUM + H2)/HSUMT3 DMAX = MAX( ABS(DEL1), ABS(DEL2) ) DMIN = MIN( ABS(DEL1), ABS(DEL2) ) DRAT1 = DEL1/DMAX DRAT2 = DEL2/DMAX D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) ! 50 CONTINUE ! ! SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE ! SHAPE-PRESERVING. ! W1 = -H2/HSUM W2 = (H2 + HSUM)/HSUM D(1,N) = W1*DEL1 + W2*DEL2 if ( PCHST(D(1,N),DEL2) <= ZERO) THEN D(1,N) = ZERO ELSE if ( PCHST(DEL1,DEL2) < ZERO) THEN ! NEED DO THIS CHECK ONLY if MONOTONICITY SWITCHES. DMAX = THREE*DEL2 if (ABS(D(1,N)) > ABS(DMAX)) D(1,N) = DMAX end if ! ! NORMAL RETURN. ! 5000 CONTINUE return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'PCHIM', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'PCHIM', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'PCHIM', 'X-ARRAY NOT STRICTLY INCREASING' & , IERR, 1) return !------------- LAST LINE OF PCHIM FOLLOWS ------------------------------ end subroutine PCHKT (N, X, KNOTYP, T) ! !! PCHKT computes B-spline knot sequence for PCHBS. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E3 !***TYPE SINGLE PRECISION (PCHKT-S, DPCHKT-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! Set a knot sequence for the B-spline representation of a PCH ! function with breakpoints X. All knots will be at least double. ! Endknots are set as: ! (1) quadruple knots at endpoints if KNOTYP=0; ! (2) extrapolate the length of end interval if KNOTYP=1; ! (3) periodic if KNOTYP=2. ! ! Input arguments: N, X, KNOTYP. ! Output arguments: T. ! ! Restrictions/assumptions: ! 1. N >= 2 . (not checked) ! 2. X(i) < X(i+1), i=1,...,N . (not checked) ! 3. 0 <= KNOTYP <= 2 . (Acts like KNOTYP=0 for any other value.) ! !***SEE ALSO PCHBS !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 870701 DATE WRITTEN ! 900405 Converted Fortran to upper case. ! 900410 Converted prologue to SLATEC 4.0 format. ! 900410 Minor cosmetic changes. ! 930514 Changed NKNOTS from an output to an input variable. (FNF) ! 930604 Removed unused variable NKNOTS from argument list. (FNF) !***END PROLOGUE PCHKT ! !*Internal Notes: ! ! Since this is subsidiary to PCHBS, which validates its input before ! calling, it is unnecessary for such validation to be done here. ! !**End ! ! Declare arguments. ! INTEGER N, KNOTYP REAL X(*), T(*) ! ! Declare local variables. ! INTEGER J, K, NDIM REAL HBEG, HEND !***FIRST EXECUTABLE STATEMENT PCHKT ! ! Initialize. ! NDIM = 2*N ! ! Set interior knots. ! J = 1 DO 20 K = 1, N J = J + 2 T(J) = X(K) T(J+1) = T(J) 20 CONTINUE ! Assertion: At this point T(3),...,T(NDIM+2) have been set and ! J=NDIM+1. ! ! Set end knots according to KNOTYP. ! HBEG = X(2) - X(1) HEND = X(N) - X(N-1) if (KNOTYP == 1 ) THEN ! Extrapolate. T(2) = X(1) - HBEG T(NDIM+3) = X(N) + HEND ELSE if ( KNOTYP == 2 ) THEN ! Periodic. T(2) = X(1) - HEND T(NDIM+3) = X(N) + HBEG ELSE ! Quadruple end knots. T(2) = X(1) T(NDIM+3) = X(N) end if T(1) = T(2) T(NDIM+4) = T(NDIM+3) ! ! Terminate. ! return !------------- LAST LINE OF PCHKT FOLLOWS ------------------------------ end subroutine PCHNGS (II, XVAL, IPLACE, SX, IX, IRCX) ! !! PCHNGS is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PCHNGS-S, DPCHNG-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! PCHNGS LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. ! SPARSE MATRIX ELEMENT ALTERATION SUBROUTINE. ! ! SUBROUTINE PCHNGS() CHANGES ELEMENT II IN VECTOR +/- IRCX TO THE ! VALUE XVAL. ! ! II THE ABSOLUTE VALUE OF THIS INTEGER IS THE SUBSCRIPT FOR ! THE ELEMENT TO BE CHANGED. ! XVAL NEW VALUE OF THE MATRIX ELEMENT BEING CHANGED. ! IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE. ! SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE ! MATRIX. THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY THE ! PACKAGE FOR THE USER. ! IRCX POINTS TO THE VECTOR OF THE MATRIX BEING UPDATED. ! A NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS ! BEING UPDATED. A POSITIVE VALUE OF IRCX INDICATES THAT ! COLUMN IRCX IS BEING UPDATED. A ZERO VALUE OF IRCX IS ! AN ERROR. ! ! SINCE DATA ITEMS ARE KEPT SORTED IN THE SEQUENTIAL DATA STRUCTURE, ! CHANGING A MATRIX ELEMENT CAN REQUIRE THE MOVEMENT OF ALL THE DATA ! ITEMS IN THE MATRIX. FOR THIS REASON, IT IS SUGGESTED THAT DATA ! ITEMS BE ADDED A COL. AT A TIME, IN ASCENDING COL. SEQUENCE. ! FURTHERMORE, SINCE DELETING ITEMS FROM THE DATA STRUCTURE MAY ALSO ! REQUIRE MOVING LARGE AMOUNTS OF DATA, ZERO ELEMENTS ARE EXPLICITLY ! STORED IN THE MATRIX. ! ! THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LCHNGS, ! SANDIA LABS. REPT. SAND78-0785. ! MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON ! REVISED 811130-1000 ! REVISED YYMMDD-HHMM ! !***SEE ALSO SPLP !***ROUTINES CALLED IPLOC, PRWPGE, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) !***END PROLOGUE PCHNGS DIMENSION IX(*) INTEGER IPLOC REAL SX(*),XVAL,ZERO,ONE,SXLAST,SXVAL SAVE ZERO, ONE DATA ZERO,ONE /0.E0,1.E0/ !***FIRST EXECUTABLE STATEMENT PCHNGS IOPT=1 ! ! DETERMINE NULL-CASES.. if ( II == 0) RETURN ! ! CHECK VALIDITY OF ROW/COL. INDEX. ! if (.NOT.(IRCX == 0)) go to 20002 NERR=55 call XERMSG ('SLATEC', 'PCHNGS', 'IRCX=0.', NERR, IOPT) 20002 LMX = IX(1) ! ! LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA. ! if (.NOT.(IRCX < 0)) go to 20005 ! ! CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE <= M AND ! THE INDEX MUST BE <= N. ! if (.NOT.(IX(2) < -IRCX .OR. IX(3) < ABS(II))) go to 20008 NERR=55 call XERMSG ('SLATEC', 'PCHNGS', & 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // & 'BOUNDS.', NERR, IOPT) 20008 go to 20006 ! ! CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE <= N AND ! THE INDEX MUST BE <= M. ! 20005 if (.NOT.(IX(3) < IRCX .OR. IX(2) < ABS(II))) go to 20011 NERR=55 call XERMSG ('SLATEC', 'PCHNGS', & 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // & 'BOUNDS.', NERR, IOPT) 20011 CONTINUE ! ! SET I TO BE THE ELEMENT OF ROW/COLUMN J TO BE CHANGED. ! 20006 if (.NOT.(IRCX > 0)) go to 20014 I = ABS(II) J = ABS(IRCX) go to 20015 20014 I = ABS(IRCX) J = ABS(II) ! ! THE INTEGER LL POINTS TO THE START OF THE MATRIX ELEMENT DATA. ! 20015 LL=IX(3)+4 II = ABS(II) LPG = LMX - LL ! ! SET IPLACE TO START OUR SCAN FOR THE ELEMENT AT THE BEGINNING ! OF THE VECTOR. ! if (.NOT.(J == 1)) go to 20017 IPLACE=LL+1 go to 20018 20017 IPLACE=IX(J+3)+1 ! ! IEND POINTS TO THE LAST ELEMENT OF THE VECTOR TO BE SCANNED. ! 20018 IEND = IX(J+4) ! ! SCAN THROUGH SEVERAL PAGES, if NECESSARY, TO FIND MATRIX ELEMENT. ! IPL = IPLOC(IPLACE,SX,IX) NP = ABS(IX(LMX-1)) go to 20021 20020 if (ILAST == IEND) go to 20022 ! ! THE VIRTUAL END OF DATA FOR THIS PAGE IS ILAST. ! 20021 ILAST = MIN(IEND,NP*LPG+LL-2) ! ! THE RELATIVE END OF DATA FOR THIS PAGE IS IL. ! SEARCH FOR A MATRIX VALUE WITH AN INDEX >= I ON THE PRESENT ! PAGE. ! IL = IPLOC(ILAST,SX,IX) IL = MIN(IL,LMX-2) 20023 if (.NOT.(.NOT.(IPL >= IL .OR. IX(IPL) >= I))) go to 20024 IPL=IPL+1 go to 20023 ! ! SET IPLACE AND STORE DATA ITEM if FOUND. ! 20024 if (.NOT.(IX(IPL) == I .AND. IPL <= IL)) go to 20025 SX(IPL) = XVAL SX(LMX) = ONE return ! ! EXIT FROM LOOP if ITEM WAS FOUND. ! 20025 if ( IX(IPL) > I .AND. IPL <= IL) ILAST = IEND if (.NOT.(ILAST /= IEND)) go to 20028 IPL = LL + 1 NP = NP + 1 20028 go to 20020 ! ! INSERT NEW DATA ITEM INTO LOCATION AT IPLACE(IPL). ! 20022 if (.NOT.(IPL > IL.OR.(IPL == IL.AND.I > IX(IPL)))) go to 20031 IPL = IL + 1 if ( IPL == LMX-1) IPL = IPL + 2 20031 IPLACE = (NP-1)*LPG + IPL ! ! go to A NEW PAGE, if NECESSARY, TO INSERT THE ITEM. ! if (.NOT.(IPL <= LMX .OR. IX(LMX-1) >= 0)) go to 20034 IPL=IPLOC(IPLACE,SX,IX) 20034 IEND = IX(LL) NP = ABS(IX(LMX-1)) SXVAL = XVAL ! ! LOOP THROUGH ALL SUBSEQUENT PAGES OF THE MATRIX MOVING DATA DOWN. ! THIS IS NECESSARY TO MAKE ROOM FOR THE NEW MATRIX ELEMENT AND ! KEEP THE ENTRIES SORTED. ! go to 20038 20037 if (IX(LMX-1) <= 0) go to 20039 20038 ILAST = MIN(IEND,NP*LPG+LL-2) IL = IPLOC(ILAST,SX,IX) IL = MIN(IL,LMX-2) SXLAST = SX(IL) IXLAST = IX(IL) ISTART = IPL + 1 if (.NOT.(ISTART <= IL)) go to 20040 K = ISTART + IL DO 50 JJ=ISTART,IL SX(K-JJ) = SX(K-JJ-1) IX(K-JJ) = IX(K-JJ-1) 50 CONTINUE SX(LMX) = ONE 20040 if (.NOT.(IPL <= LMX)) go to 20043 SX(IPL) = SXVAL IX(IPL) = I SXVAL = SXLAST I = IXLAST SX(LMX) = ONE if (.NOT.(IX(LMX-1) > 0)) go to 20046 IPL = LL + 1 NP = NP + 1 20046 CONTINUE 20043 go to 20037 20039 NP = ABS(IX(LMX-1)) ! ! DETERMINE if A NEW PAGE IS TO BE CREATED FOR THE LAST ELEMENT ! MOVED DOWN. ! IL = IL + 1 if (.NOT.(IL == LMX-1)) go to 20049 ! ! CREATE A NEW PAGE. ! IX(LMX-1) = NP ! ! WRITE THE OLD PAGE. ! SX(LMX) = ZERO KEY = 2 call PRWPGE(KEY,NP,LPG,SX,IX) SX(LMX) = ONE ! ! STORE LAST ELEMENT MOVED DOWN IN A NEW PAGE. ! IPL = LL + 1 NP = NP + 1 IX(LMX-1) = -NP SX(IPL) = SXVAL IX(IPL) = I go to 20050 ! ! LAST ELEMENT MOVED REMAINED ON THE OLD PAGE. ! 20049 if (.NOT.(IPL /= IL)) go to 20052 SX(IL) = SXVAL IX(IL) = I SX(LMX) = ONE 20052 CONTINUE ! ! INCREMENT POINTERS TO LAST ELEMENT IN VECTORS J,J+1,... . ! 20050 JSTART = J + 4 JJ=JSTART N20055=LL go to 20056 20055 JJ=JJ+1 20056 if ((N20055-JJ) < 0) go to 20057 IX(JJ) = IX(JJ) + 1 if ( MOD(IX(JJ)-LL,LPG) == LPG-1) IX(JJ) = IX(JJ) + 2 go to 20055 ! ! IPLACE POINTS TO THE INSERTED DATA ITEM. ! 20057 IPL=IPLOC(IPLACE,SX,IX) return end subroutine PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) ! !! PCHSP sets derivatives needed to determine the Hermite representation ... ! of the cubic spline interpolant to given data, with specified boundary ! conditions. ! !***LIBRARY SLATEC (PCHIP) !***CATEGORY E1A !***TYPE SINGLE PRECISION (PCHSP-S, DPCHSP-D) !***KEYWORDS CUBIC HERMITE INTERPOLATION, PCHIP, ! PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION !***AUTHOR Fritsch, F. N., (LLNL) ! Lawrence Livermore National Laboratory ! P.O. Box 808 (L-316) ! Livermore, CA 94550 ! FTS 532-4275, (510) 422-4275 !***DESCRIPTION ! ! PCHSP: Piecewise Cubic Hermite Spline ! ! Computes the Hermite representation of the cubic spline inter- ! polant to the data given in X and F satisfying the boundary ! conditions specified by IC and VC. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the F- and D arrays. ! ! The resulting piecewise cubic Hermite function may be evaluated ! by PCHFE or PCHFD. ! ! NOTE: This is a modified version of C. de Boor's cubic spline ! routine CUBSPL. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! PARAMETER (INCFD = ...) ! INTEGER IC(2), N, NWK, IERR ! REAL VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK) ! ! call PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) ! ! Parameters: ! ! IC -- (input) integer array of length 2 specifying desired ! boundary conditions: ! IC(1) = IBEG, desired condition at beginning of data. ! IC(2) = IEND, desired condition at end of data. ! ! IBEG = 0 to set D(1) so that the third derivative is con- ! tinuous at X(2). This is the "not a knot" condition ! provided by de Boor's cubic spline routine CUBSPL. ! < This is the default boundary condition. > ! IBEG = 1 if first derivative at X(1) is given in VC(1). ! IBEG = 2 if second derivative at X(1) is given in VC(1). ! IBEG = 3 to use the 3-point difference formula for D(1). ! (Reverts to the default b.c. if N < 3 .) ! IBEG = 4 to use the 4-point difference formula for D(1). ! (Reverts to the default b.c. if N < 4 .) ! NOTES: ! 1. An error return is taken if IBEG is out of range. ! 2. For the "natural" boundary condition, use IBEG=2 and ! VC(1)=0. ! ! IEND may take on the same values as IBEG, but applied to ! derivative at X(N). In case IEND = 1 or 2, the value is ! given in VC(2). ! ! NOTES: ! 1. An error return is taken if IEND is out of range. ! 2. For the "natural" boundary condition, use IEND=2 and ! VC(2)=0. ! ! VC -- (input) real array of length 2 specifying desired boundary ! values, as indicated above. ! VC(1) need be set only if IC(1) = 1 or 2 . ! VC(2) need be set only if IC(2) = 1 or 2 . ! ! N -- (input) number of data points. (Error return if N < 2 .) ! ! X -- (input) real array of independent variable values. The ! elements of X must be strictly increasing: ! X(I-1) < X(I), I = 2(1)N. ! (Error return if not.) ! ! F -- (input) real array of dependent variable values to be inter- ! polated. F(1+(I-1)*INCFD) is value corresponding to X(I). ! ! D -- (output) real array of derivative values at the data points. ! These values will determine the cubic spline interpolant ! with the requested boundary conditions. ! The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD), I=1(1)N. ! No other entries in D are changed. ! ! INCFD -- (input) increment between successive values in F and D. ! This argument is provided primarily for 2-D applications. ! (Error return if INCFD < 1 .) ! ! WK -- (scratch) real array of working storage. ! ! NWK -- (input) length of work array. ! (Error return if NWK < 2*N .) ! ! IERR -- (output) error flag. ! Normal return: ! IERR = 0 (no errors). ! "Recoverable" errors: ! IERR = -1 if N < 2 . ! IERR = -2 if INCFD < 1 . ! IERR = -3 if the X-array is not strictly increasing. ! IERR = -4 if IBEG < 0 or IBEG > 4 . ! IERR = -5 if IEND < 0 of IEND > 4 . ! IERR = -6 if both of the above are true. ! IERR = -7 if NWK is too small. ! NOTE: The above errors are checked in the order listed, ! and following arguments have **NOT** been validated. ! (The D array has not been changed in any of these cases.) ! IERR = -8 in case of trouble solving the linear system ! for the interior derivative values. ! (The D array may have been changed in this case.) ! ( Do **NOT** use it! ) ! !***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- ! Verlag, New York, 1978, pp. 53-59. !***ROUTINES CALLED PCHDF, XERMSG !***REVISION HISTORY (YYMMDD) ! 820503 DATE WRITTEN ! 820804 Converted to SLATEC library version. ! 870707 Minor cosmetic changes to prologue. ! 890411 Added SAVE statements (Vers. 3.2). ! 890703 Corrected category record. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920429 Revised format and order of references. (WRB,FNF) !***END PROLOGUE PCHSP ! Programming notes: ! ! To produce a double precision version, simply: ! a. Change PCHSP to DPCHSP wherever it occurs, ! b. Change the real declarations to double precision, and ! c. Change the constants ZERO, HALF, ... to double precision. ! ! DECLARE ARGUMENTS. ! INTEGER IC(2), N, INCFD, NWK, IERR REAL VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*) ! ! DECLARE LOCAL VARIABLES. ! INTEGER IBEG, IEND, INDEX, J, NM1 REAL G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), ZERO SAVE ZERO, HALF, ONE, TWO, THREE REAL PCHDF ! DATA ZERO /0./, HALF /0.5/, ONE /1./, TWO /2./, THREE /3./ ! ! VALIDITY-CHECK ARGUMENTS. ! !***FIRST EXECUTABLE STATEMENT PCHSP if ( N < 2 ) go to 5001 if ( INCFD < 1 ) go to 5002 DO 1 J = 2, N if ( X(J) <= X(J-1) ) go to 5003 1 CONTINUE ! IBEG = IC(1) IEND = IC(2) IERR = 0 if ( (IBEG < 0).OR.(IBEG > 4) ) IERR = IERR - 1 if ( (IEND < 0).OR.(IEND > 4) ) IERR = IERR - 2 if ( IERR < 0 ) go to 5004 ! ! FUNCTION DEFINITION IS OK -- GO ON. ! if ( NWK < 2*N ) go to 5007 ! ! COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO, ! COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.). DO 5 J=2,N WK(1,J) = X(J) - X(J-1) WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J) 5 CONTINUE ! ! SET TO DEFAULT BOUNDARY CONDITIONS if N IS TOO SMALL. ! if ( IBEG > N ) IBEG = 0 if ( IEND > N ) IEND = 0 ! ! SET UP FOR BOUNDARY CONDITIONS. ! if ( (IBEG == 1).OR.(IBEG == 2) ) THEN D(1,1) = VC(1) ELSE if (IBEG > 2) THEN ! PICK UP FIRST IBEG POINTS, IN REVERSE ORDER. DO 10 J = 1, IBEG INDEX = IBEG-J+1 ! INDEX RUNS FROM IBEG DOWN TO 1. XTEMP(J) = X(INDEX) if (J < IBEG) STEMP(J) = WK(2,INDEX) 10 CONTINUE ! -------------------------------- D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR) ! -------------------------------- if (IERR /= 0) go to 5009 IBEG = 1 end if ! if ( (IEND == 1).OR.(IEND == 2) ) THEN D(1,N) = VC(2) ELSE if (IEND > 2) THEN ! PICK UP LAST IEND POINTS. DO 15 J = 1, IEND INDEX = N-IEND+J ! INDEX RUNS FROM N+1-IEND UP TO N. XTEMP(J) = X(INDEX) if (J < IEND) STEMP(J) = WK(2,INDEX+1) 15 CONTINUE ! -------------------------------- D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR) ! -------------------------------- if (IERR /= 0) go to 5009 IEND = 1 end if ! ! --------------------( BEGIN CODING FROM CUBSPL )-------------------- ! ! **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF ! F AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM- ! INATION, WITH S(J) ENDING UP IN D(1,J), ALL J. ! WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE. ! ! CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM ! WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1) ! if (IBEG == 0) THEN if (N == 2) THEN ! NO CONDITION AT LEFT END AND N = 2. WK(2,1) = ONE WK(1,1) = ONE D(1,1) = TWO*WK(2,2) ELSE ! NOT-A-KNOT CONDITION AT LEFT END AND N > 2. WK(2,1) = WK(1,3) WK(1,1) = WK(1,2) + WK(1,3) D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3) & + WK(1,2)**2*WK(2,3)) / WK(1,1) ENDIF ELSE if (IBEG == 1) THEN ! SLOPE PRESCRIBED AT LEFT END. WK(2,1) = ONE WK(1,1) = ZERO ELSE ! SECOND DERIVATIVE PRESCRIBED AT LEFT END. WK(2,1) = TWO WK(1,1) = ONE D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1) end if ! ! if THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND ! CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH ! EQUATION READS WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J). ! NM1 = N-1 if (NM1 > 1) THEN DO 20 J=2,NM1 if (WK(2,J-1) == ZERO) go to 5008 G = -WK(1,J+1)/WK(2,J-1) D(1,J) = G*D(1,J-1) & + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J)) WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1)) 20 CONTINUE end if ! ! CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM ! (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N) ! ! if SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK- ! SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT ! AT THIS POINT. if (IEND == 1) go to 30 ! if (IEND == 0) THEN if (N == 2 .AND. IBEG == 0) THEN ! NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2. D(1,2) = WK(2,2) go to 30 ELSE if ((N == 2) .OR. (N == 3 .AND. IBEG == 0)) THEN ! EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT* ! NOT-A-KNOT AT LEFT END POINT). D(1,N) = TWO*WK(2,N) WK(2,N) = ONE if (WK(2,N-1) == ZERO) go to 5008 G = -ONE/WK(2,N-1) ELSE ! NOT-A-KNOT AND N >= 3, AND EITHER N > 3 OR ALSO NOT-A- ! KNOT AT LEFT END POINT. G = WK(1,N-1) + WK(1,N) ! DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES). D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1) & + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G if (WK(2,N-1) == ZERO) go to 5008 G = -G/WK(2,N-1) WK(2,N) = WK(1,N-1) ENDIF ELSE ! SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT. D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N) WK(2,N) = TWO if (WK(2,N-1) == ZERO) go to 5008 G = -ONE/WK(2,N-1) end if ! ! COMPLETE FORWARD PASS OF GAUSS ELIMINATION. ! WK(2,N) = G*WK(1,N-1) + WK(2,N) if (WK(2,N) == ZERO) go to 5008 D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N) ! ! CARRY OUT BACK SUBSTITUTION ! 30 CONTINUE DO 40 J=NM1,1,-1 if (WK(2,J) == ZERO) go to 5008 D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J) 40 CONTINUE ! --------------------( END CODING FROM CUBSPL )-------------------- ! ! NORMAL RETURN. ! return ! ! ERROR RETURNS. ! 5001 CONTINUE ! N < 2 RETURN. IERR = -1 call XERMSG ('SLATEC', 'PCHSP', & 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) return ! 5002 CONTINUE ! INCFD < 1 RETURN. IERR = -2 call XERMSG ('SLATEC', 'PCHSP', 'INCREMENT LESS THAN ONE', IERR, & 1) return ! 5003 CONTINUE ! X-ARRAY NOT STRICTLY INCREASING. IERR = -3 call XERMSG ('SLATEC', 'PCHSP', 'X-ARRAY NOT STRICTLY INCREASING' & , IERR, 1) return ! 5004 CONTINUE ! IC OUT OF RANGE RETURN. IERR = IERR - 3 call XERMSG ('SLATEC', 'PCHSP', 'IC OUT OF RANGE', IERR, 1) return ! 5007 CONTINUE ! NWK TOO SMALL RETURN. IERR = -7 call XERMSG ('SLATEC', 'PCHSP', 'WORK ARRAY TOO SMALL', IERR, 1) return ! 5008 CONTINUE ! SINGULAR SYSTEM. ! *** THEORETICALLY, THIS CAN ONLY OCCUR if SUCCESSIVE X-VALUES *** ! *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). *** IERR = -8 call XERMSG ('SLATEC', 'PCHSP', 'SINGULAR LINEAR SYSTEM', IERR, & 1) return ! 5009 CONTINUE ! ERROR RETURN FROM PCHDF. ! *** THIS CASE SHOULD NEVER OCCUR *** IERR = -9 call XERMSG ('SLATEC', 'PCHSP', 'ERROR RETURN FROM PCHDF', IERR, & 1) return end FUNCTION PCHST (ARG1, ARG2) ! !! PCHST is the PCHIP Sign-Testing Routine ! !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHST-S, DPCHST-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHST: PCHIP Sign-Testing Routine. ! ! Returns: ! -1. if ARG1 and ARG2 are of opposite sign. ! 0. if either argument is zero. ! +1. if ARG1 and ARG2 are of the same sign. ! ! The object is to do this without multiplying ARG1*ARG2, to avoid ! possible over/underflow problems. ! ! Fortran intrinsics used: SIGN. ! !***SEE ALSO PCHCE, PCHCI, PCHCS, PCHIM !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811103 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 870813 Minor cosmetic changes. ! 890411 Added SAVE statements (Vers. 3.2). ! 890411 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) ! 930503 Improved purpose. (FNF) !***END PROLOGUE PCHST ! !**End ! ! DECLARE ARGUMENTS. ! REAL PCHST REAL ARG1, ARG2 ! ! DECLARE LOCAL VARIABLES. ! REAL ONE, ZERO SAVE ZERO, ONE DATA ZERO /0./, ONE /1./ ! ! PERFORM THE TEST. ! !***FIRST EXECUTABLE STATEMENT PCHST PCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) if ((ARG1 == ZERO) .OR. (ARG2 == ZERO)) PCHST = ZERO ! return !------------- LAST LINE OF PCHST FOLLOWS ------------------------------ end subroutine PCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) ! !! PCHSW limits excursion from data for PCHCS. ! !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHSW-S, DPCHSW-D) !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHSW: PCHCS Switch Excursion Limiter. ! ! Called by PCHCS to adjust D1 and D2 if necessary to insure that ! the extremum on this interval is not further than DFMAX from the ! extreme data value. ! ! ---------------------------------------------------------------------- ! ! Calling sequence: ! ! INTEGER IEXTRM, IERR ! REAL DFMAX, D1, D2, H, SLOPE ! ! call PCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) ! ! Parameters: ! ! DFMAX -- (input) maximum allowed difference between F(IEXTRM) and ! the cubic determined by derivative values D1,D2. (assumes ! DFMAX > 0.) ! ! IEXTRM -- (input) index of the extreme data value. (assumes ! IEXTRM = 1 or 2 . Any value /= 1 is treated as 2.) ! ! D1,D2 -- (input) derivative values at the ends of the interval. ! (Assumes D1*D2 <= 0.) ! (output) may be modified if necessary to meet the restriction ! imposed by DFMAX. ! ! H -- (input) interval length. (Assumes H > 0.) ! ! SLOPE -- (input) data slope on the interval. ! ! IERR -- (output) error flag. should be zero. ! If IERR=-1, assumption on D1 and D2 is not satisfied. ! If IERR=-2, quadratic equation locating extremum has ! negative discriminant (should never occur). ! ! ------- ! WARNING: This routine does no validity-checking of arguments. ! ------- ! ! Fortran intrinsics used: ABS, SIGN, SQRT. ! !***SEE ALSO PCHCS !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 820218 DATE WRITTEN ! 820805 Converted to SLATEC library version. ! 870707 Replaced DATA statement for SMALL with a use of R1MACH. ! 890411 1. Added SAVE statements (Vers. 3.2). ! 2. Added REAL R1MACH for consistency with D.P. version. ! 890411 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) ! 920526 Eliminated possible divide by zero problem. (FNF) ! 930503 Improved purpose. (FNF) !***END PROLOGUE PCHSW ! !**End ! ! DECLARE ARGUMENTS. ! INTEGER IEXTRM, IERR REAL DFMAX, D1, D2, H, SLOPE ! ! DECLARE LOCAL VARIABLES. ! REAL CP, FACT, HPHI, LAMBDA, NU, ONE, PHI, RADCAL, RHO, SIGMA, & SMALL, THAT, THIRD, THREE, TWO, ZERO SAVE ZERO, ONE, TWO, THREE, FACT SAVE THIRD REAL R1MACH ! DATA ZERO /0./, ONE /1./, TWO /2./, THREE /3./, FACT /100./ ! THIRD SHOULD BE SLIGHTLY LESS THAN 1/3. DATA THIRD /0.33333/ ! ! NOTATION AND GENERAL REMARKS. ! ! RHO IS THE RATIO OF THE DATA SLOPE TO THE DERIVATIVE BEING TESTED. ! LAMBDA IS THE RATIO OF D2 TO D1. ! THAT = T-HAT(RHO) IS THE NORMALIZED LOCATION OF THE EXTREMUM. ! PHI IS THE NORMALIZED VALUE OF P(X)-F1 AT X = XHAT = X-HAT(RHO), ! WHERE THAT = (XHAT - X1)/H . ! THAT IS, P(XHAT)-F1 = D*H*PHI, WHERE D=D1 OR D2. ! SIMILARLY, P(XHAT)-F2 = D*H*(PHI-RHO) . ! ! SMALL SHOULD BE A FEW ORDERS OF MAGNITUDE GREATER THAN MACHEPS. !***FIRST EXECUTABLE STATEMENT PCHSW SMALL = FACT*R1MACH(4) ! ! DO MAIN CALCULATION. ! if (D1 == ZERO) THEN ! ! SPECIAL CASE -- D1 == ZERO . ! ! if D2 IS ALSO ZERO, THIS ROUTINE SHOULD NOT HAVE BEEN CALLED. if (D2 == ZERO) go to 5001 ! RHO = SLOPE/D2 ! EXTREMUM IS OUTSIDE INTERVAL WHEN RHO >= 1/3 . if (RHO >= THIRD) go to 5000 THAT = (TWO*(THREE*RHO-ONE)) / (THREE*(TWO*RHO-ONE)) PHI = THAT**2 * ((THREE*RHO-ONE)/THREE) ! ! CONVERT TO DISTANCE FROM F2 if IEXTRM /= 1 . if (IEXTRM /= 1) PHI = PHI - RHO ! ! TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. HPHI = H * ABS(PHI) if (HPHI*ABS(D2) > DFMAX) THEN ! AT THIS POINT, HPHI > 0, SO DIVIDE IS OK. D2 = SIGN (DFMAX/HPHI, D2) ENDIF ELSE ! RHO = SLOPE/D1 LAMBDA = -D2/D1 if (D2 == ZERO) THEN ! ! SPECIAL CASE -- D2 == ZERO . ! ! EXTREMUM IS OUTSIDE INTERVAL WHEN RHO >= 1/3 . if (RHO >= THIRD) go to 5000 CP = TWO - THREE*RHO NU = ONE - TWO*RHO THAT = ONE / (THREE*NU) ELSE if (LAMBDA <= ZERO) go to 5001 ! ! NORMAL CASE -- D1 AND D2 BOTH NONZERO, OPPOSITE SIGNS. ! NU = ONE - LAMBDA - TWO*RHO SIGMA = ONE - RHO CP = NU + SIGMA if (ABS(NU) > SMALL) THEN RADCAL = (NU - (TWO*RHO+ONE))*NU + SIGMA**2 if (RADCAL < ZERO) go to 5002 THAT = (CP - SQRT(RADCAL)) / (THREE*NU) ELSE THAT = ONE/(TWO*SIGMA) ENDIF ENDIF PHI = THAT*((NU*THAT - CP)*THAT + ONE) ! ! CONVERT TO DISTANCE FROM F2 if IEXTRM /= 1 . if (IEXTRM /= 1) PHI = PHI - RHO ! ! TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. HPHI = H * ABS(PHI) if (HPHI*ABS(D1) > DFMAX) THEN ! AT THIS POINT, HPHI > 0, SO DIVIDE IS OK. D1 = SIGN (DFMAX/HPHI, D1) D2 = -LAMBDA*D1 ENDIF end if ! ! NORMAL RETURN. ! 5000 CONTINUE IERR = 0 return ! ! ERROR RETURNS. ! 5001 CONTINUE ! D1 AND D2 BOTH ZERO, OR BOTH NONZERO AND SAME SIGN. IERR = -1 call XERMSG ('SLATEC', 'PCHSW', 'D1 AND/OR D2 INVALID', IERR, 1) return ! 5002 CONTINUE ! NEGATIVE VALUE OF RADICAL (SHOULD NEVER OCCUR). IERR = -2 call XERMSG ('SLATEC', 'PCHSW', 'NEGATIVE RADICAL', IERR, 1) return !------------- LAST LINE OF PCHSW FOLLOWS ------------------------------ end subroutine PCOEF (L, C, TC, A) ! !! PCOEF converts the POLFIT coefficients to Taylor series form. ! !***LIBRARY SLATEC !***CATEGORY K1A1A2 !***TYPE SINGLE PRECISION (PCOEF-S, DPCOEF-D) !***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT !***AUTHOR Shampine, L. F., (SNLA) ! Davenport, S. M., (SNLA) !***DESCRIPTION ! ! Written BY L. F. Shampine and S. M. Davenport. ! ! Abstract ! ! POLFIT computes the least squares polynomial fit of degree L as ! a sum of orthogonal polynomials. PCOEF changes this fit to its ! Taylor expansion about any point C , i.e. writes the polynomial ! as a sum of powers of (X-C). Taking C=0. gives the polynomial ! in powers of X, but a suitable non-zero C often leads to ! polynomials which are better scaled and more accurately evaluated. ! ! The parameters for PCOEF are ! ! INPUT -- ! L - Indicates the degree of polynomial to be changed to ! its Taylor expansion. To obtain the Taylor ! coefficients in reverse order, input L as the ! negative of the degree desired. The absolute value ! of L must be less than or equal to NDEG, the highest ! degree polynomial fitted by POLFIT . ! C - The point about which the Taylor expansion is to be ! made. ! A - Work and output array containing values from last ! call to POLFIT . ! ! OUTPUT -- ! TC - Vector containing the first LL+1 Taylor coefficients ! where LL=ABS(L). If L > 0 , the coefficients are ! in the usual Taylor series order, i.e. ! P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N ! If L < 0, the coefficients are in reverse order, ! i.e. ! P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) ! !***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, ! Curve fitting by polynomials in one variable, Report ! SLA-74-0270, Sandia Laboratories, June 1974. !***ROUTINES CALLED PVALUE !***REVISION HISTORY (YYMMDD) ! 740601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE PCOEF ! DIMENSION A(*), TC(*) !***FIRST EXECUTABLE STATEMENT PCOEF LL = ABS(L) LLP1 = LL + 1 call PVALUE (LL,LL,C,TC(1),TC(2),A) if (LL < 2) go to 2 FAC = 1.0 DO 1 I = 3,LLP1 FAC = FAC*(I-1) 1 TC(I) = TC(I)/FAC 2 if (L >= 0) go to 4 NR = LLP1/2 LLP2 = LL + 2 DO 3 I = 1,NR SAVE = TC(I) NEW = LLP2 - I TC(I) = TC(NEW) 3 TC(NEW) = SAVE 4 return end subroutine PFQAD (F, LDC, C, XI, LXI, K, ID, X1, X2, TOL, QUAD, & IERR) ! !! PFQAD computes the integral on (X1,X2) of a product of a function F and ... ! the ID-th derivative of a B-spline, (PP-representation). ! !***LIBRARY SLATEC !***CATEGORY H2A2A1, E3, K6 !***TYPE SINGLE PRECISION (PFQAD-S, DPFQAD-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! PFQAD computes the integral on (X1,X2) of a product of a ! function F and the ID-th derivative of a B-spline, using the ! PP-representation (C,XI,LXI,K). (X1,X2) is normally a sub- ! interval of XI(1) <= X <= XI(LXI+1). An integration rou- ! tine, PPGQ8(a modification of GAUS8), integrates the product ! on sub-intervals of (X1,X2) formed by the included break ! points. Integration outside of (XI(1),XI(LXI+1)) is permitted ! provided F is defined. ! ! Description of Arguments ! Input ! F - external function of one argument for the ! integrand PF(X)=F(X)*PPVAL(LDC,C,XI,LXI,K,ID,X, ! INPPV) ! LDC - leading dimension of matrix C, LDC >= K ! C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI ! XI(*) - break point array of length LXI+1 ! LXI - number of polynomial pieces ! K - order of B-spline, K >= 1 ! ID - order of the spline derivative, 0 <= ID <= K-1 ! ID=0 gives the spline function ! X1,X2 - end points of quadrature interval, normally in ! XI(1) <= X <= XI(LXI+1) ! TOL - desired accuracy for the quadrature, suggest ! 10.*STOL < TOL <= 0.1 where STOL is the single ! precision unit roundoff for the machine = R1MACH(4) ! ! Output ! QUAD - integral of PF(X) on (X1,X2) ! IERR - a status code ! IERR=1 normal return ! 2 some quadrature does not meet the ! requested tolerance ! ! Error Conditions ! TOL not greater than the single precision unit roundoff or ! less than 0.1 is a fatal error. ! Some quadrature does not meet the requested tolerance. ! !***REFERENCES D. E. Amos, Quadrature subroutines for splines and ! B-splines, Report SAND79-1825, Sandia Laboratories, ! December 1979. !***ROUTINES CALLED INTRV, PPGQ8, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE PFQAD ! INTEGER ID,IERR,IFLG,ILO,IL1,IL2,INPPV,K,LDC,LEFT,LXI,MF1,MF2 REAL A, AA, ANS, B, BB, C, Q, QUAD, TA, TB, TOL, WTOL, XI, X1, X2 REAL R1MACH, F DIMENSION XI(*), C(LDC,*) EXTERNAL F ! !***FIRST EXECUTABLE STATEMENT PFQAD IERR = 1 QUAD = 0.0E0 if ( K < 1) go to 100 if ( LDC < K) go to 105 if ( ID < 0 .OR. ID >= K) go to 110 if ( LXI < 1) go to 115 WTOL = R1MACH(4) if (TOL < WTOL .OR. TOL > 0.1E0) go to 20 AA = MIN(X1,X2) BB = MAX(X1,X2) if (AA == BB) RETURN ILO = 1 call INTRV(XI, LXI, AA, ILO, IL1, MF1) call INTRV(XI, LXI, BB, ILO, IL2, MF2) Q = 0.0E0 INPPV = 1 DO 10 LEFT=IL1,IL2 TA = XI(LEFT) A = MAX(AA,TA) if (LEFT == 1) A = AA TB = BB if (LEFT < LXI) TB = XI(LEFT+1) B = MIN(BB,TB) call PPGQ8(F,LDC,C,XI,LXI,K,ID,A,B,INPPV,TOL,ANS,IFLG) if (IFLG > 1) IERR = 2 Q = Q + ANS 10 CONTINUE if (X1 > X2) Q = -Q QUAD = Q return ! 20 CONTINUE call XERMSG ('SLATEC', 'PFQAD', & 'TOL IS LESS THAN THE SINGLE PRECISION TOLERANCE OR ' // & 'GREATER THAN 0.1', 2, 1) return 100 CONTINUE call XERMSG ('SLATEC', 'PFQAD', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'PFQAD', 'LDC DOES NOT SATISFY LDC >= K', & 2, 1) return 110 CONTINUE call XERMSG ('SLATEC', 'PFQAD', & 'ID DOES NOT SATISFY 0 <= ID < K', 2, 1) return 115 CONTINUE call XERMSG ('SLATEC', 'PFQAD', 'LXI DOES NOT SATISFY LXI >= 1', & 2, 1) return end function PGSF (X, IZ, C, A, BH) ! !! PGSF is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PGSF-S) !***AUTHOR (UNKNOWN) !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PGSF DIMENSION A(*) ,C(*) ,BH(*) !***FIRST EXECUTABLE STATEMENT PGSF FSG = 1. HSG = 1. DO 101 J=1,IZ DD = 1./(X-BH(J)) FSG = FSG*A(J)*DD HSG = HSG*C(J)*DD 101 CONTINUE if (MOD(IZ,2)) 103,102,103 102 PGSF = 1.-FSG-HSG return 103 PGSF = 1.+FSG+HSG return end function PIMACH (DUM) ! !! PIMACH supplies the value of PI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PIMACH-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subprogram supplies the value of the constant PI correct to ! machine precision where ! ! PI=3.1415926535897932384626433832795028841971693993751058209749446 ! !***SEE ALSO HSTCSP, HSTSSP, HWSCSP !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PIMACH ! !***FIRST EXECUTABLE STATEMENT PIMACH PIMACH = 3.14159265358979 return end subroutine PINITM (M, N, SX, IX, LMX, IPAGEF) ! !! PINITM is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PINITM-S, DPINTM-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! PINITM LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. ! THE MATRIX IS STORED BY COLUMNS. ! SPARSE MATRIX INITIALIZATION SUBROUTINE. ! ! M=NUMBER OF ROWS OF THE MATRIX. ! N=NUMBER OF COLUMNS OF THE MATRIX. ! SX(*),IX(*)=THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE ! MATRIX. THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY ! THE PACKAGE FOR THE USER. ! LMX=LENGTH OF THE WORK ARRAY SX(*). ! LMX MUST BE AT LEAST N+7 WHERE ! FOR GREATEST EFFICIENCY LMX SHOULD BE AT LEAST N+NZ+6 ! WHERE NZ IS THE MAXIMUM NUMBER OF NONZEROES TO BE ! STORED IN THE MATRIX. VALUES OF LMX BETWEEN N+7 AND ! N+NZ+6 WILL CAUSE DEMAND PAGING TO OCCUR. ! THIS IS IMPLEMENTED BY THE PACKAGE. ! IX(*) MUST BE DIMENSIONED AT LEAST LMX ! IPAGEF=UNIT NUMBER WHERE DEMAND PAGES WILL BE STORED. ! ! THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LINITM, ! SANDIA LABS. REPT. SAND78-0785. ! MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON ! REVISED 811130-1000 ! REVISED YYMMDD-HHMM ! !***SEE ALSO SPLP !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) !***END PROLOGUE PINITM REAL SX(LMX),ZERO,ONE DIMENSION IX(*) SAVE ZERO, ONE DATA ZERO,ONE /0.E0,1.E0/ !***FIRST EXECUTABLE STATEMENT PINITM IOPT=1 ! ! CHECK FOR INPUT ERRORS. ! if (.NOT.(M <= 0 .OR. N <= 0)) go to 20002 NERR=55 call XERMSG ('SLATEC', 'PINITM', & 'MATRIX DIMENSION M OR N <= 0.', NERR, IOPT) ! ! VERIFY if VALUE OF LMX IS LARGE ENOUGH. ! 20002 if (.NOT.(LMX < N+7)) go to 20005 NERR=55 call XERMSG ('SLATEC', 'PINITM', & 'THE VALUE OF LMX IS TOO SMALL.', NERR, IOPT) ! ! INITIALIZE DATA STRUCTURE INDEPENDENT VALUES. ! 20005 SX(1)=ZERO SX(2)=ZERO SX(3)=IPAGEF IX(1)=LMX IX(2)=M IX(3)=N IX(4)=0 SX(LMX-1)=ZERO SX(LMX)=-ONE IX(LMX-1)=-1 LP4=N+4 ! ! INITIALIZE DATA STRUCTURE DEPENDENT VALUES. ! I=4 N20008=LP4 go to 20009 20008 I=I+1 20009 if ((N20008-I) < 0) go to 20010 SX(I)=ZERO go to 20008 20010 I=5 N20012=LP4 go to 20013 20012 I=I+1 20013 if ((N20012-I) < 0) go to 20014 IX(I)=LP4 go to 20012 20014 SX(N+5)=ZERO IX(N+5)=0 IX(LMX)=0 ! ! INITIALIZATION COMPLETE. ! return end subroutine PJAC (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, F, & JAC, RPAR, IPAR) ! !! PJAC is subsidiary to DEBDF. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PJAC-S, DPJAC-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! PJAC sets up the iteration matrix (involving the Jacobian) for the ! integration package DEBDF. ! !***SEE ALSO DEBDF !***ROUTINES CALLED SGBFA, SGEFA, VNWRMS !***COMMON BLOCKS DEBDF1 !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920422 Changed DIMENSION statement. (WRB) !***END PROLOGUE PJAC ! !LLL. OPTIMIZE INTEGER NEQ, NYH, IWM, I, I1, I2, IER, II, IOWND, IOWNS, J, J1, & JJ, JSTART, KFLAG, L, LENP, MAXORD, MBA, MBAND, MEB1, MEBAND, & METH, MITER, ML, ML3, MU, N, NFE, NJE, NQ, NQU, NST EXTERNAL F, JAC REAL Y, YH, EWT, FTEM, SAVF, WM, & ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND, & CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, VNWRMS DIMENSION Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), & WM(*), IWM(*), RPAR(*), IPAR(*) COMMON /DEBDF1/ ROWND, ROWNS(210), & EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6), & IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, & NJE, NQU !----------------------------------------------------------------------- ! PJAC IS CALLED BY STOD TO COMPUTE AND PROCESS THE MATRIX ! P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. ! HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE JAC IF ! MITER = 1 OR 4, OR BY FINITE DIFFERENCING if MITER = 2, 3, OR 5. ! if MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. ! J IS STORED IN WM AND REPLACED BY P. if MITER /= 3, P IS THEN ! SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION ! OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE ! BY SGEFA if MITER = 1 OR 2, AND BY SGBFA IF MITER = 4 OR 5. ! ! IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION ! WITH PJAC USES THE FOLLOWING.. ! Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. ! FTEM = WORK ARRAY OF LENGTH N (ACOR IN STOD ). ! SAVF = ARRAY CONTAINING F EVALUATED AT PREDICTED Y. ! WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE ! INVERSE DIAGONAL MATRIX if MITER = 3 AND THE LU DECOMPOSITION ! OF P if MITER IS 1, 2 , 4, OR 5. ! STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). ! WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. ! WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN INCREMENTS. ! WM(2) = H*EL0, SAVED FOR LATER USE if MITER = 3. ! IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT ! IWM(21), if MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS THE ! BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) if MITER IS 4 OR 5. ! EL0 = EL(1) (INPUT). ! IER = OUTPUT ERROR FLAG, = 0 if NO TROUBLE, /= 0 IF ! P MATRIX FOUND TO BE SINGULAR. ! THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, ! MITER, N, NFE, AND NJE. !----------------------------------------------------------------------- !***FIRST EXECUTABLE STATEMENT PJAC NJE = NJE + 1 HL0 = H*EL0 go to (100, 200, 300, 400, 500), MITER ! 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 ! if MITER = 2, MAKE N CALLS TO F TO APPROXIMATE J. -------------------- 200 FAC = VNWRMS (N, SAVF, EWT) R0 = 1000.0E0*ABS(H)*UROUND*N*FAC if (R0 == 0.0E0) R0 = 1.0E0 SRUR = WM(1) J1 = 2 DO 230 J = 1,N YJ = Y(J) R = MAX(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 ! ADD IDENTITY MATRIX. ------------------------------------------------- 240 J = 3 DO 250 I = 1,N WM(J) = WM(J) + 1.0E0 250 J = J + (N + 1) ! DO LU DECOMPOSITION ON P. -------------------------------------------- call SGEFA (WM(3), N, N, IWM(21), IER) return ! 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) < UROUND*EWT(I)) go to 320 if (ABS(DI) == 0.0E0) go to 330 WM(I+2) = 0.1E0*R0/DI 320 CONTINUE return 330 IER = -1 return ! 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 ! if MITER = 5, MAKE MBAND CALLS TO F TO APPROXIMATE J. ---------------- 500 ML = IWM(1) MU = IWM(2) MBAND = ML + MU + 1 MBA = MIN(MBAND,N) MEBAND = MBAND + ML MEB1 = MEBAND - 1 SRUR = WM(1) FAC = VNWRMS (N, SAVF, EWT) R0 = 1000.0E0*ABS(H)*UROUND*N*FAC if (R0 == 0.0E0) R0 = 1.0E0 DO 560 J = 1,MBA DO 530 I = J,N,MBAND YI = Y(I) R = MAX(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 = MAX(SRUR*ABS(YJJ),R0*EWT(JJ)) FAC = -HL0/R I1 = MAX(JJ-MU,1) I2 = MIN(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 ! ADD IDENTITY MATRIX. ------------------------------------------------- 570 II = MBAND + 2 DO 580 I = 1,N WM(II) = WM(II) + 1.0E0 580 II = II + MEBAND ! DO LU DECOMPOSITION OF P. -------------------------------------------- call SGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) return !----------------------- END OF SUBROUTINE PJAC ----------------------- end subroutine PNNZRS (I, XVAL, IPLACE, SX, IX, IRCX) ! !! PNNZRS is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PNNZRS-S, DPNNZR-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! PNNZRS LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. ! SPARSE MATRIX NON ZERO RETRIEVAL SUBROUTINE. ! ! SUBROUTINE PNNZRS() GETS THE NEXT NONZERO VALUE IN ROW OR COLUMN ! +/- IRCX WITH AN INDEX GREATER THAN THE VALUE OF I. ! ! I ABSOLUTE VALUE OF THIS SUBSCRIPT IS TO BE EXCEEDED ! IN THE SEARCH FOR THE NEXT NONZERO VALUE. A NEGATIVE ! OR ZERO VALUE OF I CAUSES THE SEARCH TO START AT ! THE BEGINNING OF THE VECTOR. A POSITIVE VALUE ! OF I CAUSES THE SEARCH TO CONTINUE FROM THE LAST PLACE ! ACCESSED. ON OUTPUT, THE ARGUMENT I ! CONTAINS THE VALUE OF THE SUBSCRIPT FOUND. AN OUTPUT ! VALUE OF I EQUAL TO ZERO INDICATES THAT ALL COMPONENTS ! WITH AN INDEX GREATER THAN THE INPUT VALUE OF I ARE ! ZERO. ! XVAL VALUE OF THE NONZERO ELEMENT FOUND. ON OUTPUT, ! XVAL=0. WHENEVER I=0. ! IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE. ! SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE ! MATRIX. THESE ARRAY CONTENTS ARE AUTOMATICALLY ! MAINTAINED BY THE PACKAGE FOR THE USER. ! IRCX POINTS TO THE VECTOR OF THE MATRIX BEING SCANNED. A ! NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS TO BE ! SCANNED. A POSITIVE VALUE OF IRCX INDICATES THAT ! COLUMN IRCX IS TO BE SCANNED. A ZERO VALUE OF IRCX IS ! AN ERROR. ! ! THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LNNZRS, ! SANDIA LABS. REPT. SAND78-0785. ! MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON ! REVISED 811130-1000 ! REVISED YYMMDD-HHMM ! !***SEE ALSO SPLP !***ROUTINES CALLED IPLOC, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) !***END PROLOGUE PNNZRS DIMENSION IX(*) REAL XVAL,SX(*),ZERO SAVE ZERO DATA ZERO /0.E0/ !***FIRST EXECUTABLE STATEMENT PNNZRS IOPT=1 ! ! CHECK VALIDITY OF ROW/COL. INDEX. ! if (.NOT.(IRCX == 0)) go to 20002 NERR=55 call XERMSG ('SLATEC', 'PNNZRS', 'IRCX=0.', NERR, IOPT) ! ! LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA. ! 20002 LMX = IX(1) if (.NOT.(IRCX < 0)) go to 20005 ! ! CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE <= M AND ! THE INDEX MUST BE <= N. ! if (.NOT.(IX(2) < -IRCX .OR. IX(3) < ABS(I))) go to 20008 NERR=55 call XERMSG ('SLATEC', 'PNNZRS', & 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // & 'BOUNDS.', NERR, IOPT) 20008 L=IX(3) go to 20006 ! ! CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE <= N AND ! THE INDEX MUST BE <= M. ! 20005 if (.NOT.(IRCX > IX(3) .OR. ABS(I) > IX(2))) go to 20011 NERR=55 call XERMSG ('SLATEC', 'PNNZRS', & 'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' // & 'BOUNDS.', NERR, IOPT) 20011 L=IX(2) ! ! HERE L IS THE LARGEST POSSIBLE SUBSCRIPT WITHIN THE VECTOR. ! 20006 J=ABS(IRCX) LL=IX(3)+4 LPG = LMX - LL if (.NOT.(IRCX > 0)) go to 20014 ! ! SEARCHING FOR THE NEXT NONZERO IN A COLUMN. ! ! INITIALIZE STARTING LOCATIONS.. if (.NOT.(I <= 0)) go to 20017 if (.NOT.(J == 1)) go to 20020 IPLACE=LL+1 go to 20021 20020 IPLACE=IX(J+3)+1 20021 CONTINUE ! ! THE CASE I <= 0 SIGNALS THAT THE SCAN FOR THE ENTRY ! IS TO BEGIN AT THE START OF THE VECTOR. ! 20017 I = ABS(I) if (.NOT.(J == 1)) go to 20023 ISTART = LL+1 go to 20024 20023 ISTART=IX(J+3)+1 20024 IEND = IX(J+4) ! ! VALIDATE IPLACE. SET TO START OF VECTOR if OUT OF RANGE. ! if (.NOT.(ISTART > IPLACE .OR. IPLACE > IEND)) go to 20026 if (.NOT.(J == 1)) go to 20029 IPLACE=LL+1 go to 20030 20029 IPLACE=IX(J+3)+1 20030 CONTINUE ! ! SCAN THROUGH SEVERAL PAGES, if NECESSARY, TO FIND MATRIX ENTRY. ! 20026 IPL = IPLOC(IPLACE,SX,IX) ! ! FIX UP IPLACE AND IPL if THEY POINT TO PAGING DATA. ! THIS IS NECESSARY BECAUSE THERE IS CONTROL INFORMATION AT THE ! END OF EACH PAGE. ! IDIFF = LMX - IPL if (.NOT.(IDIFF <= 1.AND.IX(LMX-1) > 0)) go to 20032 ! ! UPDATE THE RELATIVE ADDRESS IN A NEW PAGE. ! IPLACE = IPLACE + IDIFF + 1 IPL = IPLOC(IPLACE,SX,IX) 20032 NP = ABS(IX(LMX-1)) go to 20036 20035 if (ILAST == IEND) go to 20037 20036 ILAST = MIN(IEND,NP*LPG+LL-2) ! ! THE VIRTUAL END OF THE DATA FOR THIS PAGE IS ILAST. ! IL = IPLOC(ILAST,SX,IX) IL = MIN(IL,LMX-2) ! ! THE RELATIVE END OF DATA FOR THIS PAGE IS IL. ! SEARCH FOR A NONZERO VALUE WITH AN INDEX > I ON THE PRESENT ! PAGE. ! 20038 if (.NOT.(.NOT.(IPL >= IL.OR.(IX(IPL) > I.AND.SX(IPL) /= ZERO)))) & go to 20039 IPL=IPL+1 go to 20038 ! ! TEST if WE HAVE FOUND THE NEXT NONZERO. ! 20039 if (.NOT.(IX(IPL) > I .AND. SX(IPL) /= ZERO .AND. IPL <= IL)) GO & TO 20040 I = IX(IPL) XVAL = SX(IPL) IPLACE = (NP-1)*LPG + IPL return ! ! UPDATE TO SCAN THE NEXT PAGE. 20040 IPL = LL + 1 NP = NP + 1 go to 20035 ! ! NO DATA WAS FOUND. END OF VECTOR ENCOUNTERED. ! 20037 I = 0 XVAL = ZERO IL = IL + 1 if ( IL == LMX-1) IL = IL + 2 ! ! if A NEW ITEM WOULD BE INSERTED, IPLACE POINTS TO THE PLACE ! TO PUT IT. ! IPLACE = (NP-1)*LPG + IL return ! ! SEARCH A ROW FOR THE NEXT NONZERO. ! FIND ELEMENT J=ABS(IRCX) IN ROWS ABS(I)+1,...,L. ! 20014 I=ABS(I) ! ! CHECK FOR END OF VECTOR. ! if (.NOT.(I == L)) go to 20043 I=0 XVAL=ZERO return 20043 I1 = I+1 II=I1 N20046=L go to 20047 20046 II=II+1 20047 if ((N20046-II) < 0) go to 20048 ! ! INITIALIZE IPPLOC FOR ORTHOGONAL SCAN. ! LOOK FOR J AS A SUBSCRIPT IN ROWS II, II=I+1,...,L. ! if (.NOT.(II == 1)) go to 20050 IPPLOC = LL + 1 go to 20051 20050 IPPLOC = IX(II+3) + 1 20051 IEND = IX(II+4) ! ! SCAN THROUGH SEVERAL PAGES, if NECESSARY, TO FIND MATRIX ENTRY. ! IPL = IPLOC(IPPLOC,SX,IX) ! ! FIX UP IPPLOC AND IPL TO POINT TO MATRIX DATA. ! IDIFF = LMX - IPL if (.NOT.(IDIFF <= 1.AND.IX(LMX-1) > 0)) go to 20053 IPPLOC = IPPLOC + IDIFF + 1 IPL = IPLOC(IPPLOC,SX,IX) 20053 NP = ABS(IX(LMX-1)) go to 20057 20056 if (ILAST == IEND) go to 20058 20057 ILAST = MIN(IEND,NP*LPG+LL-2) IL = IPLOC(ILAST,SX,IX) IL = MIN(IL,LMX-2) 20059 if (.NOT.(.NOT.(IPL >= IL .OR. IX(IPL) >= J))) go to 20060 IPL=IPL+1 go to 20059 ! ! TEST if WE HAVE FOUND THE NEXT NONZERO. ! 20060 if (.NOT.(IX(IPL) == J .AND. SX(IPL) /= ZERO .AND. IPL <= IL)) GO & TO 20061 I = II XVAL = SX(IPL) return 20061 if ( IX(IPL) >= J) ILAST = IEND IPL = LL + 1 NP = NP + 1 go to 20056 20058 go to 20046 ! ! ORTHOGONAL SCAN FAILED. THE VALUE J WAS NOT A SUBSCRIPT ! IN ANY ROW. ! 20048 I=0 XVAL=ZERO return end function POCH1 (A, X) ! !! POCH1 calculates a generalization of Pochhammer's symbol starting ! from first order. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C1, C7A !***TYPE SINGLE PRECISION (POCH1-S, DPOCH1-D) !***KEYWORDS FIRST ORDER, FNLIB, POCHHAMMER, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate a generalization of Pochhammer's symbol for special ! situations that require especially accurate values when X is small in ! POCH1(A,X) = (POCH(A,X)-1)/X ! = (GAMMA(A+X)/GAMMA(A) - 1.0)/X . ! This specification is particularly suited for stably computing ! expressions such as ! (GAMMA(A+X)/GAMMA(A) - GAMMA(B+X)/GAMMA(B))/X ! = POCH1(A,X) - POCH1(B,X) ! Note that POCH1(A,0.0) = PSI(A) ! ! When ABS(X) is so small that substantial cancellation will occur if ! the straightforward formula is used, we use an expansion due ! to Fields and discussed by Y. L. Luke, The Special Functions and Their ! Approximations, Vol. 1, Academic Press, 1969, page 34. ! ! The ratio POCH(A,X) = GAMMA(A+X)/GAMMA(A) is written by Luke as ! (A+(X-1)/2)**X * polynomial in (A+(X-1)/2)**(-2) . ! In order to maintain significance in POCH1, we write for positive A ! (A+(X-1)/2)**X = EXP(X*LOG(A+(X-1)/2)) = EXP(Q) ! = 1.0 + Q*EXPREL(Q) . ! Likewise the polynomial is written ! POLY = 1.0 + X*POLY1(A,X) . ! Thus, ! POCH1(A,X) = (POCH(A,X) - 1) / X ! = EXPREL(Q)*(Q/X + Q*POLY1(A,X)) + POLY1(A,X) ! !***REFERENCES (NONE) !***ROUTINES CALLED COT, EXPREL, POCH, PSI, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE POCH1 DIMENSION BERN(9), GBERN(10) LOGICAL FIRST EXTERNAL COT SAVE BERN, PI, SQTBIG, ALNEPS, FIRST DATA BERN( 1) / .83333333333333333E-01 / DATA BERN( 2) / -.13888888888888889E-02 / DATA BERN( 3) / .33068783068783069E-04 / DATA BERN( 4) / -.82671957671957672E-06 / DATA BERN( 5) / .20876756987868099E-07 / DATA BERN( 6) / -.52841901386874932E-09 / DATA BERN( 7) / .13382536530684679E-10 / DATA BERN( 8) / -.33896802963225829E-12 / DATA BERN( 9) / .85860620562778446E-14 / DATA PI / 3.14159265358979324E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT POCH1 if (FIRST) THEN SQTBIG = 1.0/SQRT(24.0*R1MACH(1)) ALNEPS = LOG(R1MACH(3)) end if FIRST = .FALSE. ! if (X == 0.0) POCH1 = PSI(A) if (X == 0.0) RETURN ! ABSX = ABS(X) ABSA = ABS(A) if (ABSX > 0.1*ABSA) go to 70 if (ABSX*LOG(MAX(ABSA,2.0)) > 0.1) go to 70 ! BP = A if (A < (-0.5)) BP = 1.0 - A - X INCR = 0 if (BP < 10.0) INCR = 11.0 - BP B = BP + INCR ! VAR = B + 0.5*(X-1.0) ALNVAR = LOG(VAR) Q = X*ALNVAR ! POLY1 = 0.0 if (VAR >= SQTBIG) go to 40 VAR2 = (1.0/VAR)**2 ! RHO = 0.5*(X+1.0) GBERN(1) = 1.0 GBERN(2) = -RHO/12.0 TERM = VAR2 POLY1 = GBERN(2)*TERM ! NTERMS = -0.5*ALNEPS/ALNVAR + 1.0 if (NTERMS > 9) call XERMSG ('SLATEC', 'POCH1', & 'NTERMS IS TOO BIG, MAYBE R1MACH(3) IS BAD', 1, 2) if (NTERMS < 2) go to 40 ! DO 30 K=2,NTERMS GBK = 0.0 DO 20 J=1,K NDX = K - J + 1 GBK = GBK + BERN(NDX)*GBERN(J) 20 CONTINUE GBERN(K+1) = -RHO*GBK/K ! TERM = TERM * (2*K-2.-X)*(2*K-1.-X)*VAR2 POLY1 = POLY1 + GBERN(K+1)*TERM 30 CONTINUE ! 40 POLY1 = (X-1.0)*POLY1 POCH1 = EXPREL(Q)*(ALNVAR + Q*POLY1) + POLY1 ! if (INCR == 0) go to 60 ! ! WE HAVE POCH1(B,X). BUT BP IS SMALL, SO WE USE BACKWARDS RECURSION ! TO OBTAIN POCH1(BP,X). ! DO 50 II=1,INCR I = INCR - II BINV = 1.0/(BP+I) POCH1 = (POCH1-BINV)/(1.0+X*BINV) 50 CONTINUE ! 60 if (BP == A) RETURN ! ! WE HAVE POCH1(BP,X), BUT A IS LT -0.5. WE THEREFORE USE A REFLECTION ! FORMULA TO OBTAIN POCH1(A,X). ! SINPXX = SIN(PI*X)/X SINPX2 = SIN(0.5*PI*X) TRIG = SINPXX*COT(PI*B) - 2.0*SINPX2*(SINPX2/X) ! POCH1 = TRIG + (1.0 + X*TRIG) * POCH1 return ! 70 POCH1 = (POCH(A,X) - 1.0) / X return ! end function POCH (A, X) ! !! POCH evaluates a generalization of Pochhammer's symbol. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C1, C7A !***TYPE SINGLE PRECISION (POCH-S, DPOCH-D) !***KEYWORDS FNLIB, POCHHAMMER, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate a generalization of Pochhammer's symbol ! (A)-sub-X = GAMMA(A+X)/GAMMA(A). For X a non-negative integer, ! POCH(A,X) is just Pochhammer's symbol. A and X are single precision. ! This is a preliminary version. Error handling when POCH(A,X) is ! less than half precision is probably incorrect. Grossly incorrect ! arguments are not handled properly. ! !***REFERENCES (NONE) !***ROUTINES CALLED ALGAMS, ALNREL, FAC, GAMMA, GAMR, R9LGMC, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE POCH EXTERNAL GAMMA SAVE PI DATA PI / 3.141592653589793238E0 / !***FIRST EXECUTABLE STATEMENT POCH AX = A + X if (AX > 0.0) go to 30 if (AINT(AX) /= AX) go to 30 ! if (A > 0.0 .OR. AINT(A) /= A) call XERMSG ('SLATEC', 'POCH', & 'A+X IS NON-POSITIVE INTEGER BUT A IS NOT', 2, 2) ! ! WE KNOW HERE THAT BOTH A+X AND A ARE NON-POSITIVE INTEGERS. ! POCH = 1.0 if (X == 0.0) RETURN ! N = X if (MIN(A+X,A) < (-20.0)) go to 20 ! POCH = (-1.0)**N * FAC(-INT(A))/FAC(-INT(A)-N) return ! 20 POCH = (-1.0)**N * EXP ((A-0.5)*ALNREL(X/(A-1.0)) & + X*LOG(-A+1.0-X) - X + R9LGMC(-A+1.) - R9LGMC(-A-X+1.) ) return ! ! HERE WE KNOW A+X IS NOT ZERO OR A NEGATIVE INTEGER. ! 30 POCH = 0.0 if (A <= 0.0 .AND. AINT(A) == A) RETURN ! N = ABS(X) if (REAL(N) /= X .OR. N > 20) go to 50 ! ! X IS A SMALL NON-POSITIVE INTEGER, PRESUMMABLY A COMMON CASE. ! POCH = 1.0 if (N == 0) RETURN DO 40 I=1,N POCH = POCH * (A+I-1) 40 CONTINUE return ! 50 ABSAX = ABS(A+X) ABSA = ABS(A) if (MAX(ABSAX,ABSA) > 20.0) go to 60 POCH = GAMMA(A+X)*GAMR(A) return ! 60 if (ABS(X) > 0.5*ABSA) go to 70 ! ! HERE ABS(X) IS SMALL AND BOTH ABS(A+X) AND ABS(A) ARE LARGE. THUS, ! A+X AND A MUST HAVE THE SAME SIGN. FOR NEGATIVE A, WE USE ! GAMMA(A+X)/GAMMA(A) = GAMMA(-A+1)/GAMMA(-A-X+1) * ! SIN(PI*A)/SIN(PI*(A+X)) ! B = A if (B < 0.0) B = -A - X + 1.0 POCH = EXP ((B-0.5)*ALNREL(X/B) + X*LOG(B+X) - X + & R9LGMC(B+X) - R9LGMC(B) ) if (A < 0.0 .AND. POCH /= 0.0) POCH = POCH/(COS(PI*X) + & COT(PI*A)*SIN(PI*X)) return ! 70 call ALGAMS (A+X, ALNGAX, SGNGAX) call ALGAMS (A, ALNGA, SGNGA) POCH = SGNGAX * SGNGA * EXP(ALNGAX-ALNGA) ! return end subroutine POIS3D (LPEROD, L, C1, MPEROD, M, C2, NPEROD, N, A, B, & C, LDIMF, MDIMF, F, IERROR, W) ! !! POIS3D solves a three-dimensional block tridiagonal linear system ... ! which arises from a finite difference approximation to a ! three-dimensional Poisson equation using the Fourier ! transform package FFTPAK written by Paul Swarztrauber. ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B4B !***TYPE SINGLE PRECISION (POIS3D-S) !***KEYWORDS ELLIPTIC PDE, FISHPACK, HELMHOLTZ, POISSON !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine POIS3D solves the linear system of equations ! ! C1*(X(I-1,J,K)-2.*X(I,J,K)+X(I+1,J,K)) ! + C2*(X(I,J-1,K)-2.*X(I,J,K)+X(I,J+1,K)) ! + A(K)*X(I,J,K-1)+B(K)*X(I,J,K)+C(K)*X(I,J,K+1) = F(I,J,K) ! ! for I=1,2,...,L , J=1,2,...,M , and K=1,2,...,N . ! ! The indices K-1 and K+1 are evaluated modulo N, i.e. ! X(I,J,0) = X(I,J,N) and X(I,J,N+1) = X(I,J,1). The unknowns ! X(0,J,K), X(L+1,J,K), X(I,0,K), and X(I,M+1,K) are assumed to take ! on certain prescribed values described below. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! ! * * * * * * On Input * * * * * * ! ! LPEROD Indicates the values that X(0,J,K) and X(L+1,J,K) are ! assumed to have. ! ! = 0 If X(0,J,K) = X(L,J,K) and X(L+1,J,K) = X(1,J,K). ! = 1 If X(0,J,K) = X(L+1,J,K) = 0. ! = 2 If X(0,J,K) = 0 and X(L+1,J,K) = X(L-1,J,K). ! = 3 If X(0,J,K) = X(2,J,K) and X(L+1,J,K) = X(L-1,J,K). ! = 4 If X(0,J,K) = X(2,J,K) and X(L+1,J,K) = 0. ! ! L The number of unknowns in the I-direction. L must be at ! least 3. ! ! C1 The real constant that appears in the above equation. ! ! MPEROD Indicates the values that X(I,0,K) and X(I,M+1,K) are ! assumed to have. ! ! = 0 If X(I,0,K) = X(I,M,K) and X(I,M+1,K) = X(I,1,K). ! = 1 If X(I,0,K) = X(I,M+1,K) = 0. ! = 2 If X(I,0,K) = 0 and X(I,M+1,K) = X(I,M-1,K). ! = 3 If X(I,0,K) = X(I,2,K) and X(I,M+1,K) = X(I,M-1,K). ! = 4 If X(I,0,K) = X(I,2,K) and X(I,M+1,K) = 0. ! ! M The number of unknowns in the J-direction. M must be at ! least 3. ! ! C2 The real constant which appears in the above equation. ! ! NPEROD = 0 If A(1) and C(N) are not zero. ! = 1 If A(1) = C(N) = 0. ! ! N The number of unknowns in the K-direction. N must be at ! least 3. ! ! ! A,B,C One-dimensional arrays of length N that specify the ! coefficients in the linear equations given above. ! ! If NPEROD = 0 the array elements must not depend upon the ! index K, but must be constant. Specifically, the ! subroutine checks the following condition ! ! A(K) = C(1) ! C(K) = C(1) ! B(K) = B(1) ! ! for K=1,2,...,N. ! ! LDIMF The row (or first) dimension of the three-dimensional ! array F as it appears in the program calling POIS3D. ! This parameter is used to specify the variable dimension ! of F. LDIMF must be at least L. ! ! MDIMF The column (or second) dimension of the three-dimensional ! array F as it appears in the program calling POIS3D. ! This parameter is used to specify the variable dimension ! of F. MDIMF must be at least M. ! ! F A three-dimensional array that specifies the values of ! the right side of the linear system of equations given ! above. F must be dimensioned at least L x M x N. ! ! W A one-dimensional array that must be provided by the ! user for work space. The length of W must be at least ! 30 + L + M + 2*N + MAX(L,M,N) + ! 7*(INT((L+1)/2) + INT((M+1)/2)). ! ! ! * * * * * * On Output * * * * * * ! ! F Contains the solution X. ! ! IERROR An error flag that indicates invalid input parameters. ! Except for number zero, a solution is not attempted. ! = 0 No error ! = 1 If LPEROD < 0 or > 4 ! = 2 If L < 3 ! = 3 If MPEROD < 0 or > 4 ! = 4 If M < 3 ! = 5 If NPEROD < 0 or > 1 ! = 6 If N < 3 ! = 7 If LDIMF < L ! = 8 If MDIMF < M ! = 9 If A(K) /= C(1) or C(K) /= C(1) or B(I) /= B(1) ! for some K=1,2,...,N. ! = 10 If NPEROD = 1 and A(1) /= 0 or C(N) /= 0 ! ! Since this is the only means of indicating a possibly ! incorrect call to POIS3D, the user should test IERROR ! after the call. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of A(N),B(N),C(N),F(LDIMF,MDIMF,N), ! Arguments W(see argument list) ! ! Latest December 1, 1978 ! Revision ! ! Subprograms POIS3D,POS3D1,TRIDQ,RFFTI,RFFTF,RFFTF1,RFFTB, ! Required RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,COSQF1 ! COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,CFFTI1, ! CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,CFFTF, ! CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,PIMACH, ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Written by Roland Sweet at NCAR in July 1977 ! ! Algorithm This subroutine solves three-dimensional block ! tridiagonal linear systems arising from finite ! difference approximations to three-dimensional ! Poisson equations using the Fourier transform ! package FFTPAK written by Paul Swarztrauber. ! ! Space 6561(decimal) = 14641(octal) locations on the ! Required NCAR Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine POIS3D is roughly proportional ! to L*M*N*(log2(L)+log2(M)+5), but also depends on ! input parameters LPEROD and MPEROD. Some typical ! values are listed in the table below when NPEROD=0. ! To measure the accuracy of the algorithm a ! uniform random number generator was used to create ! a solution array X for the system given in the ! 'PURPOSE' with ! ! A(K) = C(K) = -0.5*B(K) = 1, K=1,2,...,N ! ! and, when NPEROD = 1 ! ! A(1) = C(N) = 0 ! A(N) = C(1) = 2. ! ! The solution X was substituted into the given sys- ! tem and, using double precision, a right side Y was ! computed. Using this array Y subroutine POIS3D was ! called to produce an approximate solution Z. Then ! the relative error, defined as ! ! E = MAX(ABS(Z(I,J,K)-X(I,J,K)))/MAX(ABS(X(I,J,K))) ! ! where the two maxima are taken over I=1,2,...,L, ! J=1,2,...,M and K=1,2,...,N, was computed. The ! value of E is given in the table below for some ! typical values of L,M and N. ! ! ! L(=M=N) LPEROD MPEROD T(MSECS) E ! ------ ------ ------ -------- ------ ! ! 16 0 0 272 1.E-13 ! 15 1 1 287 4.E-13 ! 17 3 3 338 2.E-13 ! 32 0 0 1755 2.E-13 ! 31 1 1 1894 2.E-12 ! 33 3 3 2042 7.E-13 ! ! ! Portability American National Standards Institute FORTRAN. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS,SIN,ATAN ! Resident ! Routines ! ! Reference NONE ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES (NONE) !***ROUTINES CALLED POS3D1 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE POIS3D DIMENSION A(*) ,B(*) ,C(*) , & F(LDIMF,MDIMF,*) ,W(*) ,SAVE(6) !***FIRST EXECUTABLE STATEMENT POIS3D LP = LPEROD+1 MP = MPEROD+1 NP = NPEROD+1 ! ! CHECK FOR INVALID INPUT. ! IERROR = 0 if (LP < 1 .OR. LP > 5) IERROR = 1 if (L < 3) IERROR = 2 if (MP < 1 .OR. MP > 5) IERROR = 3 if (M < 3) IERROR = 4 if (NP < 1 .OR. NP > 2) IERROR = 5 if (N < 3) IERROR = 6 if (LDIMF < L) IERROR = 7 if (MDIMF < M) IERROR = 8 if (NP /= 1) go to 103 DO 101 K=1,N if (A(K) /= C(1)) go to 102 if (C(K) /= C(1)) go to 102 if (B(K) /= B(1)) go to 102 101 CONTINUE go to 104 102 IERROR = 9 103 if (NPEROD == 1 .AND. (A(1) /= 0. .OR. C(N) /= 0.)) IERROR = 10 104 if (IERROR /= 0) go to 122 IWYRT = L+1 IWT = IWYRT+M IWD = IWT+MAX(L,M,N)+1 IWBB = IWD+N IWX = IWBB+N IWY = IWX+7*((L+1)/2)+15 go to (105,114),NP ! ! REORDER UNKNOWNS WHEN NPEROD = 0. ! 105 NH = (N+1)/2 NHM1 = NH-1 NODD = 1 if (2*NH == N) NODD = 2 DO 111 I=1,L DO 110 J=1,M DO 106 K=1,NHM1 NHPK = NH+K NHMK = NH-K W(K) = F(I,J,NHMK)-F(I,J,NHPK) W(NHPK) = F(I,J,NHMK)+F(I,J,NHPK) 106 CONTINUE W(NH) = 2.*F(I,J,NH) go to (108,107),NODD 107 W(N) = 2.*F(I,J,N) 108 DO 109 K=1,N F(I,J,K) = W(K) 109 CONTINUE 110 CONTINUE 111 CONTINUE SAVE(1) = C(NHM1) SAVE(2) = A(NH) SAVE(3) = C(NH) SAVE(4) = B(NHM1) SAVE(5) = B(N) SAVE(6) = A(N) C(NHM1) = 0. A(NH) = 0. C(NH) = 2.*C(NH) go to (112,113),NODD 112 B(NHM1) = B(NHM1)-A(NH-1) B(N) = B(N)+A(N) go to 114 113 A(N) = C(NH) 114 CONTINUE call POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,W,W(IWYRT),W(IWT), & W(IWD),W(IWX),W(IWY),C1,C2,W(IWBB)) go to (115,122),NP 115 DO 121 I=1,L DO 120 J=1,M DO 116 K=1,NHM1 NHMK = NH-K NHPK = NH+K W(NHMK) = .5*(F(I,J,NHPK)+F(I,J,K)) W(NHPK) = .5*(F(I,J,NHPK)-F(I,J,K)) 116 CONTINUE W(NH) = .5*F(I,J,NH) go to (118,117),NODD 117 W(N) = .5*F(I,J,N) 118 DO 119 K=1,N F(I,J,K) = W(K) 119 CONTINUE 120 CONTINUE 121 CONTINUE C(NHM1) = SAVE(1) A(NH) = SAVE(2) C(NH) = SAVE(3) B(NHM1) = SAVE(4) B(N) = SAVE(5) A(N) = SAVE(6) 122 CONTINUE return end subroutine POISD2 (MR, NR, ISTAG, BA, BB, BC, Q, IDIMQ, B, W, D, & TCOS, P) ! !! POISD2 is subsidiary to GENBUN. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (POISD2-S, CMPOSD-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve Poisson's equation for Dirichlet boundary ! conditions. ! ! ISTAG = 1 if the last diagonal block is the matrix A. ! ISTAG = 2 if the last diagonal block is the matrix A+I. ! !***SEE ALSO GENBUN !***ROUTINES CALLED COSGEN, S1MERG, TRIX !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 920130 Modified to use merge routine S1MERG rather than deleted ! routine MERGE. (WRB) !***END PROLOGUE POISD2 ! DIMENSION Q(IDIMQ,*) ,BA(*) ,BB(*) ,BC(*) , & TCOS(*) ,B(*) ,D(*) ,W(*) , & P(*) !***FIRST EXECUTABLE STATEMENT POISD2 M = MR N = NR JSH = 0 FI = 1./ISTAG IP = -M IPSTOR = 0 go to (101,102),ISTAG 101 KR = 0 IRREG = 1 if (N > 1) go to 106 TCOS(1) = 0. go to 103 102 KR = 1 JSTSAV = 1 IRREG = 2 if (N > 1) go to 106 TCOS(1) = -1. 103 DO 104 I=1,M B(I) = Q(I,1) 104 CONTINUE call TRIX (1,0,M,BA,BB,BC,B,TCOS,D,W) DO 105 I=1,M Q(I,1) = B(I) 105 CONTINUE go to 183 106 LR = 0 DO 107 I=1,M P(I) = 0. 107 CONTINUE NUN = N JST = 1 JSP = N ! ! IRREG = 1 WHEN NO IRREGULARITIES HAVE OCCURRED, OTHERWISE IT IS 2. ! 108 L = 2*JST NODD = 2-2*((NUN+1)/2)+NUN ! ! NODD = 1 WHEN NUN IS ODD, OTHERWISE IT IS 2. ! go to (110,109),NODD 109 JSP = JSP-L go to 111 110 JSP = JSP-JST if (IRREG /= 1) JSP = JSP-L 111 CONTINUE ! ! REGULAR REDUCTION ! call COSGEN (JST,1,0.5,0.0,TCOS) if (L > JSP) go to 118 DO 117 J=L,JSP,L JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST JM3 = JM2-JSH JP3 = JP2+JSH if (JST /= 1) go to 113 DO 112 I=1,M B(I) = 2.*Q(I,J) Q(I,J) = Q(I,JM2)+Q(I,JP2) 112 CONTINUE go to 115 113 DO 114 I=1,M T = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) B(I) = T+Q(I,J)-Q(I,JM3)-Q(I,JP3) Q(I,J) = T 114 CONTINUE 115 CONTINUE call TRIX (JST,0,M,BA,BB,BC,B,TCOS,D,W) DO 116 I=1,M Q(I,J) = Q(I,J)+B(I) 116 CONTINUE 117 CONTINUE ! ! REDUCTION FOR LAST UNKNOWN ! 118 go to (119,136),NODD 119 go to (152,120),IRREG ! ! ODD NUMBER OF UNKNOWNS ! 120 JSP = JSP+L J = JSP JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST JM3 = JM2-JSH go to (123,121),ISTAG 121 CONTINUE if (JST /= 1) go to 123 DO 122 I=1,M B(I) = Q(I,J) Q(I,J) = 0. 122 CONTINUE go to 130 123 go to (124,126),NODDPR 124 DO 125 I=1,M IP1 = IP+I B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+P(IP1)+Q(I,J) 125 CONTINUE go to 128 126 DO 127 I=1,M B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+Q(I,JP2)-Q(I,JP1)+Q(I,J) 127 CONTINUE 128 DO 129 I=1,M Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) 129 CONTINUE 130 call TRIX (JST,0,M,BA,BB,BC,B,TCOS,D,W) IP = IP+M IPSTOR = MAX(IPSTOR,IP+M) DO 131 I=1,M IP1 = IP+I P(IP1) = Q(I,J)+B(I) B(I) = Q(I,JP2)+P(IP1) 131 CONTINUE if (LR /= 0) go to 133 DO 132 I=1,JST KRPI = KR+I TCOS(KRPI) = TCOS(I) 132 CONTINUE go to 134 133 CONTINUE call COSGEN (LR,JSTSAV,0.,FI,TCOS(JST+1)) call S1MERG (TCOS,0,JST,JST,LR,KR) 134 CONTINUE call COSGEN (KR,JSTSAV,0.0,FI,TCOS) call TRIX (KR,KR,M,BA,BB,BC,B,TCOS,D,W) DO 135 I=1,M IP1 = IP+I Q(I,J) = Q(I,JM2)+B(I)+P(IP1) 135 CONTINUE LR = KR KR = KR+L go to 152 ! ! EVEN NUMBER OF UNKNOWNS ! 136 JSP = JSP+L J = JSP JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST JM3 = JM2-JSH go to (137,138),IRREG 137 CONTINUE JSTSAV = JST IDEG = JST KR = L go to 139 138 call COSGEN (KR,JSTSAV,0.0,FI,TCOS) call COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1)) IDEG = KR KR = KR+JST 139 if (JST /= 1) go to 141 IRREG = 2 DO 140 I=1,M B(I) = Q(I,J) Q(I,J) = Q(I,JM2) 140 CONTINUE go to 150 141 DO 142 I=1,M B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 142 CONTINUE go to (143,145),IRREG 143 DO 144 I=1,M Q(I,J) = Q(I,JM2)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) 144 CONTINUE IRREG = 2 go to 150 145 CONTINUE go to (146,148),NODDPR 146 DO 147 I=1,M IP1 = IP+I Q(I,J) = Q(I,JM2)+P(IP1) 147 CONTINUE IP = IP-M go to 150 148 DO 149 I=1,M Q(I,J) = Q(I,JM2)+Q(I,J)-Q(I,JM1) 149 CONTINUE 150 call TRIX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W) DO 151 I=1,M Q(I,J) = Q(I,J)+B(I) 151 CONTINUE 152 NUN = NUN/2 NODDPR = NODD JSH = JST JST = 2*JST if (NUN >= 2) go to 108 ! ! START SOLUTION. ! J = JSP DO 153 I=1,M B(I) = Q(I,J) 153 CONTINUE go to (154,155),IRREG 154 CONTINUE call COSGEN (JST,1,0.5,0.0,TCOS) IDEG = JST go to 156 155 KR = LR+JST call COSGEN (KR,JSTSAV,0.0,FI,TCOS) call COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1)) IDEG = KR 156 CONTINUE call TRIX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W) JM1 = J-JSH JP1 = J+JSH go to (157,159),IRREG 157 DO 158 I=1,M Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) 158 CONTINUE go to 164 159 go to (160,162),NODDPR 160 DO 161 I=1,M IP1 = IP+I Q(I,J) = P(IP1)+B(I) 161 CONTINUE IP = IP-M go to 164 162 DO 163 I=1,M Q(I,J) = Q(I,J)-Q(I,JM1)+B(I) 163 CONTINUE 164 CONTINUE ! ! START BACK SUBSTITUTION. ! JST = JST/2 JSH = JST/2 NUN = 2*NUN if (NUN > N) go to 183 DO 182 J=JST,N,L JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST if (J > JST) go to 166 DO 165 I=1,M B(I) = Q(I,J)+Q(I,JP2) 165 CONTINUE go to 170 166 if (JP2 <= N) go to 168 DO 167 I=1,M B(I) = Q(I,J)+Q(I,JM2) 167 CONTINUE if (JST < JSTSAV) IRREG = 1 go to (170,171),IRREG 168 DO 169 I=1,M B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) 169 CONTINUE 170 CONTINUE call COSGEN (JST,1,0.5,0.0,TCOS) IDEG = JST JDEG = 0 go to 172 171 if (J+L > N) LR = LR-JST KR = JST+LR call COSGEN (KR,JSTSAV,0.0,FI,TCOS) call COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1)) IDEG = KR JDEG = LR 172 CONTINUE call TRIX (IDEG,JDEG,M,BA,BB,BC,B,TCOS,D,W) if (JST > 1) go to 174 DO 173 I=1,M Q(I,J) = B(I) 173 CONTINUE go to 182 174 if (JP2 > N) go to 177 175 DO 176 I=1,M Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) 176 CONTINUE go to 182 177 go to (175,178),IRREG 178 if (J+JSH > N) go to 180 DO 179 I=1,M IP1 = IP+I Q(I,J) = B(I)+P(IP1) 179 CONTINUE IP = IP-M go to 182 180 DO 181 I=1,M Q(I,J) = B(I)+Q(I,J)-Q(I,JM1) 181 CONTINUE 182 CONTINUE L = L/2 go to 164 183 CONTINUE ! ! return STORAGE REQUIREMENTS FOR P VECTORS. ! W(1) = IPSTOR return end subroutine POISN2 (M, N, ISTAG, MIXBND, A, BB, C, Q, IDIMQ, B, B2, & B3, W, W2, W3, D, TCOS, P) ! !! POISN2 is subsidiary to GENBUN. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (POISN2-S, CMPOSN-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve Poisson's equation with Neumann boundary ! conditions. ! ! ISTAG = 1 if the last diagonal block is A. ! ISTAG = 2 if the last diagonal block is A-I. ! MIXBND = 1 if have Neumann boundary conditions at both boundaries. ! MIXBND = 2 if have Neumann boundary conditions at bottom and ! Dirichlet condition at top. (for this case, must have ISTAG = 1.) ! !***SEE ALSO GENBUN !***ROUTINES CALLED COSGEN, S1MERG, TRI3, TRIX !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 920130 Modified to use merge routine S1MERG rather than deleted ! routine MERGE. (WRB) !***END PROLOGUE POISN2 ! DIMENSION A(*) ,BB(*) ,C(*) ,Q(IDIMQ,*) , & B(*) ,B2(*) ,B3(*) ,W(*) , & W2(*) ,W3(*) ,D(*) ,TCOS(*) , & K(4) ,P(*) EQUIVALENCE (K(1),K1) ,(K(2),K2) ,(K(3),K3) ,(K(4),K4) !***FIRST EXECUTABLE STATEMENT POISN2 FISTAG = 3-ISTAG FNUM = 1./ISTAG FDEN = 0.5*(ISTAG-1) MR = M IP = -MR IPSTOR = 0 I2R = 1 JR = 2 NR = N NLAST = N KR = 1 LR = 0 go to (101,103),ISTAG 101 CONTINUE DO 102 I=1,MR Q(I,N) = .5*Q(I,N) 102 CONTINUE go to (103,104),MIXBND 103 if (N <= 3) go to 155 104 CONTINUE JR = 2*I2R NROD = 1 if ((NR/2)*2 == NR) NROD = 0 go to (105,106),MIXBND 105 JSTART = 1 go to 107 106 JSTART = JR NROD = 1-NROD 107 CONTINUE JSTOP = NLAST-JR if (NROD == 0) JSTOP = JSTOP-I2R call COSGEN (I2R,1,0.5,0.0,TCOS) I2RBY2 = I2R/2 if (JSTOP >= JSTART) go to 108 J = JR go to 116 108 CONTINUE ! ! REGULAR REDUCTION. ! DO 115 J=JSTART,JSTOP,JR JP1 = J+I2RBY2 JP2 = J+I2R JP3 = JP2+I2RBY2 JM1 = J-I2RBY2 JM2 = J-I2R JM3 = JM2-I2RBY2 if (J /= 1) go to 109 JM1 = JP1 JM2 = JP2 JM3 = JP3 109 CONTINUE if (I2R /= 1) go to 111 if (J == 1) JM2 = JP2 DO 110 I=1,MR B(I) = 2.*Q(I,J) Q(I,J) = Q(I,JM2)+Q(I,JP2) 110 CONTINUE go to 113 111 CONTINUE DO 112 I=1,MR FI = Q(I,J) Q(I,J) = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) B(I) = FI+Q(I,J)-Q(I,JM3)-Q(I,JP3) 112 CONTINUE 113 CONTINUE call TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W) DO 114 I=1,MR Q(I,J) = Q(I,J)+B(I) 114 CONTINUE ! ! END OF REDUCTION FOR REGULAR UNKNOWNS. ! 115 CONTINUE ! ! BEGIN SPECIAL REDUCTION FOR LAST UNKNOWN. ! J = JSTOP+JR 116 NLAST = J JM1 = J-I2RBY2 JM2 = J-I2R JM3 = JM2-I2RBY2 if (NROD == 0) go to 128 ! ! ODD NUMBER OF UNKNOWNS ! if (I2R /= 1) go to 118 DO 117 I=1,MR B(I) = FISTAG*Q(I,J) Q(I,J) = Q(I,JM2) 117 CONTINUE go to 126 118 DO 119 I=1,MR B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 119 CONTINUE if (NRODPR /= 0) go to 121 DO 120 I=1,MR II = IP+I Q(I,J) = Q(I,JM2)+P(II) 120 CONTINUE IP = IP-MR go to 123 121 CONTINUE DO 122 I=1,MR Q(I,J) = Q(I,J)-Q(I,JM1)+Q(I,JM2) 122 CONTINUE 123 if (LR == 0) go to 124 call COSGEN (LR,1,0.5,FDEN,TCOS(KR+1)) go to 126 124 CONTINUE DO 125 I=1,MR B(I) = FISTAG*B(I) 125 CONTINUE 126 CONTINUE call COSGEN (KR,1,0.5,FDEN,TCOS) call TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W) DO 127 I=1,MR Q(I,J) = Q(I,J)+B(I) 127 CONTINUE KR = KR+I2R go to 151 128 CONTINUE ! ! EVEN NUMBER OF UNKNOWNS ! JP1 = J+I2RBY2 JP2 = J+I2R if (I2R /= 1) go to 135 DO 129 I=1,MR B(I) = Q(I,J) 129 CONTINUE call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) IP = 0 IPSTOR = MR go to (133,130),ISTAG 130 DO 131 I=1,MR P(I) = B(I) B(I) = B(I)+Q(I,N) 131 CONTINUE TCOS(1) = 1. TCOS(2) = 0. call TRIX (1,1,MR,A,BB,C,B,TCOS,D,W) DO 132 I=1,MR Q(I,J) = Q(I,JM2)+P(I)+B(I) 132 CONTINUE go to 150 133 CONTINUE DO 134 I=1,MR P(I) = B(I) Q(I,J) = Q(I,JM2)+2.*Q(I,JP2)+3.*B(I) 134 CONTINUE go to 150 135 CONTINUE DO 136 I=1,MR B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 136 CONTINUE if (NRODPR /= 0) go to 138 DO 137 I=1,MR II = IP+I B(I) = B(I)+P(II) 137 CONTINUE go to 140 138 CONTINUE DO 139 I=1,MR B(I) = B(I)+Q(I,JP2)-Q(I,JP1) 139 CONTINUE 140 CONTINUE call TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W) IP = IP+MR IPSTOR = MAX(IPSTOR,IP+MR) DO 141 I=1,MR II = IP+I P(II) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) B(I) = P(II)+Q(I,JP2) 141 CONTINUE if (LR == 0) go to 142 call COSGEN (LR,1,0.5,FDEN,TCOS(I2R+1)) call S1MERG (TCOS,0,I2R,I2R,LR,KR) go to 144 142 DO 143 I=1,I2R II = KR+I TCOS(II) = TCOS(I) 143 CONTINUE 144 call COSGEN (KR,1,0.5,FDEN,TCOS) if (LR /= 0) go to 145 go to (146,145),ISTAG 145 CONTINUE call TRIX (KR,KR,MR,A,BB,C,B,TCOS,D,W) go to 148 146 CONTINUE DO 147 I=1,MR B(I) = FISTAG*B(I) 147 CONTINUE 148 CONTINUE DO 149 I=1,MR II = IP+I Q(I,J) = Q(I,JM2)+P(II)+B(I) 149 CONTINUE 150 CONTINUE LR = KR KR = KR+JR 151 CONTINUE go to (152,153),MIXBND 152 NR = (NLAST-1)/JR+1 if (NR <= 3) go to 155 go to 154 153 NR = NLAST/JR if (NR <= 1) go to 192 154 I2R = JR NRODPR = NROD go to 104 155 CONTINUE ! ! BEGIN SOLUTION ! J = 1+JR JM1 = J-I2R JP1 = J+I2R JM2 = NLAST-I2R if (NR == 2) go to 184 if (LR /= 0) go to 170 if (N /= 3) go to 161 ! ! CASE N = 3. ! go to (156,168),ISTAG 156 CONTINUE DO 157 I=1,MR B(I) = Q(I,2) 157 CONTINUE TCOS(1) = 0. call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 158 I=1,MR Q(I,2) = B(I) B(I) = 4.*B(I)+Q(I,1)+2.*Q(I,3) 158 CONTINUE TCOS(1) = -2. TCOS(2) = 2. I1 = 2 I2 = 0 call TRIX (I1,I2,MR,A,BB,C,B,TCOS,D,W) DO 159 I=1,MR Q(I,2) = Q(I,2)+B(I) B(I) = Q(I,1)+2.*Q(I,2) 159 CONTINUE TCOS(1) = 0. call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 160 I=1,MR Q(I,1) = B(I) 160 CONTINUE JR = 1 I2R = 0 go to 194 ! ! CASE N = 2**P+1 ! 161 CONTINUE go to (162,170),ISTAG 162 CONTINUE DO 163 I=1,MR B(I) = Q(I,J)+.5*Q(I,1)-Q(I,JM1)+Q(I,NLAST)-Q(I,JM2) 163 CONTINUE call COSGEN (JR,1,0.5,0.0,TCOS) call TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 164 I=1,MR Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) B(I) = Q(I,1)+2.*Q(I,NLAST)+4.*Q(I,J) 164 CONTINUE JR2 = 2*JR call COSGEN (JR,1,0.0,0.0,TCOS) DO 165 I=1,JR I1 = JR+I I2 = JR+1-I TCOS(I1) = -TCOS(I2) 165 CONTINUE call TRIX (JR2,0,MR,A,BB,C,B,TCOS,D,W) DO 166 I=1,MR Q(I,J) = Q(I,J)+B(I) B(I) = Q(I,1)+2.*Q(I,J) 166 CONTINUE call COSGEN (JR,1,0.5,0.0,TCOS) call TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 167 I=1,MR Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I) 167 CONTINUE go to 194 ! ! CASE OF GENERAL N WITH NR = 3 . ! 168 DO 169 I=1,MR B(I) = Q(I,2) Q(I,2) = 0. B2(I) = Q(I,3) B3(I) = Q(I,1) 169 CONTINUE JR = 1 I2R = 0 J = 2 go to 177 170 CONTINUE DO 171 I=1,MR B(I) = .5*Q(I,1)-Q(I,JM1)+Q(I,J) 171 CONTINUE if (NROD /= 0) go to 173 DO 172 I=1,MR II = IP+I B(I) = B(I)+P(II) 172 CONTINUE go to 175 173 DO 174 I=1,MR B(I) = B(I)+Q(I,NLAST)-Q(I,JM2) 174 CONTINUE 175 CONTINUE DO 176 I=1,MR T = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) Q(I,J) = T B2(I) = Q(I,NLAST)+T B3(I) = Q(I,1)+2.*T 176 CONTINUE 177 CONTINUE K1 = KR+2*JR-1 K2 = KR+JR TCOS(K1+1) = -2. K4 = K1+3-ISTAG call COSGEN (K2+ISTAG-2,1,0.0,FNUM,TCOS(K4)) K4 = K1+K2+1 call COSGEN (JR-1,1,0.0,1.0,TCOS(K4)) call S1MERG (TCOS,K1,K2,K1+K2,JR-1,0) K3 = K1+K2+LR call COSGEN (JR,1,0.5,0.0,TCOS(K3+1)) K4 = K3+JR+1 call COSGEN (KR,1,0.5,FDEN,TCOS(K4)) call S1MERG (TCOS,K3,JR,K3+JR,KR,K1) if (LR == 0) go to 178 call COSGEN (LR,1,0.5,FDEN,TCOS(K4)) call S1MERG (TCOS,K3,JR,K3+JR,LR,K3-LR) call COSGEN (KR,1,0.5,FDEN,TCOS(K4)) 178 K3 = KR K4 = KR call TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) DO 179 I=1,MR B(I) = B(I)+B2(I)+B3(I) 179 CONTINUE TCOS(1) = 2. call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 180 I=1,MR Q(I,J) = Q(I,J)+B(I) B(I) = Q(I,1)+2.*Q(I,J) 180 CONTINUE call COSGEN (JR,1,0.5,0.0,TCOS) call TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) if (JR /= 1) go to 182 DO 181 I=1,MR Q(I,1) = B(I) 181 CONTINUE go to 194 182 CONTINUE DO 183 I=1,MR Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I) 183 CONTINUE go to 194 184 CONTINUE if (N /= 2) go to 188 ! ! CASE N = 2 ! DO 185 I=1,MR B(I) = Q(I,1) 185 CONTINUE TCOS(1) = 0. call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 186 I=1,MR Q(I,1) = B(I) B(I) = 2.*(Q(I,2)+B(I))*FISTAG 186 CONTINUE TCOS(1) = -FISTAG TCOS(2) = 2. call TRIX (2,0,MR,A,BB,C,B,TCOS,D,W) DO 187 I=1,MR Q(I,1) = Q(I,1)+B(I) 187 CONTINUE JR = 1 I2R = 0 go to 194 188 CONTINUE ! ! CASE OF GENERAL N AND NR = 2 . ! DO 189 I=1,MR II = IP+I B3(I) = 0. B(I) = Q(I,1)+2.*P(II) Q(I,1) = .5*Q(I,1)-Q(I,JM1) B2(I) = 2.*(Q(I,1)+Q(I,NLAST)) 189 CONTINUE K1 = KR+JR-1 TCOS(K1+1) = -2. K4 = K1+3-ISTAG call COSGEN (KR+ISTAG-2,1,0.0,FNUM,TCOS(K4)) K4 = K1+KR+1 call COSGEN (JR-1,1,0.0,1.0,TCOS(K4)) call S1MERG (TCOS,K1,KR,K1+KR,JR-1,0) call COSGEN (KR,1,0.5,FDEN,TCOS(K1+1)) K2 = KR K4 = K1+K2+1 call COSGEN (LR,1,0.5,FDEN,TCOS(K4)) K3 = LR K4 = 0 call TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) DO 190 I=1,MR B(I) = B(I)+B2(I) 190 CONTINUE TCOS(1) = 2. call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 191 I=1,MR Q(I,1) = Q(I,1)+B(I) 191 CONTINUE go to 194 192 DO 193 I=1,MR B(I) = Q(I,NLAST) 193 CONTINUE go to 196 194 CONTINUE ! ! START BACK SUBSTITUTION. ! J = NLAST-JR DO 195 I=1,MR B(I) = Q(I,NLAST)+Q(I,J) 195 CONTINUE 196 JM2 = NLAST-I2R if (JR /= 1) go to 198 DO 197 I=1,MR Q(I,NLAST) = 0. 197 CONTINUE go to 202 198 CONTINUE if (NROD /= 0) go to 200 DO 199 I=1,MR II = IP+I Q(I,NLAST) = P(II) 199 CONTINUE IP = IP-MR go to 202 200 DO 201 I=1,MR Q(I,NLAST) = Q(I,NLAST)-Q(I,JM2) 201 CONTINUE 202 CONTINUE call COSGEN (KR,1,0.5,FDEN,TCOS) call COSGEN (LR,1,0.5,FDEN,TCOS(KR+1)) if (LR /= 0) go to 204 DO 203 I=1,MR B(I) = FISTAG*B(I) 203 CONTINUE 204 CONTINUE call TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W) DO 205 I=1,MR Q(I,NLAST) = Q(I,NLAST)+B(I) 205 CONTINUE NLASTP = NLAST 206 CONTINUE JSTEP = JR JR = I2R I2R = I2R/2 if (JR == 0) go to 222 go to (207,208),MIXBND 207 JSTART = 1+JR go to 209 208 JSTART = JR 209 CONTINUE KR = KR-JR if (NLAST+JR > N) go to 210 KR = KR-JR NLAST = NLAST+JR JSTOP = NLAST-JSTEP go to 211 210 CONTINUE JSTOP = NLAST-JR 211 CONTINUE LR = KR-JR call COSGEN (JR,1,0.5,0.0,TCOS) DO 221 J=JSTART,JSTOP,JSTEP JM2 = J-JR JP2 = J+JR if (J /= JR) go to 213 DO 212 I=1,MR B(I) = Q(I,J)+Q(I,JP2) 212 CONTINUE go to 215 213 CONTINUE DO 214 I=1,MR B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) 214 CONTINUE 215 CONTINUE if (JR /= 1) go to 217 DO 216 I=1,MR Q(I,J) = 0. 216 CONTINUE go to 219 217 CONTINUE JM1 = J-I2R JP1 = J+I2R DO 218 I=1,MR Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) 218 CONTINUE 219 CONTINUE call TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 220 I=1,MR Q(I,J) = Q(I,J)+B(I) 220 CONTINUE 221 CONTINUE NROD = 1 if (NLAST+I2R <= N) NROD = 0 if (NLASTP /= NLAST) go to 194 go to 206 222 CONTINUE ! ! return STORAGE REQUIREMENTS FOR P VECTORS. ! W(1) = IPSTOR return end subroutine POISP2 (M, N, A, BB, C, Q, IDIMQ, B, B2, B3, W, W2, W3, & D, TCOS, P) ! !! POISP2 is subsidiary to GENBUN. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (POISP2-S, CMPOSP-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve Poisson equation with periodic boundary ! conditions. ! !***SEE ALSO GENBUN !***ROUTINES CALLED POISD2, POISN2 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE POISP2 ! DIMENSION A(*) ,BB(*) ,C(*) ,Q(IDIMQ,*) , & B(*) ,B2(*) ,B3(*) ,W(*) , & W2(*) ,W3(*) ,D(*) ,TCOS(*) , & P(*) !***FIRST EXECUTABLE STATEMENT POISP2 MR = M NR = (N+1)/2 NRM1 = NR-1 if (2*NR /= N) go to 107 ! ! EVEN NUMBER OF UNKNOWNS ! DO 102 J=1,NRM1 NRMJ = NR-J NRPJ = NR+J DO 101 I=1,MR S = Q(I,NRMJ)-Q(I,NRPJ) T = Q(I,NRMJ)+Q(I,NRPJ) Q(I,NRMJ) = S Q(I,NRPJ) = T 101 CONTINUE 102 CONTINUE DO 103 I=1,MR Q(I,NR) = 2.*Q(I,NR) Q(I,N) = 2.*Q(I,N) 103 CONTINUE call POISD2 (MR,NRM1,1,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P) IPSTOR = W(1) call POISN2 (MR,NR+1,1,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D, & TCOS,P) IPSTOR = MAX(IPSTOR,INT(W(1))) DO 105 J=1,NRM1 NRMJ = NR-J NRPJ = NR+J DO 104 I=1,MR S = .5*(Q(I,NRPJ)+Q(I,NRMJ)) T = .5*(Q(I,NRPJ)-Q(I,NRMJ)) Q(I,NRMJ) = S Q(I,NRPJ) = T 104 CONTINUE 105 CONTINUE DO 106 I=1,MR Q(I,NR) = .5*Q(I,NR) Q(I,N) = .5*Q(I,N) 106 CONTINUE go to 118 107 CONTINUE ! ! ODD NUMBER OF UNKNOWNS ! DO 109 J=1,NRM1 NRPJ = N+1-J DO 108 I=1,MR S = Q(I,J)-Q(I,NRPJ) T = Q(I,J)+Q(I,NRPJ) Q(I,J) = S Q(I,NRPJ) = T 108 CONTINUE 109 CONTINUE DO 110 I=1,MR Q(I,NR) = 2.*Q(I,NR) 110 CONTINUE LH = NRM1/2 DO 112 J=1,LH NRMJ = NR-J DO 111 I=1,MR S = Q(I,J) Q(I,J) = Q(I,NRMJ) Q(I,NRMJ) = S 111 CONTINUE 112 CONTINUE call POISD2 (MR,NRM1,2,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P) IPSTOR = W(1) call POISN2 (MR,NR,2,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D, & TCOS,P) IPSTOR = MAX(IPSTOR,INT(W(1))) DO 114 J=1,NRM1 NRPJ = NR+J DO 113 I=1,MR S = .5*(Q(I,NRPJ)+Q(I,J)) T = .5*(Q(I,NRPJ)-Q(I,J)) Q(I,NRPJ) = T Q(I,J) = S 113 CONTINUE 114 CONTINUE DO 115 I=1,MR Q(I,NR) = .5*Q(I,NR) 115 CONTINUE DO 117 J=1,LH NRMJ = NR-J DO 116 I=1,MR S = Q(I,J) Q(I,J) = Q(I,NRMJ) Q(I,NRMJ) = S 116 CONTINUE 117 CONTINUE 118 CONTINUE ! ! return STORAGE REQUIREMENTS FOR P VECTORS. ! W(1) = IPSTOR return end subroutine POISTG (NPEROD, N, MPEROD, M, A, B, C, IDIMY, Y, & IERROR, W) ! !! POISTG solves a block tridiagonal system of linear equations ... ! that results from a staggered grid finite difference ! approximation to 2-D elliptic PDE's. ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B4B !***TYPE SINGLE PRECISION (POISTG-S) !***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, TRIDIAGONAL !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Subroutine POISTG solves the linear system of equations ! ! A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J) ! + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J) ! ! for I=1,2,...,M and J=1,2,...,N. ! ! The indices I+1 and I-1 are evaluated modulo M, i.e. ! X(0,J) = X(M,J) and X(M+1,J) = X(1,J), and X(I,0) may be equal to ! X(I,1) or -X(I,1) and X(I,N+1) may be equal to X(I,N) or -X(I,N) ! depending on an input parameter. ! ! ! * * * * * * * * Parameter Description * * * * * * * * * * ! ! * * * * * * On Input * * * * * * ! ! NPEROD ! Indicates the values which X(I,0) and X(I,N+1) are assumed ! to have. ! = 1 If X(I,0) = -X(I,1) and X(I,N+1) = -X(I,N) ! = 2 If X(I,0) = -X(I,1) and X(I,N+1) = X(I,N) ! = 3 If X(I,0) = X(I,1) and X(I,N+1) = X(I,N) ! = 4 If X(I,0) = X(I,1) and X(I,N+1) = -X(I,N) ! ! N ! The number of unknowns in the J-direction. N must ! be greater than 2. ! ! MPEROD ! = 0 If A(1) and C(M) are not zero ! = 1 If A(1) = C(M) = 0 ! ! M ! The number of unknowns in the I-direction. M must ! be greater than 2. ! ! A,B,C ! One-dimensional arrays of length M that specify the coefficients ! in the linear equations given above. If MPEROD = 0 the array ! elements must not depend on the index I, but must be constant. ! Specifically, the subroutine checks the following condition ! ! A(I) = C(1) ! B(I) = B(1) ! C(I) = C(1) ! ! for I = 1, 2, ..., M. ! ! IDIMY ! The row (or first) dimension of the two-dimensional array Y as ! it appears in the program calling POISTG. This parameter is ! used to specify the variable dimension of Y. IDIMY must be at ! least M. ! ! Y ! A two-dimensional array that specifies the values of the ! right side of the linear system of equations given above. ! Y must be dimensioned at least M X N. ! ! W ! A one-dimensional work array that must be provided by the user ! for work space. W may require up to 9M + 4N + M(INT(log2(N))) ! locations. The actual number of locations used is computed by ! POISTG and returned in location W(1). ! ! ! * * * * * * On Output * * * * * * ! ! Y ! Contains the solution X. ! ! IERROR ! An error flag that indicates invalid input parameters. Except ! for number zero, a solution is not attempted. ! = 0 No error ! = 1 If M <= 2 ! = 2 If N <= 2 ! = 3 IDIMY < M ! = 4 If NPEROD < 1 or NPEROD > 4 ! = 5 If MPEROD < 0 or MPEROD > 1 ! = 6 If MPEROD = 0 and ! A(I) /= C(1) or B(I) /= B(1) or C(I) /= C(1) ! for some I = 1, 2, ..., M. ! = 7 If MPEROD == 1 .AND. (A(1) /= 0 .OR. C(M) /= 0) ! ! W ! W(1) contains the required length of W. ! ! *Long Description: ! ! * * * * * * * Program Specifications * * * * * * * * * * * * ! ! Dimension of A(M),B(M),C(M),Y(IDIMY,N), ! Arguments W(see argument list) ! ! Latest June 1, 1977 ! Revision ! ! Subprograms POISTG,POSTG2,COSGEN,MERGE,TRIX,TRI3,PIMACH ! Required ! ! Special NONE ! Conditions ! ! Common NONE ! Blocks ! ! I/O NONE ! ! Precision Single ! ! Specialist Roland Sweet ! ! Language FORTRAN ! ! History Written by Roland Sweet in 1973 ! Revised by Roland Sweet in 1977 ! ! ! Space 3297(decimal) = 6341(octal) locations on the ! Required NCAR Control Data 7600 ! ! Timing and The execution time T on the NCAR Control Data ! Accuracy 7600 for subroutine POISTG is roughly proportional ! to M*N*log2(N). Some typical values are listed ! in the table below. More comprehensive timing ! charts may be found in the reference. ! To measure the accuracy of the algorithm a ! uniform random number generator was used to create ! a solution array X for the system given in the ! 'PURPOSE ' with ! ! A(I) = C(I) = -0.5*B(I) = 1, I=1,2,...,M ! ! and, when MPEROD = 1 ! ! A(1) = C(M) = 0 ! B(1) = B(M) =-1. ! ! The solution X was substituted into the given sys- ! tem and, using double precision, a right side Y was ! computed. Using this array Y subroutine POISTG was ! called to produce an approximate solution Z. Then ! the relative error, defined as ! ! E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J))) ! ! where the two maxima are taken over all I=1,2,...,M ! and J=1,2,...,N, was computed. The value of E is ! given in the table below for some typical values of ! M and N. ! ! ! M (=N) MPEROD NPEROD T(MSECS) E ! ------ ------ ------ -------- ------ ! ! 31 0-1 1-4 45 9.E-13 ! 31 1 1 21 4.E-13 ! 31 1 3 41 3.E-13 ! 32 0-1 1-4 51 3.E-12 ! 32 1 1 32 3.E-13 ! 32 1 3 48 1.E-13 ! 33 0-1 1-4 42 1.E-12 ! 33 1 1 30 4.E-13 ! 33 1 3 34 1.E-13 ! 63 0-1 1-4 186 3.E-12 ! 63 1 1 91 1.E-12 ! 63 1 3 173 2.E-13 ! 64 0-1 1-4 209 4.E-12 ! 64 1 1 128 1.E-12 ! 64 1 3 199 6.E-13 ! 65 0-1 1-4 143 2.E-13 ! 65 1 1 160 1.E-11 ! 65 1 3 138 4.E-13 ! ! Portability American National Standards Institute FORTRAN. ! The machine dependent constant PI is defined in ! function PIMACH. ! ! Required COS ! Resident ! Routines ! ! Reference Schumann, U. and R. Sweet,'A Direct Method for ! the Solution of Poisson's Equation With Neumann ! Boundary Conditions on a Staggered Grid of ! Arbitrary Size,' J. Comp. Phys. 20(1976), ! pp. 171-182. ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !***REFERENCES U. Schumann and R. Sweet, A direct method for the ! solution of Poisson's equation with Neumann boundary ! conditions on a staggered grid of arbitrary size, ! Journal of Computational Physics 20, (1976), ! pp. 171-182. !***ROUTINES CALLED POSTG2 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE POISTG ! ! DIMENSION Y(IDIMY,*) DIMENSION W(*) ,B(*) ,A(*) ,C(*) !***FIRST EXECUTABLE STATEMENT POISTG IERROR = 0 if (M <= 2) IERROR = 1 if (N <= 2) IERROR = 2 if (IDIMY < M) IERROR = 3 if (NPEROD < 1 .OR. NPEROD > 4) IERROR = 4 if (MPEROD < 0 .OR. MPEROD > 1) IERROR = 5 if (MPEROD == 1) go to 103 DO 101 I=1,M if (A(I) /= C(1)) go to 102 if (C(I) /= C(1)) go to 102 if (B(I) /= B(1)) go to 102 101 CONTINUE go to 104 102 IERROR = 6 return 103 if (A(1) /= 0. .OR. C(M) /= 0.) IERROR = 7 104 if (IERROR /= 0) RETURN IWBA = M+1 IWBB = IWBA+M IWBC = IWBB+M IWB2 = IWBC+M IWB3 = IWB2+M IWW1 = IWB3+M IWW2 = IWW1+M IWW3 = IWW2+M IWD = IWW3+M IWTCOS = IWD+M IWP = IWTCOS+4*N DO 106 I=1,M K = IWBA+I-1 W(K) = -A(I) K = IWBC+I-1 W(K) = -C(I) K = IWBB+I-1 W(K) = 2.-B(I) DO 105 J=1,N Y(I,J) = -Y(I,J) 105 CONTINUE 106 CONTINUE NP = NPEROD MP = MPEROD+1 go to (110,107),MP 107 CONTINUE go to (108,108,108,119),NPEROD 108 CONTINUE call POSTG2 (NP,N,M,W(IWBA),W(IWBB),W(IWBC),IDIMY,Y,W,W(IWB2), & W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), & W(IWP)) IPSTOR = W(IWW1) IREV = 2 if (NPEROD == 4) go to 120 109 CONTINUE go to (123,129),MP 110 CONTINUE ! ! REORDER UNKNOWNS WHEN MP =0 ! MH = (M+1)/2 MHM1 = MH-1 MODD = 1 if (MH*2 == M) MODD = 2 DO 115 J=1,N DO 111 I=1,MHM1 MHPI = MH+I MHMI = MH-I W(I) = Y(MHMI,J)-Y(MHPI,J) W(MHPI) = Y(MHMI,J)+Y(MHPI,J) 111 CONTINUE W(MH) = 2.*Y(MH,J) go to (113,112),MODD 112 W(M) = 2.*Y(M,J) 113 CONTINUE DO 114 I=1,M Y(I,J) = W(I) 114 CONTINUE 115 CONTINUE K = IWBC+MHM1-1 I = IWBA+MHM1 W(K) = 0. W(I) = 0. W(K+1) = 2.*W(K+1) go to (116,117),MODD 116 CONTINUE K = IWBB+MHM1-1 W(K) = W(K)-W(I-1) W(IWBC-1) = W(IWBC-1)+W(IWBB-1) go to 118 117 W(IWBB-1) = W(K+1) 118 CONTINUE go to 107 119 CONTINUE ! ! REVERSE COLUMNS WHEN NPEROD = 4. ! IREV = 1 NBY2 = N/2 NP = 2 120 DO 122 J=1,NBY2 MSKIP = N+1-J DO 121 I=1,M A1 = Y(I,J) Y(I,J) = Y(I,MSKIP) Y(I,MSKIP) = A1 121 CONTINUE 122 CONTINUE go to (108,109),IREV 123 CONTINUE DO 128 J=1,N DO 124 I=1,MHM1 MHMI = MH-I MHPI = MH+I W(MHMI) = .5*(Y(MHPI,J)+Y(I,J)) W(MHPI) = .5*(Y(MHPI,J)-Y(I,J)) 124 CONTINUE W(MH) = .5*Y(MH,J) go to (126,125),MODD 125 W(M) = .5*Y(M,J) 126 CONTINUE DO 127 I=1,M Y(I,J) = W(I) 127 CONTINUE 128 CONTINUE 129 CONTINUE ! ! return STORAGE REQUIREMENTS FOR W ARRAY. ! W(1) = IPSTOR+IWP-1 return end subroutine POLCOF (XX, N, X, C, D, WORK) ! !! POLCOF computes the coefficients of the polynomial fit (including ... ! Hermite polynomial fits) produced by a previous call to ! POLINT. ! !***LIBRARY SLATEC !***CATEGORY E1B !***TYPE SINGLE PRECISION (POLCOF-S, DPOLCF-D) !***KEYWORDS COEFFICIENTS, POLYNOMIAL !***AUTHOR Huddleston, R. E., (SNLL) !***DESCRIPTION ! ! Written by Robert E. Huddleston, Sandia Laboratories, Livermore ! ! Abstract ! Subroutine POLCOF computes the coefficients of the polynomial ! fit (including Hermite polynomial fits ) produced by a previous ! call to POLINT. The coefficients of the polynomial, expanded about ! XX, are stored in the array D. The expansion is of the form ! P(Z) = D(1) + D(2)*(Z-XX) +D(3)*((Z-XX)**2) + ... + ! D(N)*((Z-XX)**(N-1)). ! Between the call to POLINT and the call to POLCOF the variable N ! and the arrays X and C must not be altered. ! ! ***** INPUT PARAMETERS ! ! XX - The point about which the Taylor expansion is to be made. ! ! N - **** ! * N, X, and C must remain unchanged between the ! X - * call to POLINT or the call to POLCOF. ! C - **** ! ! ***** OUTPUT PARAMETER ! ! D - The array of coefficients for the Taylor expansion as ! explained in the abstract ! ! ***** STORAGE PARAMETER ! ! WORK - This is an array to provide internal working storage. It ! must be dimensioned by at least 2*N in the calling program. ! ! ! **** Note - There are two methods for evaluating the fit produced ! by POLINT. You may call POLYVL to perform the task, or you may ! call POLCOF to obtain the coefficients of the Taylor expansion and ! then write your own evaluation scheme. Due to the inherent errors ! in the computations of the Taylor expansion from the Newton ! coefficients produced by POLINT, much more accuracy may be ! expected by calling POLYVL as opposed to writing your own scheme. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890213 DATE WRITTEN ! 891024 Corrected KEYWORD section. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE POLCOF ! DIMENSION X(*), C(*), D(*), WORK(*) !***FIRST EXECUTABLE STATEMENT POLCOF DO 10010 K=1,N D(K)=C(K) 10010 CONTINUE if (N == 1) RETURN WORK(1)=1.0 PONE=C(1) NM1=N-1 DO 10020 K=2,N KM1=K-1 NPKM1=N+K-1 WORK(NPKM1)=XX-X(KM1) WORK(K)=WORK(NPKM1)*WORK(KM1) PTWO=PONE+WORK(K)*C(K) PONE=PTWO 10020 CONTINUE D(1)=PTWO if (N == 2) RETURN DO 10030 K=2,NM1 KM1=K-1 KM2N=K-2+N NMKP1=N-K+1 DO 10030 I=2,NMKP1 KM2NPI=KM2N+I IM1=I-1 KM1PI=KM1+I WORK(I)=WORK(KM2NPI)*WORK(IM1)+WORK(I) D(K)=D(K)+WORK(I)*D(KM1PI) 10030 CONTINUE return end subroutine POLFIT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A) ! !! POLFIT fits discrete data in a least squares sense by polynomials ... ! in one variable. ! !***LIBRARY SLATEC !***CATEGORY K1A1A2 !***TYPE SINGLE PRECISION (POLFIT-S, DPOLFT-D) !***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT !***AUTHOR Shampine, L. F., (SNLA) ! Davenport, S. M., (SNLA) ! Huddleston, R. E., (SNLL) !***DESCRIPTION ! ! Abstract ! ! Given a collection of points X(I) and a set of values Y(I) which ! correspond to some function or measurement at each of the X(I), ! subroutine POLFIT computes the weighted least-squares polynomial ! fits of all degrees up to some degree either specified by the user ! or determined by the routine. The fits thus obtained are in ! orthogonal polynomial form. Subroutine PVALUE may then be ! called to evaluate the fitted polynomials and any of their ! derivatives at any point. The subroutine PCOEF may be used to ! express the polynomial fits as powers of (X-C) for any specified ! point C. ! ! The parameters for POLFIT are ! ! Input -- ! N - the number of data points. The arrays X, Y and W ! must be dimensioned at least N (N >= 1). ! X - array of values of the independent variable. These ! values may appear in any order and need not all be ! distinct. ! Y - array of corresponding function values. ! W - array of positive values to be used as weights. If ! W(1) is negative, POLFIT will set all the weights ! to 1.0, which means unweighted least squares error ! will be minimized. To minimize relative error, the ! user should set the weights to: W(I) = 1.0/Y(I)**2, ! I = 1,...,N . ! MAXDEG - maximum degree to be allowed for polynomial fit. ! MAXDEG may be any non-negative integer less than N. ! Note -- MAXDEG cannot be equal to N-1 when a ! statistical test is to be used for degree selection, ! i.e., when input value of EPS is negative. ! EPS - specifies the criterion to be used in determining ! the degree of fit to be computed. ! (1) If EPS is input negative, POLFIT chooses the ! degree based on a statistical F test of ! significance. One of three possible ! significance levels will be used: .01, .05 or ! .10. If EPS=-1.0 , the routine will ! automatically select one of these levels based ! on the number of data points and the maximum ! degree to be considered. If EPS is input as ! -.01, -.05, or -.10, a significance level of ! .01, .05, or .10, respectively, will be used. ! (2) If EPS is set to 0., POLFIT computes the ! polynomials of degrees 0 through MAXDEG . ! (3) If EPS is input positive, EPS is the RMS ! error tolerance which must be satisfied by the ! fitted polynomial. POLFIT will increase the ! degree of fit until this criterion is met or ! until the maximum degree is reached. ! ! Output -- ! NDEG - degree of the highest degree fit computed. ! EPS - RMS error of the polynomial of degree NDEG . ! R - vector of dimension at least NDEG containing values ! of the fit of degree NDEG at each of the X(I) . ! Except when the statistical test is used, these ! values are more accurate than results from subroutine ! PVALUE normally are. ! IERR - error flag with the following possible values. ! 1 -- indicates normal execution, i.e., either ! (1) the input value of EPS was negative, and the ! computed polynomial fit of degree NDEG ! satisfies the specified F test, or ! (2) the input value of EPS was 0., and the fits of ! all degrees up to MAXDEG are complete, or ! (3) the input value of EPS was positive, and the ! polynomial of degree NDEG satisfies the RMS ! error requirement. ! 2 -- invalid input parameter. At least one of the input ! parameters has an illegal value and must be corrected ! before POLFIT can proceed. Valid input results ! when the following restrictions are observed ! N >= 1 ! 0 <= MAXDEG <= N-1 for EPS >= 0. ! 0 <= MAXDEG <= N-2 for EPS < 0. ! W(1)=-1.0 or W(I) > 0., I=1,...,N . ! 3 -- cannot satisfy the RMS error requirement with a ! polynomial of degree no greater than MAXDEG . Best ! fit found is of degree MAXDEG . ! 4 -- cannot satisfy the test for significance using ! current value of MAXDEG . Statistically, the ! best fit found is of order NORD . (In this case, ! NDEG will have one of the values: MAXDEG-2, ! MAXDEG-1, or MAXDEG). Using a higher value of ! MAXDEG may result in passing the test. ! A - work and output array having at least 3N+3MAXDEG+3 ! locations ! ! Note - POLFIT calculates all fits of degrees up to and including ! NDEG . Any or all of these fits can be evaluated or ! expressed as powers of (X-C) using PVALUE and PCOEF ! after just one call to POLFIT . ! !***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, ! Curve fitting by polynomials in one variable, Report ! SLA-74-0270, Sandia Laboratories, June 1974. !***ROUTINES CALLED PVALUE, XERMSG !***REVISION HISTORY (YYMMDD) ! 740601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) ! 920527 Corrected erroneous statements in DESCRIPTION. (WRB) !***END PROLOGUE POLFIT DOUBLE PRECISION TEMD1,TEMD2 DIMENSION X(*), Y(*), W(*), R(*), A(*) DIMENSION CO(4,3) SAVE CO DATA CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2), & CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3), & CO(4,3)/-13.086850,-2.4648165,-3.3846535,-1.2973162, & -3.3381146,-1.7812271,-3.2578406,-1.6589279, & -1.6282703,-1.3152745,-3.2640179,-1.9829776/ !***FIRST EXECUTABLE STATEMENT POLFIT M = ABS(N) if (M == 0) go to 30 if (MAXDEG < 0) go to 30 A(1) = MAXDEG MOP1 = MAXDEG + 1 if (M < MOP1) go to 30 if (EPS < 0.0 .AND. M == MOP1) go to 30 XM = M ETST = EPS*EPS*XM if (W(1) < 0.0) go to 2 DO 1 I = 1,M if (W(I) <= 0.0) go to 30 1 CONTINUE go to 4 2 DO 3 I = 1,M 3 W(I) = 1.0 4 if (EPS >= 0.0) go to 8 ! ! DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR ! CHOOSING DEGREE OF POLYNOMIAL FIT ! if (EPS > (-.55)) go to 5 IDEGF = M - MAXDEG - 1 KSIG = 1 if (IDEGF < 10) KSIG = 2 if (IDEGF < 5) KSIG = 3 go to 8 5 KSIG = 1 if (EPS < (-.03)) KSIG = 2 if (EPS < (-.07)) KSIG = 3 ! ! INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING ! 8 K1 = MAXDEG + 1 K2 = K1 + MAXDEG K3 = K2 + MAXDEG + 2 K4 = K3 + M K5 = K4 + M DO 9 I = 2,K4 9 A(I) = 0.0 W11 = 0.0 if (N < 0) go to 11 ! ! UNCONSTRAINED CASE ! DO 10 I = 1,M K4PI = K4 + I A(K4PI) = 1.0 10 W11 = W11 + W(I) go to 13 ! ! CONSTRAINED CASE ! 11 DO 12 I = 1,M K4PI = K4 + I 12 W11 = W11 + W(I)*A(K4PI)**2 ! ! COMPUTE FIT OF DEGREE ZERO ! 13 TEMD1 = 0.0D0 DO 14 I = 1,M K4PI = K4 + I TEMD1 = TEMD1 + DBLE(W(I))*DBLE(Y(I))*DBLE(A(K4PI)) 14 CONTINUE TEMD1 = TEMD1/DBLE(W11) A(K2+1) = TEMD1 SIGJ = 0.0 DO 15 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = TEMD1*DBLE(A(K4PI)) R(I) = TEMD2 A(K5PI) = TEMD2 - DBLE(R(I)) 15 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 J = 0 ! ! SEE if POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION ! if (EPS) 24,26,27 ! ! INCREMENT DEGREE ! 16 J = J + 1 JP1 = J + 1 K1PJ = K1 + J K2PJ = K2 + J SIGJM1 = SIGJ ! ! COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 ! if (J > 1) A(K1PJ) = W11/W1 ! ! COMPUTE NEW A COEFFICIENT ! TEMD1 = 0.0D0 DO 18 I = 1,M K4PI = K4 + I TEMD2 = A(K4PI) TEMD1 = TEMD1 + DBLE(X(I))*DBLE(W(I))*TEMD2*TEMD2 18 CONTINUE A(JP1) = TEMD1/DBLE(W11) ! ! EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS ! W1 = W11 W11 = 0.0 DO 19 I = 1,M K3PI = K3 + I K4PI = K4 + I TEMP = A(K3PI) A(K3PI) = A(K4PI) A(K4PI) = (X(I)-A(JP1))*A(K3PI) - A(K1PJ)*TEMP 19 W11 = W11 + W(I)*A(K4PI)**2 ! ! GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE ! PRECISION ! TEMD1 = 0.0D0 DO 20 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = DBLE(W(I))*DBLE((Y(I)-R(I))-A(K5PI))*DBLE(A(K4PI)) 20 TEMD1 = TEMD1 + TEMD2 TEMD1 = TEMD1/DBLE(W11) A(K2PJ+1) = TEMD1 ! ! UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND ! ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE ! COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, ! THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST ! SIGNIFICANT BITS ARE IN A(K5PI) . ! SIGJ = 0.0 DO 21 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = DBLE(R(I)) + DBLE(A(K5PI)) + TEMD1*DBLE(A(K4PI)) R(I) = TEMD2 A(K5PI) = TEMD2 - DBLE(R(I)) 21 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 ! ! SEE if DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE ! MAXDEG HAS BEEN REACHED ! if (EPS) 23,26,27 ! ! COMPUTE F STATISTICS (INPUT EPS < 0.) ! 23 if (SIGJ == 0.0) go to 29 DEGF = M - J - 1 DEN = (CO(4,KSIG)*DEGF + 1.0)*DEGF FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN FCRIT = FCRIT*FCRIT F = (SIGJM1 - SIGJ)*DEGF/SIGJ if (F < FCRIT) go to 25 ! ! POLYNOMIAL OF DEGREE J SATISFIES F TEST ! 24 SIGPAS = SIGJ JPAS = J NFAIL = 0 if (MAXDEG == J) go to 32 go to 16 ! ! POLYNOMIAL OF DEGREE J FAILS F TEST. if THERE HAVE BEEN THREE ! SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. ! 25 NFAIL = NFAIL + 1 if (NFAIL >= 3) go to 29 if (MAXDEG == J) go to 32 go to 16 ! ! RAISE THE DEGREE if DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT ! EPS = 0.) ! 26 if (MAXDEG == J) go to 28 go to 16 ! ! SEE if RMS ERROR CRITERION IS SATISFIED (INPUT EPS > 0.) ! 27 if (SIGJ <= ETST) go to 28 if (MAXDEG == J) go to 31 go to 16 ! ! RETURNS ! 28 IERR = 1 NDEG = J SIG = SIGJ go to 33 29 IERR = 1 NDEG = JPAS SIG = SIGPAS go to 33 30 IERR = 2 call XERMSG ('SLATEC', 'POLFIT', 'INVALID INPUT PARAMETER.', 2, & 1) go to 37 31 IERR = 3 NDEG = MAXDEG SIG = SIGJ go to 33 32 IERR = 4 NDEG = JPAS SIG = SIGPAS ! 33 A(K3) = NDEG ! ! WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT ! ALL THE DATA POINTS if R DOES NOT ALREADY CONTAIN THESE VALUES ! if ( EPS >= 0.0 .OR. NDEG == MAXDEG) go to 36 NDER = 0 DO 35 I = 1,M call PVALUE (NDEG,NDER,X(I),R(I),YP,A) 35 CONTINUE 36 EPS = SQRT(SIG/XM) 37 return end subroutine POLINT (N, X, Y, C) ! !! POLINT produces the polynomial which interpolates a set of discrete data. ! !***LIBRARY SLATEC !***CATEGORY E1B !***TYPE SINGLE PRECISION (POLINT-S, DPLINT-D) !***KEYWORDS POLYNOMIAL INTERPOLATION !***AUTHOR Huddleston, R. E., (SNLL) !***DESCRIPTION ! ! Written by Robert E. Huddleston, Sandia Laboratories, Livermore ! ! Abstract ! Subroutine POLINT is designed to produce the polynomial which ! interpolates the data (X(I),Y(I)), I=1,...,N. POLINT sets up ! information in the array C which can be used by subroutine POLYVL ! to evaluate the polynomial and its derivatives and by subroutine ! POLCOF to produce the coefficients. ! ! Formal Parameters ! N - the number of data points (N >= 1) ! X - the array of abscissas (all of which must be distinct) ! Y - the array of ordinates ! C - an array of information used by subroutines ! ******* Dimensioning Information ******* ! Arrays X,Y, and C must be dimensioned at least N in the calling ! program. ! !***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, ! Curve fitting by polynomials in one variable, Report ! SLA-74-0270, Sandia Laboratories, June 1974. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 740601 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE POLINT DIMENSION X(*),Y(*),C(*) !***FIRST EXECUTABLE STATEMENT POLINT if (N <= 0) go to 91 C(1)=Y(1) if ( N == 1) RETURN DO 10010 K=2,N C(K)=Y(K) KM1=K-1 DO 10010 I=1,KM1 ! CHECK FOR DISTINCT X VALUES DIF = X(I)-X(K) if (DIF == 0.0) go to 92 C(K) = (C(I)-C(K))/DIF 10010 CONTINUE return 91 call XERMSG ('SLATEC', 'POLINT', 'N IS ZERO OR NEGATIVE.', 2, 1) return 92 call XERMSG ('SLATEC', 'POLINT', & 'THE ABSCISSAS ARE NOT DISTINCT.', 2, 1) return end subroutine POLYVL (NDER, XX, YFIT, YP, N, X, C, WORK, IERR) ! !! POLYVL calculates the value of a polynomial and its first NDER ... ! derivatives where the polynomial was produced by a previous call to POLINT. ! !***LIBRARY SLATEC !***CATEGORY E3 !***TYPE SINGLE PRECISION (POLYVL-S, DPOLVL-D) !***KEYWORDS POLYNOMIAL EVALUATION !***AUTHOR Huddleston, R. E., (SNLL) !***DESCRIPTION ! ! Written by Robert E. Huddleston, Sandia Laboratories, Livermore ! ! Abstract - ! Subroutine POLYVL calculates the value of the polynomial and ! its first NDER derivatives where the polynomial was produced by ! a previous call to POLINT. ! The variable N and the arrays X and C must not be altered ! between the call to POLINT and the call to POLYVL. ! ! ****** Dimensioning Information ******* ! ! YP must be dimensioned by at least NDER ! X must be dimensioned by at least N (see the abstract ) ! C must be dimensioned by at least N (see the abstract ) ! WORK must be dimensioned by at least 2*N if NDER is > 0. ! ! *** Note *** ! If NDER=0, neither YP nor WORK need to be dimensioned variables. ! If NDER=1, YP does not need to be a dimensioned variable. ! ! ! ***** Input parameters ! ! NDER - the number of derivatives to be evaluated ! ! XX - the argument at which the polynomial and its derivatives ! are to be evaluated. ! ! N - ***** ! * N, X, and C must not be altered between the call ! X - * to POLINT and the call to POLYVL. ! C - ***** ! ! ! ***** Output Parameters ! ! YFIT - the value of the polynomial at XX ! ! YP - the derivatives of the polynomial at XX. The derivative of ! order J at XX is stored in YP(J) , J = 1,...,NDER. ! ! IERR - Output error flag with the following possible values. ! = 1 indicates normal execution ! ! ***** Storage Parameters ! ! WORK = this is an array to provide internal working storage for ! POLYVL. It must be dimensioned by at least 2*N if NDER is ! > 0. If NDER=0, WORK does not need to be a dimensioned ! variable. ! !***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, ! Curve fitting by polynomials in one variable, Report ! SLA-74-0270, Sandia Laboratories, June 1974. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 740601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE POLYVL DIMENSION YP(*),X(*),C(*),WORK(*) !***FIRST EXECUTABLE STATEMENT POLYVL IERR=1 if (NDER > 0) go to 10020 ! ! ***** CODING FOR THE CASE NDER = 0 ! PIONE=1.0 PONE=C(1) YFIT=PONE if (N == 1) RETURN DO 10010 K=2,N PITWO=(XX-X(K-1))*PIONE PIONE=PITWO PTWO=PONE+PITWO*C(K) PONE=PTWO 10010 CONTINUE YFIT=PTWO return ! ! ***** END OF NDER = 0 CASE ! 10020 CONTINUE if (N > 1) go to 10040 YFIT=C(1) ! ! ***** CODING FOR THE CASE N=1 AND NDER > 0 ! DO 10030 K=1,NDER YP(K)=0.0 10030 CONTINUE return ! ! ***** END OF THE CASE N = 1 AND NDER > 0 ! 10040 CONTINUE if (NDER < N) go to 10050 ! ! ***** SET FLAGS FOR NUMBER OF DERIVATIVES AND FOR DERIVATIVES ! IN EXCESS OF THE DEGREE (N-1) OF THE POLYNOMIAL. ! IZERO=1 NDR=N-1 go to 10060 10050 CONTINUE IZERO=0 NDR=NDER 10060 CONTINUE M=NDR+1 MM=M ! ! ***** START OF THE CASE NDER > 0 AND N > 1 ! ***** THE POLYNOMIAL AND ITS DERIVATIVES WILL BE EVALUATED AT XX ! DO 10070 K=1,NDR YP(K)=C(K+1) 10070 CONTINUE ! ! ***** THE FOLLOWING SECTION OF CODE IS EASIER TO READ if ONE ! BREAKS WORK INTO TWO ARRAYS W AND V. THE CODE WOULD THEN ! READ ! W(1) = 1. ! PONE = C(1) ! *DO K = 2,N ! * V(K-1) = XX - X(K-1) ! * W(K) = V(K-1)*W(K-1) ! * PTWO = PONE + W(K)*C(K) ! * PONE = PWO ! ! YFIT = PTWO ! WORK(1)=1.0 PONE=C(1) DO 10080 K=2,N KM1=K-1 NPKM1=N+K-1 WORK(NPKM1)=XX-X(KM1) WORK(K)=WORK(NPKM1)*WORK(KM1) PTWO=PONE+WORK(K)*C(K) PONE=PTWO 10080 CONTINUE YFIT=PTWO ! ! ** AT THIS POINT THE POLYNOMIAL HAS BEEN EVALUATED AND INFORMATION ! FOR THE DERIVATIVE EVALUATIONS HAVE BEEN STORED IN THE ARRAY ! WORK if (N == 2) go to 10110 if (M == N) MM=NDR ! ! ***** EVALUATE THE DERIVATIVES AT XX ! ! ****** DO K=2,MM (FOR MOST CASES, MM = NDER + 1) ! * ****** DO I=2,N-K+1 ! * * W(I) = V(K-2+I)*W(I-1) + W(I) ! * * YP(K-1) = YP(K-1) + W(I)*C(K-1+I) ! ****** CONTINUE ! DO 10090 K=2,MM NMKP1=N-K+1 KM1=K-1 KM2PN=K-2+N DO 10090 I=2,NMKP1 KM2PNI=KM2PN+I IM1=I-1 KM1PI=KM1+I WORK(I)=WORK(KM2PNI)*WORK(IM1)+WORK(I) YP(KM1)=YP(KM1)+WORK(I)*C(KM1PI) 10090 CONTINUE if (NDR == 1) go to 10110 FAC=1.0 DO 10100 K=2,NDR XK=K FAC=XK*FAC YP(K)=FAC*YP(K) 10100 CONTINUE ! ! ***** END OF DERIVATIVE EVALUATIONS ! 10110 CONTINUE if (IZERO == 0) RETURN ! ! ***** SET EXCESS DERIVATIVES TO ZERO. ! DO 10120 K=N,NDER YP(K)=0.0 10120 CONTINUE return end subroutine POS3D1 (LP, L, MP, M, N, A, B, C, LDIMF, MDIMF, F, XRT, & YRT, T, D, WX, WY, C1, C2, BB) ! !! POS3D1 is subsidiary to POIS3D. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (POS3D1-S) !***AUTHOR (UNKNOWN) !***SEE ALSO POIS3D !***ROUTINES CALLED COSQB, COSQF, COSQI, COST, COSTI, PIMACH, RFFTB, ! RFFTF, RFFTI, SINQB, SINQF, SINQI, SINT, SINTI, ! TRIDQ !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900308 Changed call to TRID to call to TRIDQ. (WRB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE POS3D1 DIMENSION A(*) ,B(*) ,C(*) , & F(LDIMF,MDIMF,*) ,XRT(*) ,YRT(*) , & T(*) ,D(*) ,WX(*) ,WY(*) , & BB(*) !***FIRST EXECUTABLE STATEMENT POS3D1 PI = PIMACH(DUM) LR = L MR = M NR = N ! ! GENERATE TRANSFORM ROOTS ! LRDEL = ((LP-1)*(LP-3)*(LP-5))/3 SCALX = LR+LRDEL DX = PI/(2.*SCALX) go to (108,103,101,102,101),LP 101 DI = 0.5 SCALX = 2.*SCALX go to 104 102 DI = 1.0 go to 104 103 DI = 0.0 104 DO 105 I=1,LR XRT(I) = -4.*C1*(SIN((I-DI)*DX))**2 105 CONTINUE SCALX = 2.*SCALX go to (112,106,110,107,111),LP 106 call SINTI (LR,WX) go to 112 107 call COSTI (LR,WX) go to 112 108 XRT(1) = 0. XRT(LR) = -4.*C1 DO 109 I=3,LR,2 XRT(I-1) = -4.*C1*(SIN((I-1)*DX))**2 XRT(I) = XRT(I-1) 109 CONTINUE call RFFTI (LR,WX) go to 112 110 call SINQI (LR,WX) go to 112 111 call COSQI (LR,WX) 112 CONTINUE MRDEL = ((MP-1)*(MP-3)*(MP-5))/3 SCALY = MR+MRDEL DY = PI/(2.*SCALY) go to (120,115,113,114,113),MP 113 DJ = 0.5 SCALY = 2.*SCALY go to 116 114 DJ = 1.0 go to 116 115 DJ = 0.0 116 DO 117 J=1,MR YRT(J) = -4.*C2*(SIN((J-DJ)*DY))**2 117 CONTINUE SCALY = 2.*SCALY go to (124,118,122,119,123),MP 118 call SINTI (MR,WY) go to 124 119 call COSTI (MR,WY) go to 124 120 YRT(1) = 0. YRT(MR) = -4.*C2 DO 121 J=3,MR,2 YRT(J-1) = -4.*C2*(SIN((J-1)*DY))**2 YRT(J) = YRT(J-1) 121 CONTINUE call RFFTI (MR,WY) go to 124 122 call SINQI (MR,WY) go to 124 123 call COSQI (MR,WY) 124 CONTINUE IFWRD = 1 125 CONTINUE ! ! TRANSFORM X ! DO 141 J=1,MR DO 140 K=1,NR DO 126 I=1,LR T(I) = F(I,J,K) 126 CONTINUE go to (127,130,131,134,135),LP 127 go to (128,129),IFWRD 128 call RFFTF (LR,T,WX) go to 138 129 call RFFTB (LR,T,WX) go to 138 130 call SINT (LR,T,WX) go to 138 131 go to (132,133),IFWRD 132 call SINQF (LR,T,WX) go to 138 133 call SINQB (LR,T,WX) go to 138 134 call COST (LR,T,WX) go to 138 135 go to (136,137),IFWRD 136 call COSQF (LR,T,WX) go to 138 137 call COSQB (LR,T,WX) 138 CONTINUE DO 139 I=1,LR F(I,J,K) = T(I) 139 CONTINUE 140 CONTINUE 141 CONTINUE go to (142,164),IFWRD ! ! TRANSFORM Y ! 142 CONTINUE DO 158 I=1,LR DO 157 K=1,NR DO 143 J=1,MR T(J) = F(I,J,K) 143 CONTINUE go to (144,147,148,151,152),MP 144 go to (145,146),IFWRD 145 call RFFTF (MR,T,WY) go to 155 146 call RFFTB (MR,T,WY) go to 155 147 call SINT (MR,T,WY) go to 155 148 go to (149,150),IFWRD 149 call SINQF (MR,T,WY) go to 155 150 call SINQB (MR,T,WY) go to 155 151 call COST (MR,T,WY) go to 155 152 go to (153,154),IFWRD 153 call COSQF (MR,T,WY) go to 155 154 call COSQB (MR,T,WY) 155 CONTINUE DO 156 J=1,MR F(I,J,K) = T(J) 156 CONTINUE 157 CONTINUE 158 CONTINUE go to (159,125),IFWRD 159 CONTINUE ! ! SOLVE TRIDIAGONAL SYSTEMS IN Z ! DO 163 I=1,LR DO 162 J=1,MR DO 160 K=1,NR BB(K) = B(K)+XRT(I)+YRT(J) T(K) = F(I,J,K) 160 CONTINUE call TRIDQ (NR,A,BB,C,T,D) DO 161 K=1,NR F(I,J,K) = T(K) 161 CONTINUE 162 CONTINUE 163 CONTINUE IFWRD = 2 go to 142 164 CONTINUE DO 167 I=1,LR DO 166 J=1,MR DO 165 K=1,NR F(I,J,K) = F(I,J,K)/(SCALX*SCALY) 165 CONTINUE 166 CONTINUE 167 CONTINUE return end subroutine POSTG2 (NPEROD, N, M, A, BB, C, IDIMQ, Q, B, B2, B3, W, & W2, W3, D, TCOS, P) ! !! POSTG2 is subsidiary to POISTG. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (POSTG2-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve Poisson's equation on a staggered grid. ! !***SEE ALSO POISTG !***ROUTINES CALLED COSGEN, S1MERG, TRI3, TRIX !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 920130 Modified to use merge routine S1MERG rather than deleted ! routine MERGE. (WRB) !***END PROLOGUE POSTG2 ! DIMENSION A(*) ,BB(*) ,C(*) ,Q(IDIMQ,*) , & B(*) ,B2(*) ,B3(*) ,W(*) , & W2(*) ,W3(*) ,D(*) ,TCOS(*) , & K(4) ,P(*) EQUIVALENCE (K(1),K1) ,(K(2),K2) ,(K(3),K3) ,(K(4),K4) !***FIRST EXECUTABLE STATEMENT POSTG2 NP = NPEROD FNUM = 0.5*(NP/3) FNUM2 = 0.5*(NP/2) MR = M IP = -MR IPSTOR = 0 I2R = 1 JR = 2 NR = N NLAST = N KR = 1 LR = 0 if (NR <= 3) go to 142 101 CONTINUE JR = 2*I2R NROD = 1 if ((NR/2)*2 == NR) NROD = 0 JSTART = 1 JSTOP = NLAST-JR if (NROD == 0) JSTOP = JSTOP-I2R I2RBY2 = I2R/2 if (JSTOP >= JSTART) go to 102 J = JR go to 115 102 CONTINUE ! ! REGULAR REDUCTION. ! IJUMP = 1 DO 114 J=JSTART,JSTOP,JR JP1 = J+I2RBY2 JP2 = J+I2R JP3 = JP2+I2RBY2 JM1 = J-I2RBY2 JM2 = J-I2R JM3 = JM2-I2RBY2 if (J /= 1) go to 106 call COSGEN (I2R,1,FNUM,0.5,TCOS) if (I2R /= 1) go to 104 DO 103 I=1,MR B(I) = Q(I,1) Q(I,1) = Q(I,2) 103 CONTINUE go to 112 104 DO 105 I=1,MR B(I) = Q(I,1)+0.5*(Q(I,JP2)-Q(I,JP1)-Q(I,JP3)) Q(I,1) = Q(I,JP2)+Q(I,1)-Q(I,JP1) 105 CONTINUE go to 112 106 CONTINUE go to (107,108),IJUMP 107 CONTINUE IJUMP = 2 call COSGEN (I2R,1,0.5,0.0,TCOS) 108 CONTINUE if (I2R /= 1) go to 110 DO 109 I=1,MR B(I) = 2.*Q(I,J) Q(I,J) = Q(I,JM2)+Q(I,JP2) 109 CONTINUE go to 112 110 DO 111 I=1,MR FI = Q(I,J) Q(I,J) = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) B(I) = FI+Q(I,J)-Q(I,JM3)-Q(I,JP3) 111 CONTINUE 112 CONTINUE call TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W) DO 113 I=1,MR Q(I,J) = Q(I,J)+B(I) 113 CONTINUE ! ! END OF REDUCTION FOR REGULAR UNKNOWNS. ! 114 CONTINUE ! ! BEGIN SPECIAL REDUCTION FOR LAST UNKNOWN. ! J = JSTOP+JR 115 NLAST = J JM1 = J-I2RBY2 JM2 = J-I2R JM3 = JM2-I2RBY2 if (NROD == 0) go to 125 ! ! ODD NUMBER OF UNKNOWNS ! if (I2R /= 1) go to 117 DO 116 I=1,MR B(I) = Q(I,J) Q(I,J) = Q(I,JM2) 116 CONTINUE go to 123 117 DO 118 I=1,MR B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 118 CONTINUE if (NRODPR /= 0) go to 120 DO 119 I=1,MR II = IP+I Q(I,J) = Q(I,JM2)+P(II) 119 CONTINUE IP = IP-MR go to 122 120 CONTINUE DO 121 I=1,MR Q(I,J) = Q(I,J)-Q(I,JM1)+Q(I,JM2) 121 CONTINUE 122 if (LR == 0) go to 123 call COSGEN (LR,1,FNUM2,0.5,TCOS(KR+1)) 123 CONTINUE call COSGEN (KR,1,FNUM2,0.5,TCOS) call TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W) DO 124 I=1,MR Q(I,J) = Q(I,J)+B(I) 124 CONTINUE KR = KR+I2R go to 141 125 CONTINUE ! ! EVEN NUMBER OF UNKNOWNS ! JP1 = J+I2RBY2 JP2 = J+I2R if (I2R /= 1) go to 129 DO 126 I=1,MR B(I) = Q(I,J) 126 CONTINUE TCOS(1) = 0. call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) IP = 0 IPSTOR = MR DO 127 I=1,MR P(I) = B(I) B(I) = B(I)+Q(I,N) 127 CONTINUE TCOS(1) = -1.+2*(NP/2) TCOS(2) = 0. call TRIX (1,1,MR,A,BB,C,B,TCOS,D,W) DO 128 I=1,MR Q(I,J) = Q(I,JM2)+P(I)+B(I) 128 CONTINUE go to 140 129 CONTINUE DO 130 I=1,MR B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 130 CONTINUE if (NRODPR /= 0) go to 132 DO 131 I=1,MR II = IP+I B(I) = B(I)+P(II) 131 CONTINUE go to 134 132 CONTINUE DO 133 I=1,MR B(I) = B(I)+Q(I,JP2)-Q(I,JP1) 133 CONTINUE 134 CONTINUE call COSGEN (I2R,1,0.5,0.0,TCOS) call TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W) IP = IP+MR IPSTOR = MAX(IPSTOR,IP+MR) DO 135 I=1,MR II = IP+I P(II) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) B(I) = P(II)+Q(I,JP2) 135 CONTINUE if (LR == 0) go to 136 call COSGEN (LR,1,FNUM2,0.5,TCOS(I2R+1)) call S1MERG (TCOS,0,I2R,I2R,LR,KR) go to 138 136 DO 137 I=1,I2R II = KR+I TCOS(II) = TCOS(I) 137 CONTINUE 138 call COSGEN (KR,1,FNUM2,0.5,TCOS) call TRIX (KR,KR,MR,A,BB,C,B,TCOS,D,W) DO 139 I=1,MR II = IP+I Q(I,J) = Q(I,JM2)+P(II)+B(I) 139 CONTINUE 140 CONTINUE LR = KR KR = KR+JR 141 CONTINUE NR = (NLAST-1)/JR+1 if (NR <= 3) go to 142 I2R = JR NRODPR = NROD go to 101 142 CONTINUE ! ! BEGIN SOLUTION ! J = 1+JR JM1 = J-I2R JP1 = J+I2R JM2 = NLAST-I2R if (NR == 2) go to 180 if (LR /= 0) go to 167 if (N /= 3) go to 156 ! ! CASE N = 3. ! go to (143,148,143),NP 143 DO 144 I=1,MR B(I) = Q(I,2) B2(I) = Q(I,1)+Q(I,3) B3(I) = 0. 144 CONTINUE go to (146,146,145),NP 145 TCOS(1) = -1. TCOS(2) = 1. K1 = 1 go to 147 146 TCOS(1) = -2. TCOS(2) = 1. TCOS(3) = -1. K1 = 2 147 K2 = 1 K3 = 0 K4 = 0 go to 150 148 DO 149 I=1,MR B(I) = Q(I,2) B2(I) = Q(I,3) B3(I) = Q(I,1) 149 CONTINUE call COSGEN (3,1,0.5,0.0,TCOS) TCOS(4) = -1. TCOS(5) = 1. TCOS(6) = -1. TCOS(7) = 1. K1 = 3 K2 = 2 K3 = 1 K4 = 1 150 call TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) DO 151 I=1,MR B(I) = B(I)+B2(I)+B3(I) 151 CONTINUE go to (153,153,152),NP 152 TCOS(1) = 2. call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) 153 DO 154 I=1,MR Q(I,2) = B(I) B(I) = Q(I,1)+B(I) 154 CONTINUE TCOS(1) = -1.+4.*FNUM call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 155 I=1,MR Q(I,1) = B(I) 155 CONTINUE JR = 1 I2R = 0 go to 188 ! ! CASE N = 2**P+1 ! 156 CONTINUE DO 157 I=1,MR B(I) = Q(I,J)+Q(I,1)-Q(I,JM1)+Q(I,NLAST)-Q(I,JM2) 157 CONTINUE go to (158,160,158),NP 158 DO 159 I=1,MR B2(I) = Q(I,1)+Q(I,NLAST)+Q(I,J)-Q(I,JM1)-Q(I,JP1) B3(I) = 0. 159 CONTINUE K1 = NLAST-1 K2 = NLAST+JR-1 call COSGEN (JR-1,1,0.0,1.0,TCOS(NLAST)) TCOS(K2) = 2*NP-4 call COSGEN (JR,1,0.5-FNUM,0.5,TCOS(K2+1)) K3 = (3-NP)/2 call S1MERG (TCOS,K1,JR-K3,K2-K3,JR+K3,0) K1 = K1-1+K3 call COSGEN (JR,1,FNUM,0.5,TCOS(K1+1)) K2 = JR K3 = 0 K4 = 0 go to 162 160 DO 161 I=1,MR FI = (Q(I,J)-Q(I,JM1)-Q(I,JP1))/2. B2(I) = Q(I,1)+FI B3(I) = Q(I,NLAST)+FI 161 CONTINUE K1 = NLAST+JR-1 K2 = K1+JR-1 call COSGEN (JR-1,1,0.0,1.0,TCOS(K1+1)) call COSGEN (NLAST,1,0.5,0.0,TCOS(K2+1)) call S1MERG (TCOS,K1,JR-1,K2,NLAST,0) K3 = K1+NLAST-1 K4 = K3+JR call COSGEN (JR,1,0.5,0.5,TCOS(K3+1)) call COSGEN (JR,1,0.0,0.5,TCOS(K4+1)) call S1MERG (TCOS,K3,JR,K4,JR,K1) K2 = NLAST-1 K3 = JR K4 = JR 162 call TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) DO 163 I=1,MR B(I) = B(I)+B2(I)+B3(I) 163 CONTINUE if (NP /= 3) go to 164 TCOS(1) = 2. call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) 164 DO 165 I=1,MR Q(I,J) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) B(I) = Q(I,J)+Q(I,1) 165 CONTINUE call COSGEN (JR,1,FNUM,0.5,TCOS) call TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 166 I=1,MR Q(I,1) = Q(I,1)-Q(I,JM1)+B(I) 166 CONTINUE go to 188 ! ! CASE OF GENERAL N WITH NR = 3 . ! 167 CONTINUE DO 168 I=1,MR B(I) = Q(I,1)-Q(I,JM1)+Q(I,J) 168 CONTINUE if (NROD /= 0) go to 170 DO 169 I=1,MR II = IP+I B(I) = B(I)+P(II) 169 CONTINUE go to 172 170 DO 171 I=1,MR B(I) = B(I)+Q(I,NLAST)-Q(I,JM2) 171 CONTINUE 172 CONTINUE DO 173 I=1,MR T = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) Q(I,J) = T B2(I) = Q(I,NLAST)+T B3(I) = Q(I,1)+T 173 CONTINUE K1 = KR+2*JR call COSGEN (JR-1,1,0.0,1.0,TCOS(K1+1)) K2 = K1+JR TCOS(K2) = 2*NP-4 K4 = (NP-1)*(3-NP) K3 = K2+1-K4 call COSGEN (KR+JR+K4,1,K4/2.,1.-K4,TCOS(K3)) K4 = 1-NP/3 call S1MERG (TCOS,K1,JR-K4,K2-K4,KR+JR+K4,0) if (NP == 3) K1 = K1-1 K2 = KR+JR K4 = K1+K2 call COSGEN (KR,1,FNUM2,0.5,TCOS(K4+1)) K3 = K4+KR call COSGEN (JR,1,FNUM,0.5,TCOS(K3+1)) call S1MERG (TCOS,K4,KR,K3,JR,K1) K4 = K3+JR call COSGEN (LR,1,FNUM2,0.5,TCOS(K4+1)) call S1MERG (TCOS,K3,JR,K4,LR,K1+K2) call COSGEN (KR,1,FNUM2,0.5,TCOS(K3+1)) K3 = KR K4 = KR call TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) DO 174 I=1,MR B(I) = B(I)+B2(I)+B3(I) 174 CONTINUE if (NP /= 3) go to 175 TCOS(1) = 2. call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) 175 DO 176 I=1,MR Q(I,J) = Q(I,J)+B(I) B(I) = Q(I,1)+Q(I,J) 176 CONTINUE call COSGEN (JR,1,FNUM,0.5,TCOS) call TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) if (JR /= 1) go to 178 DO 177 I=1,MR Q(I,1) = B(I) 177 CONTINUE go to 188 178 CONTINUE DO 179 I=1,MR Q(I,1) = Q(I,1)-Q(I,JM1)+B(I) 179 CONTINUE go to 188 180 CONTINUE ! ! CASE OF GENERAL N AND NR = 2 . ! DO 181 I=1,MR II = IP+I B3(I) = 0. B(I) = Q(I,1)+P(II) Q(I,1) = Q(I,1)-Q(I,JM1) B2(I) = Q(I,1)+Q(I,NLAST) 181 CONTINUE K1 = KR+JR K2 = K1+JR call COSGEN (JR-1,1,0.0,1.0,TCOS(K1+1)) go to (182,183,182),NP 182 TCOS(K2) = 2*NP-4 call COSGEN (KR,1,0.0,1.0,TCOS(K2+1)) go to 184 183 call COSGEN (KR+1,1,0.5,0.0,TCOS(K2)) 184 K4 = 1-NP/3 call S1MERG (TCOS,K1,JR-K4,K2-K4,KR+K4,0) if (NP == 3) K1 = K1-1 K2 = KR call COSGEN (KR,1,FNUM2,0.5,TCOS(K1+1)) K4 = K1+KR call COSGEN (LR,1,FNUM2,0.5,TCOS(K4+1)) K3 = LR K4 = 0 call TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) DO 185 I=1,MR B(I) = B(I)+B2(I) 185 CONTINUE if (NP /= 3) go to 186 TCOS(1) = 2. call TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) 186 DO 187 I=1,MR Q(I,1) = Q(I,1)+B(I) 187 CONTINUE 188 CONTINUE ! ! START BACK SUBSTITUTION. ! J = NLAST-JR DO 189 I=1,MR B(I) = Q(I,NLAST)+Q(I,J) 189 CONTINUE JM2 = NLAST-I2R if (JR /= 1) go to 191 DO 190 I=1,MR Q(I,NLAST) = 0. 190 CONTINUE go to 195 191 CONTINUE if (NROD /= 0) go to 193 DO 192 I=1,MR II = IP+I Q(I,NLAST) = P(II) 192 CONTINUE IP = IP-MR go to 195 193 DO 194 I=1,MR Q(I,NLAST) = Q(I,NLAST)-Q(I,JM2) 194 CONTINUE 195 CONTINUE call COSGEN (KR,1,FNUM2,0.5,TCOS) call COSGEN (LR,1,FNUM2,0.5,TCOS(KR+1)) call TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W) DO 196 I=1,MR Q(I,NLAST) = Q(I,NLAST)+B(I) 196 CONTINUE NLASTP = NLAST 197 CONTINUE JSTEP = JR JR = I2R I2R = I2R/2 if (JR == 0) go to 210 JSTART = 1+JR KR = KR-JR if (NLAST+JR > N) go to 198 KR = KR-JR NLAST = NLAST+JR JSTOP = NLAST-JSTEP go to 199 198 CONTINUE JSTOP = NLAST-JR 199 CONTINUE LR = KR-JR call COSGEN (JR,1,0.5,0.0,TCOS) DO 209 J=JSTART,JSTOP,JSTEP JM2 = J-JR JP2 = J+JR if (J /= JR) go to 201 DO 200 I=1,MR B(I) = Q(I,J)+Q(I,JP2) 200 CONTINUE go to 203 201 CONTINUE DO 202 I=1,MR B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) 202 CONTINUE 203 CONTINUE if (JR /= 1) go to 205 DO 204 I=1,MR Q(I,J) = 0. 204 CONTINUE go to 207 205 CONTINUE JM1 = J-I2R JP1 = J+I2R DO 206 I=1,MR Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) 206 CONTINUE 207 CONTINUE call TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 208 I=1,MR Q(I,J) = Q(I,J)+B(I) 208 CONTINUE 209 CONTINUE NROD = 1 if (NLAST+I2R <= N) NROD = 0 if (NLASTP /= NLAST) go to 188 go to 197 210 CONTINUE ! ! return STORAGE REQUIREMENTS FOR P VECTORS. ! W(1) = IPSTOR return end subroutine PPADD (N, IERROR, A, C, CBP, BP, BH) ! !! PPADD is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PPADD-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! PPADD computes the eigenvalues of the periodic tridiagonal matrix ! with coefficients AN,BN,CN. ! ! N is the order of the BH and BP polynomials. ! BP contains the eigenvalues on output. ! CBP is the same as BP except type complex. ! BH is used to temporarily store the roots of the B HAT polynomial ! which enters through BP. ! !***SEE ALSO BLKTRI !***ROUTINES CALLED BSRH, PPSGF, PPSPF, PSGF !***COMMON BLOCKS CBLKT !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PPADD ! COMPLEX CX ,FSG ,HSG , & DD ,F ,FP ,FPP , & CDIS ,R1 ,R2 ,R3 , & CBP DIMENSION A(*) ,C(*) ,BP(*) ,BH(*) , & CBP(*) COMMON /CBLKT/ NPP ,K ,EPS ,CNV , & NM ,NCMPLX ,IK EXTERNAL PSGF ,PPSPF ,PPSGF !***FIRST EXECUTABLE STATEMENT PPADD SCNV = SQRT(CNV) IZ = N if (BP(N)-BP(1)) 101,142,103 101 DO 102 J=1,N NT = N-J BH(J) = BP(NT+1) 102 CONTINUE go to 105 103 DO 104 J=1,N BH(J) = BP(J) 104 CONTINUE 105 NCMPLX = 0 MODIZ = MOD(IZ,2) IS = 1 if (MODIZ) 106,107,106 106 if (A(1)) 110,142,107 107 XL = BH(1) DB = BH(3)-BH(1) 108 XL = XL-DB if (PSGF(XL,IZ,C,A,BH)) 108,108,109 109 SGN = -1. CBP(1) = CMPLX(BSRH(XL,BH(1),IZ,C,A,BH,PSGF,SGN),0.) IS = 2 110 if = IZ-1 if (MODIZ) 111,112,111 111 if (A(1)) 112,142,115 112 XR = BH(IZ) DB = BH(IZ)-BH(IZ-2) 113 XR = XR+DB if (PSGF(XR,IZ,C,A,BH)) 113,114,114 114 SGN = 1. CBP(IZ) = CMPLX(BSRH(BH(IZ),XR,IZ,C,A,BH,PSGF,SGN),0.) if = IZ-2 115 DO 136 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) 118,118,116 116 if (PSG*PPSGF(XM,IZ,C,A,BH)) 117,118,119 ! ! CASE OF A REAL ZERO ! 117 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 136 ! ! CASE OF A MULTIPLE ZERO ! 118 CBP(IG) = CMPLX(XM,0.) CBP(IG+1) = CMPLX(XM,0.) go to 136 ! ! CASE OF A COMPLEX ZERO ! 119 IT = 0 ICV = 0 CX = CMPLX(XM,0.) 120 FSG = (1.,0.) HSG = (1.,0.) FP = (0.,0.) FPP = (0.,0.) DO 121 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 121 CONTINUE if (MODIZ) 123,122,123 122 F = (1.,0.)-FSG-HSG go to 124 123 F = (1.,0.)+FSG+HSG 124 I3 = 0 if (ABS(FP)) 126,126,125 125 I3 = 1 R3 = -F/FP 126 if (ABS(FPP)) 132,132,127 127 CDIS = SQRT(FP**2-2.*F*FPP) R1 = CDIS-FP R2 = -FP-CDIS if (ABS(R1)-ABS(R2)) 129,129,128 128 R1 = R1/FPP go to 130 129 R1 = R2/FPP 130 R2 = 2.*F/FPP/R1 if (ABS(R2) < ABS(R1)) R1 = R2 if (I3) 133,133,131 131 if (ABS(R3) < ABS(R1)) R1 = R3 go to 133 132 R1 = R3 133 CX = CX+R1 IT = IT+1 if (IT > 50) go to 142 if (ABS(R1) > SCNV) go to 120 if (ICV) 134,134,135 134 ICV = 1 go to 120 135 CBP(IG) = CX CBP(IG+1) = CONJG(CX) 136 CONTINUE if (ABS(CBP(N))-ABS(CBP(1))) 137,142,139 137 NHALF = N/2 DO 138 J=1,NHALF NT = N-J CX = CBP(J) CBP(J) = CBP(NT+1) CBP(NT+1) = CX 138 CONTINUE 139 NCMPLX = 1 DO 140 J=2,IZ if (AIMAG(CBP(J))) 143,140,143 140 CONTINUE NCMPLX = 0 DO 141 J=2,IZ BP(J) = REAL(CBP(J)) 141 CONTINUE go to 143 142 IERROR = 4 143 CONTINUE return end subroutine PPGQ8 (FUN, LDC, C, XI, LXI, KK, ID, A, B, INPPV, ERR, & ANS, IERR) ! !! PPGQ8 is subsidiary to PFQAD. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PPGQ8-S, DPPGQ8-D) !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! PPGQ8, a modification of GAUS8, integrates the ! product of FUN(X) by the ID-th derivative of a spline ! PPVAL(LDC,C,XI,LXI,KK,ID,X,INPPV) between limits A and B. ! ! Description of arguments ! ! INPUT-- ! FUN - Name of external function of one argument which ! multiplies PPVAL. ! LDC - Leading dimension of matrix C, LDC >= KK ! C - Matrix of Taylor derivatives of dimension at least ! (K,LXI) ! XI - Breakpoint vector of length LXI+1 ! LXI - Number of polynomial pieces ! KK - Order of the spline, KK >= 1 ! ID - Order of the spline derivative, 0 <= ID <= KK-1 ! A - Lower limit of integral ! B - Upper limit of integral (may be less than A) ! INPPV- Initialization parameter for PPVAL ! ERR - Is a requested pseudorelative error tolerance. Normally ! pick a value of ABS(ERR) < 1E-3. ANS will normally ! have no more error than ABS(ERR) times the integral of ! the absolute value of FUN(X)*PPVAL(LDC,C,XI,LXI,KK,ID,X, ! INPPV). ! ! OUTPUT-- ! ERR - Will be an estimate of the absolute error in ANS if the ! input value of ERR was negative. (ERR is unchanged if ! the input value of ERR was nonnegative.) The estimated ! error is solely for information to the user and should ! not be used as a correction to the computed integral. ! ANS - Computed value of integral ! IERR- A status code ! --Normal codes ! 1 ANS most likely meets requested error tolerance, ! or A=B. ! -1 A and B ARE too nearly equal to allow normal ! integration. ANS is set to zero. ! --Abnormal code ! 2 ANS probably does not meet requested error tolerance. ! !***SEE ALSO PFQAD !***ROUTINES CALLED I1MACH, PPVAL, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE PPGQ8 ! INTEGER ID,IERR,INPPV,K,KK,KML,KMX,L,LDC,LMN,LMX,LR,LXI,MXL, & NBITS, NIB, NLMN, NLMX INTEGER I1MACH REAL A,AA,AE,ANIB, ANS,AREA,B, BE,C,CC,EE, EF, EPS, ERR, & EST,GL,GLR,GR,HH,SQ2,TOL,VL,VR,W1, W2, W3, W4, XI, X1, & X2, X3, X4, X, H REAL R1MACH, PPVAL, G8, FUN DIMENSION XI(*), C(LDC,*) DIMENSION AA(30), HH(30), LR(30), VL(30), GR(30) SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, NLMN, KMX, KML DATA X1, X2, X3, X4/ & 1.83434642495649805E-01, 5.25532409916328986E-01, & 7.96666477413626740E-01, 9.60289856497536232E-01/ DATA W1, W2, W3, W4/ & 3.62683783378361983E-01, 3.13706645877887287E-01, & 2.22381034453374471E-01, 1.01228536290376259E-01/ DATA SQ2/1.41421356E0/ DATA NLMN/1/,KMX/5000/,KML/6/ G8(X,H)=H*((W1*(FUN(X-X1*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X-X1*H,INPPV) & +FUN(X+X1*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X+X1*H,INPPV)) & +W2*(FUN(X-X2*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X-X2*H,INPPV) & +FUN(X+X2*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X+X2*H,INPPV))) & +(W3*(FUN(X-X3*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X-X3*H,INPPV) & +FUN(X+X3*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X+X3*H,INPPV)) & +W4*(FUN(X-X4*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X-X4*H,INPPV) & +FUN(X+X4*H)*PPVAL(LDC,C,XI,LXI,KK,ID,X+X4*H,INPPV)))) ! ! INITIALIZE ! !***FIRST EXECUTABLE STATEMENT PPGQ8 K = I1MACH(11) ANIB = R1MACH(5)*K/0.30102000E0 NBITS = INT(ANIB) NLMX = (NBITS*5)/8 ANS = 0.0E0 IERR = 1 BE = 0.0E0 if (A == B) go to 140 LMX = NLMX LMN = NLMN if (B == 0.0E0) go to 10 if (SIGN(1.0E0,B)*A <= 0.0E0) go to 10 CC = ABS(1.0E0-A/B) if (CC > 0.1E0) go to 10 if (CC <= 0.0E0) go to 140 ANIB = 0.5E0 - LOG(CC)/0.69314718E0 NIB = INT(ANIB) LMX = MIN(NLMX,NBITS-NIB-7) if (LMX < 1) go to 130 LMN = MIN(LMN,LMX) 10 TOL = MAX(ABS(ERR),2.0E0**(5-NBITS))/2.0E0 if (ERR == 0.0E0) TOL = SQRT(R1MACH(4)) EPS = TOL HH(1) = (B-A)/4.0E0 AA(1) = A LR(1) = 1 L = 1 EST = G8(AA(L)+2.0E0*HH(L),2.0E0*HH(L)) K = 8 AREA = ABS(EST) EF = 0.5E0 MXL = 0 ! ! COMPUTE REFINED ESTIMATES, ESTIMATE THE ERROR, ETC. ! 20 GL = G8(AA(L)+HH(L),HH(L)) GR(L) = G8(AA(L)+3.0E0*HH(L),HH(L)) K = K + 16 AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST)) GLR = GL + GR(L) EE = ABS(EST-GLR)*EF AE = MAX(EPS*AREA,TOL*ABS(GLR)) if (EE-AE) 40, 40, 50 30 MXL = 1 40 BE = BE + (EST-GLR) if (LR(L)) 60, 60, 80 ! ! CONSIDER THE LEFT HALF OF THIS LEVEL ! 50 if (K > KMX) LMX = KML if (L >= LMX) go to 30 L = L + 1 EPS = EPS*0.5E0 EF = EF/SQ2 HH(L) = HH(L-1)*0.5E0 LR(L) = -1 AA(L) = AA(L-1) EST = GL go to 20 ! ! PROCEED TO RIGHT HALF AT THIS LEVEL ! 60 VL(L) = GLR 70 EST = GR(L-1) LR(L) = 1 AA(L) = AA(L) + 4.0E0*HH(L) go to 20 ! ! return ONE LEVEL ! 80 VR = GLR 90 if (L <= 1) go to 120 L = L - 1 EPS = EPS*2.0E0 EF = EF*SQ2 if (LR(L)) 100, 100, 110 100 VL(L) = VL(L+1) + VR go to 70 110 VR = VL(L+1) + VR go to 90 ! ! EXIT ! 120 ANS = VR if ((MXL == 0) .OR. (ABS(BE) <= 2.0E0*TOL*AREA)) go to 140 IERR = 2 call XERMSG ('SLATEC', 'PPGQ8', & 'ANS IS PROBABLY INSUFFICIENTLY ACCURATE.', 3, 1) go to 140 130 IERR = -1 call XERMSG ('SLATEC', 'PPGQ8', & 'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL INTEGRATION. ' // & 'ANS IS SET TO ZERO AND IERR TO -1.', 1, -1) 140 CONTINUE if (ERR < 0.0E0) ERR = BE return end function PPGSF (X, IZ, C, A, BH) ! !! PPGSF is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PPGSF-S) !***AUTHOR (UNKNOWN) !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PPGSF DIMENSION A(*) ,C(*) ,BH(*) !***FIRST EXECUTABLE STATEMENT PPGSF SUM = 0. DO 101 J=1,IZ SUM = SUM-1./(X-BH(J))**2 101 CONTINUE PPGSF = SUM return end function PPPSF (X, IZ, C, A, BH) ! !! PPPSF is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PPPSF-S) !***AUTHOR (UNKNOWN) !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PPPSF DIMENSION A(*) ,C(*) ,BH(*) !***FIRST EXECUTABLE STATEMENT PPPSF SUM = 0. DO 101 J=1,IZ SUM = SUM+1./(X-BH(J)) 101 CONTINUE PPPSF = SUM return end subroutine PPQAD (LDC, C, XI, LXI, K, X1, X2, PQUAD) ! !! PPQAD computes the integral on (X1,X2) of a K-th order B-spline ... ! using the piecewise polynomial (PP) representation. ! !***LIBRARY SLATEC !***CATEGORY H2A2A1, E3, K6 !***TYPE SINGLE PRECISION (PPQAD-S, DPPQAD-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Abstract ! PPQAD computes the integral on (X1,X2) of a K-th order ! B-spline using the piecewise polynomial representation ! (C,XI,LXI,K). Here the Taylor expansion about the left ! end point XI(J) of the J-th interval is integrated and ! evaluated on subintervals of (X1,X2) which are formed by ! included break points. Integration outside (XI(1),XI(LXI+1)) ! is permitted. ! ! Description of Arguments ! Input ! LDC - leading dimension of matrix C, LDC >= K ! C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI ! XI(*) - break point array of length LXI+1 ! LXI - number of polynomial pieces ! K - order of B-spline, K >= 1 ! X1,X2 - end points of quadrature interval, normally in ! XI(1) <= X <= XI(LXI+1) ! ! Output ! PQUAD - integral of the PP representation over (X1,X2) ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES D. E. Amos, Quadrature subroutines for splines and ! B-splines, Report SAND79-1825, Sandia Laboratories, ! December 1979. !***ROUTINES CALLED INTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE PPQAD ! INTEGER I, II, IL, ILO, IL1, IL2, IM, K, LDC, LEFT, LXI, MF1, MF2 REAL A, AA, BB, C, DX, FLK, PQUAD, Q, S, SS, TA, TB, X, XI, X1, X2 DIMENSION XI(*), C(LDC,*), SS(2) ! !***FIRST EXECUTABLE STATEMENT PPQAD PQUAD = 0.0E0 if ( K < 1) go to 100 if ( LXI < 1) go to 105 if ( LDC < K) go to 110 AA = MIN(X1,X2) BB = MAX(X1,X2) if (AA == BB) RETURN ILO = 1 call INTRV(XI, LXI, AA, ILO, IL1, MF1) call INTRV(XI, LXI, BB, ILO, IL2, MF2) Q = 0.0E0 DO 40 LEFT=IL1,IL2 TA = XI(LEFT) A = MAX(AA,TA) if (LEFT == 1) A = AA TB = BB if (LEFT < LXI) TB = XI(LEFT+1) X = MIN(BB,TB) DO 30 II=1,2 SS(II) = 0.0E0 DX = X - XI(LEFT) if (DX == 0.0E0) go to 20 S = C(K,LEFT) FLK = K IM = K - 1 IL = IM DO 10 I=1,IL S = S*DX/FLK + C(IM,LEFT) IM = IM - 1 FLK = FLK - 1.0E0 10 CONTINUE SS(II) = S*DX 20 CONTINUE X = A 30 CONTINUE Q = Q + (SS(1)-SS(2)) 40 CONTINUE if (X1 > X2) Q = -Q PQUAD = Q return ! ! 100 CONTINUE call XERMSG ('SLATEC', 'PPQAD', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 105 CONTINUE call XERMSG ('SLATEC', 'PPQAD', 'LXI DOES NOT SATISFY LXI >= 1', & 2, 1) return 110 CONTINUE call XERMSG ('SLATEC', 'PPQAD', 'LDC DOES NOT SATISFY LDC >= K', & 2, 1) return end function PPSGF (X, IZ, C, A, BH) ! !! PPSGF is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PPSGF-S) !***AUTHOR (UNKNOWN) !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PPSGF DIMENSION A(*) ,C(*) ,BH(*) !***FIRST EXECUTABLE STATEMENT PPSGF SUM = 0. DO 101 J=1,IZ SUM = SUM-1./(X-BH(J))**2 101 CONTINUE PPSGF = SUM return end function PPSPF (X, IZ, C, A, BH) ! !! PPSPF is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PPSPF-S) !***AUTHOR (UNKNOWN) !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PPSPF DIMENSION A(*) ,C(*) ,BH(*) !***FIRST EXECUTABLE STATEMENT PPSPF SUM = 0. DO 101 J=1,IZ SUM = SUM+1./(X-BH(J)) 101 CONTINUE PPSPF = SUM return end function PPVAL (LDC, C, XI, LXI, K, IDERIV, X, INPPV) ! !! PPVAL calculates the value of the IDERIV-th derivative of the B-spline ... ! from the PP-representation. ! !***LIBRARY SLATEC !***CATEGORY E3, K6 !***TYPE SINGLE PRECISION (PPVAL-S, DPPVAL-D) !***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! Written by Carl de Boor and modified by D. E. Amos ! ! Abstract ! PPVAL is the PPVALU function of the reference. ! ! PPVAL calculates (at X) the value of the IDERIV-th ! derivative of the B-spline from the PP-representation ! (C,XI,LXI,K). The Taylor expansion about XI(J) for X in ! the interval XI(J) <= X < XI(J+1) is evaluated, J=1,LXI. ! Right limiting values at X=XI(J) are obtained. PPVAL will ! extrapolate beyond XI(1) and XI(LXI+1). ! ! To obtain left limiting values (left derivatives) at XI(J), ! replace LXI by J-1 and set X=XI(J),J=2,LXI+1. ! ! Description of Arguments ! Input ! LDC - leading dimension of C matrix, LDC >= K ! C - matrix of dimension at least (K,LXI) containing ! right derivatives at break points XI(*). ! XI - break point vector of length LXI+1 ! LXI - number of polynomial pieces ! K - order of B-spline, K >= 1 ! IDERIV - order of the derivative, 0 <= IDERIV <= K-1 ! IDERIV=0 gives the B-spline value ! X - argument, XI(1) <= X <= XI(LXI+1) ! INPPV - an initialization parameter which must be set ! to 1 the first time PPVAL is called. ! ! Output ! INPPV - INPPV contains information for efficient process- ! ing after the initial call and INPPV must not ! be changed by the user. Distinct splines require ! distinct INPPV parameters. ! PPVAL - value of the IDERIV-th derivative at X ! ! Error Conditions ! Improper input is a fatal error ! !***REFERENCES Carl de Boor, Package for calculating with B-splines, ! SIAM Journal on Numerical Analysis 14, 3 (June 1977), ! pp. 441-472. !***ROUTINES CALLED INTRV, XERMSG !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE PPVAL ! INTEGER I, IDERIV, INPPV, J, K, LDC, LXI, NDUMMY REAL C, DX, FLTK, X, XI DIMENSION XI(*), C(LDC,*) !***FIRST EXECUTABLE STATEMENT PPVAL PPVAL = 0.0E0 if ( K < 1) go to 90 if ( LDC < K) go to 80 if ( LXI < 1) go to 85 if ( IDERIV < 0 .OR. IDERIV >= K) go to 95 I = K - IDERIV FLTK = I call INTRV(XI, LXI, X, INPPV, I, NDUMMY) DX = X - XI(I) J = K 10 PPVAL = (PPVAL/FLTK)*DX + C(J,I) J = J - 1 FLTK = FLTK - 1.0E0 if (FLTK > 0.0E0) go to 10 return ! ! 80 CONTINUE call XERMSG ('SLATEC', 'PPVAL', 'LDC DOES NOT SATISFY LDC >= K', & 2, 1) return 85 CONTINUE call XERMSG ('SLATEC', 'PPVAL', 'LXI DOES NOT SATISFY LXI >= 1', & 2, 1) return 90 CONTINUE call XERMSG ('SLATEC', 'PPVAL', 'K DOES NOT SATISFY K >= 1', 2, & 1) return 95 CONTINUE call XERMSG ('SLATEC', 'PPVAL', & 'IDERIV DOES NOT SATISFY 0 <= IDERIV < K', 2, 1) return end subroutine PROC (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, & B, C, D, W, U) ! !! PROC is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE COMPLEX (PROD-S, PROC-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! PROC applies a sequence of matrix operations to the vector X and ! stores the result in Y. ! BD,BM1,BM2 are arrays containing roots of certain B polynomials. ! ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. ! AA Array containing scalar multipliers of the vector X. ! NA is the length of the array AA. ! X,Y The matrix operations are applied to X and the result is Y. ! A,B,C are arrays which contain the tridiagonal matrix. ! M is the order of the matrix. ! D,W,U are working arrays. ! IS determines whether or not a change in sign is made. ! !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PROC ! DIMENSION A(*) ,B(*) ,C(*) ,X(*) , & Y(*) ,D(*) ,W(*) ,BD(*) , & BM1(*) ,BM2(*) ,AA(*) ,U(*) COMPLEX X ,Y ,A ,B , & C ,D ,W ,U , & DEN !***FIRST EXECUTABLE STATEMENT PROC DO 101 J=1,M W(J) = X(J) Y(J) = W(J) 101 CONTINUE MM = M-1 ID = ND IBR = 0 M1 = NM1 M2 = NM2 IA = NA 102 if (IA) 105,105,103 103 RT = AA(IA) if (ND == 0) RT = -RT IA = IA-1 ! ! SCALAR MULTIPLICATION ! DO 104 J=1,M Y(J) = RT*W(J) 104 CONTINUE 105 if (ID) 125,125,106 106 RT = BD(ID) ID = ID-1 if (ID == 0) IBR = 1 ! ! BEGIN SOLUTION TO SYSTEM ! D(M) = A(M)/(B(M)-RT) W(M) = Y(M)/(B(M)-RT) DO 107 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 107 CONTINUE DEN = B(1)-RT-C(1)*D(2) W(1) = (1.,0.) if (ABS(DEN)) 108,109,108 108 W(1) = (Y(1)-C(1)*W(2))/DEN 109 DO 110 J=2,M W(J) = W(J)-D(J)*W(J-1) 110 CONTINUE if (NA) 113,113,102 111 DO 112 J=1,M Y(J) = W(J) 112 CONTINUE IBR = 1 go to 102 113 if (M1) 114,114,115 114 if (M2) 111,111,120 115 if (M2) 117,117,116 116 if (ABS(BM1(M1))-ABS(BM2(M2))) 120,120,117 117 if (IBR) 118,118,119 118 if (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 111,119,119 119 RT = RT-BM1(M1) M1 = M1-1 go to 123 120 if (IBR) 121,121,122 121 if (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 111,122,122 122 RT = RT-BM2(M2) M2 = M2-1 123 DO 124 J=1,M Y(J) = Y(J)+RT*W(J) 124 CONTINUE go to 102 125 RETURN end subroutine PROCP (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, & B, C, D, U, W) ! !! PROCP is subsidiary to CBLKTR. ! !***LIBRARY SLATEC !***TYPE COMPLEX (PRODP-C, PROCP-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! PROCP applies a sequence of matrix operations to the vector X and ! stores the result in Y (periodic boundary conditions). ! ! BD,BM1,BM2 are arrays containing roots of certain B polynomials. ! ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. ! AA Array containing scalar multipliers of the vector X. ! NA is the length of the array AA. ! X,Y The matrix operations are applied to X and the result is Y. ! A,B,C are arrays which contain the tridiagonal matrix. ! M is the order of the matrix. ! D,U,W are working arrays. ! IS determines whether or not a change in sign is made. ! !***SEE ALSO CBLKTR !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PROCP ! DIMENSION A(*) ,B(*) ,C(*) ,X(*) , & Y(*) ,D(*) ,U(*) ,BD(*) , & BM1(*) ,BM2(*) ,AA(*) ,W(*) COMPLEX X ,Y ,A ,B , & C ,D ,U ,W , & DEN ,YM ,V ,BH ,AM !***FIRST EXECUTABLE STATEMENT PROCP DO 101 J=1,M Y(J) = X(J) W(J) = Y(J) 101 CONTINUE MM = M-1 MM2 = M-2 ID = ND IBR = 0 M1 = NM1 M2 = NM2 IA = NA 102 if (IA) 105,105,103 103 RT = AA(IA) if (ND == 0) RT = -RT IA = IA-1 DO 104 J=1,M Y(J) = RT*W(J) 104 CONTINUE 105 if (ID) 128,128,106 106 RT = BD(ID) ID = ID-1 if (ID == 0) IBR = 1 ! ! BEGIN SOLUTION TO SYSTEM ! 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) 109,107,107 107 DO 108 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) 108 CONTINUE 109 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 (ABS(DEN)) 110,111,110 110 W(M) = (YM-AM*W(M-1))/DEN go to 112 111 W(M) = (1.,0.) 112 W(M-1) = W(M-1)-D(M-1)*W(M) DO 113 J=2,MM K = M-J W(K) = W(K)-D(K)*W(K+1)-U(K)*W(M) 113 CONTINUE if (NA) 116,116,102 114 DO 115 J=1,M Y(J) = W(J) 115 CONTINUE IBR = 1 go to 102 116 if (M1) 117,117,118 117 if (M2) 114,114,123 118 if (M2) 120,120,119 119 if (ABS(BM1(M1))-ABS(BM2(M2))) 123,123,120 120 if (IBR) 121,121,122 121 if (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 114,122,122 122 RT = RT-BM1(M1) M1 = M1-1 go to 126 123 if (IBR) 124,124,125 124 if (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 114,125,125 125 RT = RT-BM2(M2) M2 = M2-1 126 DO 127 J=1,M Y(J) = Y(J)+RT*W(J) 127 CONTINUE go to 102 128 RETURN end subroutine PROD (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, & B, C, D, W, U) ! !! PROD is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PROD-S, PROC-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! PROD applies a sequence of matrix operations to the vector X and ! stores the result in Y. ! ! BD,BM1,BM2 are arrays containing roots of certain B polynomials. ! ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. ! AA Array containing scalar multipliers of the vector X. ! NA is the length of the array AA. ! X,Y The matrix operations are applied to X and the result is Y. ! A,B,C are arrays which contain the tridiagonal matrix. ! M is the order of the matrix. ! D,W,U are working arrays. ! IS determines whether or not a change in sign is made. ! !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PROD ! DIMENSION A(*) ,B(*) ,C(*) ,X(*) , & Y(*) ,D(*) ,W(*) ,BD(*) , & BM1(*) ,BM2(*) ,AA(*) ,U(*) !***FIRST EXECUTABLE STATEMENT PROD DO 101 J=1,M W(J) = X(J) Y(J) = W(J) 101 CONTINUE MM = M-1 ID = ND IBR = 0 M1 = NM1 M2 = NM2 IA = NA 102 if (IA) 105,105,103 103 RT = AA(IA) if (ND == 0) RT = -RT IA = IA-1 ! ! SCALAR MULTIPLICATION ! DO 104 J=1,M Y(J) = RT*W(J) 104 CONTINUE 105 if (ID) 125,125,106 106 RT = BD(ID) ID = ID-1 if (ID == 0) IBR = 1 ! ! BEGIN SOLUTION TO SYSTEM ! D(M) = A(M)/(B(M)-RT) W(M) = Y(M)/(B(M)-RT) DO 107 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 107 CONTINUE DEN = B(1)-RT-C(1)*D(2) W(1) = 1. if (DEN) 108,109,108 108 W(1) = (Y(1)-C(1)*W(2))/DEN 109 DO 110 J=2,M W(J) = W(J)-D(J)*W(J-1) 110 CONTINUE if (NA) 113,113,102 111 DO 112 J=1,M Y(J) = W(J) 112 CONTINUE IBR = 1 go to 102 113 if (M1) 114,114,115 114 if (M2) 111,111,120 115 if (M2) 117,117,116 116 if (ABS(BM1(M1))-ABS(BM2(M2))) 120,120,117 117 if (IBR) 118,118,119 118 if (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 111,119,119 119 RT = RT-BM1(M1) M1 = M1-1 go to 123 120 if (IBR) 121,121,122 121 if (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 111,122,122 122 RT = RT-BM2(M2) M2 = M2-1 123 DO 124 J=1,M Y(J) = Y(J)+RT*W(J) 124 CONTINUE go to 102 125 RETURN end subroutine PRODP (ND, BD, NM1, BM1, NM2, BM2, NA, AA, X, Y, M, A, & B, C, D, U, W) ! !! PRODP is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PRODP-S, PROCP-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! PRODP applies a sequence of matrix operations to the vector X and ! stores the result in Y (periodic boundary conditions). ! ! BD,BM1,BM2 are arrays containing roots of certain B polynomials. ! ND,NM1,NM2 are the lengths of the arrays BD,BM1,BM2 respectively. ! AA Array containing scalar multipliers of the vector X. ! NA is the length of the array AA. ! X,Y The matrix operations are applied to X and the result is Y. ! A,B,C are arrays which contain the tridiagonal matrix. ! M is the order of the matrix. ! D,W,U are working arrays. ! IS determines whether or not a change in sign is made. ! !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PRODP ! DIMENSION A(*) ,B(*) ,C(*) ,X(*) , & Y(*) ,D(*) ,U(*) ,BD(*) , & BM1(*) ,BM2(*) ,AA(*) ,W(*) !***FIRST EXECUTABLE STATEMENT PRODP DO 101 J=1,M Y(J) = X(J) W(J) = Y(J) 101 CONTINUE MM = M-1 MM2 = M-2 ID = ND IBR = 0 M1 = NM1 M2 = NM2 IA = NA 102 if (IA) 105,105,103 103 RT = AA(IA) if (ND == 0) RT = -RT IA = IA-1 DO 104 J=1,M Y(J) = RT*W(J) 104 CONTINUE 105 if (ID) 128,128,106 106 RT = BD(ID) ID = ID-1 if (ID == 0) IBR = 1 ! ! BEGIN SOLUTION TO SYSTEM ! 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) 109,107,107 107 DO 108 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) 108 CONTINUE 109 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) 110,111,110 110 W(M) = (YM-AM*W(M-1))/DEN go to 112 111 W(M) = 1. 112 W(M-1) = W(M-1)-D(M-1)*W(M) DO 113 J=2,MM K = M-J W(K) = W(K)-D(K)*W(K+1)-U(K)*W(M) 113 CONTINUE if (NA) 116,116,102 114 DO 115 J=1,M Y(J) = W(J) 115 CONTINUE IBR = 1 go to 102 116 if (M1) 117,117,118 117 if (M2) 114,114,123 118 if (M2) 120,120,119 119 if (ABS(BM1(M1))-ABS(BM2(M2))) 123,123,120 120 if (IBR) 121,121,122 121 if (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 114,122,122 122 RT = RT-BM1(M1) M1 = M1-1 go to 126 123 if (IBR) 124,124,125 124 if (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 114,125,125 125 RT = RT-BM2(M2) M2 = M2-1 126 DO 127 J=1,M Y(J) = Y(J)+RT*W(J) 127 CONTINUE go to 102 128 RETURN end function PRVEC (M, U, V) ! !! PRVEC is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PRVEC-S, DPRVEC-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This subroutine computes the inner product of a vector U ! with the imaginary product or mate vector corresponding to V ! !***SEE ALSO BVSUP !***ROUTINES CALLED SDOT !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE PRVEC ! DIMENSION U(*),V(*) !***FIRST EXECUTABLE STATEMENT PRVEC N=M/2 NP=N+1 VP=SDOT(N,U(1),1,V(NP),1) PRVEC=SDOT(N,U(NP),1,V(1),1) - VP return end subroutine PRWPGE (KEY, IPAGE, LPG, SX, IX) ! !! PRWPGE is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PRWPGE-S, DPRWPG-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! PRWPGE LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. ! VIRTUAL MEMORY PAGE READ/WRITE SUBROUTINE. ! ! DEPENDING ON THE VALUE OF KEY, SUBROUTINE PRWPGE() PERFORMS A PAGE ! READ OR WRITE OF PAGE IPAGE. THE PAGE HAS LENGTH LPG. ! ! KEY IS A FLAG INDICATING WHETHER A PAGE READ OR WRITE IS ! TO BE PERFORMED. ! if KEY = 1 DATA IS READ. ! if KEY = 2 DATA IS WRITTEN. ! IPAGE IS THE PAGE NUMBER OF THE MATRIX TO BE ACCESSED. ! LPG IS THE LENGTH OF THE PAGE OF THE MATRIX TO BE ACCESSED. ! SX(*),IX(*) IS THE MATRIX TO BE ACCESSED. ! ! THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWPGE, ! SANDIA LABS. REPT. SAND78-0785. ! MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON ! REVISED 811130-1000 ! REVISED YYMMDD-HHMM ! !***SEE ALSO SPLP !***ROUTINES CALLED PRWVIR, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Fixed error messages and replaced GOTOs with ! IF-THEN-ELSE. (RWC) ! 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) !***END PROLOGUE PRWPGE REAL SX(*) DIMENSION IX(*) !***FIRST EXECUTABLE STATEMENT PRWPGE ! ! CHECK if IPAGE IS IN RANGE. ! if (IPAGE < 1) THEN call XERMSG ('SLATEC', 'PRWPGE', & 'THE VALUE OF IPAGE (PAGE NUMBER) WAS NOT IN THE RANGE' // & '1 <= IPAGE <= MAXPGE.', 55, 1) end if ! ! CHECK if LPG IS POSITIVE. ! if (LPG <= 0) THEN call XERMSG ('SLATEC', 'PRWPGE', & 'THE VALUE OF LPG (PAGE LENGTH) WAS NONPOSITIVE.', 55, 1) end if ! ! DECIDE if WE ARE READING OR WRITING. ! if (KEY == 1) THEN ! ! CODE TO DO A PAGE READ. ! call PRWVIR(KEY,IPAGE,LPG,SX,IX) ELSE if (KEY == 2) THEN ! ! CODE TO DO A PAGE WRITE. ! call PRWVIR(KEY,IPAGE,LPG,SX,IX) ELSE call XERMSG ('SLATEC', 'PRWPGE', & 'THE VALUE OF KEY (READ-WRITE FLAG) WAS NOT 1 OR 2.', 55, 1) end if return end subroutine PRWVIR (KEY, IPAGE, LPG, SX, IX) ! !! PRWVIR is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PRWVIR-S, DPRWVR-D) !***AUTHOR Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! PRWVIR LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SPARSE MATRIX ! STORAGE SCHEME. THE PAGE STORAGE IS ON RANDOM ACCESS DISK. ! PRWVIR IS PART OF THE SPARSE LP PACKAGE, SPLP. ! ! KEY IS A FLAG WHICH INDICATES WHETHER A READ OR WRITE ! OPERATION IS TO BE PERFORMED. A VALUE OF KEY=1 INDICATES ! A READ. A VALUE OF KEY=2 INDICATES A WRITE. ! IPAGE IS THE PAGE OF MATRIX MN WE ARE ACCESSING. ! LPG IS THE LENGTH OF THE PAGE. ! SX(*),IX(*) IS THE MATRIX DATA. ! ! THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWVIR, ! SANDIA LABS. REPT. SAND78-0785. ! MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON ! !***SEE ALSO SPLP !***ROUTINES CALLED SOPENM, SREADP, SWRITP !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 891009 Removed unreferenced variables. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) !***END PROLOGUE PRWVIR DIMENSION IX(*) REAL SX(*),ZERO,ONE LOGICAL FIRST SAVE ZERO, ONE DATA ZERO,ONE/0.E0,1.E0/ !***FIRST EXECUTABLE STATEMENT PRWVIR ! ! COMPUTE STARTING ADDRESS OF PAGE. ! IPAGEF=SX(3) ISTART = IX(3) + 5 ! ! OPEN RANDOM ACCESS FILE NUMBER IPAGEF, if FIRST PAGE WRITE. ! FIRST=SX(4) == ZERO if (.NOT.(FIRST)) go to 20002 call SOPENM(IPAGEF,LPG) SX(4)=ONE ! ! PERFORM EITHER A READ OR A WRITE. ! 20002 IADDR = 2*IPAGE - 1 if (.NOT.(KEY == 1)) go to 20005 call SREADP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR) go to 20006 20005 if (.NOT.(KEY == 2)) go to 10001 call SWRITP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR) 10001 CONTINUE 20006 RETURN end function PSGF (X, IZ, C, A, BH) ! !! PSGF is subsidiary to BLKTRI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PSGF-S) !***AUTHOR (UNKNOWN) !***SEE ALSO BLKTRI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PSGF DIMENSION A(*) ,C(*) ,BH(*) !***FIRST EXECUTABLE STATEMENT PSGF FSG = 1. HSG = 1. DO 101 J=1,IZ DD = 1./(X-BH(J)) FSG = FSG*A(J)*DD HSG = HSG*C(J)*DD 101 CONTINUE if (MOD(IZ,2)) 103,102,103 102 PSGF = 1.-FSG-HSG return 103 PSGF = 1.+FSG+HSG return end function PSI (X) ! !! PSI computes the Psi (or Digamma) function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7C !***TYPE SINGLE PRECISION (PSI-S, DPSI-D, CPSI-C) !***KEYWORDS DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! PSI(X) calculates the psi (or digamma) function for real argument X. ! PSI(X) is the logarithmic derivative of the gamma function of X. ! ! Series for PSI on the interval 0. to 1.00000D+00 ! with weighted error 2.03E-17 ! log weighted error 16.69 ! significant figures required 16.39 ! decimal places required 17.37 ! ! Series for APSI on the interval 0. to 2.50000D-01 ! with weighted error 5.54E-17 ! log weighted error 16.26 ! significant figures required 14.42 ! decimal places required 16.86 ! !***REFERENCES (NONE) !***ROUTINES CALLED COT, CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900727 Added EXTERNAL statement. (WRB) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE PSI DIMENSION PSICS(23), APSICS(16) LOGICAL FIRST EXTERNAL COT SAVE PSICS, APSICS, PI, NTPSI, NTAPSI, XBIG, DXREL, FIRST DATA PSICS( 1) / -.038057080835217922E0 / DATA PSICS( 2) / .49141539302938713E0 / DATA PSICS( 3) / -.056815747821244730E0 / DATA PSICS( 4) / .008357821225914313E0 / DATA PSICS( 5) / -.001333232857994342E0 / DATA PSICS( 6) / .000220313287069308E0 / DATA PSICS( 7) / -.000037040238178456E0 / DATA PSICS( 8) / .000006283793654854E0 / DATA PSICS( 9) / -.000001071263908506E0 / DATA PSICS(10) / .000000183128394654E0 / DATA PSICS(11) / -.000000031353509361E0 / DATA PSICS(12) / .000000005372808776E0 / DATA PSICS(13) / -.000000000921168141E0 / DATA PSICS(14) / .000000000157981265E0 / DATA PSICS(15) / -.000000000027098646E0 / DATA PSICS(16) / .000000000004648722E0 / DATA PSICS(17) / -.000000000000797527E0 / DATA PSICS(18) / .000000000000136827E0 / DATA PSICS(19) / -.000000000000023475E0 / DATA PSICS(20) / .000000000000004027E0 / DATA PSICS(21) / -.000000000000000691E0 / DATA PSICS(22) / .000000000000000118E0 / DATA PSICS(23) / -.000000000000000020E0 / DATA APSICS( 1) / -.0204749044678185E0 / DATA APSICS( 2) / -.0101801271534859E0 / DATA APSICS( 3) / .0000559718725387E0 / DATA APSICS( 4) / -.0000012917176570E0 / DATA APSICS( 5) / .0000000572858606E0 / DATA APSICS( 6) / -.0000000038213539E0 / DATA APSICS( 7) / .0000000003397434E0 / DATA APSICS( 8) / -.0000000000374838E0 / DATA APSICS( 9) / .0000000000048990E0 / DATA APSICS(10) / -.0000000000007344E0 / DATA APSICS(11) / .0000000000001233E0 / DATA APSICS(12) / -.0000000000000228E0 / DATA APSICS(13) / .0000000000000045E0 / DATA APSICS(14) / -.0000000000000009E0 / DATA APSICS(15) / .0000000000000002E0 / DATA APSICS(16) / -.0000000000000000E0 / DATA PI / 3.14159265358979324E0/ DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT PSI if (FIRST) THEN NTPSI = INITS (PSICS, 23, 0.1*R1MACH(3)) NTAPSI = INITS (APSICS, 16, 0.1*R1MACH(3)) ! XBIG = 1.0/SQRT(R1MACH(3)) DXREL = SQRT (R1MACH(4)) end if FIRST = .FALSE. ! Y = ABS(X) if (Y >= 2.0) go to 30 ! ! PSI(X) FOR -2. < X < 2. ! N = X if (X < 0.) N = N - 1 Y = X - N N = N - 1 PSI = CSEVL (2.*Y-1., PSICS, NTPSI) if (N == 0) RETURN ! N = -N if (X == 0.) call XERMSG ('SLATEC', 'PSI', 'X IS 0', 2, 2) if (X < 0. .AND. X+N-2 == 0.) call XERMSG ('SLATEC', 'PSI', & 'X IS A NEGATIVE INTEGER', 3, 2) if (X < (-0.5) .AND. ABS((X-AINT(X-0.5))/X) < DXREL) & call XERMSG ('SLATEC', 'PSI', & 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER', & 1, 1) ! DO 20 I=1,N PSI = PSI - 1.0/(X+I-1) 20 CONTINUE return ! ! PSI(X) FOR ABS(X) >= 2. ! 30 AUX = 0. if (Y < XBIG) AUX = CSEVL (8./Y**2-1., APSICS, NTAPSI) if (X < 0.) PSI = LOG(ABS(X)) - 0.5/X + AUX - PI*COT(PI*X) if (X > 0.) PSI = LOG(X) - 0.5/X + AUX return ! end subroutine PSIFN (X, N, KODE, M, ANS, NZ, IERR) ! !! PSIFN computes derivatives of the Psi function. ! !***LIBRARY SLATEC !***CATEGORY C7C !***TYPE SINGLE PRECISION (PSIFN-S, DPSIFN-D) !***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, ! PSI FUNCTION !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! The following definitions are used in PSIFN: ! ! Definition 1 ! PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of ! the LOG GAMMA function. ! Definition 2 ! K K ! PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). ! ___________________________________________________________________ ! PSIFN computes a sequence of SCALED derivatives of ! the PSI function; i.e. for fixed X and M it computes ! the M-member sequence ! ! ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) ! for K = N,...,N+M-1 ! ! where PSI(K,X) is as defined above. For KODE=1, PSIFN returns ! the scaled derivatives as described. KODE=2 is operative only ! when K=0 and in that case PSIFN returns -PSI(X) + LN(X). That ! is, the logarithmic behavior for large X is removed when KODE=1 ! and K=0. When sums or differences of PSI functions are computed ! the logarithmic terms can be combined analytically and computed ! separately to help retain significant digits. ! ! Note that call PSIFN(X,0,1,1,ANS) results in ! ANS = -PSI(X) ! ! Input ! X - Argument, X .gt. 0.0E0 ! N - First member of the sequence, 0 .le. N .le. 100 ! N=0 gives ANS(1) = -PSI(X) for KODE=1 ! -PSI(X)+LN(X) for KODE=2 ! KODE - Selection parameter ! KODE=1 returns scaled derivatives of the PSI ! function. ! KODE=2 returns scaled derivatives of the PSI ! function EXCEPT when N=0. In this case, ! ANS(1) = -PSI(X) + LN(X) is returned. ! M - Number of members of the sequence, M .ge. 1 ! ! Output ! ANS - A vector of length at least M whose first M ! components contain the sequence of derivatives ! scaled according to KODE. ! NZ - Underflow flag ! NZ.eq.0, A normal return ! NZ.ne.0, Underflow, last NZ components of ANS are ! set to zero, ANS(M-K+1)=0.0, K=1,...,NZ ! IERR - Error flag ! IERR=0, A normal return, computation completed ! IERR=1, Input error, no computation ! IERR=2, Overflow, X too small or N+M-1 too ! large or both ! IERR=3, Error, N too large. Dimensioned ! array TRMR(NMAX) is not large enough for N ! ! The nominal computational accuracy is the maximum of unit ! roundoff (=R1MACH(4)) and 1.0E-18 since critical constants ! are given to only 18 digits. ! ! DPSIFN is the Double Precision version of PSIFN. ! ! *Long Description: ! ! The basic method of evaluation is the asymptotic expansion ! for large X.ge.XMIN followed by backward recursion on a two ! term recursion relation ! ! W(X+1) + X**(-N-1) = W(X). ! ! This is supplemented by a series ! ! SUM( (X+K)**(-N-1) , K=0,1,2,... ) ! ! which converges rapidly for large N. Both XMIN and the ! number of terms of the series are calculated from the unit ! roundoff of the machine environment. ! !***REFERENCES Handbook of Mathematical Functions, National Bureau ! of Standards Applied Mathematics Series 55, edited ! by M. Abramowitz and I. A. Stegun, equations 6.3.5, ! 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. ! D. E. Amos, A portable Fortran subroutine for ! derivatives of the Psi function, Algorithm 610, ACM ! Transactions on Mathematical Software 9, 4 (1983), ! pp. 494-502. !***ROUTINES CALLED I1MACH, R1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE PSIFN INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ INTEGER I1MACH REAL ANS, ARG, B, DEN, ELIM, EPS, FLN, FN, FNP, FNS, FX, RLN, & RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM, TRMR, & TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, XM, & XMIN, XQ, YINT REAL R1MACH DIMENSION B(22), TRM(22), TRMR(100), ANS(*) SAVE NMAX, B DATA NMAX /100/ !----------------------------------------------------------------------- ! BERNOULLI NUMBERS !----------------------------------------------------------------------- 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.00000000000000000E+00, & -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/ ! !***FIRST EXECUTABLE STATEMENT PSIFN IERR = 0 NZ=0 if (X <= 0.0E0) IERR=1 if (N < 0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (M < 1) IERR=1 if (IERR /= 0) RETURN MM=M NX = MIN(-I1MACH(12),I1MACH(13)) R1M5 = R1MACH(5) R1M4 = R1MACH(4)*0.5E0 WDTOL = MAX(R1M4,0.5E-18) !----------------------------------------------------------------------- ! ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT !----------------------------------------------------------------------- ELIM = 2.302E0*(NX*R1M5-3.0E0) XLN = LOG(X) 41 CONTINUE NN = N + MM - 1 FN = NN FNP = FN + 1.0E0 T = FNP*XLN !----------------------------------------------------------------------- ! OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X !----------------------------------------------------------------------- if (ABS(T) > ELIM) go to 290 if (X < WDTOL) go to 260 !----------------------------------------------------------------------- ! COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 !----------------------------------------------------------------------- RLN = R1M5*I1MACH(11) RLN = MIN(RLN,18.06E0) FLN = MAX(RLN,3.0E0) - 3.0E0 YINT = 3.50E0 + 0.40E0*FLN SLOPE = 0.21E0 + FLN*(0.0006038E0*FLN+0.008677E0) XM = YINT + SLOPE*FN MX = INT(XM) + 1 XMIN = MX if (N == 0) go to 50 XM = -2.302E0*RLN - MIN(0.0E0,XLN) FNS = N ARG = XM/FNS ARG = MIN(0.0E0,ARG) EPS = EXP(ARG) XM = 1.0E0 - EPS if (ABS(ARG) < 1.0E-3) XM = -ARG FLN = X*XM/EPS XM = XMIN - X if (XM > 7.0E0 .AND. FLN < 15.0E0) go to 200 50 CONTINUE XDMY = X XDMLN = XLN XINC = 0.0E0 if (X >= XMIN) go to 60 NX = INT(X) XINC = XMIN - NX XDMY = X + XINC XDMLN = LOG(XDMY) 60 CONTINUE !----------------------------------------------------------------------- ! GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION !----------------------------------------------------------------------- T = FN*XDMLN T1 = XDMLN + XDMLN T2 = T + XDMLN TK = MAX(ABS(T),ABS(T1),ABS(T2)) if (TK > ELIM) go to 380 TSS = EXP(-T) TT = 0.5E0/XDMY T1 = TT TST = WDTOL*TT if (NN /= 0) T1 = TT + 1.0E0/FN RXSQ = 1.0E0/(XDMY*XDMY) TA = 0.5E0*RXSQ T = FNP*TA S = T*B(3) if (ABS(S) < TST) go to 80 TK = 2.0E0 DO 70 K=4,22 T = T*((TK+FN+1.0E0)/(TK+1.0E0))*((TK+FN)/(TK+2.0E0))*RXSQ TRM(K) = T*B(K) if (ABS(TRM(K)) < TST) go to 80 S = S + TRM(K) TK = TK + 2.0E0 70 CONTINUE 80 CONTINUE S = (S+T1)*TSS if (XINC == 0.0E0) go to 100 !----------------------------------------------------------------------- ! BACKWARD RECUR FROM XDMY TO X !----------------------------------------------------------------------- NX = INT(XINC) NP = NN + 1 if (NX > NMAX) go to 390 if (NN == 0) go to 160 XM = XINC - 1.0E0 FX = X + XM !----------------------------------------------------------------------- ! THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL !----------------------------------------------------------------------- DO 90 I=1,NX TRMR(I) = FX**(-NP) S = S + TRMR(I) XM = XM - 1.0E0 FX = X + XM 90 CONTINUE 100 CONTINUE ANS(MM) = S if (FN == 0.0E0) go to 180 !----------------------------------------------------------------------- ! GENERATE LOWER DERIVATIVES, J < N+MM-1 !----------------------------------------------------------------------- if (MM == 1) RETURN DO 150 J=2,MM FNP = FN FN = FN - 1.0E0 TSS = TSS*XDMY T1 = TT if (FN /= 0.0E0) T1 = TT + 1.0E0/FN T = FNP*TA S = T*B(3) if (ABS(S) < TST) go to 120 TK = 3.0E0 + FNP DO 110 K=4,22 TRM(K) = TRM(K)*FNP/TK if (ABS(TRM(K)) < TST) go to 120 S = S + TRM(K) TK = TK + 2.0E0 110 CONTINUE 120 CONTINUE S = (S+T1)*TSS if (XINC == 0.0E0) go to 140 if (FN == 0.0E0) go to 160 XM = XINC - 1.0E0 FX = X + XM DO 130 I=1,NX TRMR(I) = TRMR(I)*FX S = S + TRMR(I) XM = XM - 1.0E0 FX = X + XM 130 CONTINUE 140 CONTINUE MX = MM - J + 1 ANS(MX) = S if (FN == 0.0E0) go to 180 150 CONTINUE return !----------------------------------------------------------------------- ! RECURSION FOR N = 0 !----------------------------------------------------------------------- 160 CONTINUE DO 170 I=1,NX S = S + 1.0E0/(X+NX-I) 170 CONTINUE 180 CONTINUE if (KODE == 2) go to 190 ANS(1) = S - XDMLN return 190 CONTINUE if (XDMY == X) RETURN XQ = XDMY/X ANS(1) = S - LOG(XQ) return !----------------------------------------------------------------------- ! COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... !----------------------------------------------------------------------- 200 CONTINUE NN = INT(FLN) + 1 NP = N + 1 T1 = (FNS+1.0E0)*XLN T = EXP(-T1) S = T DEN = X DO 210 I=1,NN DEN = DEN + 1.0E0 TRM(I) = DEN**(-NP) S = S + TRM(I) 210 CONTINUE ANS(1) = S if (N /= 0) go to 220 if (KODE == 2) ANS(1) = S + XLN 220 CONTINUE if (MM == 1) RETURN !----------------------------------------------------------------------- ! GENERATE HIGHER DERIVATIVES, J > N !----------------------------------------------------------------------- TOL = WDTOL/5.0E0 DO 250 J=2,MM T = T/X S = T TOLS = T*TOL DEN = X DO 230 I=1,NN DEN = DEN + 1.0E0 TRM(I) = TRM(I)/DEN S = S + TRM(I) if (TRM(I) < TOLS) go to 240 230 CONTINUE 240 CONTINUE ANS(J) = S 250 CONTINUE return !----------------------------------------------------------------------- ! SMALL X < UNIT ROUND OFF !----------------------------------------------------------------------- 260 CONTINUE ANS(1) = X**(-N-1) if (MM == 1) go to 280 K = 1 DO 270 I=2,MM ANS(K+1) = ANS(K)/X K = K + 1 270 CONTINUE 280 CONTINUE if (N /= 0) RETURN if (KODE == 2) ANS(1) = ANS(1) + XLN return 290 CONTINUE if (T > 0.0E0) go to 380 NZ=0 IERR=2 return 380 CONTINUE NZ=NZ+1 ANS(MM)=0.0E0 MM=MM-1 if ( MM == 0) RETURN go to 41 390 CONTINUE IERR=3 NZ=0 return end function PSIXN (N) ! !! PSIXN is subsidiary to EXINT. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PSIXN-S, DPSIXN-D) !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! This subroutine returns values of PSI(X)=derivative of log ! GAMMA(X), X > 0.0 at integer arguments. A table look-up is ! performed for N <= 100, and the asymptotic expansion is ! evaluated for N > 100. ! !***SEE ALSO EXINT !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE PSIXN ! INTEGER N, K REAL AX, B, C, FN, RFN2, TRM, S, WDTOL REAL R1MACH DIMENSION B(6), C(100) !----------------------------------------------------------------------- ! PSIXN(N), N = 1,100 !----------------------------------------------------------------------- DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), & C(19), C(20), C(21), C(22), C(23), C(24)/ & -5.77215664901532861E-01, 4.22784335098467139E-01, & 9.22784335098467139E-01, 1.25611766843180047E+00, & 1.50611766843180047E+00, 1.70611766843180047E+00, & 1.87278433509846714E+00, 2.01564147795561000E+00, & 2.14064147795561000E+00, 2.25175258906672111E+00, & 2.35175258906672111E+00, 2.44266167997581202E+00, & 2.52599501330914535E+00, 2.60291809023222227E+00, & 2.67434666166079370E+00, 2.74101332832746037E+00, & 2.80351332832746037E+00, 2.86233685773922507E+00, & 2.91789241329478063E+00, 2.97052399224214905E+00, & 3.02052399224214905E+00, 3.06814303986119667E+00, & 3.11359758531574212E+00, 3.15707584618530734E+00/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ & 3.19874251285197401E+00, 3.23874251285197401E+00, & 3.27720405131351247E+00, 3.31424108835054951E+00, & 3.34995537406483522E+00, 3.38443813268552488E+00, & 3.41777146601885821E+00, 3.45002953053498724E+00, & 3.48127953053498724E+00, 3.51158256083801755E+00, & 3.54099432554389990E+00, 3.56956575411532847E+00, & 3.59734353189310625E+00, 3.62437055892013327E+00, & 3.65068634839381748E+00, 3.67632737403484313E+00, & 3.70132737403484313E+00, 3.72571761793728215E+00, & 3.74952714174680596E+00, 3.77278295570029433E+00, & 3.79551022842756706E+00, 3.81773245064978928E+00, & 3.83947158108457189E+00, 3.86074817682925274E+00/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), & C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ & 3.88158151016258607E+00, 3.90198967342789220E+00, & 3.92198967342789220E+00, 3.94159751656514710E+00, & 3.96082828579591633E+00, 3.97969621032421822E+00, & 3.99821472884273674E+00, 4.01639654702455492E+00, & 4.03425368988169777E+00, 4.05179754953082058E+00, & 4.06903892884116541E+00, 4.08598808138353829E+00, & 4.10265474805020496E+00, 4.11904819067315578E+00, & 4.13517722293122029E+00, 4.15105023880423617E+00, & 4.16667523880423617E+00, 4.18205985418885155E+00, & 4.19721136934036670E+00, 4.21213674247469506E+00, & 4.22684262482763624E+00, 4.24133537845082464E+00, & 4.25562109273653893E+00, 4.26970559977879245E+00/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), & C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), & C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ & 4.28359448866768134E+00, 4.29729311880466764E+00, & 4.31080663231818115E+00, 4.32413996565151449E+00, & 4.33729786038835659E+00, 4.35028487337536958E+00, & 4.36310538619588240E+00, 4.37576361404398366E+00, & 4.38826361404398366E+00, 4.40060929305632934E+00, & 4.41280441500754886E+00, 4.42485260777863319E+00, & 4.43675736968339510E+00, 4.44852207556574804E+00, & 4.46014998254249223E+00, 4.47164423541605544E+00, & 4.48300787177969181E+00, 4.49424382683587158E+00, & 4.50535493794698269E+00, 4.51634394893599368E+00, & 4.52721351415338499E+00, 4.53796620232542800E+00, & 4.54860450019776842E+00, 4.55913081598724211E+00/ DATA C(97), C(98), C(99), C(100)/ & 4.56954748265390877E+00, 4.57985676100442424E+00, & 4.59006084263707730E+00, 4.60016185273808740E+00/ !----------------------------------------------------------------------- ! COEFFICIENTS OF ASYMPTOTIC EXPANSION !----------------------------------------------------------------------- DATA B(1), B(2), B(3), B(4), B(5), B(6)/ & 8.33333333333333333E-02, -8.33333333333333333E-03, & 3.96825396825396825E-03, -4.16666666666666666E-03, & 7.57575757575757576E-03, -2.10927960927960928E-02/ ! !***FIRST EXECUTABLE STATEMENT PSIXN if (N > 100) go to 10 PSIXN = C(N) return 10 CONTINUE WDTOL = MAX(R1MACH(4),1.0E-18) FN = N AX = 1.0E0 S = -0.5E0/FN if (ABS(S) <= WDTOL) go to 30 RFN2 = 1.0E0/(FN*FN) DO 20 K=1,6 AX = AX*RFN2 TRM = -B(K)*AX if (ABS(TRM) < WDTOL) go to 30 S = S + TRM 20 CONTINUE 30 CONTINUE PSIXN = S + LOG(FN) return end subroutine PVALUE (L, NDER, X, YFIT, YP, A) ! !! PVALUE uses the coefficients generated by POLFIT to evaluate the ... ! polynomial fit of degree L, along with the first NDER of ... ! its derivatives, at a specified point. ! !***LIBRARY SLATEC !***CATEGORY K6 !***TYPE SINGLE PRECISION (PVALUE-S, DP1VLU-D) !***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION !***AUTHOR Shampine, L. F., (SNLA) ! Davenport, S. M., (SNLA) !***DESCRIPTION ! ! Written by L. F. Shampine and S. M. Davenport. ! ! Abstract ! ! The subroutine PVALUE uses the coefficients generated by POLFIT ! to evaluate the polynomial fit of degree L , along with the first ! NDER of its derivatives, at a specified point. Computationally ! stable recurrence relations are used to perform this task. ! ! The parameters for PVALUE are ! ! Input -- ! L - the degree of polynomial to be evaluated. L may be ! any non-negative integer which is less than or equal ! to NDEG , the highest degree polynomial provided ! by POLFIT . ! NDER - the number of derivatives to be evaluated. NDER ! may be 0 or any positive value. If NDER is less ! than 0, it will be treated as 0. ! X - the argument at which the polynomial and its ! derivatives are to be evaluated. ! A - work and output array containing values from last ! call to POLFIT . ! ! Output -- ! YFIT - value of the fitting polynomial of degree L at X ! YP - array containing the first through NDER derivatives ! of the polynomial of degree L . YP must be ! dimensioned at least NDER in the calling program. ! !***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, ! Curve fitting by polynomials in one variable, Report ! SLA-74-0270, Sandia Laboratories, June 1974. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 740601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE PVALUE DIMENSION YP(*),A(*) CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT PVALUE if (L < 0) go to 12 NDO = MAX(NDER,0) NDO = MIN(NDO,L) MAXORD = A(1) + 0.5 K1 = MAXORD + 1 K2 = K1 + MAXORD K3 = K2 + MAXORD + 2 NORD = A(K3) + 0.5 if (L > NORD) go to 11 K4 = K3 + L + 1 if (NDER < 1) go to 2 DO 1 I = 1,NDER 1 YP(I) = 0.0 2 if (L >= 2) go to 4 if (L == 1) go to 3 ! ! L IS 0 ! VAL = A(K2+1) go to 10 ! ! L IS 1 ! 3 CC = A(K2+2) VAL = A(K2+1) + (X-A(2))*CC if (NDER >= 1) YP(1) = CC go to 10 ! ! L IS GREATER THAN 1 ! 4 NDP1 = NDO + 1 K3P1 = K3 + 1 K4P1 = K4 + 1 LP1 = L + 1 LM1 = L - 1 ILO = K3 + 3 IUP = K4 + NDP1 DO 5 I = ILO,IUP 5 A(I) = 0.0 DIF = X - A(LP1) KC = K2 + LP1 A(K4P1) = A(KC) A(K3P1) = A(KC-1) + DIF*A(K4P1) A(K3+2) = A(K4P1) ! ! EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES ! DO 9 I = 1,LM1 IN = L - I INP1 = IN + 1 K1I = K1 + INP1 IC = K2 + IN DIF = X - A(INP1) VAL = A(IC) + DIF*A(K3P1) - A(K1I)*A(K4P1) if (NDO <= 0) go to 8 DO 6 N = 1,NDO K3PN = K3P1 + N K4PN = K4P1 + N 6 YP(N) = DIF*A(K3PN) + N*A(K3PN-1) - A(K1I)*A(K4PN) ! ! SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS ! DO 7 N = 1,NDO K3PN = K3P1 + N K4PN = K4P1 + N A(K4PN) = A(K3PN) 7 A(K3PN) = YP(N) 8 A(K4P1) = A(K3P1) 9 A(K3P1) = VAL ! ! NORMAL RETURN OR ABORT DUE TO ERROR ! 10 YFIT = VAL return ! 11 WRITE (XERN1, '(I8)') L WRITE (XERN2, '(I8)') NORD call XERMSG ('SLATEC', 'PVALUE', & 'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 // & ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 // & ', COMPUTED BY POLFIT -- EXECUTION TERMINATED.', 8, 2) return ! 12 call XERMSG ('SLATEC', 'PVALUE', & 'INVALID INPUT PARAMETER. ORDER OF POLYNOMIAL EVALUATION ' // & 'REQUESTED IS NEGATIVE -- EXECUTION TERMINATED.', 2, 2) return end FUNCTION PYTHAG (A, B) ! !! PYTHAG computes the complex square root of a complex number without ... ! destructive overflow or underflow. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PYTHAG-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Finds sqrt(A**2+B**2) without overflow or destructive underflow ! !***SEE ALSO EISDOC !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE PYTHAG REAL A,B REAL PYTHAG REAL P,Q,R,S,T !***FIRST EXECUTABLE STATEMENT PYTHAG P = MAX(ABS(A),ABS(B)) Q = MIN(ABS(A),ABS(B)) if (Q == 0.0E0) go to 20 10 CONTINUE R = (Q/P)**2 T = 4.0E0 + R if (T == 4.0E0) go to 20 S = R/T P = P + 2.0E0*P*S Q = Q*S go to 10 20 PYTHAG = P return end subroutine QAGE (F, A, B, EPSABS, EPSREL, KEY, LIMIT, RESULT, & ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) ! !! QAGE calculates an approximation RESULT to a given definite integral ! I = Integral of F over (A,B), ! hopefully satisfying following claim for accuracy ! ABS(I-RESLT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A1 !***TYPE SINGLE PRECISION (QAGE-S, DQAGE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD RULES, ! GENERAL-PURPOSE, GLOBALLY ADAPTIVE, INTEGRAND EXAMINATOR, ! QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! KEY - Integer ! Key for choice of local integration rule ! A Gauss-Kronrod pair is used with ! 7 - 15 points if KEY < 2, ! 10 - 21 points if KEY = 2, ! 15 - 31 points if KEY = 3, ! 20 - 41 points if KEY = 4, ! 25 - 51 points if KEY = 5, ! 30 - 61 points if KEY > 5. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B), LIMIT >= 1. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! The estimates for result and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value ! of LIMIT. ! However, if this yields no improvement it ! is rather advised to analyze the integrand ! in order to determine the integration ! difficulties. If the position of a local ! difficulty can be determined(e.g. ! SINGULARITY, DISCONTINUITY within the ! interval) one will probably gain from ! splitting up the interval at this point ! and calling the integrator on the ! subranges. If possible, an appropriate ! special-purpose integrator should be used ! which is designed for handling the type of ! difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 6 The input is invalid, because ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! RESULT, ABSERR, NEVAL, LAST, RLIST(1) , ! ELIST(1) and IORD(1) are set to zero. ! ALIST(1) and BLIST(1) are set to A and B ! respectively. ! ! ALIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! BLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! RLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the ! integral approximations on the subintervals ! ! ELIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which are pointers to the ! error estimates over the subintervals, ! such that ELIST(IORD(1)), ..., ! ELIST(IORD(K)) form a decreasing sequence, ! with K = LAST if LAST <= (LIMIT/2+2), and ! K = LIMIT+1-LAST otherwise ! ! LAST - Integer ! Number of subintervals actually produced in the ! subdivision process ! !***REFERENCES (NONE) !***ROUTINES CALLED QK15, QK21, QK31, QK41, QK51, QK61, QPSRT, R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QAGE ! REAL A,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,B,BLIST, & B1,B2,DEFABS,DEFAB1,DEFAB2,R1MACH,ELIST,EPMACH, & EPSABS,EPSREL,ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,F, & RESABS,RESULT,RLIST,UFLOW INTEGER IER,IORD,IROFF1,IROFF2,K,KEY,KEYF,LAST, & LIMIT,MAXERR,NEVAL,NRMAX ! DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), & RLIST(*) ! EXTERNAL F ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ! ERROR ESTIMATE ! ERRMAX - ELIST(MAXERR) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QAGE EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0E+00 ELIST(1) = 0.0E+00 IORD(1) = 0 if ( EPSABS <= 0.0E+00.AND. & EPSREL < MAX(0.5E+02*EPMACH,0.5E-14)) IER = 6 if ( IER == 6) go to 999 ! ! FIRST APPROXIMATION TO THE INTEGRAL ! ----------------------------------- ! KEYF = KEY if ( KEY <= 0) KEYF = 1 if ( KEY >= 7) KEYF = 6 NEVAL = 0 if ( KEYF == 1) call QK15(F,A,B,RESULT,ABSERR,DEFABS,RESABS) if ( KEYF == 2) call QK21(F,A,B,RESULT,ABSERR,DEFABS,RESABS) if ( KEYF == 3) call QK31(F,A,B,RESULT,ABSERR,DEFABS,RESABS) if ( KEYF == 4) call QK41(F,A,B,RESULT,ABSERR,DEFABS,RESABS) if ( KEYF == 5) call QK51(F,A,B,RESULT,ABSERR,DEFABS,RESABS) if ( KEYF == 6) call QK61(F,A,B,RESULT,ABSERR,DEFABS,RESABS) LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 ! ! TEST ON ACCURACY. ! ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) if ( ABSERR <= 0.5E+02*EPMACH*DEFABS.AND.ABSERR > & ERRBND) IER = 2 if ( LIMIT == 1) IER = 1 if ( IER /= 0.OR.(ABSERR <= ERRBND.AND.ABSERR /= RESABS) & .OR.ABSERR == 0.0E+00) go to 60 ! ! INITIALIZATION ! -------------- ! ! ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR NRMAX = 1 IROFF1 = 0 IROFF2 = 0 ! ! MAIN DO-LOOP ! ------------ ! DO 30 LAST = 2,LIMIT ! ! BISECT THE SUBINTERVAL WITH THE LARGEST ERROR ESTIMATE. ! A1 = ALIST(MAXERR) B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) if ( KEYF == 1) call QK15(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 2) call QK21(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 3) call QK31(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 4) call QK41(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 5) call QK51(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 6) call QK61(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) if ( KEYF == 1) call QK15(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) if ( KEYF == 2) call QK21(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) if ( KEYF == 3) call QK31(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) if ( KEYF == 4) call QK41(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) if ( KEYF == 5) call QK51(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) if ( KEYF == 6) call QK61(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! NEVAL = NEVAL+1 AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( DEFAB1 == ERROR1.OR.DEFAB2 == ERROR2) go to 5 if ( ABS(RLIST(MAXERR)-AREA12) <= 0.1E-04*ABS(AREA12) & .AND.ERRO12 >= 0.99E+00*ERRMAX) IROFF1 = IROFF1+1 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF2 = IROFF2+1 5 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) if ( ERRSUM <= ERRBND) go to 8 ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY ! SET ERROR FLAG. ! if ( IROFF1 >= 6.OR.IROFF2 >= 20) IER = 2 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF ! SUBINTERVALS EQUALS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT A POINT OF THE INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1E+01+0.1E+03* & EPMACH)*(ABS(A2)+0.1E+04*UFLOW)) IER = 3 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! 8 if ( ERROR2 > ERROR1) go to 10 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 go to 20 10 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 ! ! call SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE ! SUBINTERVAL WITH THE LARGEST ERROR ESTIMATE (TO BE ! BISECTED NEXT). ! 20 call QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if ( IER /= 0.OR.ERRSUM <= ERRBND) go to 40 30 CONTINUE ! ! COMPUTE FINAL RESULT. ! --------------------- ! 40 RESULT = 0.0E+00 DO 50 K=1,LAST RESULT = RESULT+RLIST(K) 50 CONTINUE ABSERR = ERRSUM 60 if ( KEYF /= 1) NEVAL = (10*KEYF+1)*(2*NEVAL+1) if ( KEYF == 1) NEVAL = 30*NEVAL+15 999 RETURN end subroutine QAG (F, A, B, EPSABS, EPSREL, KEY, RESULT, ABSERR, & NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) ! !! QAG calculates an approximation RESULT to a given ... ! definite integral I = integral of F over (A,B), ... ! hopefully satisfying following claim for accuracy ... ! ABS(I-RESULT)LE.MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A1 !***TYPE SINGLE PRECISION (QAG-S, DQAG-D) !***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD RULES, ! GENERAL-PURPOSE, GLOBALLY ADAPTIVE, INTEGRAND EXAMINATOR, ! QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Real version ! ! F - Real ! Function subprogram defining the integrand ! Function F(X). The actual name for F needs to be ! Declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! And EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! The routine will end with IER = 6. ! ! KEY - Integer ! Key for choice of local integration rule ! A GAUSS-KRONROD PAIR is used with ! 7 - 15 POINTS If KEY < 2, ! 10 - 21 POINTS If KEY = 2, ! 15 - 31 POINTS If KEY = 3, ! 20 - 41 POINTS If KEY = 4, ! 25 - 51 POINTS If KEY = 5, ! 30 - 61 POINTS If KEY > 5. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! Which should EQUAL or EXCEED ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! The estimates for RESULT and ERROR are ! Less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). HOWEVER, If ! this yield no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. ! If the position of a local difficulty can ! be determined (I.E. SINGULARITY, ! DISCONTINUITY WITHIN THE INTERVAL) One ! will probably gain from splitting up the ! interval at this point and calling the ! INTEGRATOR on the SUBRANGES. If possible, ! AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR ! should be used which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 6 The input is invalid, because ! (EPSABS <= 0 AND ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! OR LIMIT < 1 OR LENW < LIMIT*4. ! RESULT, ABSERR, NEVAL, LAST are set ! to zero. ! EXCEPT when LENW is invalid, IWORK(1), ! WORK(LIMIT*2+1) and WORK(LIMIT*3+1) are ! set to zero, WORK(1) is set to A and ! WORK(LIMIT+1) to B. ! ! DIMENSIONING PARAMETERS ! LIMIT - Integer ! Dimensioning parameter for IWORK ! Limit determines the maximum number of subintervals ! in the partition of the given integration interval ! (A,B), LIMIT >= 1. ! If LIMIT < 1, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for work ! LENW must be at least LIMIT*4. ! if LENW < LIMIT*4, the routine will end with ! IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, which ! determines the number of significant elements ! actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least limit, the first K ! elements of which contain pointers to the error ! estimates over the subintervals, such that ! WORK(LIMIT*3+IWORK(1)),... , WORK(LIMIT*3+IWORK(K)) ! form a decreasing sequence with K = LAST If ! LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST otherwise ! ! WORK - Real ! Vector of dimension at least LENW ! on return ! WORK(1), ..., WORK(LAST) contain the left end ! points of the subintervals in the partition of ! (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain the ! right end points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain ! the integral approximations over the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) contain ! the error estimates. ! !***REFERENCES (NONE) !***ROUTINES CALLED QAGE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE QAG REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK,KEY,LENW,LIMIT,LVL,L1,L2,L3,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F !***FIRST EXECUTABLE STATEMENT QAG IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 if (LIMIT >= 1 .AND. LENW >= LIMIT*4) THEN ! ! PREPARE call FOR QAGE. ! L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 ! call QAGE(F,A,B,EPSABS,EPSREL,KEY,LIMIT,RESULT,ABSERR,NEVAL, & IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 end if ! if (IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'QAG', & 'ABNORMAL RETURN', IER, LVL) return end subroutine QAGIE (F, BOUND, INF, EPSABS, EPSREL, LIMIT, RESULT, & ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) ! !! QAGIE calculates an approximation RESULT to a given integral ... ! I = Integral of F over (BOUND,+INFINITY) ! or I = Integral of F over (-INFINITY,BOUND) ! or I = Integral of F over (-INFINITY,+INFINITY), ! hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A3A1, H2A4A1 !***TYPE SINGLE PRECISION (QAGIE-S, DQAGIE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, ! GLOBALLY ADAPTIVE, INFINITE INTERVALS, QUADPACK, ! QUADRATURE, TRANSFORMATION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration over infinite intervals ! Standard fortran subroutine ! ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! BOUND - Real ! Finite bound of integration range ! (has no meaning if interval is doubly-infinite) ! ! INF - Real ! Indicating the kind of integration range involved ! INF = 1 corresponds to (BOUND,+INFINITY), ! INF = -1 to (-INFINITY,BOUND), ! INF = 2 to (-INFINITY,+INFINITY). ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B), LIMIT >= 1 ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! - IER > 0 Abnormal termination of the routine. The ! estimates for result and error are less ! reliable. It is assumed that the requested ! accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. ! If the position of a local difficulty can ! be determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. If possible, ! an appropriate special-purpose integrator ! should be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. ! It is assumed that the requested tolerance ! cannot be achieved, and that the returned ! result is the best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER. ! = 6 The input is invalid, because ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! RESULT, ABSERR, NEVAL, LAST, RLIST(1), ! ELIST(1) and IORD(1) are set to zero. ! ALIST(1) and BLIST(1) are set to 0 ! and 1 respectively. ! ! ALIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left ! end points of the subintervals in the partition ! of the transformed integration range (0,1). ! ! BLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right ! end points of the subintervals in the partition ! of the transformed integration range (0,1). ! ! RLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension LIMIT, the first K ! elements of which are pointers to the ! error estimates over the subintervals, ! such that ELIST(IORD(1)), ..., ELIST(IORD(K)) ! form a decreasing sequence, with K = LAST ! If LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise ! ! LAST - Integer ! Number of subintervals actually produced ! in the subdivision process ! !***REFERENCES (NONE) !***ROUTINES CALLED QELG, QK15I, QPSRT, R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QAGIE ! REAL ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, & A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2, & DRES,R1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST, & ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS, & RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, & KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 LOGICAL EXTRAP,NOEXT ! DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), & RES3LA(3),RLIST(*),RLIST2(52) ! EXTERNAL F ! ! THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF ! LIMEXP IN SUBROUTINE QELG. ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! RLIST2 - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), ! CONTAINING THE PART OF THE EPSILON TABLE ! WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR ! ESTIMATE ! ERRMAX - ELIST(MAXERR) ! ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED ! (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE ! NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. if AN ! APPROPRIATE APPROXIMATION TO THE COMPOUNDED ! INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN ! RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED ! BY ONE. ! SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP ! TO NOW, MULTIPLIED BY 1.5 ! ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER ! THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW ! EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE ! IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. ! BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE ! TRY TO DECREASE THE VALUE OF ERLARG. ! NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION ! IS NO LONGER ALLOWED (TRUE-VALUE) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QAGIE EPMACH = R1MACH(4) ! ! TEST ON VALIDITY OF PARAMETERS ! ----------------------------- ! IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 ALIST(1) = 0.0E+00 BLIST(1) = 0.1E+01 RLIST(1) = 0.0E+00 ELIST(1) = 0.0E+00 IORD(1) = 0 if ( EPSABS <= 0.0E+00.AND.EPSREL < MAX(0.5E+02*EPMACH,0.5E-14)) & IER = 6 if ( IER == 6) go to 999 ! ! ! FIRST APPROXIMATION TO THE INTEGRAL ! ----------------------------------- ! ! DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). ! if INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE ! I1 = INTEGRAL OF F OVER (-INFINITY,0), ! I2 = INTEGRAL OF F OVER (0,+INFINITY). ! BOUN = BOUND if ( INF == 2) BOUN = 0.0E+00 call QK15I(F,BOUN,INF,0.0E+00,0.1E+01,RESULT,ABSERR, & DEFABS,RESABS) ! ! TEST ON ACCURACY ! LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 DRES = ABS(RESULT) ERRBND = MAX(EPSABS,EPSREL*DRES) if ( ABSERR <= 1.0E+02*EPMACH*DEFABS.AND.ABSERR > & ERRBND) IER = 2 if ( LIMIT == 1) IER = 1 if ( IER /= 0.OR.(ABSERR <= ERRBND.AND.ABSERR /= RESABS).OR. & ABSERR == 0.0E+00) go to 130 ! ! INITIALIZATION ! -------------- ! UFLOW = R1MACH(1) OFLOW = R1MACH(2) RLIST2(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW NRMAX = 1 NRES = 0 KTMIN = 0 NUMRL2 = 2 EXTRAP = .FALSE. NOEXT = .FALSE. IERRO = 0 IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KSGN = -1 if ( DRES >= (0.1E+01-0.5E+02*EPMACH)*DEFABS) KSGN = 1 ! ! MAIN DO-LOOP ! ------------ ! DO 90 LAST = 2,LIMIT ! ! BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ! ERROR ESTIMATE. ! A1 = ALIST(MAXERR) B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX call QK15I(F,BOUN,INF,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) call QK15I(F,BOUN,INF,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( DEFAB1 == ERROR1.OR.DEFAB2 == ERROR2)go to 15 if ( ABS(RLIST(MAXERR)-AREA12) > 0.1E-04*ABS(AREA12) & .OR.ERRO12 < 0.99E+00*ERRMAX) go to 10 if ( EXTRAP) IROFF2 = IROFF2+1 if ( .NOT.EXTRAP) IROFF1 = IROFF1+1 10 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF3 = IROFF3+1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY ! SET ERROR FLAG. ! if ( IROFF1+IROFF2 >= 10.OR.IROFF3 >= 20) IER = 2 if ( IROFF2 >= 5) IERRO = 3 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF ! SUBINTERVALS EQUALS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT SOME POINTS OF THE INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1E+01+0.1E+03*EPMACH)* & (ABS(A2)+0.1E+04*UFLOW)) IER = 4 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! if ( ERROR2 > 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 ! ! call SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE ! SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE ! BISECTED NEXT). ! 30 call QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) if ( ERRSUM <= ERRBND) go to 115 if ( IER /= 0) go to 100 if ( LAST == 2) go to 80 if ( NOEXT) go to 90 ERLARG = ERLARG-ERLAST if ( ABS(B1-A1) > SMALL) ERLARG = ERLARG+ERRO12 if ( EXTRAP) go to 40 ! ! TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE ! SMALLEST INTERVAL. ! if ( ABS(BLIST(MAXERR)-ALIST(MAXERR)) > SMALL) go to 90 EXTRAP = .TRUE. NRMAX = 2 40 if ( IERRO == 3.OR.ERLARG <= ERTEST) go to 60 ! ! THE SMALLEST INTERVAL HAS THE LARGEST ERROR. ! BEFORE BISECTING DECREASE THE SUM OF THE ERRORS ! OVER THE LARGER INTERVALS (ERLARG) AND PERFORM ! EXTRAPOLATION. ! ID = NRMAX JUPBND = LAST if ( LAST > (2+LIMIT/2)) JUPBND = LIMIT+3-LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) if ( ABS(BLIST(MAXERR)-ALIST(MAXERR)) > SMALL) go to 90 NRMAX = NRMAX+1 50 CONTINUE ! ! PERFORM EXTRAPOLATION. ! 60 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA call QELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) KTMIN = KTMIN+1 if ( KTMIN > 5.AND.ABSERR < 0.1E-02*ERRSUM) IER = 5 if ( ABSEPS >= ABSERR) go to 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) if ( ABSERR <= ERTEST) go to 100 ! ! PREPARE BISECTION OF THE SMALLEST INTERVAL. ! 70 if ( NUMRL2 == 1) NOEXT = .TRUE. if ( IER == 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 ! ! SET FINAL RESULT AND ERROR ESTIMATE. ! ------------------------------------ ! 100 if ( ABSERR == OFLOW) go to 115 if ( (IER+IERRO) == 0) go to 110 if ( IERRO == 3) ABSERR = ABSERR+CORREC if ( IER == 0) IER = 3 if ( RESULT /= 0.0E+00.AND.AREA /= 0.0E+00)go to 105 if ( ABSERR > ERRSUM)go to 115 if ( AREA == 0.0E+00) go to 130 go to 110 105 if ( ABSERR/ABS(RESULT) > ERRSUM/ABS(AREA))go to 115 ! ! TEST ON DIVERGENCE ! 110 if ( KSGN == (-1).AND.MAX(ABS(RESULT),ABS(AREA)) <= & DEFABS*0.1E-01) go to 130 if (0.1E-01 > (RESULT/AREA).OR.(RESULT/AREA) > 0.1E+03 & .OR.ERRSUM > ABS(AREA)) IER = 6 go to 130 ! ! COMPUTE GLOBAL INTEGRAL SUM. ! 115 RESULT = 0.0E+00 DO 120 K = 1,LAST RESULT = RESULT+RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 NEVAL = 30*LAST-15 if ( INF == 2) NEVAL = 2*NEVAL if ( IER > 2) IER=IER-1 999 RETURN end subroutine QAGI (F, BOUND, INF, EPSABS, EPSREL, RESULT, ABSERR, & NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) ! !! QAGI calculates an approximation RESULT to a given integral ... ! I = Integral of F over (BOUND,+INFINITY) ! OR I = Integral of F over (-INFINITY,BOUND) ! OR I = Integral of F over (-INFINITY,+INFINITY) ! Hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A3A1, H2A4A1 !***TYPE SINGLE PRECISION (QAGI-S, DQAGI-D) !***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, ! GLOBALLY ADAPTIVE, INFINITE INTERVALS, QUADPACK, ! QUADRATURE, TRANSFORMATION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration over infinite intervals ! Standard fortran subroutine ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! BOUND - Real ! Finite bound of integration range ! (has no meaning if interval is doubly-infinite) ! ! INF - Integer ! indicating the kind of integration range involved ! INF = 1 corresponds to (BOUND,+INFINITY), ! INF = -1 to (-INFINITY,BOUND), ! INF = 2 to (-INFINITY,+INFINITY). ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! - IER > 0 abnormal termination of the routine. The ! estimates for result and error are less ! reliable. It is assumed that the requested ! accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. If ! the position of a local difficulty can be ! determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. If possible, ! an appropriate special-purpose integrator ! should be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. ! It is assumed that the requested tolerance ! cannot be achieved, and that the returned ! RESULT is the best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER. ! = 6 The input is invalid, because ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or LIMIT < 1 or LENIW < LIMIT*4. ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LIMIT or LENIW is ! invalid, IWORK(1), WORK(LIMIT*2+1) and ! WORK(LIMIT*3+1) are set to ZERO, WORK(1) ! is set to A and WORK(LIMIT+1) to B. ! ! DIMENSIONING PARAMETERS ! LIMIT - Integer ! Dimensioning parameter for IWORK ! LIMIT determines the maximum number of subintervals ! in the partition of the given integration interval ! (A,B), LIMIT >= 1. ! If LIMIT < 1, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LIMIT*4. ! If LENW < LIMIT*4, the routine will end ! with IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, which ! determines the number of significant elements ! actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LIMIT, the first ! K elements of which contain pointers ! to the error estimates over the subintervals, ! such that WORK(LIMIT*3+IWORK(1)),... , ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence, with K = LAST if LAST <= (LIMIT/2+2), and ! K = LIMIT+1-LAST otherwise ! ! WORK - Real ! Vector of dimension at least LENW ! on return ! WORK(1), ..., WORK(LAST) contain the left ! end points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) Contain ! the right end points, ! WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) contain the ! integral approximations over the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3) ! contain the error estimates. ! !***REFERENCES (NONE) !***ROUTINES CALLED QAGIE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE QAGI ! REAL ABSERR, EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK, LENW,LIMIT,LVL,L1,L2,L3,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMIT AND LENW. ! !***FIRST EXECUTABLE STATEMENT QAGI IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 if ( LIMIT < 1.OR.LENW < LIMIT*4) go to 10 ! ! PREPARE call FOR QAGIE. ! L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 ! call QAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, & NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'QAGI', & 'ABNORMAL RETURN', IER, LVL) return end subroutine QAGPE (F, A, B, NPTS2, POINTS, EPSABS, EPSREL, LIMIT, & RESULT, ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, PTS, & IORD, LEVEL, NDIN, LAST) ! !! QAGPE approximates a given integral I = Integral of F over (A,B), ... ! hopefully satisfying the accuracy claim: ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! Break points of the integration interval, where local ! difficulties of the integrand may occur (e.g. singularities ! or discontinuities) are provided by the user. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE SINGLE PRECISION (QAGPE-S, DQAGPE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, ! GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, ! SINGULARITIES AT USER SPECIFIED POINTS !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! NPTS2 - Integer ! Number equal to two more than the number of ! user-supplied break points within the integration ! range, NPTS2 >= 2. ! If NPTS2 < 2, the routine will end with IER = 6. ! ! POINTS - Real ! Vector of dimension NPTS2, the first (NPTS2-2) ! elements of which are the user provided break ! POINTS. If these POINTS do not constitute an ! ascending sequence there will be an automatic ! sorting. ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B), LIMIT >= NPTS2 ! If LIMIT < NPTS2, the routine will end with ! IER = 6. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine. ! The estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. If ! the position of a local difficulty can be ! determined (i.e. SINGULARITY, ! DISCONTINUITY within the interval), it ! should be supplied to the routine as an ! element of the vector points. If necessary ! an appropriate special-purpose integrator ! must be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! At some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. It is presumed that ! the requested tolerance cannot be ! achieved, and that the returned result is ! the best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER > 0. ! = 6 The input is invalid because ! NPTS2 < 2 or ! Break points are specified outside ! the integration range or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or LIMIT < NPTS2. ! RESULT, ABSERR, NEVAL, LAST, RLIST(1), ! and ELIST(1) are set to zero. ALIST(1) and ! BLIST(1) are set to A and B respectively. ! ! ALIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left end points ! of the subintervals in the partition of the given ! integration range (A,B) ! ! BLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right end points ! of the subintervals in the partition of the given ! integration range (A,B) ! ! RLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! PTS - Real ! Vector of dimension at least NPTS2, containing the ! integration limits and the break points of the ! interval in ascending sequence. ! ! LEVEL - Integer ! Vector of dimension at least LIMIT, containing the ! subdivision levels of the subinterval, i.e. if ! (AA,BB) is a subinterval of (P1,P2) where P1 as ! well as P2 is a user-provided break point or ! integration limit, then (AA,BB) has level L if ! ABS(BB-AA) = ABS(P2-P1)*2**(-L). ! ! NDIN - Integer ! Vector of dimension at least NPTS2, after first ! integration over the intervals (PTS(I)),PTS(I+1), ! I = 0,1, ..., NPTS2-2, the error estimates over ! some of the intervals may have been increased ! artificially, in order to put their subdivision ! forward. If this happens for the subinterval ! numbered K, NDIN(K) is put to 1, otherwise ! NDIN(K) = 0. ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which are pointers to the ! error estimates over the subintervals, ! such that ELIST(IORD(1)), ..., ELIST(IORD(K)) ! form a decreasing sequence, with K = LAST ! If LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise ! ! LAST - Integer ! Number of subintervals actually produced in the ! subdivisions process ! !***REFERENCES (NONE) !***ROUTINES CALLED QELG, QK21, QPSRT, R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QAGPE REAL A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, & A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2, & DRES,R1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, & ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW,POINTS,PTS, & RESA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SIGN,TEMP, & UFLOW INTEGER I,ID,IER,IERRO,IND1,IND2,IORD,IP1,IROFF1,IROFF2, & IROFF3,J,JLOW,JUPBND,K,KSGN,KTMIN,LAST,LEVCUR,LEVEL,LEVMAX, & LIMIT,MAXERR,NDIN,NEVAL,NINT,NINTP1,NPTS,NPTS2,NRES, & NRMAX,NUMRL2 LOGICAL EXTRAP,NOEXT ! ! DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), & LEVEL(*),NDIN(*),POINTS(*),PTS(*),RES3LA(3), & RLIST(*),RLIST2(52) ! EXTERNAL F ! ! THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF ! LIMEXP IN SUBROUTINE EPSALG (RLIST2 SHOULD BE OF DIMENSION ! (LIMEXP+2) AT LEAST). ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 ! CONTAINING THE PART OF THE EPSILON TABLE WHICH ! IS STILL NEEDED FOR FURTHER COMPUTATIONS ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR ! ESTIMATE ! ERRMAX - ELIST(MAXERR) ! ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED ! (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE ! NUMRL2 - NUMBER OF ELEMENTS IN RLIST2. if AN ! APPROPRIATE APPROXIMATION TO THE COMPOUNDED ! INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN ! RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED ! BY ONE. ! ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER ! THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW ! EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE ! IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. ! BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE ! TRY TO DECREASE THE VALUE OF ERLARG. ! NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION IS ! NO LONGER ALLOWED (TRUE-VALUE) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QAGPE EPMACH = R1MACH(4) ! ! TEST ON VALIDITY OF PARAMETERS ! ----------------------------- ! IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0E+00 ELIST(1) = 0.0E+00 IORD(1) = 0 LEVEL(1) = 0 NPTS = NPTS2-2 if ( NPTS2 < 2.OR.LIMIT <= NPTS.OR.(EPSABS <= 0.0E+00.AND. & EPSREL < MAX(0.5E+02*EPMACH,0.5E-14))) IER = 6 if ( IER == 6) go to 999 ! ! if ANY BREAK POINTS ARE PROVIDED, SORT THEM INTO AN ! ASCENDING SEQUENCE. ! SIGN = 1.0E+00 if ( A > B) SIGN = -1.0E+00 PTS(1) = MIN(A,B) if ( NPTS == 0) go to 15 DO 10 I = 1,NPTS PTS(I+1) = POINTS(I) 10 CONTINUE 15 PTS(NPTS+2) = MAX(A,B) NINT = NPTS+1 A1 = PTS(1) if ( NPTS == 0) go to 40 NINTP1 = NINT+1 DO 20 I = 1,NINT IP1 = I+1 DO 20 J = IP1,NINTP1 if ( PTS(I) <= PTS(J)) go to 20 TEMP = PTS(I) PTS(I) = PTS(J) PTS(J) = TEMP 20 CONTINUE if ( PTS(1) /= MIN(A,B).OR.PTS(NINTP1) /= & MAX(A,B)) IER = 6 if ( IER == 6) go to 999 ! ! COMPUTE FIRST INTEGRAL AND ERROR APPROXIMATIONS. ! ------------------------------------------------ ! 40 RESABS = 0.0E+00 DO 50 I = 1,NINT B1 = PTS(I+1) call QK21(F,A1,B1,AREA1,ERROR1,DEFABS,RESA) ABSERR = ABSERR+ERROR1 RESULT = RESULT+AREA1 NDIN(I) = 0 if ( ERROR1 == RESA.AND.ERROR1 /= 0.0E+00) NDIN(I) = 1 RESABS = RESABS+DEFABS LEVEL(I) = 0 ELIST(I) = ERROR1 ALIST(I) = A1 BLIST(I) = B1 RLIST(I) = AREA1 IORD(I) = I A1 = B1 50 CONTINUE ERRSUM = 0.0E+00 DO 55 I = 1,NINT if ( NDIN(I) == 1) ELIST(I) = ABSERR ERRSUM = ERRSUM+ELIST(I) 55 CONTINUE ! ! TEST ON ACCURACY. ! LAST = NINT NEVAL = 21*NINT DRES = ABS(RESULT) ERRBND = MAX(EPSABS,EPSREL*DRES) if ( ABSERR <= 0.1E+03*EPMACH*RESABS.AND.ABSERR > & ERRBND) IER = 2 if ( NINT == 1) go to 80 DO 70 I = 1,NPTS JLOW = I+1 IND1 = IORD(I) DO 60 J = JLOW,NINT IND2 = IORD(J) if ( ELIST(IND1) > ELIST(IND2)) go to 60 IND1 = IND2 K = J 60 CONTINUE if ( IND1 == IORD(I)) go to 70 IORD(K) = IORD(I) IORD(I) = IND1 70 CONTINUE if ( LIMIT < NPTS2) IER = 1 80 if ( IER /= 0.OR.ABSERR <= ERRBND) go to 999 ! ! INITIALIZATION ! -------------- ! RLIST2(1) = RESULT MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) AREA = RESULT NRMAX = 1 NRES = 0 NUMRL2 = 1 KTMIN = 0 EXTRAP = .FALSE. NOEXT = .FALSE. ERLARG = ERRSUM ERTEST = ERRBND LEVMAX = 1 IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 IERRO = 0 UFLOW = R1MACH(1) OFLOW = R1MACH(2) ABSERR = OFLOW KSGN = -1 if ( DRES >= (0.1E+01-0.5E+02*EPMACH)*RESABS) KSGN = 1 ! ! MAIN DO-LOOP ! ------------ ! DO 160 LAST = NPTS2,LIMIT ! ! BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ! ERROR ESTIMATE. ! LEVCUR = LEVEL(MAXERR)+1 A1 = ALIST(MAXERR) B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX call QK21(F,A1,B1,AREA1,ERROR1,RESA,DEFAB1) call QK21(F,A2,B2,AREA2,ERROR2,RESA,DEFAB2) ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! NEVAL = NEVAL+42 AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( DEFAB1 == ERROR1.OR.DEFAB2 == ERROR2) go to 95 if ( ABS(RLIST(MAXERR)-AREA12) > 0.1E-04*ABS(AREA12) & .OR.ERRO12 < 0.99E+00*ERRMAX) go to 90 if ( EXTRAP) IROFF2 = IROFF2+1 if ( .NOT.EXTRAP) IROFF1 = IROFF1+1 90 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF3 = IROFF3+1 95 LEVEL(MAXERR) = LEVCUR LEVEL(LAST) = LEVCUR RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY ! SET ERROR FLAG. ! if ( IROFF1+IROFF2 >= 10.OR.IROFF3 >= 20) IER = 2 if ( IROFF2 >= 5) IERRO = 3 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF ! SUBINTERVALS EQUALS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT A POINT OF THE INTEGRATION RANGE ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1E+01+0.1E+03*EPMACH)* & (ABS(A2)+0.1E+04*UFLOW)) IER = 4 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! if ( ERROR2 > ERROR1) go to 100 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 go to 110 100 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 ! ! call SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE ! SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE ! BISECTED NEXT). ! 110 call QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if ( ERRSUM <= ERRBND) go to 190 ! ***JUMP OUT OF DO-LOOP if ( IER /= 0) go to 170 if ( NOEXT) go to 160 ERLARG = ERLARG-ERLAST if ( LEVCUR+1 <= LEVMAX) ERLARG = ERLARG+ERRO12 if ( EXTRAP) go to 120 ! ! TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE ! SMALLEST INTERVAL. ! if ( LEVEL(MAXERR)+1 <= LEVMAX) go to 160 EXTRAP = .TRUE. NRMAX = 2 120 if ( IERRO == 3.OR.ERLARG <= ERTEST) go to 140 ! ! THE SMALLEST INTERVAL HAS THE LARGEST ERROR. ! BEFORE BISECTING DECREASE THE SUM OF THE ERRORS ! OVER THE LARGER INTERVALS (ERLARG) AND PERFORM ! EXTRAPOLATION. ! ID = NRMAX JUPBND = LAST if ( LAST > (2+LIMIT/2)) JUPBND = LIMIT+3-LAST DO 130 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) ! ***JUMP OUT OF DO-LOOP if ( LEVEL(MAXERR)+1 <= LEVMAX) go to 160 NRMAX = NRMAX+1 130 CONTINUE ! ! PERFORM EXTRAPOLATION. ! 140 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA if ( NUMRL2 <= 2) go to 155 call QELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) KTMIN = KTMIN+1 if ( KTMIN > 5.AND.ABSERR < 0.1E-02*ERRSUM) IER = 5 if ( ABSEPS >= ABSERR) go to 150 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) ! ***JUMP OUT OF DO-LOOP if ( ABSERR < ERTEST) go to 170 ! ! PREPARE BISECTION OF THE SMALLEST INTERVAL. ! 150 if ( NUMRL2 == 1) NOEXT = .TRUE. if ( IER >= 5) go to 170 155 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. LEVMAX = LEVMAX+1 ERLARG = ERRSUM 160 CONTINUE ! ! SET THE FINAL RESULT. ! --------------------- ! ! 170 if ( ABSERR == OFLOW) go to 190 if ( (IER+IERRO) == 0) go to 180 if ( IERRO == 3) ABSERR = ABSERR+CORREC if ( IER == 0) IER = 3 if ( RESULT /= 0.0E+00.AND.AREA /= 0.0E+00)go to 175 if ( ABSERR > ERRSUM)go to 190 if ( AREA == 0.0E+00) go to 210 go to 180 175 if ( ABSERR/ABS(RESULT) > ERRSUM/ABS(AREA))go to 190 ! ! TEST ON DIVERGENCE. ! 180 if ( KSGN == (-1).AND.MAX(ABS(RESULT),ABS(AREA)) <= & DEFABS*0.1E-01) go to 210 if ( 0.1E-01 > (RESULT/AREA).OR.(RESULT/AREA) > 0.1E+03.OR. & ERRSUM > ABS(AREA)) IER = 6 go to 210 ! ! COMPUTE GLOBAL INTEGRAL SUM. ! 190 RESULT = 0.0E+00 DO 200 K = 1,LAST RESULT = RESULT+RLIST(K) 200 CONTINUE ABSERR = ERRSUM 210 if ( IER > 2) IER = IER - 1 RESULT = RESULT*SIGN 999 return end subroutine QAGP (F, A, B, NPTS2, POINTS, EPSABS, EPSREL, RESULT, & ABSERR, NEVAL, IER, LENIW, LENW, LAST, IWORK, WORK) ! !! QAGP calculates an approximation RESULT to a given integral ... ! I = Integral of F over (A,B), ! hopefully satisfying following claim for accuracy ! break points of the integration interval, where local ! difficulties of the integrand may occur(e.g. SINGULARITIES, ! DISCONTINUITIES), are provided by the user. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE SINGLE PRECISION (QAGP-S, DQAGP-D) !***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, ! GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, ! SINGULARITIES AT USER SPECIFIED POINTS !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! Function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! NPTS2 - Integer ! Number equal to two more than the number of ! user-supplied break points within the integration ! range, NPTS >= 2. ! If NPTS2 < 2, The routine will end with IER = 6. ! ! POINTS - Real ! Vector of dimension NPTS2, the first (NPTS2-2) ! elements of which are the user provided break ! points. If these points do not constitute an ! ascending sequence there will be an automatic ! sorting. ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! And EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! The routine will end with IER = 6. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine. ! The estimates for integral and error are ! less reliable. it is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. one can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. If ! the position of a local difficulty can be ! determined (i.e. SINGULARITY, ! DISCONTINUITY within the interval), it ! should be supplied to the routine as an ! element of the vector points. If necessary ! an appropriate special-purpose integrator ! must be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! roundoff error is detected in the ! extrapolation table. ! It is presumed that the requested ! tolerance cannot be achieved, and that ! the returned RESULT is the best which ! can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. it must be noted that ! divergence can occur with any other value ! of IER > 0. ! = 6 The input is invalid because ! NPTS2 < 2 or ! break points are specified outside ! the integration range or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LENIW or LENW or NPTS2 ! is invalid, IWORK(1), IWORK(LIMIT+1), ! WORK(LIMIT*2+1) and WORK(LIMIT*3+1) ! are set to zero. ! WORK(1) is set to A and WORK(LIMIT+1) ! to B (where LIMIT = (LENIW-NPTS2)/2). ! ! DIMENSIONING PARAMETERS ! LENIW - Integer ! Dimensioning parameter for IWORK ! LENIW determines LIMIT = (LENIW-NPTS2)/2, ! which is the maximum number of subintervals in the ! partition of the given integration interval (A,B), ! LENIW >= (3*NPTS2-2). ! If LENIW < (3*NPTS2-2), the routine will end with ! IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LENIW*2-NPTS2. ! If LENW < LENIW*2-NPTS2, the routine will end ! with IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, which ! determines the number of significant elements ! actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LENIW. on return, ! the first K elements of which contain ! pointers to the error estimates over the ! subintervals, such that WORK(LIMIT*3+IWORK(1)),..., ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence, with K = LAST if LAST <= (LIMIT/2+2), and ! K = LIMIT+1-LAST otherwise ! IWORK(LIMIT+1), ...,IWORK(LIMIT+LAST) Contain the ! subdivision levels of the subintervals, i.e. ! if (AA,BB) is a subinterval of (P1,P2) ! where P1 as well as P2 is a user-provided ! break point or integration LIMIT, then (AA,BB) has ! level L if ABS(BB-AA) = ABS(P2-P1)*2**(-L), ! IWORK(LIMIT*2+1), ..., IWORK(LIMIT*2+NPTS2) have ! no significance for the user, ! note that LIMIT = (LENIW-NPTS2)/2. ! ! WORK - Real ! Vector of dimension at least LENW ! on return ! WORK(1), ..., WORK(LAST) contain the left ! end points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain ! the right end points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain ! the integral approximations over the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) ! contain the corresponding error estimates, ! WORK(LIMIT*4+1), ..., WORK(LIMIT*4+NPTS2) ! contain the integration limits and the ! break points sorted in an ascending sequence. ! note that LIMIT = (LENIW-NPTS2)/2. ! !***REFERENCES (NONE) !***ROUTINES CALLED QAGPE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE QAGP ! REAL A,ABSERR,B,EPSABS,EPSREL,F,POINTS,RESULT,WORK INTEGER IER,IWORK,LENIW,LENW,LIMIT,LVL,L1,L2,L3,NEVAL,NPTS2 ! DIMENSION IWORK(*),POINTS(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMIT AND LENW. ! !***FIRST EXECUTABLE STATEMENT QAGP IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 if ( LENIW < (3*NPTS2-2).OR.LENW < (LENIW*2-NPTS2).OR.NPTS2 < 2) & go to 10 ! ! PREPARE call FOR QAGPE. ! LIMIT = (LENIW-NPTS2)/2 L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 L4 = LIMIT+L3 ! call QAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, & NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),WORK(L4), & IWORK(1),IWORK(L1),IWORK(L2),LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'QAGP', & 'ABNORMAL RETURN', IER, LVL) return end subroutine QAGSE (F, A, B, EPSABS, EPSREL, LIMIT, RESULT, ABSERR, & NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) ! !! QAGSE calculates an approximation RESULT to a given integral ... ! I = Integral of F over (A,B), ! hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A1 !***TYPE SINGLE PRECISION (QAGSE-S, DQAGSE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, END POINT SINGULARITIES, ! EXTRAPOLATION, GENERAL-PURPOSE, GLOBALLY ADAPTIVE, ! QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B) ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! the estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more sub- ! divisions by increasing the value of LIMIT ! (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. If ! the position of a local difficulty can be ! determined (e.g. singularity, ! discontinuity within the interval) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. If possible, ! an appropriate special-purpose integrator ! should be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is detec- ! ted, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour ! occurs at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. ! It is presumed that the requested ! tolerance cannot be achieved, and that the ! returned result is the best which can be ! obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER. ! = 6 The input is invalid, because ! EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28). ! RESULT, ABSERR, NEVAL, LAST, RLIST(1), ! IORD(1) and ELIST(1) are set to zero. ! ALIST(1) and BLIST(1) are set to A and B ! respectively. ! ! ALIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left end points ! of the subintervals in the partition of the ! given integration range (A,B) ! ! BLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right end points ! of the subintervals in the partition of the given ! integration range (A,B) ! ! RLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which are pointers to the ! error estimates over the subintervals, ! such that ELIST(IORD(1)), ..., ELIST(IORD(K)) ! form a decreasing sequence, with K = LAST ! If LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise ! ! LAST - Integer ! Number of subintervals actually produced in the ! subdivision process ! !***REFERENCES (NONE) !***ROUTINES CALLED QELG, QK21, QPSRT, R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QAGSE ! REAL A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, & A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,R1MACH, & DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, & ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS, & RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, & KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 LOGICAL EXTRAP,NOEXT ! DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*), & RES3LA(3),RLIST(*),RLIST2(52) ! EXTERNAL F ! ! THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF ! LIMEXP IN SUBROUTINE QELG (RLIST2 SHOULD BE OF DIMENSION ! (LIMEXP+2) AT LEAST). ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 ! CONTAINING THE PART OF THE EPSILON TABLE ! WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR ! ESTIMATE ! ERRMAX - ELIST(MAXERR) ! ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED ! (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT INTERVAL ! *****2 - VARIABLE FOR THE RIGHT INTERVAL ! LAST - INDEX FOR SUBDIVISION ! NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE ! NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. if AN ! APPROPRIATE APPROXIMATION TO THE COMPOUNDED ! INTEGRAL HAS BEEN OBTAINED IT IS PUT IN ! RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED ! BY ONE. ! SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED ! UP TO NOW, MULTIPLIED BY 1.5 ! ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER ! THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW ! EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE ! IS ATTEMPTING TO PERFORM EXTRAPOLATION ! I.E. BEFORE SUBDIVIDING THE SMALLEST INTERVAL ! WE TRY TO DECREASE THE VALUE OF ERLARG. ! NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION ! IS NO LONGER ALLOWED (TRUE VALUE) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QAGSE EPMACH = R1MACH(4) ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0E+00 ELIST(1) = 0.0E+00 if ( EPSABS <= 0.0E+00.AND.EPSREL < MAX(0.5E+02*EPMACH,0.5E-14)) & IER = 6 if ( IER == 6) go to 999 ! ! FIRST APPROXIMATION TO THE INTEGRAL ! ----------------------------------- ! UFLOW = R1MACH(1) OFLOW = R1MACH(2) IERRO = 0 call QK21(F,A,B,RESULT,ABSERR,DEFABS,RESABS) ! ! TEST ON ACCURACY. ! DRES = ABS(RESULT) ERRBND = MAX(EPSABS,EPSREL*DRES) LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 if ( ABSERR <= 1.0E+02*EPMACH*DEFABS.AND.ABSERR > & ERRBND) IER = 2 if ( LIMIT == 1) IER = 1 if ( IER /= 0.OR.(ABSERR <= ERRBND.AND.ABSERR /= RESABS).OR. & ABSERR == 0.0E+00) go to 140 ! ! INITIALIZATION ! -------------- ! 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 >= (0.1E+01-0.5E+02*EPMACH)*DEFABS) KSGN = 1 ! ! MAIN DO-LOOP ! ------------ ! DO 90 LAST = 2,LIMIT ! ! BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ! ERROR ESTIMATE. ! A1 = ALIST(MAXERR) B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX call QK21(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1) call QK21(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2) ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( DEFAB1 == ERROR1.OR.DEFAB2 == ERROR2) go to 15 if ( ABS(RLIST(MAXERR)-AREA12) > 0.1E-04*ABS(AREA12) & .OR.ERRO12 < 0.99E+00*ERRMAX) go to 10 if ( EXTRAP) IROFF2 = IROFF2+1 if ( .NOT.EXTRAP) IROFF1 = IROFF1+1 10 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF3 = IROFF3+1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY ! SET ERROR FLAG. ! if ( IROFF1+IROFF2 >= 10.OR.IROFF3 >= 20) IER = 2 if ( IROFF2 >= 5) IERRO = 3 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF ! SUBINTERVALS EQUALS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT A POINT OF THE INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1E+01+0.1E+03*EPMACH)* & (ABS(A2)+0.1E+04*UFLOW)) IER = 4 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! if ( ERROR2 > 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 ! ! call SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE ! SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE ! BISECTED NEXT). ! 30 call QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if ( ERRSUM <= ERRBND) go to 115 ! ***JUMP OUT OF DO-LOOP if ( IER /= 0) go to 100 if ( LAST == 2) go to 80 if ( NOEXT) go to 90 ERLARG = ERLARG-ERLAST if ( ABS(B1-A1) > SMALL) ERLARG = ERLARG+ERRO12 if ( EXTRAP) go to 40 ! ! TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE ! SMALLEST INTERVAL. ! if ( ABS(BLIST(MAXERR)-ALIST(MAXERR)) > SMALL) go to 90 EXTRAP = .TRUE. NRMAX = 2 40 if ( IERRO == 3.OR.ERLARG <= ERTEST) go to 60 ! ! THE SMALLEST INTERVAL HAS THE LARGEST ERROR. ! BEFORE BISECTING DECREASE THE SUM OF THE ERRORS ! OVER THE LARGER INTERVALS (ERLARG) AND PERFORM ! EXTRAPOLATION. ! ID = NRMAX JUPBND = LAST if ( LAST > (2+LIMIT/2)) JUPBND = LIMIT+3-LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) ! ***JUMP OUT OF DO-LOOP if ( ABS(BLIST(MAXERR)-ALIST(MAXERR)) > SMALL) go to 90 NRMAX = NRMAX+1 50 CONTINUE ! ! PERFORM EXTRAPOLATION. ! 60 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA call QELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) KTMIN = KTMIN+1 if ( KTMIN > 5.AND.ABSERR < 0.1E-02*ERRSUM) IER = 5 if ( ABSEPS >= ABSERR) go to 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) ! ***JUMP OUT OF DO-LOOP if ( ABSERR <= ERTEST) go to 100 ! ! PREPARE BISECTION OF THE SMALLEST INTERVAL. ! 70 if ( NUMRL2 == 1) NOEXT = .TRUE. if ( IER == 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 = ABS(B-A)*0.375E+00 ERLARG = ERRSUM ERTEST = ERRBND RLIST2(2) = AREA 90 CONTINUE ! ! SET FINAL RESULT AND ERROR ESTIMATE. ! ------------------------------------ ! 100 if ( ABSERR == OFLOW) go to 115 if ( IER+IERRO == 0) go to 110 if ( IERRO == 3) ABSERR = ABSERR+CORREC if ( IER == 0) IER = 3 if ( RESULT /= 0.0E+00.AND.AREA /= 0.0E+00) go to 105 if ( ABSERR > ERRSUM) go to 115 if ( AREA == 0.0E+00) go to 130 go to 110 105 if ( ABSERR/ABS(RESULT) > ERRSUM/ABS(AREA)) go to 115 ! ! TEST ON DIVERGENCE. ! 110 if ( KSGN == (-1).AND.MAX(ABS(RESULT),ABS(AREA)) <= & DEFABS*0.1E-01) go to 130 if ( 0.1E-01 > (RESULT/AREA).OR.(RESULT/AREA) > 0.1E+03 & .OR.ERRSUM > ABS(AREA)) IER = 6 go to 130 ! ! COMPUTE GLOBAL INTEGRAL SUM. ! 115 RESULT = 0.0E+00 DO 120 K = 1,LAST RESULT = RESULT+RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 if ( IER > 2) IER = IER-1 140 NEVAL = 42*LAST-21 999 RETURN end subroutine QAGS (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, NEVAL, & IER, LIMIT, LENW, LAST, IWORK, WORK) ! !! QAGS approximates the definite integral of F(X) over (A,B). ! ! Hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A1 !***TYPE SINGLE PRECISION (QAGS-S, DQAGS-D) !***KEYWORDS AUTOMATIC INTEGRATOR, END POINT SINGULARITIES, ! EXTRAPOLATION, GENERAL-PURPOSE, GLOBALLY ADAPTIVE, ! QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a definite integral ! Standard fortran subroutine ! Real version ! ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! Function F(X). The actual name for F needs to be ! Declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! And EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! The routine will end with IER = 6. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! The estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more sub- ! divisions by increasing the value of LIMIT ! (and taking the according dimension ! adjustments into account. However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. If ! the position of a local difficulty can be ! determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. If possible, ! an appropriate special-purpose integrator ! should be used, which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is detec- ! ted, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour ! occurs at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! Extrapolation table. It is presumed that ! the requested tolerance cannot be ! achieved, and that the returned result is ! the best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER. ! = 6 The input is invalid, because ! (EPSABS <= 0 AND ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28) ! OR LIMIT < 1 OR LENW < LIMIT*4. ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LIMIT or LENW is ! invalid, IWORK(1), WORK(LIMIT*2+1) and ! WORK(LIMIT*3+1) are set to zero, WORK(1) ! is set to A and WORK(LIMIT+1) TO B. ! ! DIMENSIONING PARAMETERS ! LIMIT - Integer ! Dimensioning parameter for IWORK ! LIMIT determines the maximum number of subintervals ! in the partition of the given integration interval ! (A,B), LIMIT >= 1. ! if LIMIT < 1, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LIMIT*4. ! If LENW < LIMIT*4, the routine will end ! with IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, determines the ! number of significant elements actually in the WORK ! Arrays. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which contain pointers ! to the error estimates over the subintervals ! such that WORK(LIMIT*3+IWORK(1)),... , ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence, with K = LAST if LAST <= (LIMIT/2+2), ! and K = LIMIT+1-LAST otherwise ! ! WORK - Real ! Vector of dimension at least LENW ! on return ! WORK(1), ..., WORK(LAST) contain the left ! end-points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain ! the right end-points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain ! the integral approximations over the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) ! contain the error estimates. ! !***REFERENCES (NONE) !***ROUTINES CALLED QAGSE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE QAGS ! ! REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK,LENW,LIMIT,LVL,L1,L2,L3,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMIT AND LENW. ! !***FIRST EXECUTABLE STATEMENT QAGS IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 if ( LIMIT < 1.OR.LENW < LIMIT*4) go to 10 ! ! PREPARE call FOR QAGSE. ! L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 ! call QAGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL, & IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'QAGS', & 'ABNORMAL RETURN', IER, LVL) return end subroutine QAWCE (F, A, B, C, EPSABS, EPSREL, LIMIT, RESULT, & ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST) ! !! QAWCE calculates an approximation RESULT to a CAUCHY PRINCIPAL VALUE ... ! I = Integral of F*W over (A,B) ! (W(X) = 1/(X-C), (C /= A, C /= B), hopefully satisfying ! following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1, J4 !***TYPE SINGLE PRECISION (QAWCE-S, DQAWCE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CAUCHY PRINCIPAL VALUE, ! CLENSHAW-CURTIS METHOD, QUADPACK, QUADRATURE, ! SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a CAUCHY PRINCIPAL VALUE ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! C - Real ! Parameter in the WEIGHT function, C /= A, C /= B ! If C = A OR C = B, the routine will end with ! IER = 6. ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B), LIMIT >= 1 ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! the estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more sub- ! divisions by increasing the value of ! LIMIT. However, if this yields no ! improvement it is advised to analyze the ! the integrand, in order to determine the ! the integration difficulties. If the ! position of a local difficulty can be ! determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling ! appropriate integrators on the subranges. ! = 2 The occurrence of roundoff error is detec- ! ted, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour ! occurs at some interior points of ! the integration interval. ! = 6 The input is invalid, because ! C = A or C = B or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or LIMIT < 1. ! RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1), ! IORD(1) and LAST are set to zero. ALIST(1) ! and BLIST(1) are set to A and B ! respectively. ! ! ALIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! BLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! RLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Real ! Vector of dimension LIMIT, the first LAST ! elements of which are the moduli of the absolute ! error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which are pointers to the error ! estimates over the subintervals, so that ! ELIST(IORD(1)), ..., ELIST(IORD(K)) with K = LAST ! If LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise, form a decreasing sequence ! ! LAST - Integer ! Number of subintervals actually produced in ! the subdivision process ! !***REFERENCES (NONE) !***ROUTINES CALLED QC25C, QPSRT, R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QAWCE ! REAL A,AA,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,B,BB,BLIST, & B1,B2,C,R1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERRBND,ERRMAX,ERROR1, & ERROR2,ERRSUM,F,RESULT,RLIST,UFLOW INTEGER IER,IORD,IROFF1,IROFF2,K,KRULE,LAST,LIMIT,MAXERR,NEV, & NEVAL,NRMAX ! DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), & IORD(*) ! EXTERNAL F ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ! ERROR ESTIMATE ! ERRMAX - ELIST(MAXERR) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QAWCE EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! IER = 6 NEVAL = 0 LAST = 0 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0E+00 ELIST(1) = 0.0E+00 IORD(1) = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 if (C == A.OR.C == B.OR.(EPSABS <= 0.0E+00.AND. & EPSREL < MAX(0.5E+02*EPMACH,0.5E-14))) go to 999 ! ! FIRST APPROXIMATION TO THE INTEGRAL ! ----------------------------------- ! AA=A BB=B if (A <= B) go to 10 AA=B BB=A 10 IER=0 KRULE = 1 call QC25C(F,AA,BB,C,RESULT,ABSERR,KRULE,NEVAL) LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 ALIST(1) = A BLIST(1) = B ! ! TEST ON ACCURACY ! ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) if ( LIMIT == 1) IER = 1 if ( ABSERR < MIN(0.1E-01*ABS(RESULT),ERRBND) & .OR.IER == 1) go to 70 ! ! INITIALIZATION ! -------------- ! ALIST(1) = AA BLIST(1) = BB RLIST(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR NRMAX = 1 IROFF1 = 0 IROFF2 = 0 ! ! MAIN DO-LOOP ! ------------ ! DO 40 LAST = 2,LIMIT ! ! BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ! ERROR ESTIMATE. ! A1 = ALIST(MAXERR) B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) B2 = BLIST(MAXERR) if ( C <= B1.AND.C > A1) B1 = 0.5E+00*(C+B2) if ( C > B1.AND.C < B2) B1 = 0.5E+00*(A1+C) A2 = B1 KRULE = 2 call QC25C(F,A1,B1,C,AREA1,ERROR1,KRULE,NEV) NEVAL = NEVAL+NEV call QC25C(F,A2,B2,C,AREA2,ERROR2,KRULE,NEV) NEVAL = NEVAL+NEV ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( ABS(RLIST(MAXERR)-AREA12) < 0.1E-04*ABS(AREA12) & .AND.ERRO12 >= 0.99E+00*ERRMAX.AND.KRULE == 0) & IROFF1 = IROFF1+1 if ( LAST > 10.AND.ERRO12 > ERRMAX.AND.KRULE == 0) & IROFF2 = IROFF2+1 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) if ( ERRSUM <= ERRBND) go to 15 ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY ! SET ERROR FLAG. ! if ( IROFF1 >= 6.AND.IROFF2 > 20) IER = 2 ! ! SET ERROR FLAG IN THE CASE THAT NUMBER OF INTERVAL ! BISECTIONS EXCEEDS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT A POINT OF THE INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1E+01+0.1E+03*EPMACH) & *(ABS(A2)+0.1E+04*UFLOW)) IER = 3 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! 15 if ( ERROR2 > 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 ! ! call SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE ! SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE ! BISECTED NEXT). ! 30 call QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if ( IER /= 0.OR.ERRSUM <= ERRBND) go to 50 40 CONTINUE ! ! COMPUTE FINAL RESULT. ! --------------------- ! 50 RESULT = 0.0E+00 DO 60 K=1,LAST RESULT = RESULT+RLIST(K) 60 CONTINUE ABSERR = ERRSUM 70 if (AA == B) RESULT=-RESULT 999 RETURN end subroutine QAWC (F, A, B, C, EPSABS, EPSREL, RESULT, ABSERR, & NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) ! !! QAWC calculates an approximation RESULT to a Cauchy principal value ... ! I = INTEGRAL of F*W over (A,B) ! (W(X) = 1/((X-C), C /= A, C /= B), hopefully satisfying ! following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABE,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1, J4 !***TYPE SINGLE PRECISION (QAWC-S, DQAWC-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CAUCHY PRINCIPAL VALUE, ! CLENSHAW-CURTIS METHOD, GLOBALLY ADAPTIVE, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of a Cauchy principal value ! Standard fortran subroutine ! Real version ! ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! Function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Under limit of integration ! ! B - Real ! Upper limit of integration ! ! C - Parameter in the weight function, C /= A, C /= B. ! If C = A or C = B, the routine will end with ! IER = 6 . ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate or the modulus of the absolute error, ! Which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! the estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more sub- ! divisions by increasing the value of LIMIT ! (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. ! If the position of a local difficulty ! can be determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling ! appropriate integrators on the subranges. ! = 2 The occurrence of roundoff error is detec- ! ted, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 6 The input is invalid, because ! C = A or C = B or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or LIMIT < 1 or LENW < LIMIT*4. ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LENW or LIMIT is ! invalid, IWORK(1), WORK(LIMIT*2+1) and ! WORK(LIMIT*3+1) are set to zero, WORK(1) ! is set to A and WORK(LIMIT+1) to B. ! ! DIMENSIONING PARAMETERS ! LIMIT - Integer ! Dimensioning parameter for IWORK ! LIMIT determines the maximum number of subintervals ! in the partition of the given integration interval ! (A,B), LIMIT >= 1. ! If LIMIT < 1, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LIMIT*4. ! If LENW < LIMIT*4, the routine will end with ! IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, which ! determines the number of significant elements ! actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which contain pointers ! to the error estimates over the subintervals, ! such that WORK(LIMIT*3+IWORK(1)), ... , ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence, with K = LAST if LAST <= (LIMIT/2+2), ! and K = LIMIT+1-LAST otherwise ! ! WORK - Real ! Vector of dimension at least LENW ! On return ! WORK(1), ..., WORK(LAST) contain the left ! end points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain ! the right end points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain ! the integral approximations over the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) ! contain the error estimates. ! !***REFERENCES (NONE) !***ROUTINES CALLED QAWCE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE QAWC ! REAL A,ABSERR,B,C,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK,LENW,LIMIT,LVL,L1,L2,L3,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMIT AND LENW. ! !***FIRST EXECUTABLE STATEMENT QAWC IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 if ( LIMIT < 1.OR.LENW < LIMIT*4) go to 10 ! ! PREPARE call FOR QAWCE. ! L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 call QAWCE(F,A,B,C,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL,IER, & WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'QAWC', & 'ABNORMAL RETURN', IER, LVL) return end subroutine QAWFE (F, A, OMEGA, INTEGR, EPSABS, LIMLST, LIMIT, & MAXP1, RESULT, ABSERR, NEVAL, IER, RSLST, ERLST, IERLST, LST, & ALIST, BLIST, RLIST, ELIST, IORD, NNLOG, CHEBMO) ! !! QAWFE calculates an approximation result to a given Fourier integral ... ! I = Integral of F(X)*W(X) over (A,INFINITY) ! where W(X) = COS(OMEGA*X) or W(X) = SIN(OMEGA*X), ! hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= EPSABS. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A3A1 !***TYPE SINGLE PRECISION (QAWFE-S, DQAWFE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CONVERGENCE ACCELERATION, ! FOURIER INTEGRALS, INTEGRATION BETWEEN ZEROS, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE INTEGRAL !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of Fourier integrals ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! Function F(X). The actual name for F needs to ! be declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! OMEGA - Real ! Parameter in the WEIGHT function ! ! INTEGR - Integer ! Indicates which WEIGHT function is used ! INTEGR = 1 W(X) = COS(OMEGA*X) ! INTEGR = 2 W(X) = SIN(OMEGA*X) ! If INTEGR /= 1.AND.INTEGR /= 2, the routine will ! end with IER = 6. ! ! EPSABS - Real ! absolute accuracy requested, EPSABS > 0 ! If EPSABS <= 0, the routine will end with IER = 6. ! ! LIMLST - Integer ! LIMLST gives an upper bound on the number of ! cycles, LIMLST >= 1. ! If LIMLST < 3, the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! allowed in the partition of each cycle, LIMIT >= 1 ! each cycle, LIMIT >= 1. ! ! MAXP1 - Integer ! Gives an upper bound on the number of ! Chebyshev moments which can be stored, I.E. ! for the intervals of lengths ABS(B-A)*2**(-L), ! L=0,1, ..., MAXP1-2, MAXP1 >= 1 ! ! ON RETURN ! RESULT - Real ! Approximation to the integral X ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - IER = 0 Normal and reliable termination of ! the routine. It is assumed that the ! requested accuracy has been achieved. ! IER > 0 Abnormal termination of the routine. The ! estimates for integral and error are less ! reliable. It is assumed that the requested ! accuracy has not been achieved. ! ERROR MESSAGES ! If OMEGA /= 0 ! IER = 1 Maximum number of cycles allowed ! Has been achieved., i.e. of subintervals ! (A+(K-1)C,A+KC) where ! C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), ! for K = 1, 2, ..., LST. ! One can allow more cycles by increasing ! the value of LIMLST (and taking the ! according dimension adjustments into ! account). ! Examine the array IWORK which contains ! the error flags on the cycles, in order to ! look for eventual local integration ! difficulties. If the position of a local ! difficulty can be determined (e.g. ! SINGULARITY, DISCONTINUITY within the ! interval) one will probably gain from ! splitting up the interval at this point ! and calling appropriate integrators on ! the subranges. ! = 4 The extrapolation table constructed for ! convergence acceleration of the series ! formed by the integral contributions over ! the cycles, does not converge to within ! the requested accuracy. As in the case of ! IER = 1, it is advised to examine the ! array IWORK which contains the error ! flags on the cycles. ! = 6 The input is invalid because ! (INTEGR /= 1 AND INTEGR /= 2) or ! EPSABS <= 0 or LIMLST < 3. ! RESULT, ABSERR, NEVAL, LST are set ! to zero. ! = 7 Bad integrand behaviour occurs within one ! or more of the cycles. Location and type ! of the difficulty involved can be ! determined from the vector IERLST. Here ! LST is the number of cycles actually ! needed (see below). ! IERLST(K) = 1 The maximum number of ! subdivisions (= LIMIT) has ! been achieved on the K th ! cycle. ! = 2 Occurrence of roundoff error ! is detected and prevents the ! tolerance imposed on the ! K th cycle, from being ! achieved. ! = 3 Extremely bad integrand ! behaviour occurs at some ! points of the K th cycle. ! = 4 The integration procedure ! over the K th cycle does ! not converge (to within the ! required accuracy) due to ! roundoff in the ! extrapolation procedure ! invoked on this cycle. It ! is assumed that the result ! on this interval is the ! best which can be obtained. ! = 5 The integral over the K th ! cycle is probably divergent ! or slowly convergent. It ! must be noted that ! divergence can occur with ! any other value of ! IERLST(K). ! If OMEGA = 0 and INTEGR = 1, ! The integral is calculated by means of DQAGIE ! and IER = IERLST(1) (with meaning as described ! for IERLST(K), K = 1). ! ! RSLST - Real ! Vector of dimension at least LIMLST ! RSLST(K) contains the integral contribution ! over the interval (A+(K-1)C,A+KC) where ! C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), ! K = 1, 2, ..., LST. ! Note that, if OMEGA = 0, RSLST(1) contains ! the value of the integral over (A,INFINITY). ! ! ERLST - Real ! Vector of dimension at least LIMLST ! ERLST(K) contains the error estimate corresponding ! with RSLST(K). ! ! IERLST - Integer ! Vector of dimension at least LIMLST ! IERLST(K) contains the error flag corresponding ! with RSLST(K). For the meaning of the local error ! flags see description of output parameter IER. ! ! LST - Integer ! Number of subintervals needed for the integration ! If OMEGA = 0 then LST is set to 1. ! ! ALIST, BLIST, RLIST, ELIST - Real ! vector of dimension at least LIMIT, ! ! IORD, NNLOG - Integer ! Vector of dimension at least LIMIT, providing ! space for the quantities needed in the subdivision ! process of each cycle ! ! CHEBMO - Real ! Array of dimension at least (MAXP1,25), providing ! space for the Chebyshev moments needed within the ! cycles ! !***REFERENCES (NONE) !***ROUTINES CALLED QAGIE, QAWOE, QELG, R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QAWFE ! REAL A,ABSEPS,ABSERR,ALIST,BLIST,CHEBMO,CORREC,CYCLE, & C1,C2,DL,DRL,ELIST,EP,EPS,EPSA,EPSABS,ERLST, & ERRSUM,FACT,OMEGA,P,PI,P1,PSUM,RESEPS,RESULT,RES3LA,RLIST,RSLST & ,R1MACH,UFLOW INTEGER IER,IERLST,INTEGR,IORD,KTMIN,L,LST,LIMIT,LL,MAXP1, & NEV,NEVAL,NNLOG,NRES,NUMRL2 ! DIMENSION ALIST(*),BLIST(*),CHEBMO(MAXP1,25),ELIST(*), & ERLST(*),IERLST(*),IORD(*),NNLOG(*),PSUM(52), & RES3LA(3),RLIST(*),RSLST(*) ! EXTERNAL F ! ! ! THE DIMENSION OF PSUM IS DETERMINED BY THE VALUE OF ! LIMEXP IN SUBROUTINE QELG (PSUM MUST BE ! OF DIMENSION (LIMEXP+2) AT LEAST). ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! C1, C2 - END POINTS OF SUBINTERVAL (OF LENGTH ! CYCLE) ! CYCLE - (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA) ! PSUM - VECTOR OF DIMENSION AT LEAST (LIMEXP+2) ! (SEE ROUTINE QELG) ! PSUM CONTAINS THE PART OF THE EPSILON ! TABLE WHICH IS STILL NEEDED FOR FURTHER ! COMPUTATIONS. ! EACH ELEMENT OF PSUM IS A PARTIAL SUM OF ! THE SERIES WHICH SHOULD SUM TO THE VALUE OF ! THE INTEGRAL. ! ERRSUM - SUM OF ERROR ESTIMATES OVER THE ! SUBINTERVALS, CALCULATED CUMULATIVELY ! EPSA - ABSOLUTE TOLERANCE REQUESTED OVER CURRENT ! SUBINTERVAL ! CHEBMO - ARRAY CONTAINING THE MODIFIED CHEBYSHEV ! MOMENTS (SEE ALSO ROUTINE QC25F) ! SAVE P, PI DATA P/0.9E+00/,PI/0.31415926535897932E+01/ ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! !***FIRST EXECUTABLE STATEMENT QAWFE RESULT = 0.0E+00 ABSERR = 0.0E+00 NEVAL = 0 LST = 0 IER = 0 if ( (INTEGR /= 1.AND.INTEGR /= 2).OR.EPSABS <= 0.0E+00.OR. & LIMLST < 3) IER = 6 if ( IER == 6) go to 999 if ( OMEGA /= 0.0E+00) go to 10 ! ! INTEGRATION BY QAGIE if OMEGA IS ZERO ! -------------------------------------- ! if ( INTEGR == 1) call QAGIE(F,A,1,EPSABS,0.0E+00,LIMIT, & RESULT,ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) RSLST(1) = RESULT ERLST(1) = ABSERR IERLST(1) = IER LST = 1 go to 999 ! ! INITIALIZATIONS ! --------------- ! 10 L = ABS(OMEGA) DL = 2*L+1 CYCLE = DL*PI/ABS(OMEGA) IER = 0 KTMIN = 0 NEVAL = 0 NUMRL2 = 0 NRES = 0 C1 = A C2 = CYCLE+A P1 = 0.1E+01-P EPS = EPSABS UFLOW = R1MACH(1) if ( EPSABS > UFLOW/P1) EPS = EPSABS*P1 EP = EPS FACT = 0.1E+01 CORREC = 0.0E+00 ABSERR = 0.0E+00 ERRSUM = 0.0E+00 ! ! MAIN DO-LOOP ! ------------ ! DO 50 LST = 1,LIMLST ! ! INTEGRATE OVER CURRENT SUBINTERVAL. ! EPSA = EPS*FACT call QAWOE(F,C1,C2,OMEGA,INTEGR,EPSA,0.0E+00,LIMIT,LST,MAXP1, & RSLST(LST),ERLST(LST),NEV,IERLST(LST),LAST,ALIST,BLIST,RLIST, & ELIST,IORD,NNLOG,MOMCOM,CHEBMO) NEVAL = NEVAL+NEV FACT = FACT*P ERRSUM = ERRSUM+ERLST(LST) DRL = 0.5E+02*ABS(RSLST(LST)) ! ! TEST ON ACCURACY WITH PARTIAL SUM ! if ( ERRSUM+DRL <= EPSABS.AND.LST >= 6) go to 80 CORREC = MAX(CORREC,ERLST(LST)) if ( IERLST(LST) /= 0) EPS = MAX(EP,CORREC*P1) if ( IERLST(LST) /= 0) IER = 7 if ( IER == 7.AND.(ERRSUM+DRL) <= CORREC*0.1E+02.AND. & LST > 5) go to 80 NUMRL2 = NUMRL2+1 if ( LST > 1) go to 20 PSUM(1) = RSLST(1) go to 40 20 PSUM(NUMRL2) = PSUM(LL)+RSLST(LST) if ( LST == 2) go to 40 ! ! TEST ON MAXIMUM NUMBER OF SUBINTERVALS ! if ( LST == LIMLST) IER = 1 ! ! PERFORM NEW EXTRAPOLATION ! call QELG(NUMRL2,PSUM,RESEPS,ABSEPS,RES3LA,NRES) ! ! TEST WHETHER EXTRAPOLATED RESULT IS INFLUENCED BY ! ROUNDOFF ! KTMIN = KTMIN+1 if ( KTMIN >= 15.AND.ABSERR <= 0.1E-02*(ERRSUM+DRL)) IER = 4 if ( ABSEPS > ABSERR.AND.LST /= 3) go to 30 ABSERR = ABSEPS RESULT = RESEPS KTMIN = 0 ! ! if IER IS NOT 0, CHECK WHETHER DIRECT RESULT (PARTIAL ! SUM) OR EXTRAPOLATED RESULT YIELDS THE BEST INTEGRAL ! APPROXIMATION ! if ( (ABSERR+0.1E+02*CORREC) <= EPSABS.OR. & (ABSERR <= EPSABS.AND.0.1E+02*CORREC >= EPSABS)) go to 60 30 if ( IER /= 0.AND.IER /= 7) go to 60 40 LL = NUMRL2 C1 = C2 C2 = C2+CYCLE 50 CONTINUE ! ! SET FINAL RESULT AND ERROR ESTIMATE ! ----------------------------------- ! 60 ABSERR = ABSERR+0.1E+02*CORREC if ( IER == 0) go to 999 if ( RESULT /= 0.0E+00.AND.PSUM(NUMRL2) /= 0.0E+00) go to 70 if ( ABSERR > ERRSUM) go to 80 if ( PSUM(NUMRL2) == 0.0E+00) go to 999 70 if ( ABSERR/ABS(RESULT) > (ERRSUM+DRL)/ABS(PSUM(NUMRL2))) & go to 80 if ( IER >= 1.AND.IER /= 7) ABSERR = ABSERR+DRL go to 999 80 RESULT = PSUM(NUMRL2) ABSERR = ERRSUM+DRL 999 RETURN end subroutine QAWF (F, A, OMEGA, INTEGR, EPSABS, RESULT, ABSERR, & NEVAL, IER, LIMLST, LST, LENIW, MAXP1, LENW, IWORK, WORK) ! !! QAWF calculates an approximation RESULT to a given Fourier integral ... ! I = Integral of F(X)*W(X) over (A,INFINITY) ! where W(X) = COS(OMEGA*X) or W(X) = SIN(OMEGA*X). ! Hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= EPSABS. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A3A1 !***TYPE SINGLE PRECISION (QAWF-S, DQAWF-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CONVERGENCE ACCELERATION, ! FOURIER INTEGRALS, INTEGRATION BETWEEN ZEROS, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE INTEGRAL !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of Fourier integrals ! Standard fortran subroutine ! Real version ! ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! OMEGA - Real ! Parameter in the integrand WEIGHT function ! ! INTEGR - Integer ! Indicates which of the WEIGHT functions is used ! INTEGR = 1 W(X) = COS(OMEGA*X) ! INTEGR = 2 W(X) = SIN(OMEGA*X) ! if INTEGR /= 1.AND.INTEGR /= 2, the routine ! will end with IER = 6. ! ! EPSABS - Real ! Absolute accuracy requested, EPSABS > 0. ! If EPSABS <= 0, the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! Which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine. ! The estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! If OMEGA /= 0 ! IER = 1 Maximum number of cycles allowed ! has been achieved, i.e. of subintervals ! (A+(K-1)C,A+KC) where ! C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA), ! FOR K = 1, 2, ..., LST. ! One can allow more cycles by increasing ! the value of LIMLST (and taking the ! according dimension adjustments into ! account). Examine the array IWORK which ! contains the error flags on the cycles, in ! order to look for eventual local ! integration difficulties. ! If the position of a local difficulty ! can be determined (e.g. singularity, ! discontinuity within the interval) one ! will probably gain from splitting up the ! interval at this point and calling ! appropriate integrators on the subranges. ! = 4 The extrapolation table constructed for ! convergence acceleration of the series ! formed by the integral contributions over ! the cycles, does not converge to within ! the requested accuracy. ! As in the case of IER = 1, it is advised ! to examine the array IWORK which contains ! the error flags on the cycles. ! = 6 The input is invalid because ! (INTEGR /= 1 AND INTEGR /= 2) or ! EPSABS <= 0 or LIMLST < 1 or ! LENIW < (LIMLST+2) or MAXP1 < 1 or ! LENW < (LENIW*2+MAXP1*25). ! RESULT, ABSERR, NEVAL, LST are set to ! zero. ! = 7 Bad integrand behaviour occurs within ! one or more of the cycles. Location and ! type of the difficulty involved can be ! determined from the first LST elements of ! vector IWORK. Here LST is the number of ! cycles actually needed (see below). ! IWORK(K) = 1 The maximum number of ! subdivisions (=(LENIW-LIMLST) ! /2) has been achieved on the ! K th cycle. ! = 2 Occurrence of roundoff error ! is detected and prevents the ! tolerance imposed on the K th ! cycle, from being achieved ! on this cycle. ! = 3 Extremely bad integrand ! behaviour occurs at some ! points of the K th cycle. ! = 4 The integration procedure ! over the K th cycle does ! not converge (to within the ! required accuracy) due to ! roundoff in the extrapolation ! procedure invoked on this ! cycle. It is assumed that the ! result on this interval is ! the best which can be ! obtained. ! = 5 The integral over the K th ! cycle is probably divergent ! or slowly convergent. It must ! be noted that divergence can ! occur with any other value of ! IWORK(K). ! If OMEGA = 0 and INTEGR = 1, ! The integral is calculated by means of DQAGIE, ! and IER = IWORK(1) (with meaning as described ! for IWORK(K),K = 1). ! ! DIMENSIONING PARAMETERS ! LIMLST - Integer ! LIMLST gives an upper bound on the number of ! cycles, LIMLST >= 3. ! If LIMLST < 3, the routine will end with IER = 6. ! ! LST - Integer ! On return, LST indicates the number of cycles ! actually needed for the integration. ! If OMEGA = 0, then LST is set to 1. ! ! LENIW - Integer ! Dimensioning parameter for IWORK. On entry, ! (LENIW-LIMLST)/2 equals the maximum number of ! subintervals allowed in the partition of each ! cycle, LENIW >= (LIMLST+2). ! If LENIW < (LIMLST+2), the routine will end with ! IER = 6. ! ! MAXP1 - Integer ! MAXP1 gives an upper bound on the number of ! Chebyshev moments which can be stored, i.e. for ! the intervals of lengths ABS(B-A)*2**(-L), ! L = 0,1, ..., MAXP1-2, MAXP1 >= 1. ! If MAXP1 < 1, the routine will end with IER = 6. ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LENIW*2+MAXP1*25. ! If LENW < (LENIW*2+MAXP1*25), the routine will ! end with IER = 6. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LENIW ! On return, IWORK(K) FOR K = 1, 2, ..., LST ! contain the error flags on the cycles. ! ! WORK - Real ! Vector of dimension at least ! On return, ! WORK(1), ..., WORK(LST) contain the integral ! approximations over the cycles, ! WORK(LIMLST+1), ..., WORK(LIMLST+LST) contain ! the error estimates over the cycles. ! further elements of WORK have no specific ! meaning for the user. ! !***REFERENCES (NONE) !***ROUTINES CALLED QAWFE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE QAWF ! REAL A,ABSERR,EPSABS,F,OMEGA,RESULT,WORK INTEGER IER,INTEGR,LENIW,LIMIT,LIMLST,LVL,LST,L1,L2,L3,L4,L5,L6, & MAXP1,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMLST, LENIW, MAXP1 AND LENW. ! !***FIRST EXECUTABLE STATEMENT QAWF IER = 6 NEVAL = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 if ( LIMLST < 3.OR.LENIW < (LIMLST+2).OR.MAXP1 < 1.OR.LENW < & (LENIW*2+MAXP1*25)) go to 10 ! ! PREPARE call FOR QAWFE ! LIMIT = (LENIW-LIMLST)/2 L1 = LIMLST+1 L2 = LIMLST+L1 L3 = LIMIT+L2 L4 = LIMIT+L3 L5 = LIMIT+L4 L6 = LIMIT+L5 LL2 = LIMIT+L1 call QAWFE(F,A,OMEGA,INTEGR,EPSABS,LIMLST,LIMIT,MAXP1,RESULT, & ABSERR,NEVAL,IER,WORK(1),WORK(L1),IWORK(1),LST,WORK(L2), & WORK(L3),WORK(L4),WORK(L5),IWORK(L1),IWORK(LL2),WORK(L6)) ! ! call ERROR HANDLER if NECESSARY ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'QAWF', & 'ABNORMAL RETURN', IER, LVL) return end subroutine QAWOE (F, A, B, OMEGA, INTEGR, EPSABS, EPSREL, LIMIT, & ICALL, MAXP1, RESULT, ABSERR, NEVAL, IER, LAST, ALIST, BLIST, & RLIST, ELIST, IORD, NNLOG, MOMCOM, CHEBMO) ! !! QAWOE calculates an approximation to a given definite integral ! I = Integral of F(X)*W(X) over (A,B), where ! W(X) = COS(OMEGA*X) ! or W(X) = SIN(OMEGA*X), ! hopefully satisfying the following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE SINGLE PRECISION (QAWOE-S, DQAWOE-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, ! EXTRAPOLATION, GLOBALLY ADAPTIVE, ! INTEGRAND WITH OSCILLATORY COS OR SIN FACTOR, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of Oscillatory integrals ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! OMEGA - Real ! Parameter in the integrand weight function ! ! INTEGR - Integer ! Indicates which of the WEIGHT functions is to be ! used ! INTEGR = 1 W(X) = COS(OMEGA*X) ! INTEGR = 2 W(X) = SIN(OMEGA*X) ! If INTEGR /= 1 and INTEGR /= 2, the routine ! will end with IER = 6. ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subdivisions ! in the partition of (A,B), LIMIT >= 1. ! ! ICALL - Integer ! If QAWOE is to be used only once, ICALL must ! be set to 1. Assume that during this call, the ! Chebyshev moments (for CLENSHAW-CURTIS integration ! of degree 24) have been computed for intervals of ! lengths (ABS(B-A))*2**(-L), L=0,1,2,...MOMCOM-1. ! If ICALL > 1 this means that QAWOE has been ! called twice or more on intervals of the same ! length ABS(B-A). The Chebyshev moments already ! computed are then re-used in subsequent calls. ! If ICALL < 1, the routine will end with IER = 6. ! ! MAXP1 - Integer ! Gives an upper bound on the number of Chebyshev ! moments which can be stored, i.e. for the ! intervals of lengths ABS(B-A)*2**(-L), ! L=0,1, ..., MAXP1-2, MAXP1 >= 1. ! If MAXP1 < 1, the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the ! requested accuracy has been achieved. ! - IER > 0 Abnormal termination of the routine. ! The estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand, in order to ! determine the integration difficulties. ! If the position of a local difficulty can ! be determined (e.g. SINGULARITY, ! DISCONTINUITY within the interval) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. If possible, ! an appropriate special-purpose integrator ! should be used which is designed for ! handling the type of difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. ! It is presumed that the requested ! tolerance cannot be achieved due to ! roundoff in the extrapolation table, ! and that the returned result is the ! best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER > 0. ! = 6 The input is invalid, because ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or (INTEGR /= 1 and INTEGR /= 2) or ! ICALL < 1 or MAXP1 < 1. ! RESULT, ABSERR, NEVAL, LAST, RLIST(1), ! ELIST(1), IORD(1) and NNLOG(1) are set ! to ZERO. ALIST(1) and BLIST(1) are set ! to A and B respectively. ! ! LAST - Integer ! On return, LAST equals the number of ! subintervals produces in the subdivision ! process, which determines the number of ! significant elements actually in the ! WORK ARRAYS. ! ALIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! BLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! RLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! elements of which are pointers to the error ! estimates over the subintervals, ! such that ELIST(IORD(1)), ..., ! ELIST(IORD(K)) form a decreasing sequence, with ! K = LAST if LAST <= (LIMIT/2+2), and ! K = LIMIT+1-LAST otherwise. ! ! NNLOG - Integer ! Vector of dimension at least LIMIT, containing the ! subdivision levels of the subintervals, i.e. ! IWORK(I) = L means that the subinterval ! numbered I is of length ABS(B-A)*2**(1-L) ! ! ON ENTRY AND RETURN ! MOMCOM - Integer ! Indicating that the Chebyshev moments ! have been computed for intervals of lengths ! (ABS(B-A))*2**(-L), L=0,1,2, ..., MOMCOM-1, ! MOMCOM < MAXP1 ! ! CHEBMO - Real ! Array of dimension (MAXP1,25) containing the ! Chebyshev moments ! !***REFERENCES (NONE) !***ROUTINES CALLED QC25F, QELG, QPSRT, R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QAWOE ! REAL A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, & A2,B,BLIST,B1,B2,CHEBMO,CORREC,DEFAB1,DEFAB2,DEFABS, & DOMEGA,R1MACH,DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG, & ERLAST,ERRBND,ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW, & OMEGA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW,WIDTH INTEGER ICALL,ID,IER,IERRO,INTEGR,IORD,IROFF1,IROFF2,IROFF3, & JUPBND,K,KSGN,KTMIN,LAST,LIMIT,MAXERR,MAXP1,MOMCOM,NEV, & NEVAL,NNLOG,NRES,NRMAX,NRMOM,NUMRL2 LOGICAL EXTRAP,NOEXT,EXTALL ! DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), & IORD(*),RLIST2(52),RES3LA(3),CHEBMO(MAXP1,25),NNLOG(*) ! EXTERNAL F ! ! THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF ! LIMEXP IN SUBROUTINE QELG (RLIST2 SHOULD BE OF ! DIMENSION (LIMEXP+2) AT LEAST). ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 ! CONTAINING THE PART OF THE EPSILON TABLE ! WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ! ERROR ESTIMATE ! ERRMAX - ELIST(MAXERR) ! ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE ! NUMRL2 - NUMBER OF ELEMENTS IN RLIST2. if AN APPROPRIATE ! APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS ! BEEN OBTAINED IT IS PUT IN RLIST2(NUMRL2) AFTER ! NUMRL2 HAS BEEN INCREASED BY ONE ! SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED ! UP TO NOW, MULTIPLIED BY 1.5 ! ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER ! THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW ! EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE IS ! ATTEMPTING TO PERFORM EXTRAPOLATION, I.E. BEFORE ! SUBDIVIDING THE SMALLEST INTERVAL WE TRY TO ! DECREASE THE VALUE OF ERLARG ! NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION ! IS NO LONGER ALLOWED (TRUE VALUE) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QAWOE EPMACH = R1MACH(4) ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! IER = 0 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0E+00 ELIST(1) = 0.0E+00 IORD(1) = 0 NNLOG(1) = 0 if ( (INTEGR /= 1.AND.INTEGR /= 2).OR.(EPSABS <= 0.0E+00.AND. & EPSREL < MAX(0.5E+02*EPMACH,0.5E-14)).OR.ICALL < 1.OR. & MAXP1 < 1) IER = 6 if ( IER == 6) go to 999 ! ! FIRST APPROXIMATION TO THE INTEGRAL ! ----------------------------------- ! DOMEGA = ABS(OMEGA) NRMOM = 0 if (ICALL > 1) go to 5 MOMCOM = 0 5 call QC25F(F,A,B,DOMEGA,INTEGR,NRMOM,MAXP1,0,RESULT,ABSERR, & NEVAL,DEFABS,RESABS,MOMCOM,CHEBMO) ! ! TEST ON ACCURACY. ! DRES = ABS(RESULT) ERRBND = MAX(EPSABS,EPSREL*DRES) RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 if ( ABSERR <= 0.1E+03*EPMACH*DEFABS.AND.ABSERR > & ERRBND) IER = 2 if ( LIMIT == 1) IER = 1 if ( IER /= 0.OR.ABSERR <= ERRBND) go to 200 ! ! INITIALIZATIONS ! --------------- ! UFLOW = R1MACH(1) OFLOW = R1MACH(2) ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW NRMAX = 1 EXTRAP = .FALSE. NOEXT = .FALSE. IERRO = 0 IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KTMIN = 0 SMALL = ABS(B-A)*0.75E+00 NRES = 0 NUMRL2 = 0 EXTALL = .FALSE. if ( 0.5E+00*ABS(B-A)*DOMEGA > 0.2E+01) go to 10 NUMRL2 = 1 EXTALL = .TRUE. RLIST2(1) = RESULT 10 if ( 0.25E+00*ABS(B-A)*DOMEGA <= 0.2E+01) EXTALL = .TRUE. KSGN = -1 if ( DRES >= (0.1E+01-0.5E+02*EPMACH)*DEFABS) KSGN = 1 ! ! MAIN DO-LOOP ! ------------ ! DO 140 LAST = 2,LIMIT ! ! BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ! ERROR ESTIMATE. ! NRMOM = NNLOG(MAXERR)+1 A1 = ALIST(MAXERR) B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX call QC25F(F,A1,B1,DOMEGA,INTEGR,NRMOM,MAXP1,0, & AREA1,ERROR1,NEV,RESABS,DEFAB1,MOMCOM,CHEBMO) NEVAL = NEVAL+NEV call QC25F(F,A2,B2,DOMEGA,INTEGR,NRMOM,MAXP1,1, & AREA2,ERROR2,NEV,RESABS,DEFAB2,MOMCOM,CHEBMO) NEVAL = NEVAL+NEV ! ! IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL ! AND ERROR AND TEST FOR ACCURACY. ! AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( DEFAB1 == ERROR1.OR.DEFAB2 == ERROR2) go to 25 if ( ABS(RLIST(MAXERR)-AREA12) > 0.1E-04*ABS(AREA12) & .OR.ERRO12 < 0.99E+00*ERRMAX) go to 20 if ( EXTRAP) IROFF2 = IROFF2+1 if ( .NOT.EXTRAP) IROFF1 = IROFF1+1 20 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF3 = IROFF3+1 25 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 NNLOG(MAXERR) = NRMOM NNLOG(LAST) = NRMOM ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) ! ! TEST FOR ROUNDOFF ERROR AND EVENTUALLY ! SET ERROR FLAG ! if ( IROFF1+IROFF2 >= 10.OR.IROFF3 >= 20) IER = 2 if ( IROFF2 >= 5) IERRO = 3 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF ! SUBINTERVALS EQUALS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT A POINT OF THE INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1E+01+0.1E+03*EPMACH) & *(ABS(A2)+0.1E+04*UFLOW)) IER = 4 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! if ( ERROR2 > ERROR1) go to 30 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 go to 40 30 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 ! ! call SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE ! SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE ! BISECTED NEXT). ! 40 call QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if ( ERRSUM <= ERRBND) go to 170 if ( IER /= 0) go to 150 if ( LAST == 2.AND.EXTALL) go to 120 if ( NOEXT) go to 140 if ( .NOT.EXTALL) go to 50 ERLARG = ERLARG-ERLAST if ( ABS(B1-A1) > SMALL) ERLARG = ERLARG+ERRO12 if ( EXTRAP) go to 70 ! ! TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE ! SMALLEST INTERVAL. ! 50 WIDTH = ABS(BLIST(MAXERR)-ALIST(MAXERR)) if ( WIDTH > SMALL) go to 140 if ( EXTALL) go to 60 ! ! TEST WHETHER WE CAN START WITH THE EXTRAPOLATION ! PROCEDURE (WE DO THIS if WE INTEGRATE OVER THE ! NEXT INTERVAL WITH USE OF A GAUSS-KRONROD RULE - SEE ! SUBROUTINE QC25F). ! SMALL = SMALL*0.5E+00 if ( 0.25E+00*WIDTH*DOMEGA > 0.2E+01) go to 140 EXTALL = .TRUE. go to 130 60 EXTRAP = .TRUE. NRMAX = 2 70 if ( IERRO == 3.OR.ERLARG <= ERTEST) go to 90 ! ! THE SMALLEST INTERVAL HAS THE LARGEST ERROR. ! BEFORE BISECTING DECREASE THE SUM OF THE ERRORS ! OVER THE LARGER INTERVALS (ERLARG) AND PERFORM ! EXTRAPOLATION. ! JUPBND = LAST if (LAST > (LIMIT/2+2)) JUPBND = LIMIT+3-LAST ID = NRMAX DO 80 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) if ( ABS(BLIST(MAXERR)-ALIST(MAXERR)) > SMALL) go to 140 NRMAX = NRMAX+1 80 CONTINUE ! ! PERFORM EXTRAPOLATION. ! 90 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA if ( NUMRL2 < 3) go to 110 call QELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES) KTMIN = KTMIN+1 if ( KTMIN > 5.AND.ABSERR < 0.1E-02*ERRSUM) IER = 5 if ( ABSEPS >= ABSERR) go to 100 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = MAX(EPSABS,EPSREL*ABS(RESEPS)) ! ***JUMP OUT OF DO-LOOP if ( ABSERR <= ERTEST) go to 150 ! ! PREPARE BISECTION OF THE SMALLEST INTERVAL. ! 100 if ( NUMRL2 == 1) NOEXT = .TRUE. if ( IER == 5) go to 150 110 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5E+00 ERLARG = ERRSUM go to 140 120 SMALL = SMALL*0.5E+00 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA 130 ERTEST = ERRBND ERLARG = ERRSUM 140 CONTINUE ! ! SET THE FINAL RESULT. ! --------------------- ! 150 if ( ABSERR == OFLOW.OR.NRES == 0) go to 170 if ( IER+IERRO == 0) go to 165 if ( IERRO == 3) ABSERR = ABSERR+CORREC if ( IER == 0) IER = 3 if ( RESULT /= 0.0E+00.AND.AREA /= 0.0E+00) go to 160 if ( ABSERR > ERRSUM) go to 170 if ( AREA == 0.0E+00) go to 190 go to 165 160 if ( ABSERR/ABS(RESULT) > ERRSUM/ABS(AREA)) go to 170 ! ! TEST ON DIVERGENCE. ! 165 if ( KSGN == (-1).AND.MAX(ABS(RESULT),ABS(AREA)) <= & DEFABS*0.1E-01) go to 190 if ( 0.1E-01 > (RESULT/AREA).OR.(RESULT/AREA) > 0.1E+03 & .OR.ERRSUM >= ABS(AREA)) IER = 6 go to 190 ! ! COMPUTE GLOBAL INTEGRAL SUM. ! 170 RESULT = 0.0E+00 DO 180 K=1,LAST RESULT = RESULT+RLIST(K) 180 CONTINUE ABSERR = ERRSUM 190 if (IER > 2) IER=IER-1 200 if (INTEGR == 2.AND.OMEGA < 0.0E+00) RESULT=-RESULT 999 RETURN end subroutine QAWO (F, A, B, OMEGA, INTEGR, EPSABS, EPSREL, RESULT, & ABSERR, NEVAL, IER, LENIW, MAXP1, LENW, LAST, IWORK, WORK) ! !! QAWO calculates an approximation to a given definite integral ... ! I = Integral of F(X)*W(X) over (A,B), where ! W(X) = COS(OMEGA*X) ! or W(X) = SIN(OMEGA*X), ! hopefully satisfying the following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE SINGLE PRECISION (QAWO-S, DQAWO-D) !***KEYWORDS AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, ! EXTRAPOLATION, GLOBALLY ADAPTIVE, ! INTEGRAND WITH OSCILLATORY COS OR SIN FACTOR, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Computation of oscillatory integrals ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the function ! F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! OMEGA - Real ! Parameter in the integrand weight function ! ! INTEGR - Integer ! Indicates which of the weight functions is used ! INTEGR = 1 W(X) = COS(OMEGA*X) ! INTEGR = 2 W(X) = SIN(OMEGA*X) ! If INTEGR /= 1.AND.INTEGR /= 2, the routine will ! end with IER = 6. ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! - IER > 0 Abnormal termination of the routine. ! The estimates for integral and error are ! less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved(= LENIW/2). One can ! allow more subdivisions by increasing the ! value of LENIW (and taking the according ! dimension adjustments into account). ! However, if this yields no improvement it ! is advised to analyze the integrand in ! order to determine the integration ! difficulties. If the position of a local ! difficulty can be determined (e.g. ! SINGULARITY, DISCONTINUITY within the ! interval) one will probably gain from ! splitting up the interval at this point ! and calling the integrator on the ! subranges. If possible, an appropriate ! special-purpose integrator should be used ! which is designed for handling the type of ! difficulty involved. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! The error may be under-estimated. ! = 3 Extremely bad integrand behaviour occurs ! at some interior points of the ! integration interval. ! = 4 The algorithm does not converge. ! Roundoff error is detected in the ! extrapolation table. It is presumed that ! the requested tolerance cannot be achieved ! due to roundoff in the extrapolation ! table, and that the returned result is ! the best which can be obtained. ! = 5 The integral is probably divergent, or ! slowly convergent. It must be noted that ! divergence can occur with any other value ! of IER. ! = 6 The input is invalid, because ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or (INTEGR /= 1 AND INTEGR /= 2), ! or LENIW < 2 OR MAXP1 < 1 or ! LENW < LENIW*2+MAXP1*25. ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LENIW, MAXP1 or LENW are ! invalid, WORK(LIMIT*2+1), WORK(LIMIT*3+1), ! IWORK(1), IWORK(LIMIT+1) are set to zero, ! WORK(1) is set to A and WORK(LIMIT+1) to ! B. ! ! DIMENSIONING PARAMETERS ! LENIW - Integer ! Dimensioning parameter for IWORK. ! LENIW/2 equals the maximum number of subintervals ! allowed in the partition of the given integration ! interval (A,B), LENIW >= 2. ! If LENIW < 2, the routine will end with IER = 6. ! ! MAXP1 - Integer ! Gives an upper bound on the number of Chebyshev ! moments which can be stored, i.e. for the ! intervals of lengths ABS(B-A)*2**(-L), ! L=0,1, ..., MAXP1-2, MAXP1 >= 1 ! If MAXP1 < 1, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LENIW*2+MAXP1*25. ! If LENW < (LENIW*2+MAXP1*25), the routine will ! end with IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of subintervals ! produced in the subdivision process, which ! determines the number of significant elements ! actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension at least LENIW ! on return, the first K elements of which contain ! pointers to the error estimates over the ! subintervals, such that WORK(LIMIT*3+IWORK(1)), .. ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence, with LIMIT = LENW/2 , and K = LAST ! if LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise. ! Furthermore, IWORK(LIMIT+1), ..., IWORK(LIMIT+ ! LAST) indicate the subdivision levels of the ! subintervals, such that IWORK(LIMIT+I) = L means ! that the subinterval numbered I is of length ! ABS(B-A)*2**(1-L). ! ! WORK - Real ! Vector of dimension at least LENW ! On return ! WORK(1), ..., WORK(LAST) contain the left ! end points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain ! the right end points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain ! the integral approximations over the ! subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) ! contain the error estimates. ! WORK(LIMIT*4+1), ..., WORK(LIMIT*4+MAXP1*25) ! Provide space for storing the Chebyshev moments. ! Note that LIMIT = LENW/2. ! !***REFERENCES (NONE) !***ROUTINES CALLED QAWOE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE QAWO ! REAL A,ABSERR,B,EPSABS,EPSREL,F,OMEGA,RESULT INTEGER IER,INTEGR,LENIW,LVL,L1,L2,L3,L4,MAXP1,MOMCOM,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LENIW, MAXP1 AND LENW. ! !***FIRST EXECUTABLE STATEMENT QAWO IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 if ( LENIW < 2.OR.MAXP1 < 1.OR.LENW < (LENIW*2+MAXP1*25)) & go to 10 ! ! PREPARE call FOR QAWOE ! LIMIT = LENIW/2 L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 L4 = LIMIT+L3 call QAWOE(F,A,B,OMEGA,INTEGR,EPSABS,EPSREL,LIMIT,1,MAXP1,RESULT, & ABSERR,NEVAL,IER,LAST,WORK(1),WORK(L1),WORK(L2),WORK(L3), & IWORK(1),IWORK(L1),MOMCOM,WORK(L4)) ! ! call ERROR HANDLER if NECESSARY ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'QAWO', & 'ABNORMAL RETURN', IER, LVL) return end subroutine QAWSE (F, A, B, ALFA, BETA, INTEGR, EPSABS, EPSREL, & LIMIT, RESULT, ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, & IORD, LAST) ! !! QAWSE calculates an approximation RESULT to a given integral ... ! I = Integral of F*W over (A,B), ! (where W shows a singular behaviour at the end points, ! see parameter INTEGR). ! Hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE SINGLE PRECISION (QAWSE-S, DQAWSE-D) !***KEYWORDS ALGEBRAIC-LOGARITHMIC END POINT SINGULARITIES, ! AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, QUADPACK, ! QUADRATURE, SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration of functions having algebraico-logarithmic ! end point singularities ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration, B > A ! If B <= A, the routine will end with IER = 6. ! ! ALFA - Real ! Parameter in the WEIGHT function, ALFA > (-1) ! If ALFA <= (-1), the routine will end with ! IER = 6. ! ! BETA - Real ! Parameter in the WEIGHT function, BETA > (-1) ! If BETA <= (-1), the routine will end with ! IER = 6. ! ! INTEGR - Integer ! Indicates which WEIGHT function is to be used ! = 1 (X-A)**ALFA*(B-X)**BETA ! = 2 (X-A)**ALFA*(B-X)**BETA*LOG(X-A) ! = 3 (X-A)**ALFA*(B-X)**BETA*LOG(B-X) ! = 4 (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X) ! If INTEGR < 1 or INTEGR > 4, the routine ! will end with IER = 6. ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! LIMIT - Integer ! Gives an upper bound on the number of subintervals ! in the partition of (A,B), LIMIT >= 2 ! If LIMIT < 2, the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! the estimates for the integral and error ! are less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT. However, if this yields no ! improvement, it is advised to analyze the ! integrand in order to determine the ! integration difficulties which prevent the ! requested tolerance from being achieved. ! In case of a jump DISCONTINUITY or a local ! SINGULARITY of algebraico-logarithmic type ! at one or more interior points of the ! integration range, one should proceed by ! splitting up the interval at these ! points and calling the integrator on the ! subranges. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 6 The input is invalid, because ! B <= A or ALFA <= (-1) or BETA <= (-1), or ! INTEGR < 1 or INTEGR > 4, or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! or LIMIT < 2. ! RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1), ! IORD(1) and LAST are set to zero. ALIST(1) ! and BLIST(1) are set to A and B ! respectively. ! ! ALIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the left ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! BLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the right ! end points of the subintervals in the partition ! of the given integration range (A,B) ! ! RLIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the integral ! approximations on the subintervals ! ! ELIST - Real ! Vector of dimension at least LIMIT, the first ! LAST elements of which are the moduli of the ! absolute error estimates on the subintervals ! ! IORD - Integer ! Vector of dimension at least LIMIT, the first K ! of which are pointers to the error ! estimates over the subintervals, so that ! ELIST(IORD(1)), ..., ELIST(IORD(K)) with K = LAST ! If LAST <= (LIMIT/2+2), and K = LIMIT+1-LAST ! otherwise form a decreasing sequence ! ! LAST - Integer ! Number of subintervals actually produced in ! the subdivision process ! !***REFERENCES (NONE) !***ROUTINES CALLED QC25S, QMOMO, QPSRT, R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QAWSE ! REAL A,ABSERR,ALFA,ALIST,AREA,AREA1,AREA12, & AREA2,A1,A2,B,BETA,BLIST,B1,B2,CENTRE, & R1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERRBND,ERRMAX, & ERROR1,ERRO12,ERROR2,ERRSUM,F,RESAS1,RESAS2,RESULT,RG,RH,RI,RJ, & RLIST,UFLOW INTEGER IER,INTEGR,IORD,IROFF1,IROFF2,K,LAST, & LIMIT,MAXERR,NEV,NEVAL,NRMAX ! EXTERNAL F ! DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*), & IORD(*),RI(25),RJ(25),RH(25),RG(25) ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS ! CONSIDERED UP TO NOW ! RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER ! (ALIST(I),BLIST(I)) ! ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) ! MAXERR - POINTER TO THE INTERVAL WITH LARGEST ! ERROR ESTIMATE ! ERRMAX - ELIST(MAXERR) ! AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS ! ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS ! ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* ! ABS(RESULT)) ! *****1 - VARIABLE FOR THE LEFT SUBINTERVAL ! *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL ! LAST - INDEX FOR SUBDIVISION ! ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QAWSE EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! IER = 6 NEVAL = 0 LAST = 0 RLIST(1) = 0.0E+00 ELIST(1) = 0.0E+00 IORD(1) = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 if (B <= A.OR.(EPSABS == 0.0E+00.AND. & EPSREL < MAX(0.5E+02*EPMACH,0.5E-14)).OR.ALFA <= (-0.1E+01) & .OR.BETA <= (-0.1E+01).OR.INTEGR < 1.OR.INTEGR > 4.OR. & LIMIT < 2) go to 999 IER = 0 ! ! COMPUTE THE MODIFIED CHEBYSHEV MOMENTS. ! call QMOMO(ALFA,BETA,RI,RJ,RG,RH,INTEGR) ! ! INTEGRATE OVER THE INTERVALS (A,(A+B)/2) ! AND ((A+B)/2,B). ! CENTRE = 0.5E+00*(B+A) call QC25S(F,A,B,A,CENTRE,ALFA,BETA,RI,RJ,RG,RH,AREA1, & ERROR1,RESAS1,INTEGR,NEV) NEVAL = NEV call QC25S(F,A,B,CENTRE,B,ALFA,BETA,RI,RJ,RG,RH,AREA2, & ERROR2,RESAS2,INTEGR,NEV) LAST = 2 NEVAL = NEVAL+NEV RESULT = AREA1+AREA2 ABSERR = ERROR1+ERROR2 ! ! TEST ON ACCURACY. ! ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT)) ! ! INITIALIZATION ! -------------- ! if ( ERROR2 > ERROR1) go to 10 ALIST(1) = A ALIST(2) = CENTRE BLIST(1) = CENTRE BLIST(2) = B RLIST(1) = AREA1 RLIST(2) = AREA2 ELIST(1) = ERROR1 ELIST(2) = ERROR2 go to 20 10 ALIST(1) = CENTRE ALIST(2) = A BLIST(1) = B BLIST(2) = CENTRE RLIST(1) = AREA2 RLIST(2) = AREA1 ELIST(1) = ERROR2 ELIST(2) = ERROR1 20 IORD(1) = 1 IORD(2) = 2 if ( LIMIT == 2) IER = 1 if ( ABSERR <= ERRBND.OR.IER == 1) go to 999 ERRMAX = ELIST(1) MAXERR = 1 NRMAX = 1 AREA = RESULT ERRSUM = ABSERR IROFF1 = 0 IROFF2 = 0 ! ! MAIN DO-LOOP ! ------------ ! DO 60 LAST = 3,LIMIT ! ! BISECT THE SUBINTERVAL WITH LARGEST ERROR ESTIMATE. ! A1 = ALIST(MAXERR) B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ! call QC25S(F,A,B,A1,B1,ALFA,BETA,RI,RJ,RG,RH,AREA1, & ERROR1,RESAS1,INTEGR,NEV) NEVAL = NEVAL+NEV call QC25S(F,A,B,A2,B2,ALFA,BETA,RI,RJ,RG,RH,AREA2, & ERROR2,RESAS2,INTEGR,NEV) NEVAL = NEVAL+NEV ! ! IMPROVE PREVIOUS APPROXIMATIONS INTEGRAL AND ERROR ! AND TEST FOR ACCURACY. ! AREA12 = AREA1+AREA2 ERRO12 = ERROR1+ERROR2 ERRSUM = ERRSUM+ERRO12-ERRMAX AREA = AREA+AREA12-RLIST(MAXERR) if ( A == A1.OR.B == B2) go to 30 if ( RESAS1 == ERROR1.OR.RESAS2 == ERROR2) go to 30 ! ! TEST FOR ROUNDOFF ERROR. ! if ( ABS(RLIST(MAXERR)-AREA12) < 0.1E-04*ABS(AREA12) & .AND.ERRO12 >= 0.99E+00*ERRMAX) IROFF1 = IROFF1+1 if ( LAST > 10.AND.ERRO12 > ERRMAX) IROFF2 = IROFF2+1 30 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ! ! TEST ON ACCURACY. ! ERRBND = MAX(EPSABS,EPSREL*ABS(AREA)) if ( ERRSUM <= ERRBND) go to 35 ! ! SET ERROR FLAG IN THE CASE THAT THE NUMBER OF INTERVAL ! BISECTIONS EXCEEDS LIMIT. ! if ( LAST == LIMIT) IER = 1 ! ! ! SET ERROR FLAG IN THE CASE OF ROUNDOFF ERROR. ! if ( IROFF1 >= 6.OR.IROFF2 >= 20) IER = 2 ! ! SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR ! AT INTERIOR POINTS OF INTEGRATION RANGE. ! if ( MAX(ABS(A1),ABS(B2)) <= (0.1E+01+0.1E+03*EPMACH)* & (ABS(A2)+0.1E+04*UFLOW)) IER = 3 ! ! APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. ! 35 if ( ERROR2 > ERROR1) go to 40 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 go to 50 40 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 ! ! call SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING ! IN THE LIST OF ERROR ESTIMATES AND SELECT THE ! SUBINTERVAL WITH LARGEST ERROR ESTIMATE (TO BE ! BISECTED NEXT). ! 50 call QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) ! ***JUMP OUT OF DO-LOOP if (IER /= 0.OR.ERRSUM <= ERRBND) go to 70 60 CONTINUE ! ! COMPUTE FINAL RESULT. ! --------------------- ! 70 RESULT = 0.0E+00 DO 80 K=1,LAST RESULT = RESULT+RLIST(K) 80 CONTINUE ABSERR = ERRSUM 999 RETURN end subroutine QAWS (F, A, B, ALFA, BETA, INTEGR, EPSABS, EPSREL, & RESULT, ABSERR, NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) ! !! QAWS calculates an approximation RESULT to a given integral ... ! I = Integral of F*W over (A,B), ! (where W shows a singular behaviour at the end points ! see parameter INTEGR). ! Hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1 !***TYPE SINGLE PRECISION (QAWS-S, DQAWS-D) !***KEYWORDS ALGEBRAIC-LOGARITHMIC END POINT SINGULARITIES, ! AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, ! GLOBALLY ADAPTIVE, QUADPACK, QUADRATURE, SPECIAL-PURPOSE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration of functions having algebraico-logarithmic ! end point singularities ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration, B > A ! If B <= A, the routine will end with IER = 6. ! ! ALFA - Real ! Parameter in the integrand function, ALFA > (-1) ! If ALFA <= (-1), the routine will end with ! IER = 6. ! ! BETA - Real ! Parameter in the integrand function, BETA > (-1) ! If BETA <= (-1), the routine will end with ! IER = 6. ! ! INTEGR - Integer ! Indicates which WEIGHT function is to be used ! = 1 (X-A)**ALFA*(B-X)**BETA ! = 2 (X-A)**ALFA*(B-X)**BETA*LOG(X-A) ! = 3 (X-A)**ALFA*(B-X)**BETA*LOG(B-X) ! = 4 (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X) ! If INTEGR < 1 or INTEGR > 4, the routine ! will end with IER = 6. ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! and EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! the routine will end with IER = 6. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! Which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - Integer ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine ! The estimates for the integral and error ! are less reliable. It is assumed that the ! requested accuracy has not been achieved. ! ERROR MESSAGES ! IER = 1 Maximum number of subdivisions allowed ! has been achieved. One can allow more ! subdivisions by increasing the value of ! LIMIT (and taking the according dimension ! adjustments into account). However, if ! this yields no improvement it is advised ! to analyze the integrand, in order to ! determine the integration difficulties ! which prevent the requested tolerance from ! being achieved. In case of a jump ! discontinuity or a local singularity ! of algebraico-logarithmic type at one or ! more interior points of the integration ! range, one should proceed by splitting up ! the interval at these points and calling ! the integrator on the subranges. ! = 2 The occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! = 3 Extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 6 The input is invalid, because ! B <= A or ALFA <= (-1) or BETA <= (-1) or ! or INTEGR < 1 or INTEGR > 4 or ! (EPSABS <= 0 and ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28)) ! or LIMIT < 2 or LENW < LIMIT*4. ! RESULT, ABSERR, NEVAL, LAST are set to ! zero. Except when LENW or LIMIT is invalid ! IWORK(1), WORK(LIMIT*2+1) and ! WORK(LIMIT*3+1) are set to zero, WORK(1) ! is set to A and WORK(LIMIT+1) to B. ! ! DIMENSIONING PARAMETERS ! LIMIT - Integer ! Dimensioning parameter for IWORK ! LIMIT determines the maximum number of ! subintervals in the partition of the given ! integration interval (A,B), LIMIT >= 2. ! If LIMIT < 2, the routine will end with IER = 6. ! ! LENW - Integer ! Dimensioning parameter for WORK ! LENW must be at least LIMIT*4. ! If LENW < LIMIT*4, the routine will end ! with IER = 6. ! ! LAST - Integer ! On return, LAST equals the number of ! subintervals produced in the subdivision process, ! which determines the significant number of ! elements actually in the WORK ARRAYS. ! ! WORK ARRAYS ! IWORK - Integer ! Vector of dimension LIMIT, the first K ! elements of which contain pointers ! to the error estimates over the subintervals, ! such that WORK(LIMIT*3+IWORK(1)), ..., ! WORK(LIMIT*3+IWORK(K)) form a decreasing ! sequence with K = LAST if LAST <= (LIMIT/2+2), ! and K = LIMIT+1-LAST otherwise ! ! WORK - Real ! Vector of dimension LENW ! On return ! WORK(1), ..., WORK(LAST) contain the left ! end points of the subintervals in the ! partition of (A,B), ! WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain ! the right end points, ! WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) ! contain the integral approximations over ! the subintervals, ! WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) ! contain the error estimates. ! !***REFERENCES (NONE) !***ROUTINES CALLED QAWSE, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE QAWS ! REAL A,ABSERR,ALFA,B,BETA,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,INTEGR,IWORK,LENW,LIMIT,LVL,L1,L2,L3,NEVAL ! DIMENSION IWORK(*),WORK(*) ! EXTERNAL F ! ! CHECK VALIDITY OF LIMIT AND LENW. ! !***FIRST EXECUTABLE STATEMENT QAWS IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0E+00 ABSERR = 0.0E+00 if ( LIMIT < 2.OR.LENW < LIMIT*4) go to 10 ! ! PREPARE call FOR QAWSE. ! L1 = LIMIT+1 L2 = LIMIT+L1 L3 = LIMIT+L2 ! call QAWSE(F,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,LIMIT,RESULT, & ABSERR,NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) ! ! call ERROR HANDLER if NECESSARY. ! LVL = 0 10 if ( IER == 6) LVL = 1 if (IER /= 0) call XERMSG ('SLATEC', 'QAWS', & 'ABNORMAL RETURN', IER, LVL) return end subroutine QC25C (F, A, B, C, RESULT, ABSERR, KRUL, NEVAL) ! !! QC25C computes I = Integral of F*W over (A,B) with error estimate, ... ! where W(X) = 1/(X-C) ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A2, J4 !***TYPE SINGLE PRECISION (QC25C-S, DQC25C-D) !***KEYWORDS 25-POINT CLENSHAW-CURTIS INTEGRATION, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules for the computation of CAUCHY ! PRINCIPAL VALUE integrals ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! F - Real ! Function subprogram defining the integrand function ! F(X). The actual name for F needs to be declared ! E X T E R N A L in the driver program. ! ! A - Real ! Left end point of the integration interval ! ! B - Real ! Right end point of the integration interval, B > A ! ! C - Real ! Parameter in the WEIGHT function ! ! RESULT - Real ! Approximation to the integral ! result is computed by using a generalized ! Clenshaw-Curtis method if C lies within ten percent ! of the integration interval. In the other case the ! 15-point Kronrod rule obtained by optimal addition ! of abscissae to the 7-point Gauss rule, is applied. ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! KRUL - Integer ! Key which is decreased by 1 if the 15-point ! Gauss-Kronrod scheme has been used ! ! NEVAL - Integer ! Number of integrand evaluations ! !***REFERENCES (NONE) !***ROUTINES CALLED QCHEB, QK15W, QWGTC !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QC25C ! REAL A,ABSERR,AK22,AMOM0,AMOM1,AMOM2,B,C,CC, & CENTR,CHEB12,CHEB24,QWGTC,F,FVAL,HLGTH,P2,P3,P4, & RESABS,RESASC,RESULT,RES12,RES24,U,X INTEGER I,ISYM,K,KP,KRUL,NEVAL ! DIMENSION X(11),FVAL(25),CHEB12(13),CHEB24(25) ! EXTERNAL F, QWGTC ! ! THE VECTOR X CONTAINS THE VALUES COS(K*PI/24), ! K = 1, ..., 11, TO BE USED FOR THE CHEBYSHEV SERIES ! EXPANSION OF F ! SAVE X DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10), & X(11)/ & 0.9914448613738104E+00, 0.9659258262890683E+00, & 0.9238795325112868E+00, 0.8660254037844386E+00, & 0.7933533402912352E+00, 0.7071067811865475E+00, & 0.6087614290087206E+00, 0.5000000000000000E+00, & 0.3826834323650898E+00, 0.2588190451025208E+00, & 0.1305261922200516E+00/ ! ! LIST OF MAJOR VARIABLES ! ---------------------- ! FVAL - VALUE OF THE FUNCTION F AT THE POINTS ! COS(K*PI/24), K = 0, ..., 24 ! CHEB12 - CHEBYSHEV SERIES EXPANSION COEFFICIENTS, ! FOR THE FUNCTION F, OF DEGREE 12 ! CHEB24 - CHEBYSHEV SERIES EXPANSION COEFFICIENTS, ! FOR THE FUNCTION F, OF DEGREE 24 ! RES12 - APPROXIMATION TO THE INTEGRAL CORRESPONDING ! TO THE USE OF CHEB12 ! RES24 - APPROXIMATION TO THE INTEGRAL CORRESPONDING ! TO THE USE OF CHEB24 ! QWGTC - EXTERNAL FUNCTION SUBPROGRAM DEFINING ! THE WEIGHT FUNCTION ! HLGTH - HALF-LENGTH OF THE INTERVAL ! CENTR - MID POINT OF THE INTERVAL ! ! ! CHECK THE POSITION OF C. ! !***FIRST EXECUTABLE STATEMENT QC25C CC = (0.2E+01*C-B-A)/(B-A) if ( ABS(CC) < 0.11E+01) go to 10 ! ! APPLY THE 15-POINT GAUSS-KRONROD SCHEME. ! KRUL = KRUL-1 call QK15W(F,QWGTC,C,P2,P3,P4,KP,A,B,RESULT,ABSERR, & RESABS,RESASC) NEVAL = 15 if (RESASC == ABSERR) KRUL = KRUL+1 go to 50 ! ! USE THE GENERALIZED CLENSHAW-CURTIS METHOD. ! 10 HLGTH = 0.5E+00*(B-A) CENTR = 0.5E+00*(B+A) NEVAL = 25 FVAL(1) = 0.5E+00*F(HLGTH+CENTR) FVAL(13) = F(CENTR) FVAL(25) = 0.5E+00*F(CENTR-HLGTH) DO 20 I=2,12 U = HLGTH*X(I-1) ISYM = 26-I FVAL(I) = F(U+CENTR) FVAL(ISYM) = F(CENTR-U) 20 CONTINUE ! ! COMPUTE THE CHEBYSHEV SERIES EXPANSION. ! call QCHEB(X,FVAL,CHEB12,CHEB24) ! ! THE MODIFIED CHEBYSHEV MOMENTS ARE COMPUTED ! BY FORWARD RECURSION, USING AMOM0 AND AMOM1 ! AS STARTING VALUES. ! AMOM0 = LOG(ABS((0.1E+01-CC)/(0.1E+01+CC))) AMOM1 = 0.2E+01+CC*AMOM0 RES12 = CHEB12(1)*AMOM0+CHEB12(2)*AMOM1 RES24 = CHEB24(1)*AMOM0+CHEB24(2)*AMOM1 DO 30 K=3,13 AMOM2 = 0.2E+01*CC*AMOM1-AMOM0 AK22 = (K-2)*(K-2) if ( (K/2)*2 == K) AMOM2 = AMOM2-0.4E+01/(AK22-0.1E+01) RES12 = RES12+CHEB12(K)*AMOM2 RES24 = RES24+CHEB24(K)*AMOM2 AMOM0 = AMOM1 AMOM1 = AMOM2 30 CONTINUE DO 40 K=14,25 AMOM2 = 0.2E+01*CC*AMOM1-AMOM0 AK22 = (K-2)*(K-2) if ( (K/2)*2 == K) AMOM2 = AMOM2-0.4E+01/ & (AK22-0.1E+01) RES24 = RES24+CHEB24(K)*AMOM2 AMOM0 = AMOM1 AMOM1 = AMOM2 40 CONTINUE RESULT = RES24 ABSERR = ABS(RES24-RES12) 50 RETURN end subroutine QC25F (F, A, B, OMEGA, INTEGR, NRMOM, MAXP1, KSAVE, & RESULT, ABSERR, NEVAL, RESABS, RESASC, MOMCOM, CHEBMO) ! !! QC25F computes the integral I=Integral of F(X) over (A,B) ... ! Where W(X) = COS(OMEGA*X) Or (WX)=SIN(OMEGA*X) ! and to compute J=Integral of ABS(F) over (A,B). For small ! value of OMEGA or small intervals (A,B) 15-point GAUSS- ! KRONROD Rule used. Otherwise generalized CLENSHAW-CURTIS is used. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A2 !***TYPE SINGLE PRECISION (QC25F-S, DQC25F-D) !***KEYWORDS CLENSHAW-CURTIS METHOD, GAUSS-KRONROD RULES, ! INTEGRATION RULES FOR FUNCTIONS WITH COS OR SIN FACTOR, ! QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules for functions with COS or SIN factor ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to ! be declared E X T E R N A L in the calling program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! OMEGA - Real ! Parameter in the WEIGHT function ! ! INTEGR - Integer ! Indicates which WEIGHT function is to be used ! INTEGR = 1 W(X) = COS(OMEGA*X) ! INTEGR = 2 W(X) = SIN(OMEGA*X) ! ! NRMOM - Integer ! The length of interval (A,B) is equal to the length ! of the original integration interval divided by ! 2**NRMOM (we suppose that the routine is used in an ! adaptive integration process, otherwise set ! NRMOM = 0). NRMOM must be zero at the first call. ! ! MAXP1 - Integer ! Gives an upper bound on the number of Chebyshev ! moments which can be stored, i.e. for the ! intervals of lengths ABS(BB-AA)*2**(-L), ! L = 0,1,2, ..., MAXP1-2. ! ! KSAVE - Integer ! Key which is one when the moments for the ! current interval have been computed ! ! ON RETURN ! RESULT - Real ! Approximation to the integral I ! ! ABSERR - Real ! Estimate of the modulus of the absolute ! error, which should equal or exceed ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! RESABS - Real ! Approximation to the integral J ! ! RESASC - Real ! Approximation to the integral of ABS(F-I/(B-A)) ! ! ON ENTRY AND RETURN ! MOMCOM - Integer ! For each interval length we need to compute the ! Chebyshev moments. MOMCOM counts the number of ! intervals for which these moments have already been ! computed. If NRMOM < MOMCOM or KSAVE = 1, the ! Chebyshev moments for the interval (A,B) have ! already been computed and stored, otherwise we ! compute them and we increase MOMCOM. ! ! CHEBMO - Real ! Array of dimension at least (MAXP1,25) containing ! the modified Chebyshev moments for the first MOMCOM ! MOMCOM interval lengths ! !***REFERENCES (NONE) !***ROUTINES CALLED QCHEB, QK15W, QWGTF, R1MACH, SGTSL !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QC25F ! REAL A,ABSERR,AC,AN,AN2,AS,ASAP,ASS,B,CENTR,CHEBMO, & CHEB12,CHEB24,CONC,CONS,COSPAR,D,QWGTF, & D1,R1MACH,D2,ESTC,ESTS,F,FVAL,HLGTH,OFLOW,OMEGA,PARINT,PAR2, & PAR22,P2,P3,P4,RESABS,RESASC,RESC12,RESC24,RESS12,RESS24, & RESULT,SINPAR,V,X INTEGER I,IERS,INTEGR,ISYM,J,K,KSAVE,M,MAXP1,MOMCOM,NEVAL, & NOEQU,NOEQ1,NRMOM ! DIMENSION CHEBMO(MAXP1,25),CHEB12(13),CHEB24(25),D(25),D1(25), & D2(25),FVAL(25),V(28),X(11) ! EXTERNAL F, QWGTF ! ! THE VECTOR X CONTAINS THE VALUES COS(K*PI/24) ! K = 1, ...,11, TO BE USED FOR THE CHEBYSHEV EXPANSION OF F ! SAVE X DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9), & X(10),X(11)/ & 0.9914448613738104E+00, 0.9659258262890683E+00, & 0.9238795325112868E+00, 0.8660254037844386E+00, & 0.7933533402912352E+00, 0.7071067811865475E+00, & 0.6087614290087206E+00, 0.5000000000000000E+00, & 0.3826834323650898E+00, 0.2588190451025208E+00, & 0.1305261922200516E+00/ ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTEGRATION INTERVAL ! HLGTH - HALF-LENGTH OF THE INTEGRATION INTERVAL ! FVAL - VALUE OF THE FUNCTION F AT THE POINTS ! (B-A)*0.5*COS(K*PI/12) + (B+A)*0.5, ! K = 0, ..., 24 ! CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION ! OF DEGREE 12, FOR THE FUNCTION F, IN THE ! INTERVAL (A,B) ! CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION ! OF DEGREE 24, FOR THE FUNCTION F, IN THE ! INTERVAL (A,B) ! RESC12 - APPROXIMATION TO THE INTEGRAL OF ! COS(0.5*(B-A)*OMEGA*X)*F(0.5*(B-A)*X+0.5*(B+A)) ! OVER (-1,+1), USING THE CHEBYSHEV SERIES ! EXPANSION OF DEGREE 12 ! RESC24 - APPROXIMATION TO THE SAME INTEGRAL, USING THE ! CHEBYSHEV SERIES EXPANSION OF DEGREE 24 ! RESS12 - THE ANALOGUE OF RESC12 FOR THE SINE ! RESS24 - THE ANALOGUE OF RESC24 FOR THE SINE ! ! ! MACHINE DEPENDENT CONSTANT ! -------------------------- ! ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QC25F OFLOW = R1MACH(2) ! CENTR = 0.5E+00*(B+A) HLGTH = 0.5E+00*(B-A) PARINT = OMEGA*HLGTH ! ! COMPUTE THE INTEGRAL USING THE 15-POINT GAUSS-KRONROD ! FORMULA if THE VALUE OF THE PARAMETER IN THE INTEGRAND ! IS SMALL. ! if ( ABS(PARINT) > 0.2E+01) go to 10 call QK15W(F,QWGTF,OMEGA,P2,P3,P4,INTEGR,A,B,RESULT, & ABSERR,RESABS,RESASC) NEVAL = 15 go to 170 ! ! COMPUTE THE INTEGRAL USING THE GENERALIZED CLENSHAW- ! CURTIS METHOD. ! 10 CONC = HLGTH*COS(CENTR*OMEGA) CONS = HLGTH*SIN(CENTR*OMEGA) RESASC = OFLOW NEVAL = 25 ! ! CHECK WHETHER THE CHEBYSHEV MOMENTS FOR THIS INTERVAL ! HAVE ALREADY BEEN COMPUTED. ! if ( NRMOM < MOMCOM.OR.KSAVE == 1) go to 120 ! ! COMPUTE A NEW SET OF CHEBYSHEV MOMENTS. ! M = MOMCOM+1 PAR2 = PARINT*PARINT PAR22 = PAR2+0.2E+01 SINPAR = SIN(PARINT) COSPAR = COS(PARINT) ! ! COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO COSINE. ! V(1) = 0.2E+01*SINPAR/PARINT V(2) = (0.8E+01*COSPAR+(PAR2+PAR2-0.8E+01)*SINPAR/ & PARINT)/PAR2 V(3) = (0.32E+02*(PAR2-0.12E+02)*COSPAR+(0.2E+01* & ((PAR2-0.80E+02)*PAR2+0.192E+03)*SINPAR)/ & PARINT)/(PAR2*PAR2) AC = 0.8E+01*COSPAR AS = 0.24E+02*PARINT*SINPAR if ( ABS(PARINT) > 0.24E+02) go to 30 ! ! COMPUTE THE CHEBYSHEV MOMENTS AS THE ! SOLUTIONS OF A BOUNDARY VALUE PROBLEM WITH 1 ! INITIAL VALUE (V(3)) AND 1 END VALUE (COMPUTED ! USING AN ASYMPTOTIC FORMULA). ! NOEQU = 25 NOEQ1 = NOEQU-1 AN = 0.6E+01 DO 20 K = 1,NOEQ1 AN2 = AN*AN D(K) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2) D2(K) = (AN-0.1E+01)*(AN-0.2E+01)*PAR2 D1(K+1) = (AN+0.3E+01)*(AN+0.4E+01)*PAR2 V(K+3) = AS-(AN2-0.4E+01)*AC AN = AN+0.2E+01 20 CONTINUE AN2 = AN*AN D(NOEQU) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2) V(NOEQU+3) = AS-(AN2-0.4E+01)*AC V(4) = V(4)-0.56E+02*PAR2*V(3) ASS = PARINT*SINPAR ASAP = (((((0.210E+03*PAR2-0.1E+01)*COSPAR-(0.105E+03*PAR2 & -0.63E+02)*ASS)/AN2-(0.1E+01-0.15E+02*PAR2)*COSPAR & +0.15E+02*ASS)/AN2-COSPAR+0.3E+01*ASS)/AN2-COSPAR)/AN2 V(NOEQU+3) = V(NOEQU+3)-0.2E+01*ASAP*PAR2*(AN-0.1E+01)* & (AN-0.2E+01) ! ! SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN ! ELIMINATION WITH PARTIAL PIVOTING. ! call SGTSL(NOEQU,D1,D,D2,V(4),IERS) go to 50 ! ! COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF FORWARD ! RECURSION. ! 30 AN = 0.4E+01 DO 40 I = 4,13 AN2 = AN*AN V(I) = ((AN2-0.4E+01)*(0.2E+01*(PAR22-AN2-AN2)*V(I-1)-AC) & +AS-PAR2*(AN+0.1E+01)*(AN+0.2E+01)*V(I-2))/ & (PAR2*(AN-0.1E+01)*(AN-0.2E+01)) AN = AN+0.2E+01 40 CONTINUE 50 DO 60 J = 1,13 CHEBMO(M,2*J-1) = V(J) 60 CONTINUE ! ! COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO SINE. ! V(1) = 0.2E+01*(SINPAR-PARINT*COSPAR)/PAR2 V(2) = (0.18E+02-0.48E+02/PAR2)*SINPAR/PAR2 & +(-0.2E+01+0.48E+02/PAR2)*COSPAR/PARINT AC = -0.24E+02*PARINT*COSPAR AS = -0.8E+01*SINPAR if ( ABS(PARINT) > 0.24E+02) go to 80 ! ! COMPUTE THE CHEBYSHEV MOMENTS AS THE ! SOLUTIONS OF A BOUNDARY VALUE PROBLEM WITH 1 ! INITIAL VALUE (V(2)) AND 1 END VALUE (COMPUTED ! USING AN ASYMPTOTIC FORMULA). ! AN = 0.5E+01 DO 70 K = 1,NOEQ1 AN2 = AN*AN D(K) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2) D2(K) = (AN-0.1E+01)*(AN-0.2E+01)*PAR2 D1(K+1) = (AN+0.3E+01)*(AN+0.4E+01)*PAR2 V(K+2) = AC+(AN2-0.4E+01)*AS AN = AN+0.2E+01 70 CONTINUE AN2 = AN*AN D(NOEQU) = -0.2E+01*(AN2-0.4E+01)*(PAR22-AN2-AN2) V(NOEQU+2) = AC+(AN2-0.4E+01)*AS V(3) = V(3)-0.42E+02*PAR2*V(2) ASS = PARINT*COSPAR ASAP = (((((0.105E+03*PAR2-0.63E+02)*ASS+(0.210E+03*PAR2 & -0.1E+01)*SINPAR)/AN2+(0.15E+02*PAR2-0.1E+01)*SINPAR- & 0.15E+02*ASS)/AN2-0.3E+01*ASS-SINPAR)/AN2-SINPAR)/AN2 V(NOEQU+2) = V(NOEQU+2)-0.2E+01*ASAP*PAR2*(AN-0.1E+01) & *(AN-0.2E+01) ! ! SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN ! ELIMINATION WITH PARTIAL PIVOTING. ! call SGTSL(NOEQU,D1,D,D2,V(3),IERS) go to 100 ! ! COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF ! FORWARD RECURSION. ! 80 AN = 0.3E+01 DO 90 I = 3,12 AN2 = AN*AN V(I) = ((AN2-0.4E+01)*(0.2E+01*(PAR22-AN2-AN2)*V(I-1)+AS) & +AC-PAR2*(AN+0.1E+01)*(AN+0.2E+01)*V(I-2)) & /(PAR2*(AN-0.1E+01)*(AN-0.2E+01)) AN = AN+0.2E+01 90 CONTINUE 100 DO 110 J = 1,12 CHEBMO(M,2*J) = V(J) 110 CONTINUE 120 if (NRMOM < MOMCOM) M = NRMOM+1 if (MOMCOM < MAXP1-1.AND.NRMOM >= MOMCOM) MOMCOM = MOMCOM+1 ! ! COMPUTE THE COEFFICIENTS OF THE CHEBYSHEV EXPANSIONS ! OF DEGREES 12 AND 24 OF THE FUNCTION F. ! FVAL(1) = 0.5E+00*F(CENTR+HLGTH) FVAL(13) = F(CENTR) FVAL(25) = 0.5E+00*F(CENTR-HLGTH) DO 130 I = 2,12 ISYM = 26-I FVAL(I) = F(HLGTH*X(I-1)+CENTR) FVAL(ISYM) = F(CENTR-HLGTH*X(I-1)) 130 CONTINUE call QCHEB(X,FVAL,CHEB12,CHEB24) ! ! COMPUTE THE INTEGRAL AND ERROR ESTIMATES. ! RESC12 = CHEB12(13)*CHEBMO(M,13) RESS12 = 0.0E+00 K = 11 DO 140 J = 1,6 RESC12 = RESC12+CHEB12(K)*CHEBMO(M,K) RESS12 = RESS12+CHEB12(K+1)*CHEBMO(M,K+1) K = K-2 140 CONTINUE RESC24 = CHEB24(25)*CHEBMO(M,25) RESS24 = 0.0E+00 RESABS = ABS(CHEB24(25)) K = 23 DO 150 J = 1,12 RESC24 = RESC24+CHEB24(K)*CHEBMO(M,K) RESS24 = RESS24+CHEB24(K+1)*CHEBMO(M,K+1) RESABS = ABS(CHEB24(K))+ABS(CHEB24(K+1)) K = K-2 150 CONTINUE ESTC = ABS(RESC24-RESC12) ESTS = ABS(RESS24-RESS12) RESABS = RESABS*ABS(HLGTH) if ( INTEGR == 2) go to 160 RESULT = CONC*RESC24-CONS*RESS24 ABSERR = ABS(CONC*ESTC)+ABS(CONS*ESTS) go to 170 160 RESULT = CONC*RESS24+CONS*RESC24 ABSERR = ABS(CONC*ESTS)+ABS(CONS*ESTC) 170 RETURN end subroutine QC25S (F, A, B, BL, BR, ALFA, BETA, RI, RJ, RG, RH, & RESULT, ABSERR, RESASC, INTEGR, NEV) ! !! QC25S computes I = Integral of F*W over (BL,BR), with error estimate, ... ! where the weight function W has a singular ! behaviour of ALGEBRAICO-LOGARITHMIC type at the points ! A and/or B. (BL,BR) is a part of (A,B). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A2 !***TYPE SINGLE PRECISION (QC25S-S, DQC25S-D) !***KEYWORDS 25-POINT CLENSHAW-CURTIS INTEGRATION, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules for integrands having ALGEBRAICO-LOGARITHMIC ! end point singularities ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! F - Real ! Function subprogram defining the integrand ! F(X). The actual name for F needs to be declared ! E X T E R N A L in the driver program. ! ! A - Real ! Left end point of the original interval ! ! B - Real ! Right end point of the original interval, B > A ! ! BL - Real ! Lower limit of integration, BL >= A ! ! BR - Real ! Upper limit of integration, BR <= B ! ! ALFA - Real ! PARAMETER IN THE WEIGHT FUNCTION ! ! BETA - Real ! Parameter in the weight function ! ! RI,RJ,RG,RH - Real ! Modified CHEBYSHEV moments for the application ! of the generalized CLENSHAW-CURTIS ! method (computed in subroutine DQMOMO) ! ! RESULT - Real ! Approximation to the integral ! RESULT is computed by using a generalized ! CLENSHAW-CURTIS method if B1 = A or BR = B. ! in all other cases the 15-POINT KRONROD ! RULE is applied, obtained by optimal addition of ! Abscissae to the 7-POINT GAUSS RULE. ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! RESASC - Real ! Approximation to the integral of ABS(F*W-I/(B-A)) ! ! INTEGR - Integer ! Which determines the weight function ! = 1 W(X) = (X-A)**ALFA*(B-X)**BETA ! = 2 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A) ! = 3 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(B-X) ! = 4 W(X) = (X-A)**ALFA*(B-X)**BETA*LOG(X-A)* ! LOG(B-X) ! ! NEV - Integer ! Number of integrand evaluations ! !***REFERENCES (NONE) !***ROUTINES CALLED QCHEB, QK15W, QWGTS !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QC25S ! REAL A,ABSERR,ALFA,B,BETA,BL,BR,CENTR,CHEB12,CHEB24, & DC,F,FACTOR,FIX,FVAL,HLGTH,RESABS,RESASC, & RESULT,RES12,RES24,RG,RH,RI,RJ,U,QWGTS,X INTEGER I,INTEGR,ISYM,NEV ! DIMENSION CHEB12(13),CHEB24(25),FVAL(25),RG(25),RH(25),RI(25), & RJ(25),X(11) ! EXTERNAL F, QWGTS ! ! THE VECTOR X CONTAINS THE VALUES COS(K*PI/24) ! K = 1, ..., 11, TO BE USED FOR THE COMPUTATION OF THE ! CHEBYSHEV SERIES EXPANSION OF F. ! SAVE X DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10), & X(11)/ & 0.9914448613738104E+00, 0.9659258262890683E+00, & 0.9238795325112868E+00, 0.8660254037844386E+00, & 0.7933533402912352E+00, 0.7071067811865475E+00, & 0.6087614290087206E+00, 0.5000000000000000E+00, & 0.3826834323650898E+00, 0.2588190451025208E+00, & 0.1305261922200516E+00/ ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! FVAL - VALUE OF THE FUNCTION F AT THE POINTS ! (BR-BL)*0.5*COS(K*PI/24)+(BR+BL)*0.5 ! K = 0, ..., 24 ! CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION ! OF DEGREE 12, FOR THE FUNCTION F, IN THE ! INTERVAL (BL,BR) ! CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION ! OF DEGREE 24, FOR THE FUNCTION F, IN THE ! INTERVAL (BL,BR) ! RES12 - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB12 ! RES24 - APPROXIMATION TO THE INTEGRAL OBTAINED FROM CHEB24 ! QWGTS - EXTERNAL FUNCTION SUBPROGRAM DEFINING ! THE FOUR POSSIBLE WEIGHT FUNCTIONS ! HLGTH - HALF-LENGTH OF THE INTERVAL (BL,BR) ! CENTR - MID POINT OF THE INTERVAL (BL,BR) ! !***FIRST EXECUTABLE STATEMENT QC25S NEV = 25 if ( BL == A.AND.(ALFA /= 0.0E+00.OR.INTEGR == 2.OR.INTEGR == 4)) & go to 10 if ( BR == B.AND.(BETA /= 0.0E+00.OR.INTEGR == 3.OR.INTEGR == 4)) & go to 140 ! ! if A > BL AND B < BR, APPLY THE 15-POINT GAUSS-KRONROD ! SCHEME. ! ! call QK15W(F,QWGTS,A,B,ALFA,BETA,INTEGR,BL,BR, & RESULT,ABSERR,RESABS,RESASC) NEV = 15 go to 270 ! ! THIS PART OF THE PROGRAM IS EXECUTED ONLY if A = BL. ! ---------------------------------------------------- ! ! COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE ! FOLLOWING FUNCTION ! F1 = (0.5*(B+B-BR-A)-0.5*(BR-A)*X)**BETA ! *F(0.5*(BR-A)*X+0.5*(BR+A)) ! 10 HLGTH = 0.5E+00*(BR-BL) CENTR = 0.5E+00*(BR+BL) FIX = B-CENTR FVAL(1) = 0.5E+00*F(HLGTH+CENTR)*(FIX-HLGTH)**BETA FVAL(13) = F(CENTR)*(FIX**BETA) FVAL(25) = 0.5E+00*F(CENTR-HLGTH)*(FIX+HLGTH)**BETA DO 20 I=2,12 U = HLGTH*X(I-1) ISYM = 26-I FVAL(I) = F(U+CENTR)*(FIX-U)**BETA FVAL(ISYM) = F(CENTR-U)*(FIX+U)**BETA 20 CONTINUE FACTOR = HLGTH**(ALFA+0.1E+01) RESULT = 0.0E+00 ABSERR = 0.0E+00 RES12 = 0.0E+00 RES24 = 0.0E+00 if ( INTEGR > 2) go to 70 call QCHEB(X,FVAL,CHEB12,CHEB24) ! ! INTEGR = 1 (OR 2) ! DO 30 I=1,13 RES12 = RES12+CHEB12(I)*RI(I) RES24 = RES24+CHEB24(I)*RI(I) 30 CONTINUE DO 40 I=14,25 RES24 = RES24+CHEB24(I)*RI(I) 40 CONTINUE if ( INTEGR == 1) go to 130 ! ! INTEGR = 2 ! DC = LOG(BR-BL) RESULT = RES24*DC ABSERR = ABS((RES24-RES12)*DC) RES12 = 0.0E+00 RES24 = 0.0E+00 DO 50 I=1,13 RES12 = RES12+CHEB12(I)*RG(I) RES24 = RES12+CHEB24(I)*RG(I) 50 CONTINUE DO 60 I=14,25 RES24 = RES24+CHEB24(I)*RG(I) 60 CONTINUE go to 130 ! ! COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE ! FOLLOWING FUNCTION ! F4 = F1*LOG(0.5*(B+B-BR-A)-0.5*(BR-A)*X) ! 70 FVAL(1) = FVAL(1)*LOG(FIX-HLGTH) FVAL(13) = FVAL(13)*LOG(FIX) FVAL(25) = FVAL(25)*LOG(FIX+HLGTH) DO 80 I=2,12 U = HLGTH*X(I-1) ISYM = 26-I FVAL(I) = FVAL(I)*LOG(FIX-U) FVAL(ISYM) = FVAL(ISYM)*LOG(FIX+U) 80 CONTINUE call QCHEB(X,FVAL,CHEB12,CHEB24) ! ! INTEGR = 3 (OR 4) ! DO 90 I=1,13 RES12 = RES12+CHEB12(I)*RI(I) RES24 = RES24+CHEB24(I)*RI(I) 90 CONTINUE DO 100 I=14,25 RES24 = RES24+CHEB24(I)*RI(I) 100 CONTINUE if ( INTEGR == 3) go to 130 ! ! INTEGR = 4 ! DC = LOG(BR-BL) RESULT = RES24*DC ABSERR = ABS((RES24-RES12)*DC) RES12 = 0.0E+00 RES24 = 0.0E+00 DO 110 I=1,13 RES12 = RES12+CHEB12(I)*RG(I) RES24 = RES24+CHEB24(I)*RG(I) 110 CONTINUE DO 120 I=14,25 RES24 = RES24+CHEB24(I)*RG(I) 120 CONTINUE 130 RESULT = (RESULT+RES24)*FACTOR ABSERR = (ABSERR+ABS(RES24-RES12))*FACTOR go to 270 ! ! THIS PART OF THE PROGRAM IS EXECUTED ONLY if B = BR. ! ---------------------------------------------------- ! ! COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE ! FOLLOWING FUNCTION ! F2 = (0.5*(B+BL-A-A)+0.5*(B-BL)*X)**ALFA ! *F(0.5*(B-BL)*X+0.5*(B+BL)) ! 140 HLGTH = 0.5E+00*(BR-BL) CENTR = 0.5E+00*(BR+BL) FIX = CENTR-A FVAL(1) = 0.5E+00*F(HLGTH+CENTR)*(FIX+HLGTH)**ALFA FVAL(13) = F(CENTR)*(FIX**ALFA) FVAL(25) = 0.5E+00*F(CENTR-HLGTH)*(FIX-HLGTH)**ALFA DO 150 I=2,12 U = HLGTH*X(I-1) ISYM = 26-I FVAL(I) = F(U+CENTR)*(FIX+U)**ALFA FVAL(ISYM) = F(CENTR-U)*(FIX-U)**ALFA 150 CONTINUE FACTOR = HLGTH**(BETA+0.1E+01) RESULT = 0.0E+00 ABSERR = 0.0E+00 RES12 = 0.0E+00 RES24 = 0.0E+00 if ( INTEGR == 2.OR.INTEGR == 4) go to 200 ! ! INTEGR = 1 (OR 3) ! call QCHEB(X,FVAL,CHEB12,CHEB24) DO 160 I=1,13 RES12 = RES12+CHEB12(I)*RJ(I) RES24 = RES24+CHEB24(I)*RJ(I) 160 CONTINUE DO 170 I=14,25 RES24 = RES24+CHEB24(I)*RJ(I) 170 CONTINUE if ( INTEGR == 1) go to 260 ! ! INTEGR = 3 ! DC = LOG(BR-BL) RESULT = RES24*DC ABSERR = ABS((RES24-RES12)*DC) RES12 = 0.0E+00 RES24 = 0.0E+00 DO 180 I=1,13 RES12 = RES12+CHEB12(I)*RH(I) RES24 = RES24+CHEB24(I)*RH(I) 180 CONTINUE DO 190 I=14,25 RES24 = RES24+CHEB24(I)*RH(I) 190 CONTINUE go to 260 ! ! COMPUTE THE CHEBYSHEV SERIES EXPANSION OF THE ! FOLLOWING FUNCTION ! F3 = F2*LOG(0.5*(B-BL)*X+0.5*(B+BL-A-A)) ! 200 FVAL(1) = FVAL(1)*LOG(FIX+HLGTH) FVAL(13) = FVAL(13)*LOG(FIX) FVAL(25) = FVAL(25)*LOG(FIX-HLGTH) DO 210 I=2,12 U = HLGTH*X(I-1) ISYM = 26-I FVAL(I) = FVAL(I)*LOG(FIX+U) FVAL(ISYM) = FVAL(ISYM)*LOG(FIX-U) 210 CONTINUE call QCHEB(X,FVAL,CHEB12,CHEB24) ! ! INTEGR = 2 (OR 4) ! DO 220 I=1,13 RES12 = RES12+CHEB12(I)*RJ(I) RES24 = RES24+CHEB24(I)*RJ(I) 220 CONTINUE DO 230 I=14,25 RES24 = RES24+CHEB24(I)*RJ(I) 230 CONTINUE if ( INTEGR == 2) go to 260 DC = LOG(BR-BL) RESULT = RES24*DC ABSERR = ABS((RES24-RES12)*DC) RES12 = 0.0E+00 RES24 = 0.0E+00 ! ! INTEGR = 4 ! DO 240 I=1,13 RES12 = RES12+CHEB12(I)*RH(I) RES24 = RES24+CHEB24(I)*RH(I) 240 CONTINUE DO 250 I=14,25 RES24 = RES24+CHEB24(I)*RH(I) 250 CONTINUE 260 RESULT = (RESULT+RES24)*FACTOR ABSERR = (ABSERR+ABS(RES24-RES12))*FACTOR 270 RETURN end subroutine QCHEB (X, FVAL, CHEB12, CHEB24) ! !! QCHEB computes the CHEBYSHEV series expansion of degrees 12 and 24 ... ! of a function using A ! FAST FOURIER TRANSFORM METHOD ! F(X) = SUM(K=1,..,13) (CHEB12(K)*T(K-1,X)), ! F(X) = SUM(K=1,..,25) (CHEB24(K)*T(K-1,X)), ! Where T(K,X) is the CHEBYSHEV POLYNOMIAL OF DEGREE K. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QCHEB-S, DQCHEB-D) !***KEYWORDS CHEBYSHEV SERIES EXPANSION, FAST FOURIER TRANSFORM !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Chebyshev Series Expansion ! Standard Fortran Subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! X - Real ! Vector of dimension 11 containing the ! Values COS(K*PI/24), K = 1, ..., 11 ! ! FVAL - Real ! Vector of dimension 25 containing the ! function values at the points ! (B+A+(B-A)*COS(K*PI/24))/2, K = 0, ...,24, ! where (A,B) is the approximation interval. ! FVAL(1) and FVAL(25) are divided by two ! (these values are destroyed at output). ! ! ON RETURN ! CHEB12 - Real ! Vector of dimension 13 containing the ! CHEBYSHEV coefficients for degree 12 ! ! CHEB24 - Real ! Vector of dimension 25 containing the ! CHEBYSHEV Coefficients for degree 24 ! !***SEE ALSO QC25C, QC25F, QC25S !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 830518 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE QCHEB ! REAL ALAM,ALAM1,ALAM2,CHEB12,CHEB24, & FVAL,PART1,PART2,PART3,V,X INTEGER I,J ! DIMENSION CHEB12(13),CHEB24(25),FVAL(25),V(12),X(11) ! !***FIRST EXECUTABLE STATEMENT QCHEB DO 10 I=1,12 J = 26-I V(I) = FVAL(I)-FVAL(J) FVAL(I) = FVAL(I)+FVAL(J) 10 CONTINUE ALAM1 = V(1)-V(9) ALAM2 = X(6)*(V(3)-V(7)-V(11)) CHEB12(4) = ALAM1+ALAM2 CHEB12(10) = ALAM1-ALAM2 ALAM1 = V(2)-V(8)-V(10) ALAM2 = V(4)-V(6)-V(12) ALAM = X(3)*ALAM1+X(9)*ALAM2 CHEB24(4) = CHEB12(4)+ALAM CHEB24(22) = CHEB12(4)-ALAM ALAM = X(9)*ALAM1-X(3)*ALAM2 CHEB24(10) = CHEB12(10)+ALAM CHEB24(16) = CHEB12(10)-ALAM PART1 = X(4)*V(5) PART2 = X(8)*V(9) PART3 = X(6)*V(7) ALAM1 = V(1)+PART1+PART2 ALAM2 = X(2)*V(3)+PART3+X(10)*V(11) CHEB12(2) = ALAM1+ALAM2 CHEB12(12) = ALAM1-ALAM2 ALAM = X(1)*V(2)+X(3)*V(4)+X(5)*V(6)+X(7)*V(8) & +X(9)*V(10)+X(11)*V(12) CHEB24(2) = CHEB12(2)+ALAM CHEB24(24) = CHEB12(2)-ALAM ALAM = X(11)*V(2)-X(9)*V(4)+X(7)*V(6)-X(5)*V(8) & +X(3)*V(10)-X(1)*V(12) CHEB24(12) = CHEB12(12)+ALAM CHEB24(14) = CHEB12(12)-ALAM ALAM1 = V(1)-PART1+PART2 ALAM2 = X(10)*V(3)-PART3+X(2)*V(11) CHEB12(6) = ALAM1+ALAM2 CHEB12(8) = ALAM1-ALAM2 ALAM = X(5)*V(2)-X(9)*V(4)-X(1)*V(6) & -X(11)*V(8)+X(3)*V(10)+X(7)*V(12) CHEB24(6) = CHEB12(6)+ALAM CHEB24(20) = CHEB12(6)-ALAM ALAM = X(7)*V(2)-X(3)*V(4)-X(11)*V(6)+X(1)*V(8) & -X(9)*V(10)-X(5)*V(12) CHEB24(8) = CHEB12(8)+ALAM CHEB24(18) = CHEB12(8)-ALAM DO 20 I=1,6 J = 14-I V(I) = FVAL(I)-FVAL(J) FVAL(I) = FVAL(I)+FVAL(J) 20 CONTINUE ALAM1 = V(1)+X(8)*V(5) ALAM2 = X(4)*V(3) CHEB12(3) = ALAM1+ALAM2 CHEB12(11) = ALAM1-ALAM2 CHEB12(7) = V(1)-V(5) ALAM = X(2)*V(2)+X(6)*V(4)+X(10)*V(6) CHEB24(3) = CHEB12(3)+ALAM CHEB24(23) = CHEB12(3)-ALAM ALAM = X(6)*(V(2)-V(4)-V(6)) CHEB24(7) = CHEB12(7)+ALAM CHEB24(19) = CHEB12(7)-ALAM ALAM = X(10)*V(2)-X(6)*V(4)+X(2)*V(6) CHEB24(11) = CHEB12(11)+ALAM CHEB24(15) = CHEB12(11)-ALAM DO 30 I=1,3 J = 8-I V(I) = FVAL(I)-FVAL(J) FVAL(I) = FVAL(I)+FVAL(J) 30 CONTINUE CHEB12(5) = V(1)+X(8)*V(3) CHEB12(9) = FVAL(1)-X(8)*FVAL(3) ALAM = X(4)*V(2) CHEB24(5) = CHEB12(5)+ALAM CHEB24(21) = CHEB12(5)-ALAM ALAM = X(8)*FVAL(2)-FVAL(4) CHEB24(9) = CHEB12(9)+ALAM CHEB24(17) = CHEB12(9)-ALAM CHEB12(1) = FVAL(1)+FVAL(3) ALAM = FVAL(2)+FVAL(4) CHEB24(1) = CHEB12(1)+ALAM CHEB24(25) = CHEB12(1)-ALAM CHEB12(13) = V(1)-V(3) CHEB24(13) = CHEB12(13) ALAM = 0.1E+01/0.6E+01 DO 40 I=2,12 CHEB12(I) = CHEB12(I)*ALAM 40 CONTINUE ALAM = 0.5E+00*ALAM CHEB12(1) = CHEB12(1)*ALAM CHEB12(13) = CHEB12(13)*ALAM DO 50 I=2,24 CHEB24(I) = CHEB24(I)*ALAM 50 CONTINUE CHEB24(1) = 0.5E+00*ALAM*CHEB24(1) CHEB24(25) = 0.5E+00*ALAM*CHEB24(25) return end subroutine QELG (N, EPSTAB, RESULT, ABSERR, RES3LA, NRES) ! !! QELG determines the limit of a given sequence of approximations, ... ! by means of the Epsilon algorithm of ! P. Wynn. An estimate of the absolute error is also given. ! The condensed Epsilon table is computed. Only those ! elements needed for the computation of the next diagonal ! are preserved. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QELG-S, DQELG-D) !***KEYWORDS CONVERGENCE ACCELERATION, EPSILON ALGORITHM, EXTRAPOLATION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Epsilon algorithm ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! N - Integer ! EPSTAB(N) contains the new element in the ! first column of the epsilon table. ! ! EPSTAB - Real ! Vector of dimension 52 containing the elements ! of the two lower diagonals of the triangular ! epsilon table. The elements are numbered ! starting at the right-hand corner of the ! triangle. ! ! RESULT - Real ! Resulting approximation to the integral ! ! ABSERR - Real ! Estimate of the absolute error computed from ! RESULT and the 3 previous results ! ! RES3LA - Real ! Vector of dimension 3 containing the last 3 ! results ! ! NRES - Integer ! Number of calls to the routine ! (should be zero at first call) ! !***SEE ALSO QAGIE, QAGOE, QAGPE, QAGSE !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE QELG ! REAL ABSERR,DELTA1,DELTA2,DELTA3,R1MACH, & 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) ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! E0 - THE 4 ELEMENTS ON WHICH THE ! E1 COMPUTATION OF A NEW ELEMENT IN ! E2 THE EPSILON TABLE IS BASED ! E3 E0 ! E3 E1 NEW ! E2 ! NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW ! DIAGONAL ! ERROR - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2) ! RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE ! OF ERROR ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! OFLOW IS THE LARGEST POSITIVE MAGNITUDE. ! LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON ! TABLE CAN CONTAIN. if THIS NUMBER IS REACHED, THE UPPER ! DIAGONAL OF THE EPSILON TABLE IS DELETED. ! !***FIRST EXECUTABLE STATEMENT QELG EPMACH = R1MACH(4) OFLOW = R1MACH(2) NRES = NRES+1 ABSERR = OFLOW RESULT = EPSTAB(N) if ( N < 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 = MAX(ABS(E2),E1ABS)*EPMACH DELTA3 = E1-E0 ERR3 = ABS(DELTA3) TOL3 = MAX(E1ABS,ABS(E0))*EPMACH if ( ERR2 > TOL2.OR.ERR3 > TOL3) go to 10 ! ! if E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE ! ACCURACY, CONVERGENCE IS ASSUMED. ! RESULT = E2 ! ABSERR = ABS(E1-E0)+ABS(E2-E1) ! RESULT = RES ABSERR = ERR2+ERR3 ! ***JUMP OUT OF DO-LOOP go to 100 10 E3 = EPSTAB(K1) EPSTAB(K1) = E1 DELTA1 = E1-E3 ERR1 = ABS(DELTA1) TOL1 = MAX(E1ABS,ABS(E3))*EPMACH ! ! if TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT ! A PART OF THE TABLE BY ADJUSTING THE VALUE OF N ! if ( ERR1 <= TOL1.OR.ERR2 <= TOL2.OR.ERR3 <= TOL3) go to 20 SS = 0.1E+01/DELTA1+0.1E+01/DELTA2-0.1E+01/DELTA3 EPSINF = ABS(SS*E1) ! ! TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND ! EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE ! OF N. ! if ( EPSINF > 0.1E-03) go to 30 20 N = I+I-1 ! ***JUMP OUT OF DO-LOOP go to 50 ! ! COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST ! THE VALUE OF RESULT. ! 30 RES = E1+0.1E+01/SS EPSTAB(K1) = RES K1 = K1-2 ERROR = ERR2+ABS(RES-E2)+ERR3 if ( ERROR > ABSERR) go to 40 ABSERR = ERROR RESULT = RES 40 CONTINUE ! ! SHIFT THE TABLE. ! 50 if ( N == LIMEXP) N = 2*(LIMEXP/2)-1 IB = 1 if ( (NUM/2)*2 == NUM) IB = 2 IE = NEWELM+1 DO 60 I=1,IE IB2 = IB+2 EPSTAB(IB) = EPSTAB(IB2) IB = IB2 60 CONTINUE if ( NUM == 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 >= 4) go to 90 RES3LA(NRES) = RESULT ABSERR = OFLOW go to 100 ! ! COMPUTE ERROR ESTIMATE ! 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 = MAX(ABSERR,0.5E+01*EPMACH*ABS(RESULT)) return end subroutine QFORM (M, N, Q, LDQ, WA) ! !! QFORM is subsidiary to SNSQ and SNSQE. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QFORM-S, DQFORM-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine proceeds from the computed QR factorization of ! an M by N matrix A to accumulate the M by M orthogonal matrix ! Q from its factored form. ! ! The subroutine statement is ! ! SUBROUTINE QFORM(M,N,Q,LDQ,WA) ! ! where ! ! M is a positive integer input variable set to the number ! of rows of A and the order of Q. ! ! N is a positive integer input variable set to the number ! of columns of A. ! ! Q is an M by M array. On input the full lower trapezoid in ! the first min(M,N) columns of Q contains the factored form. ! On output Q has been accumulated into a square matrix. ! ! LDQ is a positive integer input variable not less than M ! which specifies the leading dimension of the array Q. ! ! WA is a work array of length M. ! !***SEE ALSO SNSQ, SNSQE !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE QFORM INTEGER M,N,LDQ REAL Q(LDQ,*),WA(*) INTEGER I,J,JM1,K,L,MINMN,NP1 REAL ONE,SUM,TEMP,ZERO SAVE ONE, ZERO DATA ONE,ZERO /1.0E0,0.0E0/ !***FIRST EXECUTABLE STATEMENT QFORM MINMN = MIN(M,N) if (MINMN < 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 ! ! INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX. ! NP1 = N + 1 if (M < 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 ! ! ACCUMULATE Q FROM ITS FACTORED FORM. ! 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) == 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 ! ! LAST CARD OF SUBROUTINE QFORM. ! end subroutine QK15 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! QK15 computes I = Integral of F over (A,B), with error estimate... ! J = integral of ABS(F) over (A,B) ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE SINGLE PRECISION (QK15-S, DQK15-D) !***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! FUNCTION F(X). The actual name for F needs to be ! Declared E X T E R N A L in the calling program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! ON RETURN ! RESULT - Real ! Approximation to the integral I ! Result is computed by applying the 15-POINT ! KRONROD RULE (RESK) obtained by optimal addition ! of abscissae to the 7-POINT GAUSS RULE(RESG). ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should not exceed ABS(I-RESULT) ! ! RESABS - Real ! Approximation to the integral J ! ! RESASC - Real ! Approximation to the integral of ABS(F-I/(B-A)) ! over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QK15 ! REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, & FV1,FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW, & WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(7),FV2(7),WG(4),WGK(8),XGK(8) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 7-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 15-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 7-POINT GAUSS RULE ! SAVE XGK, WGK, WG 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.0E+00 / 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/ DATA WG(1),WG(2),WG(3),WG(4)/ & 0.1294849661688697E+00, 0.2797053914892767E+00, & 0.3818300505051189E+00, 0.4179591836734694E+00/ ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 7-POINT GAUSS FORMULA ! RESK - RESULT OF THE 15-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), ! I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QK15 EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! CENTR = 0.5E+00*(A+B) HLGTH = 0.5E+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 15-POINT KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! FC = F(CENTR) RESG = FC*WG(4) RESK = FC*WGK(8) RESABS = ABS(RESK) DO 10 J=1,3 JTW = J*2 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,4 JTWM1 = J*2-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.5E+00 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 RESABS = RESABS*DHLGTH RESASC = RESASC*DHLGTH ABSERR = ABS((RESK-RESG)*HLGTH) if ( RESASC /= 0.0E+00.AND.ABSERR /= 0.0E+00) & ABSERR = RESASC*MIN(0.1E+01, & (0.2E+03*ABSERR/RESASC)**1.5E+00) if ( RESABS > UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5E+02)*RESABS,ABSERR) return end subroutine QK15I (F, BOUN, INF, A, B, RESULT, ABSERR, RESABS, & RESASC) ! !! QK15I estimates an integral over an infinite or semi-infinite domain. ! !***PURPOSE The original (infinite integration range is mapped ! onto the interval (0,1) and (A,B) is a part of (0,1). ! it is the purpose to compute ! I = Integral of transformed integrand over (A,B), ! J = Integral of ABS(Transformed Integrand) over (A,B). !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A3A2, H2A4A2 !***TYPE SINGLE PRECISION (QK15I-S, DQK15I-D) !***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration Rule ! Standard Fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! FUNCTION F(X). The actual name for F needs to be ! Declared E X T E R N A L in the calling program. ! ! BOUN - Real ! Finite bound of original integration ! Range (SET TO ZERO if INF = +2) ! ! INF - Integer ! If INF = -1, the original interval is ! (-INFINITY,BOUND), ! If INF = +1, the original interval is ! (BOUND,+INFINITY), ! If INF = +2, the original interval is ! (-INFINITY,+INFINITY) AND ! The integral is computed as the sum of two ! integrals, one over (-INFINITY,0) and one over ! (0,+INFINITY). ! ! A - Real ! Lower limit for integration over subrange ! of (0,1) ! ! B - Real ! Upper limit for integration over subrange ! of (0,1) ! ! ON RETURN ! RESULT - Real ! Approximation to the integral I ! Result is computed by applying the 15-POINT ! KRONROD RULE(RESK) obtained by optimal addition ! of abscissae to the 7-POINT GAUSS RULE(RESG). ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! WHICH SHOULD EQUAL or EXCEED ABS(I-RESULT) ! ! RESABS - Real ! Approximation to the integral J ! ! RESASC - Real ! Approximation to the integral of ! ABS((TRANSFORMED INTEGRAND)-I/(B-A)) over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QK15I ! REAL A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR, & DINF,R1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1, & FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,TABSC1,TABSC2, & UFLOW,WG,WGK,XGK INTEGER INF,J EXTERNAL F ! DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(8) ! ! THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL ! (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND ! THEIR CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 7-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 15-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING ! TO THE ABSCISSAE XGK(2), XGK(4), ... ! WG(1), WG(3), ... ARE SET TO ZERO. ! SAVE XGK, WGK, WG 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/ ! 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/ ! 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/ ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC* - ABSCISSA ! TABSC* - TRANSFORMED ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 7-POINT GAUSS FORMULA ! RESK - RESULT OF THE 15-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED ! INTEGRAND OVER (A,B), I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QK15I EPMACH = R1MACH(4) UFLOW = R1MACH(1) DINF = MIN(1,INF) ! CENTR = 0.5E+00*(A+B) HLGTH = 0.5E+00*(B-A) TABSC1 = BOUN+DINF*(0.1E+01-CENTR)/CENTR FVAL1 = F(TABSC1) if ( INF == 2) FVAL1 = FVAL1+F(-TABSC1) FC = (FVAL1/CENTR)/CENTR ! ! COMPUTE THE 15-POINT KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ERROR. ! 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*(0.1E+01-ABSC1)/ABSC1 TABSC2 = BOUN+DINF*(0.1E+01-ABSC2)/ABSC2 FVAL1 = F(TABSC1) FVAL2 = F(TABSC2) if ( INF == 2) FVAL1 = FVAL1+F(-TABSC1) if ( INF == 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.5E+00 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 /= 0.0E+00.AND.ABSERR /= 0.E0) ABSERR = RESASC* & MIN(0.1E+01,(0.2E+03*ABSERR/RESASC)**1.5E+00) if ( RESABS > UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5E+02)*RESABS,ABSERR) return end subroutine QK15W (F, W, P1, P2, P3, P4, KP, A, B, RESULT, ABSERR, & RESABS, RESASC) ! !! QK15W estimates an integral with a weight function W(X). ! ! Discussion: ! ! Recently bug was discovered in subroutines QK15W, DQK15W, ! which are Quadpack routines included in SLATEC. In these ! routines, the DATA initialization of WG(3) should be changed from ! 0.3818300505051889E+0 and 0.3818300505051889D+00 ! to ! 0.3818300505051189E+0 and 0.3818300505051189D+00 ! respectively. ! ! DONE, JVB, 16 November 2023. ! !***PURPOSE To compute I = Integral of F*W over (A,B), with error ! estimate ! J = Integral of ABS(F*W) over (A,B) !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A2 !***TYPE SINGLE PRECISION (QK15W-S, DQK15W-D) !***KEYWORDS 15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the driver program. ! ! W - Real ! Function subprogram defining the integrand ! WEIGHT function W(X). The actual name for W ! needs to be declared E X T E R N A L in the ! calling program. ! ! P1, P2, P3, P4 - Real ! Parameters in the WEIGHT function ! ! KP - Integer ! Key for indicating the type of WEIGHT function ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! ON RETURN ! RESULT - Real ! Approximation to the integral I ! RESULT is computed by applying the 15-point ! Kronrod rule (RESK) obtained by optimal addition ! of abscissae to the 7-point Gauss rule (RESG). ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! RESABS - Real ! Approximation to the integral of ABS(F) ! ! RESASC - Real ! Approximation to the integral of ABS(F-I/(B-A)) ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QK15W ! REAL A,ABSC,ABSC1,ABSC2,ABSERR,B,CENTR,DHLGTH, & R1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2, & HLGTH,P1,P2,P3,P4,RESABS,RESASC,RESG,RESK,RESKH,RESULT,UFLOW, & W,WG,WGK,XGK INTEGER J,JTW,JTWM1,KP EXTERNAL F, W ! DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(4) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 15-POINT GAUSS-KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 7-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 15-POINT GAUSS-KRONROD RULE ! ! WG - WEIGHTS OF THE 7-POINT GAUSS RULE ! SAVE XGK, WGK, WG 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/ ! 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/ ! DATA WG(1),WG(2),WG(3),WG(4)/ & 0.1294849661688697E+00, & 0.2797053914892767E+00, & 0.3818300505051189E+00, & 0.4179591836734694E+00/ ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC* - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 7-POINT GAUSS FORMULA ! RESK - RESULT OF THE 15-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F*W OVER (A,B), ! I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QK15W EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! CENTR = 0.5E+00*(A+B) HLGTH = 0.5E+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 15-POINT KRONROD APPROXIMATION TO THE ! INTEGRAL, AND ESTIMATE THE ERROR. ! FC = F(CENTR)*W(CENTR,P1,P2,P3,P4,KP) RESG = WG(4)*FC RESK = WGK(8)*FC RESABS = ABS(RESK) DO 10 J=1,3 JTW = J*2 ABSC = HLGTH*XGK(JTW) ABSC1 = CENTR-ABSC ABSC2 = CENTR+ABSC FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP) FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP) 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,4 JTWM1 = J*2-1 ABSC = HLGTH*XGK(JTWM1) ABSC1 = CENTR-ABSC ABSC2 = CENTR+ABSC FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP) FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP) 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.5E+00 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 RESABS = RESABS*DHLGTH RESASC = RESASC*DHLGTH ABSERR = ABS((RESK-RESG)*HLGTH) if ( RESASC /= 0.0E+00.AND.ABSERR /= 0.0E+00) & ABSERR = RESASC*MIN(0.1E+01, & (0.2E+03*ABSERR/RESASC)**1.5E+00) if ( RESABS > UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX((EPMACH* & 0.5E+02)*RESABS,ABSERR) return end subroutine QK21 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! QK21 estimates an integral with a 21 point Gauss Kronrod rule. ! !***PURPOSE To compute I = Integral of F over (A,B), with error ! estimate ! J = Integral of ABS(F) over (A,B) !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE SINGLE PRECISION (QK21-S, DQK21-D) !***KEYWORDS 21-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! FUNCTION F(X). The actual name for F needs to be ! Declared E X T E R N A L in the driver program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! ON RETURN ! RESULT - Real ! Approximation to the integral I ! RESULT is computed by applying the 21-POINT ! KRONROD RULE (RESK) obtained by optimal addition ! of abscissae to the 10-POINT GAUSS RULE (RESG). ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should not exceed ABS(I-RESULT) ! ! RESABS - Real ! Approximation to the integral J ! ! RESASC - Real ! Approximation to the integral of ABS(F-I/(B-A)) ! over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QK21 ! REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, & FV1,FV2,HLGTH,RESABS,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW,WG,WGK, & XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(10),FV2(10),WG(5),WGK(11),XGK(11) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 21-POINT KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 10-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 10-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 21-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 10-POINT GAUSS RULE ! SAVE XGK, WGK, WG 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/ ! 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/ ! 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/ ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 10-POINT GAUSS FORMULA ! RESK - RESULT OF THE 21-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), ! I.E. TO I/(B-A) ! ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QK21 EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! CENTR = 0.5E+00*(A+B) HLGTH = 0.5E+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 21-POINT KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! RESG = 0.0E+00 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.5E+00 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 /= 0.0E+00.AND.ABSERR /= 0.0E+00) & ABSERR = RESASC*MIN(0.1E+01, & (0.2E+03*ABSERR/RESASC)**1.5E+00) if ( RESABS > UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5E+02)*RESABS,ABSERR) return end subroutine QK31 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! QK31 estimates an integral with a 31 point Gauss-Kronrod rule. ! !***PURPOSE To compute I = Integral of F over (A,B) with error ! estimate ! J = Integral of ABS(F) over (A,B) !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE SINGLE PRECISION (QK31-S, DQK31-D) !***KEYWORDS 31-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! FUNCTION F(X). The actual name for F needs to be ! Declared E X T E R N A L in the calling program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! ON RETURN ! RESULT - Real ! Approximation to the integral I ! RESULT is computed by applying the 31-POINT ! GAUSS-KRONROD RULE (RESK), obtained by optimal ! addition of abscissae to the 15-POINT GAUSS ! RULE (RESG). ! ! ABSERR - Real ! Estimate of the modulus of the modulus, ! which should not exceed ABS(I-RESULT) ! ! RESABS - Real ! Approximation to the integral J ! ! RESASC - Real ! Approximation to the integral of ABS(F-I/(B-A)) ! over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QK31 REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, & FV1,FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW, & WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(15),FV2(15),XGK(16),WGK(16),WG(8) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 31-POINT KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 15-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 15-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 31-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 15-POINT GAUSS RULE ! SAVE XGK, WGK, WG DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8), & XGK(9),XGK(10),XGK(11),XGK(12),XGK(13),XGK(14),XGK(15), & XGK(16)/ & 0.9980022986933971E+00, 0.9879925180204854E+00, & 0.9677390756791391E+00, 0.9372733924007059E+00, & 0.8972645323440819E+00, 0.8482065834104272E+00, & 0.7904185014424659E+00, 0.7244177313601700E+00, & 0.6509967412974170E+00, 0.5709721726085388E+00, & 0.4850818636402397E+00, 0.3941513470775634E+00, & 0.2991800071531688E+00, 0.2011940939974345E+00, & 0.1011420669187175E+00, 0.0E+00 / DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8), & WGK(9),WGK(10),WGK(11),WGK(12),WGK(13),WGK(14),WGK(15), & WGK(16)/ & 0.5377479872923349E-02, 0.1500794732931612E-01, & 0.2546084732671532E-01, 0.3534636079137585E-01, & 0.4458975132476488E-01, 0.5348152469092809E-01, & 0.6200956780067064E-01, 0.6985412131872826E-01, & 0.7684968075772038E-01, 0.8308050282313302E-01, & 0.8856444305621177E-01, 0.9312659817082532E-01, & 0.9664272698362368E-01, 0.9917359872179196E-01, & 0.1007698455238756E+00, 0.1013300070147915E+00/ DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ & 0.3075324199611727E-01, 0.7036604748810812E-01, & 0.1071592204671719E+00, 0.1395706779261543E+00, & 0.1662692058169939E+00, 0.1861610000155622E+00, & 0.1984314853271116E+00, 0.2025782419255613E+00/ ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 15-POINT GAUSS FORMULA ! RESK - RESULT OF THE 31-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), ! I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QK31 EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! CENTR = 0.5E+00*(A+B) HLGTH = 0.5E+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 31-POINT KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! FC = F(CENTR) RESG = WG(8)*FC RESK = WGK(16)*FC RESABS = ABS(RESK) DO 10 J=1,7 JTW = J*2 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,8 JTWM1 = J*2-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.5E+00 RESASC = WGK(16)*ABS(FC-RESKH) DO 20 J=1,15 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 /= 0.0E+00.AND.ABSERR /= 0.0E+00) & ABSERR = RESASC*MIN(0.1E+01, & (0.2E+03*ABSERR/RESASC)**1.5E+00) if ( RESABS > UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5E+02)*RESABS,ABSERR) return end subroutine QK41 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! QK41 estimates an integral with a 41 point Gauss Kronrod rule. ! !***PURPOSE To compute I = Integral of F over (A,B), with error ! estimate ! J = Integral of ABS(F) over (A,B) !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE SINGLE PRECISION (QK41-S, DQK41-D) !***KEYWORDS 41-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! FUNCTION F(X). The actual name for F needs to be ! declared E X T E R N A L in the calling program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! ON RETURN ! RESULT - Real ! Approximation to the integral I ! RESULT is computed by applying the 41-POINT ! GAUSS-KRONROD RULE (RESK) obtained by optimal ! addition of abscissae to the 20-POINT GAUSS ! RULE (RESG). ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should not exceed ABS(I-RESULT) ! ! RESABS - Real ! Approximation to the integral J ! ! RESASC - Real ! Approximation to the integral of ABS(F-I/(B-A)) ! over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QK41 ! REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, & FV1,FV2,HLGTH,RESABS, & RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW, & WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(20),FV2(20),XGK(21),WGK(21),WG(10) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 41-POINT GAUSS-KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 20-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 20-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 41-POINT GAUSS-KRONROD RULE ! ! WG - WEIGHTS OF THE 20-POINT GAUSS RULE ! SAVE XGK, WGK, WG DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8), & XGK(9),XGK(10),XGK(11),XGK(12),XGK(13),XGK(14),XGK(15), & XGK(16),XGK(17),XGK(18),XGK(19),XGK(20),XGK(21)/ & 0.9988590315882777E+00, 0.9931285991850949E+00, & 0.9815078774502503E+00, 0.9639719272779138E+00, & 0.9408226338317548E+00, 0.9122344282513259E+00, & 0.8782768112522820E+00, 0.8391169718222188E+00, & 0.7950414288375512E+00, 0.7463319064601508E+00, & 0.6932376563347514E+00, 0.6360536807265150E+00, & 0.5751404468197103E+00, 0.5108670019508271E+00, & 0.4435931752387251E+00, 0.3737060887154196E+00, & 0.3016278681149130E+00, 0.2277858511416451E+00, & 0.1526054652409227E+00, 0.7652652113349733E-01, & 0.0E+00 / DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8), & WGK(9),WGK(10),WGK(11),WGK(12),WGK(13),WGK(14),WGK(15),WGK(16), & WGK(17),WGK(18),WGK(19),WGK(20),WGK(21)/ & 0.3073583718520532E-02, 0.8600269855642942E-02, & 0.1462616925697125E-01, 0.2038837346126652E-01, & 0.2588213360495116E-01, 0.3128730677703280E-01, & 0.3660016975820080E-01, 0.4166887332797369E-01, & 0.4643482186749767E-01, 0.5094457392372869E-01, & 0.5519510534828599E-01, 0.5911140088063957E-01, & 0.6265323755478117E-01, 0.6583459713361842E-01, & 0.6864867292852162E-01, 0.7105442355344407E-01, & 0.7303069033278667E-01, 0.7458287540049919E-01, & 0.7570449768455667E-01, 0.7637786767208074E-01, & 0.7660071191799966E-01/ DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8),WG(9),WG(10)/ & 0.1761400713915212E-01, 0.4060142980038694E-01, & 0.6267204833410906E-01, 0.8327674157670475E-01, & 0.1019301198172404E+00, 0.1181945319615184E+00, & 0.1316886384491766E+00, 0.1420961093183821E+00, & 0.1491729864726037E+00, 0.1527533871307259E+00/ ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 20-POINT GAUSS FORMULA ! RESK - RESULT OF THE 41-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO MEAN VALUE OF F OVER (A,B), I.E. ! TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QK41 EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! CENTR = 0.5E+00*(A+B) HLGTH = 0.5E+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 41-POINT GAUSS-KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! RESG = 0.0E+00 FC = F(CENTR) RESK = WGK(21)*FC RESABS = ABS(RESK) DO 10 J=1,10 JTW = J*2 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,10 JTWM1 = J*2-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.5E+00 RESASC = WGK(21)*ABS(FC-RESKH) DO 20 J=1,20 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 /= 0.0E+00.AND.ABSERR /= 0.E+00) & ABSERR = RESASC*MIN(0.1E+01, & (0.2E+03*ABSERR/RESASC)**1.5E+00) if ( RESABS > UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5E+02)*RESABS,ABSERR) return end subroutine QK51 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! QK51 estimates an integral with a 51 point Gauss-Kronrod rule. ! !***PURPOSE To compute I = Integral of F over (A,B) with error ! estimate ! J = Integral of ABS(F) over (A,B) !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE SINGLE PRECISION (QK51-S, DQK51-D) !***KEYWORDS 51-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rules ! Standard fortran subroutine ! Real version ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subroutine defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the calling program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! ON RETURN ! RESULT - Real ! Approximation to the integral I ! RESULT is computed by applying the 51-point ! Kronrod rule (RESK) obtained by optimal addition ! of abscissae to the 25-point Gauss rule (RESG). ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should not exceed ABS(I-RESULT) ! ! RESABS - Real ! Approximation to the integral J ! ! RESASC - Real ! Approximation to the integral of ABS(F-I/(B-A)) ! over (A,B) ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QK51 ! REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, & FV1,FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW, & WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(25),FV2(25),XGK(26),WGK(26),WG(13) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). ! BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR ! CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 51-POINT KRONROD RULE ! XGK(2), XGK(4), ... ABSCISSAE OF THE 25-POINT ! GAUSS RULE ! XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY ! ADDED TO THE 25-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 51-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 25-POINT GAUSS RULE ! SAVE XGK, WGK, WG DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8), & XGK(9),XGK(10),XGK(11),XGK(12),XGK(13),XGK(14)/ & 0.9992621049926098E+00, 0.9955569697904981E+00, & 0.9880357945340772E+00, 0.9766639214595175E+00, & 0.9616149864258425E+00, 0.9429745712289743E+00, & 0.9207471152817016E+00, 0.8949919978782754E+00, & 0.8658470652932756E+00, 0.8334426287608340E+00, & 0.7978737979985001E+00, 0.7592592630373576E+00, & 0.7177664068130844E+00, 0.6735663684734684E+00/ DATA XGK(15),XGK(16),XGK(17),XGK(18),XGK(19),XGK(20),XGK(21), & XGK(22),XGK(23),XGK(24),XGK(25),XGK(26)/ & 0.6268100990103174E+00, 0.5776629302412230E+00, & 0.5263252843347192E+00, 0.4730027314457150E+00, & 0.4178853821930377E+00, 0.3611723058093878E+00, & 0.3030895389311078E+00, 0.2438668837209884E+00, & 0.1837189394210489E+00, 0.1228646926107104E+00, & 0.6154448300568508E-01, 0.0E+00 / DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8), & WGK(9),WGK(10),WGK(11),WGK(12),WGK(13),WGK(14)/ & 0.1987383892330316E-02, 0.5561932135356714E-02, & 0.9473973386174152E-02, 0.1323622919557167E-01, & 0.1684781770912830E-01, 0.2043537114588284E-01, & 0.2400994560695322E-01, 0.2747531758785174E-01, & 0.3079230016738749E-01, 0.3400213027432934E-01, & 0.3711627148341554E-01, 0.4008382550403238E-01, & 0.4287284502017005E-01, 0.4550291304992179E-01/ DATA WGK(15),WGK(16),WGK(17),WGK(18),WGK(19),WGK(20),WGK(21) & ,WGK(22),WGK(23),WGK(24),WGK(25),WGK(26)/ & 0.4798253713883671E-01, 0.5027767908071567E-01, & 0.5236288580640748E-01, 0.5425112988854549E-01, & 0.5595081122041232E-01, 0.5743711636156783E-01, & 0.5868968002239421E-01, 0.5972034032417406E-01, & 0.6053945537604586E-01, 0.6112850971705305E-01, & 0.6147118987142532E-01, 0.6158081806783294E-01/ DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8),WG(9), & WG(10),WG(11),WG(12),WG(13)/ & 0.1139379850102629E-01, 0.2635498661503214E-01, & 0.4093915670130631E-01, 0.5490469597583519E-01, & 0.6803833381235692E-01, 0.8014070033500102E-01, & 0.9102826198296365E-01, 0.1005359490670506E+00, & 0.1085196244742637E+00, 0.1148582591457116E+00, & 0.1194557635357848E+00, 0.1222424429903100E+00, & 0.1231760537267155E+00/ ! ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 25-POINT GAUSS FORMULA ! RESK - RESULT OF THE 51-POINT KRONROD FORMULA ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), ! I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QK51 EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! CENTR = 0.5E+00*(A+B) HLGTH = 0.5E+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 51-POINT KRONROD APPROXIMATION TO ! THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! FC = F(CENTR) RESG = WG(13)*FC RESK = WGK(26)*FC RESABS = ABS(RESK) DO 10 J=1,12 JTW = J*2 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,13 JTWM1 = J*2-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.5E+00 RESASC = WGK(26)*ABS(FC-RESKH) DO 20 J=1,25 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 /= 0.0E+00.AND.ABSERR /= 0.0E+00) & ABSERR = RESASC*MIN(0.1E+01, & (0.2E+03*ABSERR/RESASC)**1.5E+00) if ( RESABS > UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5E+02)*RESABS,ABSERR) return end subroutine QK61 (F, A, B, RESULT, ABSERR, RESABS, RESASC) ! !! QK61 estimates an integral with a 61 point Gauss-Kronrod rule. ! !***PURPOSE To compute I = Integral of F over (A,B) with error ! estimate ! J = Integral of ABS(F) over (A,B) !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A2 !***TYPE SINGLE PRECISION (QK61-S, DQK61-D) !***KEYWORDS 61-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! Integration rule ! Standard fortran subroutine ! Real version ! ! ! PARAMETERS ! ON ENTRY ! F - Real ! Function subprogram defining the integrand ! function F(X). The actual name for F needs to be ! declared E X T E R N A L in the calling program. ! ! A - Real ! Lower limit of integration ! ! B - Real ! Upper limit of integration ! ! ON RETURN ! RESULT - Real ! Approximation to the integral I ! RESULT is computed by applying the 61-point ! Kronrod rule (RESK) obtained by optimal addition of ! abscissae to the 30-point Gauss rule (RESG). ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should equal or exceed ABS(I-RESULT) ! ! RESABS - Real ! Approximation to the integral J ! ! RESASC - Real ! Approximation to the integral of ABS(F-I/(B-A)) ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QK61 ! REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2, & FV1,FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW, & WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F ! DIMENSION FV1(30),FV2(30),XGK(31),WGK(31),WG(15) ! ! THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE ! INTERVAL (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ! ABSCISSAE AND THEIR CORRESPONDING WEIGHTS ARE GIVEN. ! ! XGK - ABSCISSAE OF THE 61-POINT KRONROD RULE ! XGK(2), XGK(4) ... ABSCISSAE OF THE 30-POINT ! GAUSS RULE ! XGK(1), XGK(3) ... OPTIMALLY ADDED ABSCISSAE ! TO THE 30-POINT GAUSS RULE ! ! WGK - WEIGHTS OF THE 61-POINT KRONROD RULE ! ! WG - WEIGHTS OF THE 30-POINT GAUSS RULE ! SAVE XGK, WGK, WG DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8), & XGK(9),XGK(10)/ & 0.9994844100504906E+00, 0.9968934840746495E+00, & 0.9916309968704046E+00, 0.9836681232797472E+00, & 0.9731163225011263E+00, 0.9600218649683075E+00, & 0.9443744447485600E+00, 0.9262000474292743E+00, & 0.9055733076999078E+00, 0.8825605357920527E+00/ DATA XGK(11),XGK(12),XGK(13),XGK(14),XGK(15),XGK(16), & XGK(17),XGK(18),XGK(19),XGK(20)/ & 0.8572052335460611E+00, 0.8295657623827684E+00, & 0.7997278358218391E+00, 0.7677774321048262E+00, & 0.7337900624532268E+00, 0.6978504947933158E+00, & 0.6600610641266270E+00, 0.6205261829892429E+00, & 0.5793452358263617E+00, 0.5366241481420199E+00/ DATA XGK(21),XGK(22),XGK(23),XGK(24), & XGK(25),XGK(26),XGK(27),XGK(28),XGK(29),XGK(30),XGK(31)/ & 0.4924804678617786E+00, 0.4470337695380892E+00, & 0.4004012548303944E+00, 0.3527047255308781E+00, & 0.3040732022736251E+00, 0.2546369261678898E+00, & 0.2045251166823099E+00, 0.1538699136085835E+00, & 0.1028069379667370E+00, 0.5147184255531770E-01, & 0.0E+00 / DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8), & WGK(9),WGK(10)/ & 0.1389013698677008E-02, 0.3890461127099884E-02, & 0.6630703915931292E-02, 0.9273279659517763E-02, & 0.1182301525349634E-01, 0.1436972950704580E-01, & 0.1692088918905327E-01, 0.1941414119394238E-01, & 0.2182803582160919E-01, 0.2419116207808060E-01/ DATA WGK(11),WGK(12),WGK(13),WGK(14),WGK(15),WGK(16), & WGK(17),WGK(18),WGK(19),WGK(20)/ & 0.2650995488233310E-01, 0.2875404876504129E-01, & 0.3090725756238776E-01, 0.3298144705748373E-01, & 0.3497933802806002E-01, 0.3688236465182123E-01, & 0.3867894562472759E-01, 0.4037453895153596E-01, & 0.4196981021516425E-01, 0.4345253970135607E-01/ DATA WGK(21),WGK(22),WGK(23),WGK(24), & WGK(25),WGK(26),WGK(27),WGK(28),WGK(29),WGK(30),WGK(31)/ & 0.4481480013316266E-01, 0.4605923827100699E-01, & 0.4718554656929915E-01, 0.4818586175708713E-01, & 0.4905543455502978E-01, 0.4979568342707421E-01, & 0.5040592140278235E-01, 0.5088179589874961E-01, & 0.5122154784925877E-01, 0.5142612853745903E-01, & 0.5149472942945157E-01/ DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ & 0.7968192496166606E-02, 0.1846646831109096E-01, & 0.2878470788332337E-01, 0.3879919256962705E-01, & 0.4840267283059405E-01, 0.5749315621761907E-01, & 0.6597422988218050E-01, 0.7375597473770521E-01/ DATA WG(9),WG(10),WG(11),WG(12),WG(13),WG(14),WG(15)/ & 0.8075589522942022E-01, 0.8689978720108298E-01, & 0.9212252223778613E-01, 0.9636873717464426E-01, & 0.9959342058679527E-01, 0.1017623897484055E+00, & 0.1028526528935588E+00/ ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTERVAL ! HLGTH - HALF-LENGTH OF THE INTERVAL ! ABSC - ABSCISSA ! FVAL* - FUNCTION VALUE ! RESG - RESULT OF THE 30-POINT GAUSS RULE ! RESK - RESULT OF THE 61-POINT KRONROD RULE ! RESKH - APPROXIMATION TO THE MEAN VALUE OF F ! OVER (A,B), I.E. TO I/(B-A) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QK61 EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! CENTR = 0.5E+00*(B+A) HLGTH = 0.5E+00*(B-A) DHLGTH = ABS(HLGTH) ! ! COMPUTE THE 61-POINT KRONROD APPROXIMATION TO THE ! INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. ! RESG = 0.0E+00 FC = F(CENTR) RESK = WGK(31)*FC RESABS = ABS(RESK) DO 10 J=1,15 JTW = J*2 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,15 JTWM1 = J*2-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.5E+00 RESASC = WGK(31)*ABS(FC-RESKH) DO 20 J=1,30 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 /= 0.0E+00.AND.ABSERR /= 0.0E+00) & ABSERR = RESASC*MIN(0.1E+01, & (0.2E+03*ABSERR/RESASC)**1.5E+00) if ( RESABS > UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5E+02)*RESABS,ABSERR) return end subroutine QMOMO (ALFA, BETA, RI, RJ, RG, RH, INTEGR) ! !! QMOMO computes modified Chebyshev moments. ... ! The K-th ! modified Chebyshev moment is defined as the integral over ! (-1,1) of W(X)*T(K,X), where T(K,X) is the Chebyshev ! polynomial of degree K. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A2A1, C3A2 !***TYPE SINGLE PRECISION (QMOMO-S, DQMOMO-D) !***KEYWORDS MODIFIED CHEBYSHEV MOMENTS, QUADPACK, QUADRATURE !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! MODIFIED CHEBYSHEV MOMENTS ! STANDARD FORTRAN SUBROUTINE ! REAL VERSION ! ! PARAMETERS ! ALFA - Real ! Parameter in the weight function W(X), ALFA > (-1) ! ! BETA - Real ! Parameter in the weight function W(X), BETA > (-1) ! ! RI - Real ! Vector of dimension 25 ! RI(K) is the integral over (-1,1) of ! (1+X)**ALFA*T(K-1,X), K = 1, ..., 25. ! ! RJ - Real ! Vector of dimension 25 ! RJ(K) is the integral over (-1,1) of ! (1-X)**BETA*T(K-1,X), K = 1, ..., 25. ! ! RG - Real ! Vector of dimension 25 ! RG(K) is the integral over (-1,1) of ! (1+X)**ALFA*LOG((1+X)/2)*T(K-1,X), K = 1, ..., 25. ! ! RH - Real ! Vector of dimension 25 ! RH(K) is the integral over (-1,1) of ! (1-X)**BETA*LOG((1-X)/2)*T(K-1,X), K = 1, ..., 25. ! ! INTEGR - Integer ! Input parameter indicating the modified ! Moments to be computed ! INTEGR = 1 compute RI, RJ ! = 2 compute RI, RJ, RG ! = 3 compute RI, RJ, RH ! = 4 compute RI, RJ, RG, RH ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 891009 Removed unreferenced statement label. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE QMOMO ! REAL ALFA,ALFP1,ALFP2,AN,ANM1,BETA,BETP1, & BETP2,RALF,RBET,RG,RH,RI,RJ INTEGER I,IM1,INTEGR ! DIMENSION RG(25),RH(25),RI(25),RJ(25) ! ! !***FIRST EXECUTABLE STATEMENT QMOMO ALFP1 = ALFA+0.1E+01 BETP1 = BETA+0.1E+01 ALFP2 = ALFA+0.2E+01 BETP2 = BETA+0.2E+01 RALF = 0.2E+01**ALFP1 RBET = 0.2E+01**BETP1 ! ! COMPUTE RI, RJ USING A FORWARD RECURRENCE RELATION. ! RI(1) = RALF/ALFP1 RJ(1) = RBET/BETP1 RI(2) = RI(1)*ALFA/ALFP2 RJ(2) = RJ(1)*BETA/BETP2 AN = 0.2E+01 ANM1 = 0.1E+01 DO 20 I=3,25 RI(I) = -(RALF+AN*(AN-ALFP2)*RI(I-1))/ & (ANM1*(AN+ALFP1)) RJ(I) = -(RBET+AN*(AN-BETP2)*RJ(I-1))/ & (ANM1*(AN+BETP1)) ANM1 = AN AN = AN+0.1E+01 20 CONTINUE if ( INTEGR == 1) go to 70 if ( INTEGR == 3) go to 40 ! ! COMPUTE RG USING A FORWARD RECURRENCE RELATION. ! RG(1) = -RI(1)/ALFP1 RG(2) = -(RALF+RALF)/(ALFP2*ALFP2)-RG(1) AN = 0.2E+01 ANM1 = 0.1E+01 IM1 = 2 DO 30 I=3,25 RG(I) = -(AN*(AN-ALFP2)*RG(IM1)-AN*RI(IM1)+ANM1*RI(I))/ & (ANM1*(AN+ALFP1)) ANM1 = AN AN = AN+0.1E+01 IM1 = I 30 CONTINUE if ( INTEGR == 2) go to 70 ! ! COMPUTE RH USING A FORWARD RECURRENCE RELATION. ! 40 RH(1) = -RJ(1)/BETP1 RH(2) = -(RBET+RBET)/(BETP2*BETP2)-RH(1) AN = 0.2E+01 ANM1 = 0.1E+01 IM1 = 2 DO 50 I=3,25 RH(I) = -(AN*(AN-BETP2)*RH(IM1)-AN*RJ(IM1)+ & ANM1*RJ(I))/(ANM1*(AN+BETP1)) ANM1 = AN AN = AN+0.1E+01 IM1 = I 50 CONTINUE DO 60 I=2,25,2 RH(I) = -RH(I) 60 CONTINUE 70 DO 80 I=2,25,2 RJ(I) = -RJ(I) 80 CONTINUE return end subroutine QNC79 (FUN, A, B, ERR, ANS, IERR, K) ! !! QNC79 integrates a function using 7-point adaptive Newton-Cotes quadrature. ! !***LIBRARY SLATEC !***CATEGORY H2A1A1 !***TYPE SINGLE PRECISION (QNC79-S, DQNC79-D) !***KEYWORDS ADAPTIVE QUADRATURE, INTEGRATION, NEWTON-COTES !***AUTHOR Kahaner, D. K., (NBS) ! Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! QNC79 is a general purpose program for evaluation of ! one dimensional integrals of user defined functions. ! QNC79 will pick its own points for evaluation of the ! integrand and these will vary from problem to problem. ! Thus, QNC79 is not designed to integrate over data sets. ! Moderately smooth integrands will be integrated efficiently ! and reliably. For problems with strong singularities, ! oscillations etc., the user may wish to use more sophis- ! ticated routines such as those in QUADPACK. One measure ! of the reliability of QNC79 is the output parameter K, ! giving the number of integrand evaluations that were needed. ! ! Description of Arguments ! ! --Input-- ! FUN - name of external function to be integrated. This name ! must be in an EXTERNAL statement in your calling ! program. You must write a Fortran function to evaluate ! FUN. This should be of the form ! REAL FUNCTION FUN (X) ! C ! C X can vary from A to B ! C FUN(X) should be finite for all X on interval. ! C ! FUN = ... ! return ! END ! A - lower limit of integration ! B - upper limit of integration (may be less than A) ! ERR - is a requested error tolerance. Normally, pick a value ! 0 < ERR < 1.0E-3. ! ! --Output-- ! ANS - computed value of the integral. Hopefully, ANS is ! accurate to within ERR * integral of ABS(FUN(X)). ! IERR - a status code ! - Normal codes ! 1 ANS most likely meets requested error tolerance. ! -1 A equals B, or A and B are too nearly equal to ! allow normal integration. ANS is set to zero. ! - Abnormal code ! 2 ANS probably does not meet requested error tolerance. ! K - the number of function evaluations actually used to do ! the integration. A value of K > 1000 indicates a ! difficult problem; other programs may be more efficient. ! QNC79 will gracefully give up if K exceeds 2000. ! !***REFERENCES (NONE) !***ROUTINES CALLED I1MACH, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920218 Code and prologue polished. (WRB) !***END PROLOGUE QNC79 ! .. Scalar Arguments .. REAL A, ANS, B, ERR INTEGER IERR, K ! .. Function Arguments .. REAL FUN EXTERNAL FUN ! .. Local Scalars .. REAL AE, AREA, BANK, BLOCAL, C, CE, EE, EF, EPS, Q13, Q7, Q7L, & SQ2, TEST, TOL, VR, W1, W2, W3, W4 INTEGER I, KML, KMX, L, LMN, LMX, NBITS, NIB, NLMN, NLMX LOGICAL FIRST ! .. Local Arrays .. REAL AA(40), F(13), F1(40), F2(40), F3(40), F4(40), F5(40), & F6(40), F7(40), HH(40), Q7R(40), VL(40) INTEGER LR(40) ! .. External Functions .. REAL R1MACH INTEGER I1MACH EXTERNAL R1MACH, I1MACH ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, LOG, MAX, MIN, SIGN, SQRT ! .. Save statement .. SAVE NBITS, NLMX, FIRST, SQ2, W1, W2, W3, W4 ! .. Data statements .. DATA KML /7/, KMX /2000/, NLMN /2/ DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT QNC79 if (FIRST) THEN W1 = 41.0E0/140.0E0 W2 = 216.0E0/140.0E0 W3 = 27.0E0/140.0E0 W4 = 272.0E0/140.0E0 NBITS = R1MACH(5)*I1MACH(11)/0.30102000E0 NLMX = MIN(40,(NBITS*4)/5) SQ2 = SQRT(2.0E0) end if FIRST = .FALSE. ANS = 0.0E0 IERR = 1 CE = 0.0E0 if (A == B) go to 260 LMX = NLMX LMN = NLMN if (B == 0.0E0) go to 100 if (SIGN(1.0E0,B)*A <= 0.0E0) go to 100 C = ABS(1.0E0-A/B) if (C > 0.1E0) go to 100 if (C <= 0.0E0) go to 260 NIB = 0.5E0 - LOG(C)/LOG(2.0E0) LMX = MIN(NLMX,NBITS-NIB-4) if (LMX < 2) go to 260 LMN = MIN(LMN,LMX) 100 TOL = MAX(ABS(ERR),2.0E0**(5-NBITS)) if (ERR == 0.0E0) TOL = SQRT(R1MACH(4)) EPS = TOL HH(1) = (B-A)/12.0E0 AA(1) = A LR(1) = 1 DO 110 I = 1,11,2 F(I) = FUN(A+(I-1)*HH(1)) 110 CONTINUE BLOCAL = B F(13) = FUN(BLOCAL) K = 7 L = 1 AREA = 0.0E0 Q7 = 0.0E0 EF = 256.0E0/255.0E0 BANK = 0.0E0 ! ! Compute refined estimates, estimate the error, etc. ! 120 DO 130 I = 2,12,2 F(I) = FUN(AA(L)+(I-1)*HH(L)) 130 CONTINUE K = K + 6 ! ! Compute left and right half estimates ! Q7L = HH(L)*((W1*(F(1)+F(7))+W2*(F(2)+F(6)))+ & (W3*(F(3)+F(5))+W4*F(4))) Q7R(L) = HH(L)*((W1*(F(7)+F(13))+W2*(F(8)+F(12)))+ & (W3*(F(9)+F(11))+W4*F(10))) ! ! Update estimate of integral of absolute value ! AREA = AREA + (ABS(Q7L)+ABS(Q7R(L))-ABS(Q7)) ! ! Do not bother to test convergence before minimum refinement level ! if (L < LMN) go to 180 ! ! Estimate the error in new value for whole interval, Q13 ! Q13 = Q7L + Q7R(L) EE = ABS(Q7-Q13)*EF ! ! Compute nominal allowed error ! AE = EPS*AREA ! ! Borrow from bank account, but not too much ! TEST = MIN(AE+0.8E0*BANK,10.0E0*AE) ! ! Don't ask for excessive accuracy ! TEST = MAX(TEST,TOL*ABS(Q13),0.00003E0*TOL*AREA) ! ! Now, did this interval pass or not? ! if (EE-TEST) 150,150,170 ! ! Have hit maximum refinement level -- penalize the cumulative error ! 140 CE = CE + (Q7-Q13) go to 160 ! ! On good intervals accumulate the theoretical estimate ! 150 CE = CE + (Q7-Q13)/255.0 ! ! Update the bank account. Don't go into debt. ! 160 BANK = BANK + (AE-EE) if (BANK < 0.0E0) BANK = 0.0E0 ! ! Did we just finish a left half or a right half? ! if (LR(L)) 190,190,210 ! ! Consider the left half of next deeper level ! 170 if (K > KMX) LMX = MIN(KML,LMX) if (L >= LMX) go to 140 180 L = L + 1 EPS = EPS*0.5E0 if (L <= 17) EF = EF/SQ2 HH(L) = HH(L-1)*0.5E0 LR(L) = -1 AA(L) = AA(L-1) Q7 = Q7L F1(L) = F(7) F2(L) = F(8) F3(L) = F(9) F4(L) = F(10) F5(L) = F(11) F6(L) = F(12) F7(L) = F(13) F(13) = F(7) F(11) = F(6) F(9) = F(5) F(7) = F(4) F(5) = F(3) F(3) = F(2) go to 120 ! ! Proceed to right half at this level ! 190 VL(L) = Q13 200 Q7 = Q7R(L-1) LR(L) = 1 AA(L) = AA(L) + 12.0E0*HH(L) F(1) = F1(L) F(3) = F2(L) F(5) = F3(L) F(7) = F4(L) F(9) = F5(L) F(11) = F6(L) F(13) = F7(L) go to 120 ! ! Left and right halves are done, so go back up a level ! 210 VR = Q13 220 if (L <= 1) go to 250 if (L <= 17) EF = EF*SQ2 EPS = EPS*2.0E0 L = L - 1 if (LR(L)) 230,230,240 230 VL(L) = VL(L+1) + VR go to 200 240 VR = VL(L+1) + VR go to 220 ! ! Exit ! 250 ANS = VR if (ABS(CE) <= 2.0E0*TOL*AREA) go to 270 IERR = 2 call XERMSG ('SLATEC', 'QNC79', & 'ANS is probably insufficiently accurate.', 2, 1) go to 270 260 IERR = -1 call XERMSG ('SLATEC', 'QNC79', & 'A and B are too nearly equal to allow normal integration. $$' & // 'ANS is set to zero and IERR to -1.', -1, -1) 270 RETURN end subroutine QNG (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, NEVAL, & IER) ! !! QNG calculates an approximation RESULT to an integral ! I = integral of F over (A,B), ! hopefully satisfying following claim for accuracy ! ABS(I-RESULT) <= MAX(EPSABS,EPSREL*ABS(I)). ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2A1A1 !***TYPE SINGLE PRECISION (QNG-S, DQNG-D) !***KEYWORDS AUTOMATIC INTEGRATOR, GAUSS-KRONROD(PATTERSON) RULES, ! NONADAPTIVE, QUADPACK, QUADRATURE, SMOOTH INTEGRAND !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! NON-ADAPTIVE INTEGRATION ! STANDARD FORTRAN SUBROUTINE ! REAL VERSION ! ! F - Real version ! Function subprogram defining the integrand function ! F(X). The actual name for F needs to be declared ! E X T E R N A L in the driver program. ! ! A - Real version ! Lower limit of integration ! ! B - Real version ! Upper limit of integration ! ! EPSABS - Real ! Absolute accuracy requested ! EPSREL - Real ! Relative accuracy requested ! If EPSABS <= 0 ! And EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28), ! The routine will end with IER = 6. ! ! ON RETURN ! RESULT - Real ! Approximation to the integral I ! Result is obtained by applying the 21-POINT ! GAUSS-KRONROD RULE (RES21) obtained by optimal ! addition of abscissae to the 10-POINT GAUSS RULE ! (RES10), or by applying the 43-POINT RULE (RES43) ! obtained by optimal addition of abscissae to the ! 21-POINT GAUSS-KRONROD RULE, or by applying the ! 87-POINT RULE (RES87) obtained by optimal addition ! of abscissae to the 43-POINT RULE. ! ! ABSERR - Real ! Estimate of the modulus of the absolute error, ! which should EQUAL or EXCEED ABS(I-RESULT) ! ! NEVAL - Integer ! Number of integrand evaluations ! ! IER - IER = 0 normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! IER > 0 Abnormal termination of the routine. It is ! assumed that the requested accuracy has ! not been achieved. ! ERROR MESSAGES ! IER = 1 The maximum number of steps has been ! executed. The integral is probably too ! difficult to be calculated by DQNG. ! = 6 The input is invalid, because ! EPSABS <= 0 AND ! EPSREL < MAX(50*REL.MACH.ACC.,0.5D-28). ! RESULT, ABSERR and NEVAL are set to zero. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) !***END PROLOGUE QNG ! REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,EPSABS,EPSREL,F,FCENTR, & FVAL,FVAL1,FVAL2,FV1,FV2,FV3,FV4,HLGTH,RESULT,RES10,RES21,RES43, & RES87,RESABS,RESASC,RESKH,R1MACH,SAVFUN,UFLOW,W10,W21A,W43A, & W43B,W87A,W87B,X1,X2,X3,X4 INTEGER IER,IPX,K,L,NEVAL EXTERNAL F ! DIMENSION FV1(5),FV2(5),FV3(5),FV4(5),X1(5),X2(5),X3(11),X4(22), & W10(5),W21A(5),W21B(6),W43A(10),W43B(12),W87A(21),W87B(23), & SAVFUN(21) ! ! THE FOLLOWING DATA STATEMENTS CONTAIN THE ! ABSCISSAE AND WEIGHTS OF THE INTEGRATION RULES USED. ! ! X1 ABSCISSAE COMMON TO THE 10-, 21-, 43- ! AND 87-POINT RULE ! X2 ABSCISSAE COMMON TO THE 21-, 43- AND ! 87-POINT RULE ! X3 ABSCISSAE COMMON TO THE 43- AND 87-POINT ! RULE ! X4 ABSCISSAE OF THE 87-POINT RULE ! W10 WEIGHTS OF THE 10-POINT FORMULA ! W21A WEIGHTS OF THE 21-POINT FORMULA FOR ! ABSCISSAE X1 ! W21B WEIGHTS OF THE 21-POINT FORMULA FOR ! ABSCISSAE X2 ! W43A WEIGHTS OF THE 43-POINT FORMULA FOR ! ABSCISSAE X1, X3 ! W43B WEIGHTS OF THE 43-POINT FORMULA FOR ! ABSCISSAE X3 ! W87A WEIGHTS OF THE 87-POINT FORMULA FOR ! ABSCISSAE X1, X2, X3 ! W87B WEIGHTS OF THE 87-POINT FORMULA FOR ! ABSCISSAE X4 ! SAVE X1, X2, X3, X4, W10, W21A, W21B, W43A, W43B, W87A, W87B DATA X1(1),X1(2),X1(3),X1(4),X1(5)/ & 0.9739065285171717E+00, 0.8650633666889845E+00, & 0.6794095682990244E+00, 0.4333953941292472E+00, & 0.1488743389816312E+00/ DATA X2(1),X2(2),X2(3),X2(4),X2(5)/ & 0.9956571630258081E+00, 0.9301574913557082E+00, & 0.7808177265864169E+00, 0.5627571346686047E+00, & 0.2943928627014602E+00/ DATA X3(1),X3(2),X3(3),X3(4),X3(5),X3(6),X3(7),X3(8), & X3(9),X3(10),X3(11)/ & 0.9993333609019321E+00, 0.9874334029080889E+00, & 0.9548079348142663E+00, 0.9001486957483283E+00, & 0.8251983149831142E+00, 0.7321483889893050E+00, & 0.6228479705377252E+00, 0.4994795740710565E+00, & 0.3649016613465808E+00, 0.2222549197766013E+00, & 0.7465061746138332E-01/ DATA X4(1),X4(2),X4(3),X4(4),X4(5),X4(6),X4(7),X4(8),X4(9), & X4(10),X4(11),X4(12),X4(13),X4(14),X4(15),X4(16),X4(17),X4(18), & X4(19),X4(20),X4(21),X4(22)/ 0.9999029772627292E+00, & 0.9979898959866787E+00, 0.9921754978606872E+00, & 0.9813581635727128E+00, 0.9650576238583846E+00, & 0.9431676131336706E+00, 0.9158064146855072E+00, & 0.8832216577713165E+00, 0.8457107484624157E+00, & 0.8035576580352310E+00, 0.7570057306854956E+00, & 0.7062732097873218E+00, 0.6515894665011779E+00, & 0.5932233740579611E+00, 0.5314936059708319E+00, & 0.4667636230420228E+00, 0.3994248478592188E+00, & 0.3298748771061883E+00, 0.2585035592021616E+00, & 0.1856953965683467E+00, 0.1118422131799075E+00, & 0.3735212339461987E-01/ DATA W10(1),W10(2),W10(3),W10(4),W10(5)/ & 0.6667134430868814E-01, 0.1494513491505806E+00, & 0.2190863625159820E+00, 0.2692667193099964E+00, & 0.2955242247147529E+00/ DATA W21A(1),W21A(2),W21A(3),W21A(4),W21A(5)/ & 0.3255816230796473E-01, 0.7503967481091995E-01, & 0.1093871588022976E+00, 0.1347092173114733E+00, & 0.1477391049013385E+00/ DATA W21B(1),W21B(2),W21B(3),W21B(4),W21B(5),W21B(6)/ & 0.1169463886737187E-01, 0.5475589657435200E-01, & 0.9312545458369761E-01, 0.1234919762620659E+00, & 0.1427759385770601E+00, 0.1494455540029169E+00/ DATA W43A(1),W43A(2),W43A(3),W43A(4),W43A(5),W43A(6),W43A(7), & W43A(8),W43A(9),W43A(10)/ 0.1629673428966656E-01, & 0.3752287612086950E-01, 0.5469490205825544E-01, & 0.6735541460947809E-01, 0.7387019963239395E-01, & 0.5768556059769796E-02, 0.2737189059324884E-01, & 0.4656082691042883E-01, 0.6174499520144256E-01, & 0.7138726726869340E-01/ DATA W43B(1),W43B(2),W43B(3),W43B(4),W43B(5),W43B(6), & W43B(7),W43B(8),W43B(9),W43B(10),W43B(11),W43B(12)/ & 0.1844477640212414E-02, 0.1079868958589165E-01, & 0.2189536386779543E-01, 0.3259746397534569E-01, & 0.4216313793519181E-01, 0.5074193960018458E-01, & 0.5837939554261925E-01, 0.6474640495144589E-01, & 0.6956619791235648E-01, 0.7282444147183321E-01, & 0.7450775101417512E-01, 0.7472214751740301E-01/ DATA W87A(1),W87A(2),W87A(3),W87A(4),W87A(5),W87A(6), & W87A(7),W87A(8),W87A(9),W87A(10),W87A(11),W87A(12), & W87A(13),W87A(14),W87A(15),W87A(16),W87A(17),W87A(18), & W87A(19),W87A(20),W87A(21)/ & 0.8148377384149173E-02, 0.1876143820156282E-01, & 0.2734745105005229E-01, 0.3367770731163793E-01, & 0.3693509982042791E-01, 0.2884872430211531E-02, & 0.1368594602271270E-01, 0.2328041350288831E-01, & 0.3087249761171336E-01, 0.3569363363941877E-01, & 0.9152833452022414E-03, 0.5399280219300471E-02, & 0.1094767960111893E-01, 0.1629873169678734E-01, & 0.2108156888920384E-01, 0.2537096976925383E-01, & 0.2918969775647575E-01, 0.3237320246720279E-01, & 0.3478309895036514E-01, 0.3641222073135179E-01, & 0.3725387550304771E-01/ DATA W87B(1),W87B(2),W87B(3),W87B(4),W87B(5),W87B(6),W87B(7), & W87B(8),W87B(9),W87B(10),W87B(11),W87B(12),W87B(13),W87B(14), & W87B(15),W87B(16),W87B(17),W87B(18),W87B(19),W87B(20), & W87B(21),W87B(22),W87B(23)/ 0.2741455637620724E-03, & 0.1807124155057943E-02, 0.4096869282759165E-02, & 0.6758290051847379E-02, 0.9549957672201647E-02, & 0.1232944765224485E-01, 0.1501044734638895E-01, & 0.1754896798624319E-01, 0.1993803778644089E-01, & 0.2219493596101229E-01, 0.2433914712600081E-01, & 0.2637450541483921E-01, 0.2828691078877120E-01, & 0.3005258112809270E-01, 0.3164675137143993E-01, & 0.3305041341997850E-01, 0.3425509970422606E-01, & 0.3526241266015668E-01, 0.3607698962288870E-01, & 0.3669860449845609E-01, 0.3712054926983258E-01, & 0.3733422875193504E-01, 0.3736107376267902E-01/ ! ! LIST OF MAJOR VARIABLES ! ----------------------- ! ! CENTR - MID POINT OF THE INTEGRATION INTERVAL ! HLGTH - HALF-LENGTH OF THE INTEGRATION INTERVAL ! FCENTR - FUNCTION VALUE AT MID POINT ! ABSC - ABSCISSA ! FVAL - FUNCTION VALUE ! SAVFUN - ARRAY OF FUNCTION VALUES WHICH ! HAVE ALREADY BEEN COMPUTED ! RES10 - 10-POINT GAUSS RESULT ! RES21 - 21-POINT KRONROD RESULT ! RES43 - 43-POINT RESULT ! RES87 - 87-POINT RESULT ! RESABS - APPROXIMATION TO THE INTEGRAL OF ABS(F) ! RESASC - APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A)) ! ! MACHINE DEPENDENT CONSTANTS ! --------------------------- ! ! EPMACH IS THE LARGEST RELATIVE SPACING. ! UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. ! !***FIRST EXECUTABLE STATEMENT QNG EPMACH = R1MACH(4) UFLOW = R1MACH(1) ! ! TEST ON VALIDITY OF PARAMETERS ! ------------------------------ ! RESULT = 0.0E+00 ABSERR = 0.0E+00 NEVAL = 0 IER = 6 if ( EPSABS <= 0.0E+00.AND.EPSREL < MAX(0.5E-14,0.5E+02*EPMACH)) & go to 80 HLGTH = 0.5E+00*(B-A) DHLGTH = ABS(HLGTH) CENTR = 0.5E+00*(B+A) FCENTR = F(CENTR) NEVAL = 21 IER = 1 ! ! COMPUTE THE INTEGRAL USING THE 10- AND 21-POINT FORMULA. ! DO 70 L = 1,3 go to (5,25,45),L 5 RES10 = 0.0E+00 RES21 = W21B(6)*FCENTR RESABS = W21B(6)*ABS(FCENTR) DO 10 K=1,5 ABSC = HLGTH*X1(K) FVAL1 = F(CENTR+ABSC) FVAL2 = F(CENTR-ABSC) FVAL = FVAL1+FVAL2 RES10 = RES10+W10(K)*FVAL RES21 = RES21+W21A(K)*FVAL RESABS = RESABS+W21A(K)*(ABS(FVAL1)+ABS(FVAL2)) SAVFUN(K) = FVAL FV1(K) = FVAL1 FV2(K) = FVAL2 10 CONTINUE IPX = 5 DO 15 K=1,5 IPX = IPX+1 ABSC = HLGTH*X2(K) FVAL1 = F(CENTR+ABSC) FVAL2 = F(CENTR-ABSC) FVAL = FVAL1+FVAL2 RES21 = RES21+W21B(K)*FVAL RESABS = RESABS+W21B(K)*(ABS(FVAL1)+ABS(FVAL2)) SAVFUN(IPX) = FVAL FV3(K) = FVAL1 FV4(K) = FVAL2 15 CONTINUE ! ! TEST FOR CONVERGENCE. ! RESULT = RES21*HLGTH RESABS = RESABS*DHLGTH RESKH = 0.5E+00*RES21 RESASC = W21B(6)*ABS(FCENTR-RESKH) DO 20 K = 1,5 RESASC = RESASC+W21A(K)*(ABS(FV1(K)-RESKH)+ABS(FV2(K)-RESKH)) & +W21B(K)*(ABS(FV3(K)-RESKH)+ABS(FV4(K)-RESKH)) 20 CONTINUE ABSERR = ABS((RES21-RES10)*HLGTH) RESASC = RESASC*DHLGTH go to 65 ! ! COMPUTE THE INTEGRAL USING THE 43-POINT FORMULA. ! 25 RES43 = W43B(12)*FCENTR NEVAL = 43 DO 30 K=1,10 RES43 = RES43+SAVFUN(K)*W43A(K) 30 CONTINUE DO 40 K=1,11 IPX = IPX+1 ABSC = HLGTH*X3(K) FVAL = F(ABSC+CENTR)+F(CENTR-ABSC) RES43 = RES43+FVAL*W43B(K) SAVFUN(IPX) = FVAL 40 CONTINUE ! ! TEST FOR CONVERGENCE. ! RESULT = RES43*HLGTH ABSERR = ABS((RES43-RES21)*HLGTH) go to 65 ! ! COMPUTE THE INTEGRAL USING THE 87-POINT FORMULA. ! 45 RES87 = W87B(23)*FCENTR NEVAL = 87 DO 50 K=1,21 RES87 = RES87+SAVFUN(K)*W87A(K) 50 CONTINUE DO 60 K=1,22 ABSC = HLGTH*X4(K) RES87 = RES87+W87B(K)*(F(ABSC+CENTR)+F(CENTR-ABSC)) 60 CONTINUE RESULT = RES87*HLGTH ABSERR = ABS((RES87-RES43)*HLGTH) 65 if ( RESASC /= 0.0E+00.AND.ABSERR /= 0.0E+00) & ABSERR = RESASC*MIN(0.1E+01, & (0.2E+03*ABSERR/RESASC)**1.5E+00) if (RESABS > UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX & ((EPMACH*0.5E+02)*RESABS,ABSERR) if (ABSERR <= MAX(EPSABS,EPSREL*ABS(RESULT))) IER = 0 ! ***JUMP OUT OF DO-LOOP if (IER == 0) go to 999 70 CONTINUE 80 call XERMSG ('SLATEC', 'QNG', 'ABNORMAL RETURN', IER, 0) 999 RETURN end subroutine QPDOC ! !! QPDOC contains documentation for QUADPACK, ... ! a package of subprograms for ! automatic evaluation of one-dimensional definite integrals. ! !***LIBRARY SLATEC (QUADPACK) !***CATEGORY H2, Z !***TYPE ALL (QPDOC-A) !***KEYWORDS DOCUMENTATION, GUIDELINES FOR SELECTION, QUADPACK, ! QUADRATURE, SURVEY OF INTEGRATORS !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven ! Kahaner, D. K., (NBS) !***DESCRIPTION ! ! 1. Introduction ! ------------ ! QUADPACK is a FORTRAN subroutine package for the numerical ! computation of definite one-dimensional integrals. It originated ! from a joint project of R. Piessens and E. de Doncker (Appl. ! Math. and Progr. Div.- K.U.Leuven, Belgium), C. Ueberhuber (Inst. ! Fuer Math.- Techn. U. Wien, Austria), and D. Kahaner (National ! Bureau of Standards- Washington D.C., U.S.A.). ! ! Documentation routine QPDOC describes the package in the form it ! was released from A.M.P.D.- Leuven, for adherence to the SLATEC ! library in May 1981. Apart from a survey of the integrators, some ! guidelines will be given in order to help the QUADPACK user with ! selecting an appropriate routine or a combination of several ! routines for handling his problem. ! ! In the Long Description of QPDOC it is demonstrated how to call ! the integrators, by means of small example calling programs. ! ! For precise guidelines involving the use of each routine in ! particular, we refer to the extensive introductory comments ! within each routine. ! ! 2. Survey ! ------ ! The following list gives an overview of the QUADPACK integrators. ! The routine names for the DOUBLE PRECISION versions are preceded ! by the letter D. ! ! - QNG : Is a simple non-adaptive automatic integrator, based on ! a sequence of rules with increasing degree of algebraic ! precision (Patterson, 1968). ! ! - QAG : Is a simple globally adaptive integrator using the ! strategy of Aind (Piessens, 1973). It is possible to ! choose between 6 pairs of Gauss-Kronrod quadrature ! formulae for the rule evaluation component. The pairs ! of high degree of precision are suitable for handling ! integration difficulties due to a strongly oscillating ! integrand. ! ! - QAGS : Is an integrator based on globally adaptive interval ! subdivision in connection with extrapolation (de Doncker, ! 1978) by the Epsilon algorithm (Wynn, 1956). ! ! - QAGP : Serves the same purposes as QAGS, but also allows ! for eventual user-supplied information, i.e. the ! abscissae of internal singularities, discontinuities ! and other difficulties of the integrand function. ! The algorithm is a modification of that in QAGS. ! ! - QAGI : Handles integration over infinite intervals. The ! infinite range is mapped onto a finite interval and ! then the same strategy as in QAGS is applied. ! ! - QAWO : Is a routine for the integration of COS(OMEGA*X)*F(X) ! or SIN(OMEGA*X)*F(X) over a finite interval (A,B). ! OMEGA is is specified by the user ! The rule evaluation component is based on the ! modified Clenshaw-Curtis technique. ! An adaptive subdivision scheme is used connected with ! an extrapolation procedure, which is a modification ! of that in QAGS and provides the possibility to deal ! even with singularities in F. ! ! - QAWF : Calculates the Fourier cosine or Fourier sine ! transform of F(X), for user-supplied interval (A, ! INFINITY), OMEGA, and F. The procedure of QAWO is ! used on successive finite intervals, and convergence ! acceleration by means of the Epsilon algorithm (Wynn, ! 1956) is applied to the series of the integral ! contributions. ! ! - QAWS : Integrates W(X)*F(X) over (A,B) with A < B finite, ! and W(X) = ((X-A)**ALFA)*((B-X)**BETA)*V(X) ! where V(X) = 1 or LOG(X-A) or LOG(B-X) ! or LOG(X-A)*LOG(B-X) ! and ALFA > (-1), BETA > (-1). ! The user specifies A, B, ALFA, BETA and the type of ! the function V. ! A globally adaptive subdivision strategy is applied, ! with modified Clenshaw-Curtis integration on the ! subintervals which contain A or B. ! ! - QAWC : Computes the Cauchy Principal Value of F(X)/(X-C) ! over a finite interval (A,B) and for ! user-determined C. ! The strategy is globally adaptive, and modified ! Clenshaw-Curtis integration is used on the subranges ! which contain the point X = C. ! ! Each of the routines above also has a "more detailed" version ! with a name ending in E, as QAGE. These provide more ! information and control than the easier versions. ! ! ! The preceding routines are all automatic. That is, the user ! inputs his problem and an error tolerance. The routine ! attempts to perform the integration to within the requested ! absolute or relative error. ! There are, in addition, a number of non-automatic integrators. ! These are most useful when the problem is such that the ! user knows that a fixed rule will provide the accuracy ! required. Typically they return an error estimate but make ! no attempt to satisfy any particular input error request. ! ! QK15 ! QK21 ! QK31 ! QK41 ! QK51 ! QK61 ! Estimate the integral on [a,b] using 15, 21,..., 61 ! point rule and return an error estimate. ! QK15I 15 point rule for (semi)infinite interval. ! QK15W 15 point rule for special singular weight functions. ! QC25C 25 point rule for Cauchy Principal Values ! QC25F 25 point rule for sin/cos integrand. ! QMOMO Integrates k-th degree Chebyshev polynomial times ! function with various explicit singularities. ! ! 3. Guidelines for the use of QUADPACK ! ---------------------------------- ! Here it is not our purpose to investigate the question when ! automatic quadrature should be used. We shall rather attempt ! to help the user who already made the decision to use QUADPACK, ! with selecting an appropriate routine or a combination of ! several routines for handling his problem. ! ! For both quadrature over finite and over infinite intervals, ! one of the first questions to be answered by the user is ! related to the amount of computer time he wants to spend, ! versus his -own- time which would be needed, for example, for ! manual subdivision of the interval or other analytic ! manipulations. ! ! (1) The user may not care about computer time, or not be ! willing to do any analysis of the problem. especially when ! only one or a few integrals must be calculated, this attitude ! can be perfectly reasonable. In this case it is clear that ! either the most sophisticated of the routines for finite ! intervals, QAGS, must be used, or its analogue for infinite ! intervals, GAGI. These routines are able to cope with ! rather difficult, even with improper integrals. ! This way of proceeding may be expensive. But the integrator ! is supposed to give you an answer in return, with additional ! information in the case of a failure, through its error ! estimate and flag. Yet it must be stressed that the programs ! cannot be totally reliable. ! ------ ! ! (2) The user may want to examine the integrand function. ! If bad local difficulties occur, such as a discontinuity, a ! singularity, derivative singularity or high peak at one or ! more points within the interval, the first advice is to ! split up the interval at these points. The integrand must ! then be examined over each of the subintervals separately, ! so that a suitable integrator can be selected for each of ! them. If this yields problems involving relative accuracies ! to be imposed on -finite- subintervals, one can make use of ! QAGP, which must be provided with the positions of the local ! difficulties. However, if strong singularities are present ! and a high accuracy is requested, application of QAGS on the ! subintervals may yield a better result. ! ! For quadrature over finite intervals we thus dispose of QAGS ! and ! - QNG for well-behaved integrands, ! - QAG for functions with an oscillating behaviour of a non ! specific type, ! - QAWO for functions, eventually singular, containing a ! factor COS(OMEGA*X) or SIN(OMEGA*X) where OMEGA is known, ! - QAWS for integrands with Algebraico-Logarithmic end point ! singularities of known type, ! - QAWC for Cauchy Principal Values. ! ! Remark ! ------ ! On return, the work arrays in the argument lists of the ! adaptive integrators contain information about the interval ! subdivision process and hence about the integrand behaviour: ! the end points of the subintervals, the local integral ! contributions and error estimates, and eventually other ! characteristics. For this reason, and because of its simple ! globally adaptive nature, the routine QAG in particular is ! well-suited for integrand examination. Difficult spots can ! be located by investigating the error estimates on the ! subintervals. ! ! For infinite intervals we provide only one general-purpose ! routine, QAGI. It is based on the QAGS algorithm applied ! after a transformation of the original interval into (0,1). ! Yet it may eventuate that another type of transformation is ! more appropriate, or one might prefer to break up the ! original interval and use QAGI only on the infinite part ! and so on. These kinds of actions suggest a combined use of ! different QUADPACK integrators. Note that, when the only ! difficulty is an integrand singularity at the finite ! integration limit, it will in general not be necessary to ! break up the interval, as QAGI deals with several types of ! singularity at the boundary point of the integration range. ! It also handles slowly convergent improper integrals, on ! the condition that the integrand does not oscillate over ! the entire infinite interval. If it does we would advise ! to sum succeeding positive and negative contributions to ! the integral -e.g. integrate between the zeros- with one ! or more of the finite-range integrators, and apply ! convergence acceleration eventually by means of QUADPACK ! subroutine QELG which implements the Epsilon algorithm. ! Such quadrature problems include the Fourier transform as ! a special case. Yet for the latter we have an automatic ! integrator available, QAWF. ! ! *Long Description: ! ! 4. Example Programs ! ---------------- ! 4.1. Calling Program for QNG ! ----------------------- ! ! REAL A,ABSERR,B,F,EPSABS,EPSREL,RESULT ! INTEGER IER,NEVAL ! EXTERNAL F ! A = 0.0E0 ! B = 1.0E0 ! EPSABS = 0.0E0 ! EPSREL = 1.0E-3 ! call QNG(F,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER) ! C INCLUDE WRITE STATEMENTS ! STOP ! END ! C ! REAL FUNCTION F(X) ! REAL X ! F = EXP(X)/(X*X+0.1E+01) ! return ! END ! ! 4.2. Calling Program for QAG ! ----------------------- ! ! REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK ! INTEGER IER,IWORK,KEY,LAST,LENW,LIMIT,NEVAL ! DIMENSION IWORK(100),WORK(400) ! EXTERNAL F ! A = 0.0E0 ! B = 1.0E0 ! EPSABS = 0.0E0 ! EPSREL = 1.0E-3 ! KEY = 6 ! LIMIT = 100 ! LENW = LIMIT*4 ! call QAG(F,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL, ! * IER,LIMIT,LENW,LAST,IWORK,WORK) ! C INCLUDE WRITE STATEMENTS ! STOP ! END ! C ! REAL FUNCTION F(X) ! REAL X ! F = 2.0E0/(2.0E0+SIN(31.41592653589793E0*X)) ! return ! END ! ! 4.3. Calling Program for QAGS ! ------------------------ ! ! REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK ! INTEGER IER,IWORK,LAST,LENW,LIMIT,NEVAL ! DIMENSION IWORK(100),WORK(400) ! EXTERNAL F ! A = 0.0E0 ! B = 1.0E0 ! EPSABS = 0.0E0 ! EPSREL = 1.0E-3 ! LIMIT = 100 ! LENW = LIMIT*4 ! call QAGS(F,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, ! * LIMIT,LENW,LAST,IWORK,WORK) ! C INCLUDE WRITE STATEMENTS ! STOP ! END ! C ! REAL FUNCTION F(X) ! REAL X ! F = 0.0E0 ! if ( X > 0.0E0) F = 1.0E0/SQRT(X) ! return ! END ! ! 4.4. Calling Program for QAGP ! ------------------------ ! ! REAL A,ABSERR,B,EPSABS,EPSREL,F,POINTS,RESULT,WORK ! INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,NEVAL,NPTS2 ! DIMENSION IWORK(204),POINTS(4),WORK(404) ! EXTERNAL F ! A = 0.0E0 ! B = 1.0E0 ! NPTS2 = 4 ! POINTS(1) = 1.0E0/7.0E0 ! POINTS(2) = 2.0E0/3.0E0 ! LIMIT = 100 ! LENIW = LIMIT*2+NPTS2 ! LENW = LIMIT*4+NPTS2 ! call QAGP(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, ! * NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) ! C INCLUDE WRITE STATEMENTS ! STOP ! END ! C ! REAL FUNCTION F(X) ! REAL X ! F = 0.0E+00 ! if ( X /= 1.0E0/7.0E0.AND.X /= 2.0E0/3.0E0) F = ! * ABS(X-1.0E0/7.0E0)**(-0.25E0)* ! * ABS(X-2.0E0/3.0E0)**(-0.55E0) ! return ! END ! ! 4.5. Calling Program for QAGI ! ------------------------ ! ! REAL ABSERR,BOUN,EPSABS,EPSREL,F,RESULT,WORK ! INTEGER IER,INF,IWORK,LAST,LENW,LIMIT,NEVAL ! DIMENSION IWORK(100),WORK(400) ! EXTERNAL F ! BOUN = 0.0E0 ! INF = 1 ! EPSABS = 0.0E0 ! EPSREL = 1.0E-3 ! LIMIT = 100 ! LENW = LIMIT*4 ! call QAGI(F,BOUN,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, ! * IER,LIMIT,LENW,LAST,IWORK,WORK) ! C INCLUDE WRITE STATEMENTS ! STOP ! END ! C ! REAL FUNCTION F(X) ! REAL X ! F = 0.0E0 ! if ( X > 0.0E0) F = SQRT(X)*LOG(X)/ ! * ((X+1.0E0)*(X+2.0E0)) ! return ! END ! ! 4.6. Calling Program for QAWO ! ------------------------ ! ! REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,OMEGA,WORK ! INTEGER IER,INTEGR,IWORK,LAST,LENIW,LENW,LIMIT,MAXP1,NEVAL ! DIMENSION IWORK(200),WORK(925) ! EXTERNAL F ! A = 0.0E0 ! B = 1.0E0 ! OMEGA = 10.0E0 ! INTEGR = 1 ! EPSABS = 0.0E0 ! EPSREL = 1.0E-3 ! LIMIT = 100 ! LENIW = LIMIT*2 ! MAXP1 = 21 ! LENW = LIMIT*4+MAXP1*25 ! call QAWO(F,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, ! * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) ! C INCLUDE WRITE STATEMENTS ! STOP ! END ! C ! REAL FUNCTION F(X) ! REAL X ! F = 0.0E0 ! if ( X > 0.0E0) F = EXP(-X)*LOG(X) ! return ! END ! ! 4.7. Calling Program for QAWF ! ------------------------ ! ! REAL A,ABSERR,EPSABS,F,RESULT,OMEGA,WORK ! INTEGER IER,INTEGR,IWORK,LAST,LENIW,LENW,LIMIT,LIMLST, ! * LST,MAXP1,NEVAL ! DIMENSION IWORK(250),WORK(1025) ! EXTERNAL F ! A = 0.0E0 ! OMEGA = 8.0E0 ! INTEGR = 2 ! EPSABS = 1.0E-3 ! LIMLST = 50 ! LIMIT = 100 ! LENIW = LIMIT*2+LIMLST ! MAXP1 = 21 ! LENW = LENIW*2+MAXP1*25 ! call QAWF(F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, ! * IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) ! C INCLUDE WRITE STATEMENTS ! STOP ! END ! C ! REAL FUNCTION F(X) ! REAL X ! if ( X > 0.0E0) F = SIN(50.0E0*X)/(X*SQRT(X)) ! return ! END ! ! 4.8. Calling Program for QAWS ! ------------------------ ! ! REAL A,ABSERR,ALFA,B,BETA,EPSABS,EPSREL,F,RESULT,WORK ! INTEGER IER,INTEGR,IWORK,LAST,LENW,LIMIT,NEVAL ! DIMENSION IWORK(100),WORK(400) ! EXTERNAL F ! A = 0.0E0 ! B = 1.0E0 ! ALFA = -0.5E0 ! BETA = -0.5E0 ! INTEGR = 1 ! EPSABS = 0.0E0 ! EPSREL = 1.0E-3 ! LIMIT = 100 ! LENW = LIMIT*4 ! call QAWS(F,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT, ! * ABSERR,NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) ! C INCLUDE WRITE STATEMENTS ! STOP ! END ! C ! REAL FUNCTION F(X) ! REAL X ! F = SIN(10.0E0*X) ! return ! END ! ! 4.9. Calling Program for QAWC ! ------------------------ ! ! REAL A,ABSERR,B,C,EPSABS,EPSREL,F,RESULT,WORK ! INTEGER IER,IWORK,LAST,LENW,LIMIT,NEVAL ! DIMENSION IWORK(100),WORK(400) ! EXTERNAL F ! A = -1.0E0 ! B = 1.0E0 ! C = 0.5E0 ! EPSABS = 0.0E0 ! EPSREL = 1.0E-3 ! LIMIT = 100 ! LENW = LIMIT*4 ! call QAWC(F,A,B,C,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, ! * IER,LIMIT,LENW,LAST,IWORK,WORK) ! C INCLUDE WRITE STATEMENTS ! STOP ! END ! C ! REAL FUNCTION F(X) ! REAL X ! F = 1.0E0/(X*X+1.0E-4) ! return ! END ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900723 PURPOSE section revised. (WRB) !***END PROLOGUE QPDOC !***FIRST EXECUTABLE STATEMENT QPDOC return end subroutine QPSRT (LIMIT, LAST, MAXERR, ERMAX, ELIST, IORD, NRMAX) ! !! QPSRT is subsidiary to QAGE, QAGIE, QAGPE, QAGSE, QAWCE, QAWOE and QAWSE. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QPSRT-S, DQPSRT-D) !***KEYWORDS SEQUENTIAL SORTING !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! 1. QPSRT ! Ordering Routine ! Standard FORTRAN Subroutine ! REAL Version ! ! 2. PURPOSE ! This routine maintains the descending ordering ! in the list of the local error estimates resulting from ! the interval subdivision process. At each call two error ! estimates are inserted using the sequential search ! method, top-down for the largest error estimate ! and bottom-up for the smallest error estimate. ! ! 3. CALLING SEQUENCE ! call QPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX) ! ! PARAMETERS (MEANING AT OUTPUT) ! LIMIT - INTEGER ! Maximum number of error estimates the list ! can contain ! ! LAST - INTEGER ! Number of error estimates currently ! in the list ! ! MAXERR - INTEGER ! MAXERR points to the NRMAX-th largest error ! estimate currently in the list ! ! ERMAX - REAL ! NRMAX-th largest error estimate ! ERMAX = ELIST(MAXERR) ! ! ELIST - REAL ! Vector of dimension LAST containing ! the error estimates ! ! IORD - INTEGER ! Vector of dimension LAST, the first K ! elements of which contain pointers ! to the error estimates, such that ! ELIST(IORD(1)),... , ELIST(IORD(K)) ! form a decreasing sequence, with ! K = LAST if LAST <= (LIMIT/2+2), and ! K = LIMIT+1-LAST otherwise ! ! NRMAX - INTEGER ! MAXERR = IORD(NRMAX) ! !***SEE ALSO QAGE, QAGIE, QAGPE, QAGSE, QAWCE, QAWOE, QAWSE !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE QPSRT ! REAL ELIST,ERMAX,ERRMAX,ERRMIN INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR, & NRMAX DIMENSION ELIST(*),IORD(*) ! ! CHECK WHETHER THE LIST CONTAINS MORE THAN ! TWO ERROR ESTIMATES. ! !***FIRST EXECUTABLE STATEMENT QPSRT if ( LAST > 2) go to 10 IORD(1) = 1 IORD(2) = 2 go to 90 ! ! THIS PART OF THE ROUTINE IS ONLY EXECUTED ! IF, DUE TO A DIFFICULT INTEGRAND, SUBDIVISION ! INCREASED THE ERROR ESTIMATE. IN THE NORMAL CASE ! THE INSERT PROCEDURE SHOULD START AFTER THE ! NRMAX-TH LARGEST ERROR ESTIMATE. ! 10 ERRMAX = ELIST(MAXERR) if ( NRMAX == 1) go to 30 IDO = NRMAX-1 DO 20 I = 1,IDO ISUCC = IORD(NRMAX-1) ! ***JUMP OUT OF DO-LOOP if ( ERRMAX <= ELIST(ISUCC)) go to 30 IORD(NRMAX) = ISUCC NRMAX = NRMAX-1 20 CONTINUE ! ! COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO ! BE MAINTAINED IN DESCENDING ORDER. THIS NUMBER ! DEPENDS ON THE NUMBER OF SUBDIVISIONS STILL ! ALLOWED. ! 30 JUPBN = LAST if ( LAST > (LIMIT/2+2)) JUPBN = LIMIT+3-LAST ERRMIN = ELIST(LAST) ! ! INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN, ! STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)). ! JBND = JUPBN-1 IBEG = NRMAX+1 if ( IBEG > JBND) go to 50 DO 40 I=IBEG,JBND ISUCC = IORD(I) ! ***JUMP OUT OF DO-LOOP if ( ERRMAX >= ELIST(ISUCC)) go to 60 IORD(I-1) = ISUCC 40 CONTINUE 50 IORD(JBND) = MAXERR IORD(JUPBN) = LAST go to 90 ! ! INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP. ! 60 IORD(I-1) = MAXERR K = JBND DO 70 J=I,JBND ISUCC = IORD(K) ! ***JUMP OUT OF DO-LOOP if ( ERRMIN < 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 ! ! SET MAXERR AND ERMAX. ! 90 MAXERR = IORD(NRMAX) ERMAX = ELIST(MAXERR) return end subroutine QRFAC (M, N, A, LDA, PIVOT, IPVT, LIPVT, SIGMA, ACNORM, & WA) ! !! QRFAC computes the QR factorization of an M by N matrix. ! !***SUBSIDIARY !***PURPOSE Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QRFAC-S, DQRFAC-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine uses Householder transformations with column ! pivoting (optional) to compute a QR factorization of the ! M by N matrix A. That is, QRFAC determines an orthogonal ! matrix Q, a permutation matrix P, and an upper trapezoidal ! matrix R with diagonal elements of nonincreasing magnitude, ! such that A*P = Q*R. The Householder transformation for ! column K, K = 1,2,...,MIN(M,N), is of the form ! ! T ! I - (1/U(K))*U*U ! ! where U has zeros in the first K-1 positions. The form of ! this transformation and the method of pivoting first ! appeared in the corresponding LINPACK subroutine. ! ! The subroutine statement is ! ! SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,SIGMA,ACNORM,WA) ! ! where ! ! M is a positive integer input variable set to the number ! of rows of A. ! ! N is a positive integer input variable set to the number ! of columns of A. ! ! A is an M by N array. On input A contains the matrix for ! which the QR factorization is to be computed. On output ! the strict upper trapezoidal part of A contains the strict ! upper trapezoidal part of R, and the lower trapezoidal ! part of A contains a factored form of Q (the non-trivial ! elements of the U vectors described above). ! ! LDA is a positive integer input variable not less than M ! which specifies the leading dimension of the array A. ! ! PIVOT is a logical input variable. If pivot is set .TRUE., ! then column pivoting is enforced. If pivot is set .FALSE., ! then no column pivoting is done. ! ! IPVT is an integer output array of length LIPVT. IPVT ! defines the permutation matrix P such that A*P = Q*R. ! Column J of P is column IPVT(J) of the identity matrix. ! If pivot is .FALSE., IPVT is not referenced. ! ! LIPVT is a positive integer input variable. If PIVOT is ! .FALSE., then LIPVT may be as small as 1. If PIVOT is ! .TRUE., then LIPVT must be at least N. ! ! SIGMA is an output array of length N which contains the ! diagonal elements of R. ! ! ACNORM is an output array of length N which contains the ! norms of the corresponding columns of the input matrix A. ! If this information is not needed, then ACNORM can coincide ! with SIGMA. ! ! WA is a work array of length N. If pivot is .FALSE., then WA ! can coincide with SIGMA. ! !***SEE ALSO SNLS1, SNLS1E, SNSQ, SNSQE !***ROUTINES CALLED ENORM, R1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE QRFAC INTEGER M,N,LDA,LIPVT INTEGER IPVT(*) LOGICAL PIVOT REAL A(LDA,*),SIGMA(*),ACNORM(*),WA(*) INTEGER I,J,JP1,K,KMAX,MINMN REAL AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO REAL R1MACH,ENORM SAVE ONE, P05, ZERO DATA ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/ !***FIRST EXECUTABLE STATEMENT QRFAC EPSMCH = R1MACH(4) ! ! COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. ! DO 10 J = 1, N ACNORM(J) = ENORM(M,A(1,J)) SIGMA(J) = ACNORM(J) WA(J) = SIGMA(J) if (PIVOT) IPVT(J) = J 10 CONTINUE ! ! REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. ! MINMN = MIN(M,N) DO 110 J = 1, MINMN if (.NOT.PIVOT) go to 40 ! ! BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. ! KMAX = J DO 20 K = J, N if (SIGMA(K) > SIGMA(KMAX)) KMAX = K 20 CONTINUE if (KMAX == 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 SIGMA(KMAX) = SIGMA(J) WA(KMAX) = WA(J) K = IPVT(J) IPVT(J) = IPVT(KMAX) IPVT(KMAX) = K 40 CONTINUE ! ! COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE ! J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. ! AJNORM = ENORM(M-J+1,A(J,J)) if (AJNORM == ZERO) go to 100 if (A(J,J) < ZERO) AJNORM = -AJNORM DO 50 I = J, M A(I,J) = A(I,J)/AJNORM 50 CONTINUE A(J,J) = A(J,J) + ONE ! ! APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS ! AND UPDATE THE NORMS. ! JP1 = J + 1 if (N < 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. SIGMA(K) == ZERO) go to 80 TEMP = A(J,K)/SIGMA(K) SIGMA(K) = SIGMA(K)*SQRT(MAX(ZERO,ONE-TEMP**2)) if (P05*(SIGMA(K)/WA(K))**2 > EPSMCH) go to 80 SIGMA(K) = ENORM(M-J,A(JP1,K)) WA(K) = SIGMA(K) 80 CONTINUE 90 CONTINUE 100 CONTINUE SIGMA(J) = -AJNORM 110 CONTINUE return ! ! LAST CARD OF SUBROUTINE QRFAC. ! end subroutine QRSOLV (N, R, LDR, IPVT, DIAG, QTB, X, SIGMA, WA) ! !! QRSOLV solves a linear system in the least squares sense. ! !***SUBSIDIARY !***PURPOSE Subsidiary to SNLS1 and SNLS1E !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QRSOLV-S, DQRSLV-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an M by N matrix A, an N by N diagonal matrix D, ! and an M-vector B, the problem is to determine an X which ! solves the system ! ! A*X = B , D*X = 0 , ! ! in the least squares sense. ! ! This subroutine completes the solution of the problem ! if it is provided with the necessary information from the ! QR factorization, with column pivoting, of A. That is, if ! A*P = Q*R, where P is a permutation matrix, Q has orthogonal ! columns, and R is an upper triangular matrix with diagonal ! elements of nonincreasing magnitude, then QRSOLV expects ! the full upper triangle of R, the permutation matrix P, ! and the first N components of (Q TRANSPOSE)*B. The system ! A*X = B, D*X = 0, is then equivalent to ! ! T T ! R*Z = Q *B , P *D*P*Z = 0 , ! ! where X = P*Z. If this system does not have full rank, ! then a least squares solution is obtained. On output QRSOLV ! also provides an upper triangular matrix S such that ! ! T T T ! P *(A *A + D*D)*P = S *S . ! ! S is computed within QRSOLV and may be of separate interest. ! ! The subroutine statement is ! ! SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SIGMA,WA) ! ! where ! ! N is a positive integer input variable set to the order of R. ! ! R is an N by N array. On input the full upper triangle ! must contain the full upper triangle of the matrix R. ! On output the full upper triangle is unaltered, and the ! strict lower triangle contains the strict upper triangle ! (transposed) of the upper triangular matrix S. ! ! LDR is a positive integer input variable not less than N ! which specifies the leading dimension of the array R. ! ! IPVT is an integer input array of length N which defines the ! permutation matrix P such that A*P = Q*R. Column J of P ! is column IPVT(J) of the identity matrix. ! ! DIAG is an input array of length N which must contain the ! diagonal elements of the matrix D. ! ! QTB is an input array of length N which must contain the first ! N elements of the vector (Q TRANSPOSE)*B. ! ! X is an output array of length N which contains the least ! squares solution of the system A*X = B, D*X = 0. ! ! SIGMA is an output array of length N which contains the ! diagonal elements of the upper triangular matrix S. ! ! WA is a work array of length N. ! !***SEE ALSO SNLS1, SNLS1E !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE QRSOLV INTEGER N,LDR INTEGER IPVT(*) REAL R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA(*) INTEGER I,J,JP1,K,KP1,L,NSING REAL COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO SAVE P5, P25, ZERO DATA P5,P25,ZERO /5.0E-1,2.5E-1,0.0E0/ !***FIRST EXECUTABLE STATEMENT QRSOLV 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 ! ! ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. ! DO 100 J = 1, N ! ! PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE ! DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. ! L = IPVT(J) if (DIAG(L) == ZERO) go to 90 DO 30 K = J, N SIGMA(K) = ZERO 30 CONTINUE SIGMA(J) = DIAG(L) ! ! THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D ! MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B ! BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. ! QTBPJ = ZERO DO 80 K = J, N ! ! DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE ! APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. ! if (SIGMA(K) == ZERO) go to 70 if (ABS(R(K,K)) >= ABS(SIGMA(K))) go to 40 COTAN = R(K,K)/SIGMA(K) SIN = P5/SQRT(P25+P25*COTAN**2) COS = SIN*COTAN go to 50 40 CONTINUE TAN = SIGMA(K)/R(K,K) COS = P5/SQRT(P25+P25*TAN**2) SIN = COS*TAN 50 CONTINUE ! ! COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND ! THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). ! R(K,K) = COS*R(K,K) + SIN*SIGMA(K) TEMP = COS*WA(K) + SIN*QTBPJ QTBPJ = -SIN*WA(K) + COS*QTBPJ WA(K) = TEMP ! ! ACCUMULATE THE TRANSFORMATION IN THE ROW OF S. ! KP1 = K + 1 if (N < KP1) go to 70 DO 60 I = KP1, N TEMP = COS*R(I,K) + SIN*SIGMA(I) SIGMA(I) = -SIN*R(I,K) + COS*SIGMA(I) R(I,K) = TEMP 60 CONTINUE 70 CONTINUE 80 CONTINUE 90 CONTINUE ! ! STORE THE DIAGONAL ELEMENT OF S AND RESTORE ! THE CORRESPONDING DIAGONAL ELEMENT OF R. ! SIGMA(J) = R(J,J) R(J,J) = X(J) 100 CONTINUE ! ! SOLVE THE TRIANGULAR SYSTEM FOR Z. if THE SYSTEM IS ! SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. ! NSING = N DO 110 J = 1, N if (SIGMA(J) == ZERO .AND. NSING == N) NSING = J - 1 if (NSING < N) WA(J) = ZERO 110 CONTINUE if (NSING < 1) go to 150 DO 140 K = 1, NSING J = NSING - K + 1 SUM = ZERO JP1 = J + 1 if (NSING < 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)/SIGMA(J) 140 CONTINUE 150 CONTINUE ! ! PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. ! DO 160 J = 1, N L = IPVT(J) X(L) = WA(J) 160 CONTINUE return ! ! LAST CARD OF SUBROUTINE QRSOLV. ! end subroutine QS2I1D (IA, JA, A, N, KFLAG) ! !! QS2I1D sorts an integer array, and adjusts two companion arrays. ! !***SUBSIDIARY !***PURPOSE Sort an integer array, moving an integer and DP array. ! This routine sorts the integer array IA and makes the same ! interchanges in the integer array JA and the double pre- ! cision array A. The array IA may be sorted in increasing ! order or decreasing order. A slightly modified QUICKSORT ! algorithm is used. !***LIBRARY SLATEC (SLAP) !***CATEGORY N6A2A !***TYPE DOUBLE PRECISION (QS2I1R-S, QS2I1D-D) !***KEYWORDS SINGLETON QUICKSORT, SLAP, SORT, SORTING !***AUTHOR Jones, R. E., (SNLA) ! Kahaner, D. K., (NBS) ! Seager, M. K., (LLNL) seager@llnl.gov ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! Written by Rondall E Jones ! Modified by John A. Wisniewski to use the Singleton QUICKSORT ! algorithm. date 18 November 1976. ! ! Further modified by David K. Kahaner ! National Bureau of Standards ! August, 1981 ! ! Even further modification made to bring the code up to the ! Fortran 77 level and make it more readable and to carry ! along one integer array and one double precision array during ! the sort by ! Mark K. Seager ! Lawrence Livermore National Laboratory ! November, 1987 ! This routine was adapted from the ISORT routine. ! ! ABSTRACT ! This routine sorts an integer array IA and makes the same ! interchanges in the integer array JA and the double precision ! array A. ! The array IA may be sorted in increasing order or decreasing ! order. A slightly modified quicksort algorithm is used. ! ! DESCRIPTION OF PARAMETERS ! IA - Integer array of values to be sorted. ! JA - Integer array to be carried along. ! A - Double Precision array to be carried along. ! N - Number of values in integer array IA to be sorted. ! KFLAG - Control parameter ! = 1 means sort IA in INCREASING order. ! =-1 means sort IA in DECREASING order. ! !***SEE ALSO DS2Y !***REFERENCES R. C. Singleton, Algorithm 347, An Efficient Algorithm ! for Sorting With Minimal Storage, Communications ACM ! 12:3 (1969), pp.185-7. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 761118 DATE WRITTEN ! 890125 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 900805 Changed XERROR calls to calls to XERMSG. (RWC) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Made subsidiary to DS2Y and corrected reference. (FNF) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 921012 Corrected all f.p. constants to double precision. (FNF) !***END PROLOGUE QS2I1D !VD$R NOVECTOR !VD$R NOCONCUR ! .. Scalar Arguments .. INTEGER KFLAG, N ! .. Array Arguments .. DOUBLE PRECISION A(N) INTEGER IA(N), JA(N) ! .. Local Scalars .. DOUBLE PRECISION R, TA, TTA INTEGER I, IIT, IJ, IT, J, JJT, JT, K, KK, L, M, NN ! .. Local Arrays .. INTEGER IL(21), IU(21) ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, INT !***FIRST EXECUTABLE STATEMENT QS2I1D NN = N if (NN < 1) THEN call XERMSG ('SLATEC', 'QS2I1D', & 'The number of values to be sorted was not positive.', 1, 1) return end if if ( N == 1 ) RETURN KK = ABS(KFLAG) if ( KK /= 1 ) THEN call XERMSG ('SLATEC', 'QS2I1D', & 'The sort control parameter, K, was not 1 or -1.', 2, 1) return end if ! ! Alter array IA to get decreasing order if needed. ! if ( KFLAG < 1 ) THEN DO 20 I=1,NN IA(I) = -IA(I) 20 CONTINUE end if ! ! Sort IA and carry JA and A along. ! And now...Just a little black magic... M = 1 I = 1 J = NN R = .375D0 210 if ( R <= 0.5898437D0 ) THEN R = R + 3.90625D-2 ELSE R = R-.21875D0 end if 225 K = I ! ! Select a central element of the array and save it in location ! it, jt, at. ! IJ = I + INT ((J-I)*R) IT = IA(IJ) JT = JA(IJ) TA = A(IJ) ! ! If first element of array is greater than it, interchange with it. ! if ( IA(I) > IT ) THEN IA(IJ) = IA(I) IA(I) = IT IT = IA(IJ) JA(IJ) = JA(I) JA(I) = JT JT = JA(IJ) A(IJ) = A(I) A(I) = TA TA = A(IJ) end if L=J ! ! If last element of array is less than it, swap with it. ! if ( IA(J) < IT ) THEN IA(IJ) = IA(J) IA(J) = IT IT = IA(IJ) JA(IJ) = JA(J) JA(J) = JT JT = JA(IJ) A(IJ) = A(J) A(J) = TA TA = A(IJ) ! ! If first element of array is greater than it, swap with it. ! if ( IA(I) > IT ) THEN IA(IJ) = IA(I) IA(I) = IT IT = IA(IJ) JA(IJ) = JA(I) JA(I) = JT JT = JA(IJ) A(IJ) = A(I) A(I) = TA TA = A(IJ) ENDIF end if ! ! Find an element in the second half of the array which is ! smaller than it. ! 240 L=L-1 if ( IA(L) > IT ) go to 240 ! ! Find an element in the first half of the array which is ! greater than it. ! 245 K=K+1 if ( IA(K) < IT ) go to 245 ! ! Interchange these elements. ! if ( K <= L ) THEN IIT = IA(L) IA(L) = IA(K) IA(K) = IIT JJT = JA(L) JA(L) = JA(K) JA(K) = JJT TTA = A(L) A(L) = A(K) A(K) = TTA GOTO 240 end if ! ! Save upper and lower subscripts of the array yet to be sorted. ! if ( L-I > J-K ) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 260 ! ! Begin again on another portion of the unsorted array. ! 255 M = M-1 if ( M == 0 ) go to 300 I = IL(M) J = IU(M) 260 if ( J-I >= 1 ) go to 225 if ( I == J ) go to 255 if ( I == 1 ) go to 210 I = I-1 265 I = I+1 if ( I == J ) go to 255 IT = IA(I+1) JT = JA(I+1) TA = A(I+1) if ( IA(I) <= IT ) go to 265 K=I 270 IA(K+1) = IA(K) JA(K+1) = JA(K) A(K+1) = A(K) K = K-1 if ( IT < IA(K) ) go to 270 IA(K+1) = IT JA(K+1) = JT A(K+1) = TA go to 265 ! ! Clean up, if necessary. ! 300 if ( KFLAG < 1 ) THEN DO 310 I=1,NN IA(I) = -IA(I) 310 CONTINUE end if return !------------- LAST LINE OF QS2I1D FOLLOWS ---------------------------- end subroutine QS2I1R (IA, JA, A, N, KFLAG) ! !! QS2I1R sorts an integer array, and adjusts two companion arrays. ! !***SUBSIDIARY !***PURPOSE Sort an integer array, moving an integer and real array. ! This routine sorts the integer array IA and makes the same ! interchanges in the integer array JA and the real array A. ! The array IA may be sorted in increasing order or decreas- ! ing order. A slightly modified QUICKSORT algorithm is ! used. !***LIBRARY SLATEC (SLAP) !***CATEGORY N6A2A !***TYPE SINGLE PRECISION (QS2I1R-S, QS2I1D-D) !***KEYWORDS SINGLETON QUICKSORT, SLAP, SORT, SORTING !***AUTHOR Jones, R. E., (SNLA) ! Kahaner, D. K., (NBS) ! Seager, M. K., (LLNL) seager@llnl.gov ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! Written by Rondall E Jones ! Modified by John A. Wisniewski to use the Singleton QUICKSORT ! algorithm. date 18 November 1976. ! ! Further modified by David K. Kahaner ! National Bureau of Standards ! August, 1981 ! ! Even further modification made to bring the code up to the ! Fortran 77 level and make it more readable and to carry ! along one integer array and one real array during the sort by ! Mark K. Seager ! Lawrence Livermore National Laboratory ! November, 1987 ! This routine was adapted from the ISORT routine. ! ! ABSTRACT ! This routine sorts an integer array IA and makes the same ! interchanges in the integer array JA and the real array A. ! The array IA may be sorted in increasing order or decreasing ! order. A slightly modified quicksort algorithm is used. ! ! DESCRIPTION OF PARAMETERS ! IA - Integer array of values to be sorted. ! JA - Integer array to be carried along. ! A - Real array to be carried along. ! N - Number of values in integer array IA to be sorted. ! KFLAG - Control parameter ! = 1 means sort IA in INCREASING order. ! =-1 means sort IA in DECREASING order. ! !***SEE ALSO SS2Y !***REFERENCES R. C. Singleton, Algorithm 347, An Efficient Algorithm ! for Sorting With Minimal Storage, Communications ACM ! 12:3 (1969), pp.185-7. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 761118 DATE WRITTEN ! 890125 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 900805 Changed XERROR calls to calls to XERMSG. (RWC) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Made subsidiary to SS2Y and corrected reference. (FNF) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 921012 Added E0's to f.p. constants. (FNF) !***END PROLOGUE QS2I1R !VD$R NOVECTOR !VD$R NOCONCUR ! .. Scalar Arguments .. INTEGER KFLAG, N ! .. Array Arguments .. REAL A(N) INTEGER IA(N), JA(N) ! .. Local Scalars .. REAL R, TA, TTA INTEGER I, IIT, IJ, IT, J, JJT, JT, K, KK, L, M, NN ! .. Local Arrays .. INTEGER IL(21), IU(21) ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, INT !***FIRST EXECUTABLE STATEMENT QS2I1R NN = N if (NN < 1) THEN call XERMSG ('SLATEC', 'QS2I1R', & 'The number of values to be sorted was not positive.', 1, 1) return end if if ( N == 1 ) RETURN KK = ABS(KFLAG) if ( KK /= 1 ) THEN call XERMSG ('SLATEC', 'QS2I1R', & 'The sort control parameter, K, was not 1 or -1.', 2, 1) return end if ! ! Alter array IA to get decreasing order if needed. ! if ( KFLAG < 1 ) THEN DO 20 I=1,NN IA(I) = -IA(I) 20 CONTINUE end if ! ! Sort IA and carry JA and A along. ! And now...Just a little black magic... M = 1 I = 1 J = NN R = .375E0 210 if ( R <= 0.5898437E0 ) THEN R = R + 3.90625E-2 ELSE R = R-.21875E0 end if 225 K = I ! ! Select a central element of the array and save it in location ! it, jt, at. ! IJ = I + INT ((J-I)*R) IT = IA(IJ) JT = JA(IJ) TA = A(IJ) ! ! If first element of array is greater than it, interchange with it. ! if ( IA(I) > IT ) THEN IA(IJ) = IA(I) IA(I) = IT IT = IA(IJ) JA(IJ) = JA(I) JA(I) = JT JT = JA(IJ) A(IJ) = A(I) A(I) = TA TA = A(IJ) end if L=J ! ! If last element of array is less than it, swap with it. ! if ( IA(J) < IT ) THEN IA(IJ) = IA(J) IA(J) = IT IT = IA(IJ) JA(IJ) = JA(J) JA(J) = JT JT = JA(IJ) A(IJ) = A(J) A(J) = TA TA = A(IJ) ! ! If first element of array is greater than it, swap with it. ! if ( IA(I) > IT ) THEN IA(IJ) = IA(I) IA(I) = IT IT = IA(IJ) JA(IJ) = JA(I) JA(I) = JT JT = JA(IJ) A(IJ) = A(I) A(I) = TA TA = A(IJ) ENDIF end if ! ! Find an element in the second half of the array which is ! smaller than it. ! 240 L=L-1 if ( IA(L) > IT ) go to 240 ! ! Find an element in the first half of the array which is ! greater than it. ! 245 K=K+1 if ( IA(K) < IT ) go to 245 ! ! Interchange these elements. ! if ( K <= L ) THEN IIT = IA(L) IA(L) = IA(K) IA(K) = IIT JJT = JA(L) JA(L) = JA(K) JA(K) = JJT TTA = A(L) A(L) = A(K) A(K) = TTA GOTO 240 end if ! ! Save upper and lower subscripts of the array yet to be sorted. ! if ( L-I > J-K ) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 260 ! ! Begin again on another portion of the unsorted array. ! 255 M = M-1 if ( M == 0 ) go to 300 I = IL(M) J = IU(M) 260 if ( J-I >= 1 ) go to 225 if ( I == J ) go to 255 if ( I == 1 ) go to 210 I = I-1 265 I = I+1 if ( I == J ) go to 255 IT = IA(I+1) JT = JA(I+1) TA = A(I+1) if ( IA(I) <= IT ) go to 265 K=I 270 IA(K+1) = IA(K) JA(K+1) = JA(K) A(K+1) = A(K) K = K-1 if ( IT < IA(K) ) go to 270 IA(K+1) = IT JA(K+1) = JT A(K+1) = TA go to 265 ! ! Clean up, if necessary. ! 300 if ( KFLAG < 1 ) THEN DO 310 I=1,NN IA(I) = -IA(I) 310 CONTINUE end if return end FUNCTION QWGTC (X, C, P2, P3, P4, KP) ! !! QWGTC defines the WEIGHT function for QAWC. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QWGTC-S, DQWGTC-D) !***KEYWORDS CAUCHY PRINCIPAL VALUE, WEIGHT FUNCTION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***SEE ALSO QK15W !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 830518 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE QWGTC ! REAL QWGTC REAL C,P2,P3,P4,X INTEGER KP !***FIRST EXECUTABLE STATEMENT QWGTC QWGTC = 0.1E+01/(X-C) return end FUNCTION QWGTF (X, OMEGA, P2, P3, P4, INTEGR) ! !! QWGTF defines the weight function for QAWF. ! !***SUBSIDIARY !***PURPOSE This function subprogram is used together with the ! routine QAWF and defines the WEIGHT function. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QWGTF-S, DQWGTF-D) !***KEYWORDS COS OR SIN IN WEIGHT FUNCTION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***SEE ALSO QK15W !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 830518 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE QWGTF ! REAL QWGTF REAL OMEGA,OMX,P2,P3,P4,X INTEGER INTEGR !***FIRST EXECUTABLE STATEMENT QWGTF OMX = OMEGA*X go to(10,20),INTEGR 10 QWGTF = COS(OMX) go to 30 20 QWGTF = SIN(OMX) 30 RETURN end FUNCTION QWGTS (X, A, B, ALFA, BETA, INTEGR) ! !! QWGTS defines the weight function for QAWS. ! !***SUBSIDIARY !***PURPOSE This function subprogram is used together with the ! routine QAWS and defines the WEIGHT function. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QWGTS-S, DQWGTS-D) !***KEYWORDS ALGEBRAICO-LOGARITHMIC, END POINT SINGULARITIES, ! WEIGHT FUNCTION !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***SEE ALSO QK15W !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE QWGTS ! REAL QWGTS REAL A,ALFA,B,BETA,BMX,X,XMA INTEGER INTEGR !***FIRST EXECUTABLE STATEMENT QWGTS XMA = X-A BMX = B-X QWGTS = XMA**ALFA*BMX**BETA go to (40,10,20,30),INTEGR 10 QWGTS = QWGTS*LOG(XMA) go to 40 20 QWGTS = QWGTS*LOG(BMX) go to 40 30 QWGTS = QWGTS*LOG(XMA)*LOG(BMX) 40 RETURN end subroutine QZHES (NM, N, A, B, MATZ, Z) ! !! QZHES is the first step of the QZ algorithm for generalized eigenproblems. ! Accepts a pair of real general ! matrices and reduces one of them to upper Hessenberg ! and the other to upper triangular form using orthogonal ! transformations. Usually followed by QZIT, QZVAL, QZVEC. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B3 !***TYPE SINGLE PRECISION (QZHES-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is the first step of the QZ algorithm ! for solving generalized matrix eigenvalue problems, ! SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART. ! ! This subroutine accepts a pair of REAL GENERAL matrices and ! reduces one of them to upper Hessenberg form and the other ! to upper triangular form using orthogonal transformations. ! It is usually followed by QZIT, QZVAL and, possibly, QZVEC. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A, B, and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrices A and B. N is an INTEGER ! variable. N must be less than or equal to NM. ! ! A contains a real general matrix. A is a two-dimensional ! REAL array, dimensioned A(NM,N). ! ! B contains a real general matrix. B is a two-dimensional ! REAL array, dimensioned B(NM,N). ! ! MATZ should be set to .TRUE. if the right hand transformations ! are to be accumulated for later use in computing ! eigenvectors, and to .FALSE. otherwise. MATZ is a LOGICAL ! variable. ! ! On Output ! ! A has been reduced to upper Hessenberg form. The elements ! below the first subdiagonal have been set to zero. ! ! B has been reduced to upper triangular form. The elements ! below the main diagonal have been set to zero. ! ! Z contains the product of the right hand transformations if ! MATZ has been set to .TRUE. Otherwise, Z is not referenced. ! Z is a two-dimensional REAL array, dimensioned Z(NM,N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE QZHES ! INTEGER I,J,K,L,N,LB,L1,NM,NK1,NM1,NM2 REAL A(NM,*),B(NM,*),Z(NM,*) REAL R,S,T,U1,U2,V1,V2,RHO LOGICAL MATZ ! ! .......... INITIALIZE Z .......... !***FIRST EXECUTABLE STATEMENT QZHES if (.NOT. MATZ) go to 10 ! DO 3 I = 1, N ! DO 2 J = 1, N Z(I,J) = 0.0E0 2 CONTINUE ! Z(I,I) = 1.0E0 3 CONTINUE ! .......... REDUCE B TO UPPER TRIANGULAR FORM .......... 10 if (N <= 1) go to 170 NM1 = N - 1 ! DO 100 L = 1, NM1 L1 = L + 1 S = 0.0E0 ! DO 20 I = L1, N S = S + ABS(B(I,L)) 20 CONTINUE ! if (S == 0.0E0) go to 100 S = S + ABS(B(L,L)) R = 0.0E0 ! DO 25 I = L, N B(I,L) = B(I,L) / S R = R + B(I,L)**2 25 CONTINUE ! R = SIGN(SQRT(R),B(L,L)) B(L,L) = B(L,L) + R RHO = R * B(L,L) ! DO 50 J = L1, N T = 0.0E0 ! DO 30 I = L, N T = T + B(I,L) * B(I,J) 30 CONTINUE ! T = -T / RHO ! DO 40 I = L, N B(I,J) = B(I,J) + T * B(I,L) 40 CONTINUE ! 50 CONTINUE ! DO 80 J = 1, N T = 0.0E0 ! DO 60 I = L, N T = T + B(I,L) * A(I,J) 60 CONTINUE ! T = -T / RHO ! DO 70 I = L, N A(I,J) = A(I,J) + T * B(I,L) 70 CONTINUE ! 80 CONTINUE ! B(L,L) = -S * R ! DO 90 I = L1, N B(I,L) = 0.0E0 90 CONTINUE ! 100 CONTINUE ! .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE ! KEEPING B TRIANGULAR .......... if (N == 2) go to 170 NM2 = N - 2 ! DO 160 K = 1, NM2 NK1 = NM1 - K ! .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- .......... DO 150 LB = 1, NK1 L = N - LB L1 = L + 1 ! .......... ZERO A(L+1,K) .......... S = ABS(A(L,K)) + ABS(A(L1,K)) if (S == 0.0E0) go to 150 U1 = A(L,K) / S U2 = A(L1,K) / S R = SIGN(SQRT(U1*U1+U2*U2),U1) V1 = -(U1 + R) / R V2 = -U2 / R U2 = V2 / V1 ! DO 110 J = K, N T = A(L,J) + U2 * A(L1,J) A(L,J) = A(L,J) + T * V1 A(L1,J) = A(L1,J) + T * V2 110 CONTINUE ! A(L1,K) = 0.0E0 ! DO 120 J = L, N T = B(L,J) + U2 * B(L1,J) B(L,J) = B(L,J) + T * V1 B(L1,J) = B(L1,J) + T * V2 120 CONTINUE ! .......... ZERO B(L+1,L) .......... S = ABS(B(L1,L1)) + ABS(B(L1,L)) if (S == 0.0E0) go to 150 U1 = B(L1,L1) / S U2 = B(L1,L) / S R = SIGN(SQRT(U1*U1+U2*U2),U1) V1 = -(U1 + R) / R V2 = -U2 / R U2 = V2 / V1 ! DO 130 I = 1, L1 T = B(I,L1) + U2 * B(I,L) B(I,L1) = B(I,L1) + T * V1 B(I,L) = B(I,L) + T * V2 130 CONTINUE ! B(L1,L) = 0.0E0 ! DO 140 I = 1, N T = A(I,L1) + U2 * A(I,L) A(I,L1) = A(I,L1) + T * V1 A(I,L) = A(I,L) + T * V2 140 CONTINUE ! if (.NOT. MATZ) go to 150 ! DO 145 I = 1, N T = Z(I,L1) + U2 * Z(I,L) Z(I,L1) = Z(I,L1) + T * V1 Z(I,L) = Z(I,L) + T * V2 145 CONTINUE ! 150 CONTINUE ! 160 CONTINUE ! 170 RETURN end subroutine QZIT (NM, N, A, B, EPS1, MATZ, Z, IERR) ! !! QZIT is the second step of the QZ algorithm for generalized eigenproblems. ! Accepts an upper Hessenberg and an upper ! triangular matrix and reduces the former to ! quasi-triangular form while preserving the form of the ! latter. Usually preceded by QZHES and followed by QZVAL ! and QZVEC. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B3 !***TYPE SINGLE PRECISION (QZIT-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is the second step of the QZ algorithm ! for solving generalized matrix eigenvalue problems, ! SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART, ! as modified in technical note NASA TN D-7305(1973) by WARD. ! ! This subroutine accepts a pair of REAL matrices, one of them ! in upper Hessenberg form and the other in upper triangular form. ! It reduces the Hessenberg matrix to quasi-triangular form using ! orthogonal transformations while maintaining the triangular form ! of the other matrix. It is usually preceded by QZHES and ! followed by QZVAL and, possibly, QZVEC. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A, B, and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrices A and B. N is an INTEGER ! variable. N must be less than or equal to NM. ! ! A contains a real upper Hessenberg matrix. A is a two- ! dimensional REAL array, dimensioned A(NM,N). ! ! B contains a real upper triangular matrix. B is a two- ! dimensional REAL array, dimensioned B(NM,N). ! ! EPS1 is a tolerance used to determine negligible elements. ! EPS1 = 0.0 (or negative) may be input, in which case an ! element will be neglected only if it is less than roundoff ! error times the norm of its matrix. If the input EPS1 is ! positive, then an element will be considered negligible ! if it is less than EPS1 times the norm of its matrix. A ! positive value of EPS1 may result in faster execution, ! but less accurate results. EPS1 is a REAL variable. ! ! MATZ should be set to .TRUE. if the right hand transformations ! are to be accumulated for later use in computing ! eigenvectors, and to .FALSE. otherwise. MATZ is a LOGICAL ! variable. ! ! Z contains, if MATZ has been set to .TRUE., the transformation ! matrix produced in the reduction by QZHES, if performed, or ! else the identity matrix. If MATZ has been set to .FALSE., ! Z is not referenced. Z is a two-dimensional REAL array, ! dimensioned Z(NM,N). ! ! On Output ! ! A has been reduced to quasi-triangular form. The elements ! below the first subdiagonal are still zero, and no two ! consecutive subdiagonal elements are nonzero. ! ! B is still in upper triangular form, although its elements ! have been altered. The location B(N,1) is used to store ! EPS1 times the norm of B for later use by QZVAL and QZVEC. ! ! Z contains the product of the right hand transformations ! (for both steps) if MATZ has been set to .TRUE. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if neither A(J,J-1) nor A(J-1,J-2) has become ! zero after a total of 30*N iterations. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE QZIT ! INTEGER I,J,K,L,N,EN,K1,K2,LD,LL,L1,NA,NM,ISH,ITN,ITS,KM1,LM1 INTEGER ENM2,IERR,LOR1,ENORN REAL A(NM,*),B(NM,*),Z(NM,*) REAL R,S,T,A1,A2,A3,EP,SH,U1,U2,U3,V1,V2,V3,ANI REAL A11,A12,A21,A22,A33,A34,A43,A44,BNI,B11 REAL B12,B22,B33,B34,B44,EPSA,EPSB,EPS1,ANORM,BNORM LOGICAL MATZ,NOTLAS ! !***FIRST EXECUTABLE STATEMENT QZIT IERR = 0 ! .......... COMPUTE EPSA,EPSB .......... ANORM = 0.0E0 BNORM = 0.0E0 ! DO 30 I = 1, N ANI = 0.0E0 if (I /= 1) ANI = ABS(A(I,I-1)) BNI = 0.0E0 ! DO 20 J = I, N ANI = ANI + ABS(A(I,J)) BNI = BNI + ABS(B(I,J)) 20 CONTINUE ! if (ANI > ANORM) ANORM = ANI if (BNI > BNORM) BNORM = BNI 30 CONTINUE ! if (ANORM == 0.0E0) ANORM = 1.0E0 if (BNORM == 0.0E0) BNORM = 1.0E0 EP = EPS1 if (EP > 0.0E0) go to 50 ! .......... COMPUTE ROUNDOFF LEVEL if EPS1 IS ZERO .......... EP = 1.0E0 40 EP = EP / 2.0E0 if (1.0E0 + EP > 1.0E0) go to 40 50 EPSA = EP * ANORM EPSB = EP * BNORM ! .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE ! KEEPING B TRIANGULAR .......... LOR1 = 1 ENORN = N EN = N ITN = 30*N ! .......... BEGIN QZ STEP .......... 60 if (EN <= 2) go to 1001 if (.NOT. MATZ) ENORN = EN ITS = 0 NA = EN - 1 ENM2 = NA - 1 70 ISH = 2 ! .......... CHECK FOR CONVERGENCE OR REDUCIBILITY. ! FOR L=EN STEP -1 UNTIL 1 DO -- .......... DO 80 LL = 1, EN LM1 = EN - LL L = LM1 + 1 if (L == 1) go to 95 if (ABS(A(L,LM1)) <= EPSA) go to 90 80 CONTINUE ! 90 A(L,LM1) = 0.0E0 if (L < NA) go to 95 ! .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED .......... EN = LM1 go to 60 ! .......... CHECK FOR SMALL TOP OF B .......... 95 LD = L 100 L1 = L + 1 B11 = B(L,L) if (ABS(B11) > EPSB) go to 120 B(L,L) = 0.0E0 S = ABS(A(L,L)) + ABS(A(L1,L)) U1 = A(L,L) / S U2 = A(L1,L) / S R = SIGN(SQRT(U1*U1+U2*U2),U1) V1 = -(U1 + R) / R V2 = -U2 / R U2 = V2 / V1 ! DO 110 J = L, ENORN T = A(L,J) + U2 * A(L1,J) A(L,J) = A(L,J) + T * V1 A(L1,J) = A(L1,J) + T * V2 T = B(L,J) + U2 * B(L1,J) B(L,J) = B(L,J) + T * V1 B(L1,J) = B(L1,J) + T * V2 110 CONTINUE ! if (L /= 1) A(L,LM1) = -A(L,LM1) LM1 = L L = L1 go to 90 120 A11 = A(L,L) / B11 A21 = A(L1,L) / B11 if (ISH == 1) go to 140 ! .......... ITERATION STRATEGY .......... if (ITN == 0) go to 1000 if (ITS == 10) go to 155 ! .......... DETERMINE TYPE OF SHIFT .......... B22 = B(L1,L1) if (ABS(B22) < EPSB) B22 = EPSB B33 = B(NA,NA) if (ABS(B33) < EPSB) B33 = EPSB B44 = B(EN,EN) if (ABS(B44) < EPSB) B44 = EPSB 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 = 0.5E0 * (A43 * B34 - A33 - A44) R = T * T + A34 * A43 - A33 * A44 if (R < 0.0E0) go to 150 ! .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A .......... ISH = 1 R = SQRT(R) SH = -T + R S = -T - R if (ABS(S-A44) < ABS(SH-A44)) SH = S ! .......... LOOK FOR TWO CONSECUTIVE SMALL ! SUB-DIAGONAL ELEMENTS OF A. ! FOR L=EN-2 STEP -1 UNTIL LD DO -- .......... DO 130 LL = LD, ENM2 L = ENM2 + LD - LL if (L == LD) go to 140 LM1 = L - 1 L1 = L + 1 T = A(L,L) if (ABS(B(L,L)) > EPSB) T = T - SH * B(L,L) if (ABS(A(L,LM1)) <= ABS(T/A(L1,L)) * EPSA) go to 100 130 CONTINUE ! 140 A1 = A11 - SH A2 = A21 if (L /= LD) A(L,LM1) = -A(L,LM1) go to 160 ! .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A .......... 150 A12 = A(L,L1) / B22 A22 = A(L1,L1) / B22 B12 = B(L,L1) / B22 A1 = ((A33 - A11) * (A44 - A11) - A34 * A43 + A43 * B34 * A11) & / A21 + A12 - A11 * B12 A2 = (A22 - A11) - A21 * B12 - (A33 - A11) - (A44 - A11) & + A43 * B34 A3 = A(L1+1,L1) / B22 go to 160 ! .......... AD HOC SHIFT .......... 155 A1 = 0.0E0 A2 = 1.0E0 A3 = 1.1605E0 160 ITS = ITS + 1 ITN = ITN - 1 if (.NOT. MATZ) LOR1 = LD ! .......... MAIN LOOP .......... DO 260 K = L, NA NOTLAS = K /= NA .AND. ISH == 2 K1 = K + 1 K2 = K + 2 KM1 = MAX(K-1,L) LL = MIN(EN,K1+ISH) if (NOTLAS) go to 190 ! .......... ZERO A(K+1,K-1) .......... if (K == L) go to 170 A1 = A(K,KM1) A2 = A(K1,KM1) 170 S = ABS(A1) + ABS(A2) if (S == 0.0E0) go to 70 U1 = A1 / S U2 = A2 / S R = SIGN(SQRT(U1*U1+U2*U2),U1) V1 = -(U1 + R) / R V2 = -U2 / R U2 = V2 / V1 ! DO 180 J = KM1, ENORN T = A(K,J) + U2 * A(K1,J) A(K,J) = A(K,J) + T * V1 A(K1,J) = A(K1,J) + T * V2 T = B(K,J) + U2 * B(K1,J) B(K,J) = B(K,J) + T * V1 B(K1,J) = B(K1,J) + T * V2 180 CONTINUE ! if (K /= L) A(K1,KM1) = 0.0E0 go to 240 ! .......... ZERO A(K+1,K-1) AND A(K+2,K-1) .......... 190 if (K == L) go to 200 A1 = A(K,KM1) A2 = A(K1,KM1) A3 = A(K2,KM1) 200 S = ABS(A1) + ABS(A2) + ABS(A3) if (S == 0.0E0) go to 260 U1 = A1 / S U2 = A2 / S U3 = A3 / S R = SIGN(SQRT(U1*U1+U2*U2+U3*U3),U1) V1 = -(U1 + R) / R V2 = -U2 / R V3 = -U3 / R U2 = V2 / V1 U3 = V3 / V1 ! DO 210 J = KM1, ENORN T = A(K,J) + U2 * A(K1,J) + U3 * A(K2,J) A(K,J) = A(K,J) + T * V1 A(K1,J) = A(K1,J) + T * V2 A(K2,J) = A(K2,J) + T * V3 T = B(K,J) + U2 * B(K1,J) + U3 * B(K2,J) B(K,J) = B(K,J) + T * V1 B(K1,J) = B(K1,J) + T * V2 B(K2,J) = B(K2,J) + T * V3 210 CONTINUE ! if (K == L) go to 220 A(K1,KM1) = 0.0E0 A(K2,KM1) = 0.0E0 ! .......... ZERO B(K+2,K+1) AND B(K+2,K) .......... 220 S = ABS(B(K2,K2)) + ABS(B(K2,K1)) + ABS(B(K2,K)) if (S == 0.0E0) go to 240 U1 = B(K2,K2) / S U2 = B(K2,K1) / S U3 = B(K2,K) / S R = SIGN(SQRT(U1*U1+U2*U2+U3*U3),U1) V1 = -(U1 + R) / R V2 = -U2 / R V3 = -U3 / R U2 = V2 / V1 U3 = V3 / V1 ! DO 230 I = LOR1, LL T = A(I,K2) + U2 * A(I,K1) + U3 * A(I,K) A(I,K2) = A(I,K2) + T * V1 A(I,K1) = A(I,K1) + T * V2 A(I,K) = A(I,K) + T * V3 T = B(I,K2) + U2 * B(I,K1) + U3 * B(I,K) B(I,K2) = B(I,K2) + T * V1 B(I,K1) = B(I,K1) + T * V2 B(I,K) = B(I,K) + T * V3 230 CONTINUE ! B(K2,K) = 0.0E0 B(K2,K1) = 0.0E0 if (.NOT. MATZ) go to 240 ! DO 235 I = 1, N T = Z(I,K2) + U2 * Z(I,K1) + U3 * Z(I,K) Z(I,K2) = Z(I,K2) + T * V1 Z(I,K1) = Z(I,K1) + T * V2 Z(I,K) = Z(I,K) + T * V3 235 CONTINUE ! .......... ZERO B(K+1,K) .......... 240 S = ABS(B(K1,K1)) + ABS(B(K1,K)) if (S == 0.0E0) go to 260 U1 = B(K1,K1) / S U2 = B(K1,K) / S R = SIGN(SQRT(U1*U1+U2*U2),U1) V1 = -(U1 + R) / R V2 = -U2 / R U2 = V2 / V1 ! DO 250 I = LOR1, LL T = A(I,K1) + U2 * A(I,K) A(I,K1) = A(I,K1) + T * V1 A(I,K) = A(I,K) + T * V2 T = B(I,K1) + U2 * B(I,K) B(I,K1) = B(I,K1) + T * V1 B(I,K) = B(I,K) + T * V2 250 CONTINUE ! B(K1,K) = 0.0E0 if (.NOT. MATZ) go to 260 ! DO 255 I = 1, N T = Z(I,K1) + U2 * Z(I,K) Z(I,K1) = Z(I,K1) + T * V1 Z(I,K) = Z(I,K) + T * V2 255 CONTINUE ! 260 CONTINUE ! .......... END QZ STEP .......... go to 70 ! .......... SET ERROR -- NEITHER BOTTOM SUBDIAGONAL ELEMENT ! HAS BECOME NEGLIGIBLE AFTER 30*N ITERATIONS .......... 1000 IERR = EN ! .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC .......... 1001 if (N > 1) B(N,1) = EPSB return end subroutine QZVAL (NM, N, A, B, ALFR, ALFI, BETA, MATZ, Z) ! !! QZVAL is the third step of the QZ algorithm for generalized eigenproblems. ! Accepts a pair of real matrices, one in ! quasi-triangular form and the other in upper triangular ! form and computes the eigenvalues of the associated ! eigenproblem. Usually preceded by QZHES, QZIT, and ! followed by QZVEC. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C2C !***TYPE SINGLE PRECISION (QZVAL-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is the third step of the QZ algorithm ! for solving generalized matrix eigenvalue problems, ! SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART. ! ! This subroutine accepts a pair of REAL matrices, one of them ! in quasi-triangular form and the other in upper triangular form. ! It reduces the quasi-triangular matrix further, so that any ! remaining 2-by-2 blocks correspond to pairs of complex ! eigenvalues, and returns quantities whose ratios give the ! generalized eigenvalues. It is usually preceded by QZHES ! and QZIT and may be followed by QZVEC. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A, B, and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrices A and B. N is an INTEGER ! variable. N must be less than or equal to NM. ! ! A contains a real upper quasi-triangular matrix. A is a two- ! dimensional REAL array, dimensioned A(NM,N). ! ! B contains a real upper triangular matrix. In addition, ! location B(N,1) contains the tolerance quantity (EPSB) ! computed and saved in QZIT. B is a two-dimensional REAL ! array, dimensioned B(NM,N). ! ! MATZ should be set to .TRUE. if the right hand transformations ! are to be accumulated for later use in computing ! eigenvectors, and to .FALSE. otherwise. MATZ is a LOGICAL ! variable. ! ! Z contains, if MATZ has been set to .TRUE., the transformation ! matrix produced in the reductions by QZHES and QZIT, if ! performed, or else the identity matrix. If MATZ has been set ! to .FALSE., Z is not referenced. Z is a two-dimensional REAL ! array, dimensioned Z(NM,N). ! ! On Output ! ! A has been reduced further to a quasi-triangular matrix in ! which all nonzero subdiagonal elements correspond to pairs ! of complex eigenvalues. ! ! B is still in upper triangular form, although its elements ! have been altered. B(N,1) is unaltered. ! ! ALFR and ALFI contain the real and imaginary parts of the ! diagonal elements of the triangular matrix that would be ! obtained if A were reduced completely to triangular form ! by unitary transformations. Non-zero values of ALFI occur ! in pairs, the first member positive and the second negative. ! ALFR and ALFI are one-dimensional REAL arrays, dimensioned ! ALFR(N) and ALFI(N). ! ! BETA contains the diagonal elements of the corresponding B, ! normalized to be real and non-negative. The generalized ! eigenvalues are then the ratios ((ALFR+I*ALFI)/BETA). ! BETA is a one-dimensional REAL array, dimensioned BETA(N). ! ! Z contains the product of the right hand transformations ! (for all three steps) if MATZ has been set to .TRUE. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE QZVAL ! INTEGER I,J,N,EN,NA,NM,NN,ISW REAL A(NM,*),B(NM,*),ALFR(*),ALFI(*),BETA(*),Z(NM,*) REAL C,D,E,R,S,T,AN,A1,A2,BN,CQ,CZ,DI,DR,EI,TI,TR REAL U1,U2,V1,V2,A1I,A11,A12,A2I,A21,A22,B11,B12,B22 REAL SQI,SQR,SSI,SSR,SZI,SZR,A11I,A11R,A12I,A12R REAL A22I,A22R,EPSB LOGICAL MATZ ! !***FIRST EXECUTABLE STATEMENT QZVAL EPSB = B(N,1) ISW = 1 ! .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES. ! FOR EN=N STEP -1 UNTIL 1 DO -- .......... DO 510 NN = 1, N EN = N + 1 - NN NA = EN - 1 if (ISW == 2) go to 505 if (EN == 1) go to 410 if (A(EN,NA) /= 0.0E0) go to 420 ! .......... 1-BY-1 BLOCK, ONE REAL ROOT .......... 410 ALFR(EN) = A(EN,EN) if (B(EN,EN) < 0.0E0) ALFR(EN) = -ALFR(EN) BETA(EN) = ABS(B(EN,EN)) ALFI(EN) = 0.0E0 go to 510 ! .......... 2-BY-2 BLOCK .......... 420 if (ABS(B(NA,NA)) <= EPSB) go to 455 if (ABS(B(EN,EN)) > EPSB) go to 430 A1 = A(EN,EN) A2 = A(EN,NA) BN = 0.0E0 go to 435 430 AN = ABS(A(NA,NA)) + ABS(A(NA,EN)) + ABS(A(EN,NA)) & + ABS(A(EN,EN)) BN = ABS(B(NA,NA)) + ABS(B(NA,EN)) + ABS(B(EN,EN)) A11 = A(NA,NA) / AN A12 = A(NA,EN) / AN A21 = A(EN,NA) / AN A22 = A(EN,EN) / AN B11 = B(NA,NA) / BN B12 = B(NA,EN) / BN B22 = B(EN,EN) / BN E = A11 / B11 EI = A22 / B22 S = A21 / (B11 * B22) T = (A22 - E * B22) / B22 if (ABS(E) <= ABS(EI)) go to 431 E = EI T = (A11 - E * B11) / B11 431 C = 0.5E0 * (T - S * B12) D = C * C + S * (A12 - E * B12) if (D < 0.0E0) go to 480 ! .......... TWO REAL ROOTS. ! ZERO BOTH A(EN,NA) AND B(EN,NA) .......... E = E + (C + SIGN(SQRT(D),C)) A11 = A11 - E * B11 A12 = A12 - E * B12 A22 = A22 - E * B22 if (ABS(A11) + ABS(A12) < & ABS(A21) + ABS(A22)) go to 432 A1 = A12 A2 = A11 go to 435 432 A1 = A22 A2 = A21 ! .......... CHOOSE AND APPLY REAL Z .......... 435 S = ABS(A1) + ABS(A2) U1 = A1 / S U2 = A2 / S R = SIGN(SQRT(U1*U1+U2*U2),U1) V1 = -(U1 + R) / R V2 = -U2 / R U2 = V2 / V1 ! DO 440 I = 1, EN T = A(I,EN) + U2 * A(I,NA) A(I,EN) = A(I,EN) + T * V1 A(I,NA) = A(I,NA) + T * V2 T = B(I,EN) + U2 * B(I,NA) B(I,EN) = B(I,EN) + T * V1 B(I,NA) = B(I,NA) + T * V2 440 CONTINUE ! if (.NOT. MATZ) go to 450 ! DO 445 I = 1, N T = Z(I,EN) + U2 * Z(I,NA) Z(I,EN) = Z(I,EN) + T * V1 Z(I,NA) = Z(I,NA) + T * V2 445 CONTINUE ! 450 if (BN == 0.0E0) go to 475 if (AN < ABS(E) * BN) go to 455 A1 = B(NA,NA) A2 = B(EN,NA) go to 460 455 A1 = A(NA,NA) A2 = A(EN,NA) ! .......... CHOOSE AND APPLY REAL Q .......... 460 S = ABS(A1) + ABS(A2) if (S == 0.0E0) go to 475 U1 = A1 / S U2 = A2 / S R = SIGN(SQRT(U1*U1+U2*U2),U1) V1 = -(U1 + R) / R V2 = -U2 / R U2 = V2 / V1 ! DO 470 J = NA, N T = A(NA,J) + U2 * A(EN,J) A(NA,J) = A(NA,J) + T * V1 A(EN,J) = A(EN,J) + T * V2 T = B(NA,J) + U2 * B(EN,J) B(NA,J) = B(NA,J) + T * V1 B(EN,J) = B(EN,J) + T * V2 470 CONTINUE ! 475 A(EN,NA) = 0.0E0 B(EN,NA) = 0.0E0 ALFR(NA) = A(NA,NA) ALFR(EN) = A(EN,EN) if (B(NA,NA) < 0.0E0) ALFR(NA) = -ALFR(NA) if (B(EN,EN) < 0.0E0) ALFR(EN) = -ALFR(EN) BETA(NA) = ABS(B(NA,NA)) BETA(EN) = ABS(B(EN,EN)) ALFI(EN) = 0.0E0 ALFI(NA) = 0.0E0 go to 505 ! .......... TWO COMPLEX ROOTS .......... 480 E = E + C EI = SQRT(-D) A11R = A11 - E * B11 A11I = EI * B11 A12R = A12 - E * B12 A12I = EI * B12 A22R = A22 - E * B22 A22I = EI * B22 if (ABS(A11R) + ABS(A11I) + ABS(A12R) + ABS(A12I) < & ABS(A21) + ABS(A22R) + ABS(A22I)) go to 482 A1 = A12R A1I = A12I A2 = -A11R A2I = -A11I go to 485 482 A1 = A22R A1I = A22I A2 = -A21 A2I = 0.0E0 ! .......... CHOOSE COMPLEX Z .......... 485 CZ = SQRT(A1*A1+A1I*A1I) if (CZ == 0.0E0) go to 487 SZR = (A1 * A2 + A1I * A2I) / CZ SZI = (A1 * A2I - A1I * A2) / CZ R = SQRT(CZ*CZ+SZR*SZR+SZI*SZI) CZ = CZ / R SZR = SZR / R SZI = SZI / R go to 490 487 SZR = 1.0E0 SZI = 0.0E0 490 if (AN < (ABS(E) + EI) * BN) go to 492 A1 = CZ * B11 + SZR * B12 A1I = SZI * B12 A2 = SZR * B22 A2I = SZI * B22 go to 495 492 A1 = CZ * A11 + SZR * A12 A1I = SZI * A12 A2 = CZ * A21 + SZR * A22 A2I = SZI * A22 ! .......... CHOOSE COMPLEX Q .......... 495 CQ = SQRT(A1*A1+A1I*A1I) if (CQ == 0.0E0) go to 497 SQR = (A1 * A2 + A1I * A2I) / CQ SQI = (A1 * A2I - A1I * A2) / CQ R = SQRT(CQ*CQ+SQR*SQR+SQI*SQI) CQ = CQ / R SQR = SQR / R SQI = SQI / R go to 500 497 SQR = 1.0E0 SQI = 0.0E0 ! .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT ! if TRANSFORMATIONS WERE APPLIED .......... 500 SSR = SQR * SZR + SQI * SZI SSI = SQR * SZI - SQI * SZR I = 1 TR = CQ * CZ * A11 + CQ * SZR * A12 + SQR * CZ * A21 & + SSR * A22 TI = CQ * SZI * A12 - SQI * CZ * A21 + SSI * A22 DR = CQ * CZ * B11 + CQ * SZR * B12 + SSR * B22 DI = CQ * SZI * B12 + SSI * B22 go to 503 502 I = 2 TR = SSR * A11 - SQR * CZ * A12 - CQ * SZR * A21 & + CQ * CZ * A22 TI = -SSI * A11 - SQI * CZ * A12 + CQ * SZI * A21 DR = SSR * B11 - SQR * CZ * B12 + CQ * CZ * B22 DI = -SSI * B11 - SQI * CZ * B12 503 T = TI * DR - TR * DI J = NA if (T < 0.0E0) J = EN R = SQRT(DR*DR+DI*DI) BETA(J) = BN * R ALFR(J) = AN * (TR * DR + TI * DI) / R ALFI(J) = AN * T / R if (I == 1) go to 502 505 ISW = 3 - ISW 510 CONTINUE ! return end subroutine QZVEC (NM, N, A, B, ALFR, ALFI, BETA, Z) ! !! QZVEC is the fourth step of the QZ algorithm for generalized eigenproblems. ! Accepts a matrix in ! quasi-triangular form and another in upper triangular ! and computes the eigenvectors of the triangular problem ! and transforms them back to the original coordinates ! Usually preceded by QZHES, QZIT, and QZVAL. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C3 !***TYPE SINGLE PRECISION (QZVEC-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is the optional fourth step of the QZ algorithm ! for solving generalized matrix eigenvalue problems, ! SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART. ! ! This subroutine accepts a pair of REAL matrices, one of them in ! quasi-triangular form (in which each 2-by-2 block corresponds to ! a pair of complex eigenvalues) and the other in upper triangular ! form. It computes the eigenvectors of the triangular problem and ! transforms the results back to the original coordinate system. ! It is usually preceded by QZHES, QZIT, and QZVAL. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A, B, and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrices A and B. N is an INTEGER ! variable. N must be less than or equal to NM. ! ! A contains a real upper quasi-triangular matrix. A is a two- ! dimensional REAL array, dimensioned A(NM,N). ! ! B contains a real upper triangular matrix. In addition, ! location B(N,1) contains the tolerance quantity (EPSB) ! computed and saved in QZIT. B is a two-dimensional REAL ! array, dimensioned B(NM,N). ! ! ALFR, ALFI, and BETA are one-dimensional REAL arrays with ! components whose ratios ((ALFR+I*ALFI)/BETA) are the ! generalized eigenvalues. They are usually obtained from ! QZVAL. They are dimensioned ALFR(N), ALFI(N), and BETA(N). ! ! Z contains the transformation matrix produced in the reductions ! by QZHES, QZIT, and QZVAL, if performed. If the ! eigenvectors of the triangular problem are desired, Z must ! contain the identity matrix. Z is a two-dimensional REAL ! array, dimensioned Z(NM,N). ! ! On Output ! ! A is unaltered. Its subdiagonal elements provide information ! about the storage of the complex eigenvectors. ! ! B has been destroyed. ! ! ALFR, ALFI, and BETA are unaltered. ! ! Z contains the real and imaginary parts of the eigenvectors. ! If ALFI(J) == 0.0, the J-th eigenvalue is real and ! the J-th column of Z contains its eigenvector. ! If ALFI(J) /= 0.0, the J-th eigenvalue is complex. ! If ALFI(J) > 0.0, the eigenvalue is the first of ! a complex pair and the J-th and (J+1)-th columns ! of Z contain its eigenvector. ! If ALFI(J) < 0.0, the eigenvalue is the second of ! a complex pair and the (J-1)-th and J-th columns ! of Z contain the conjugate of its eigenvector. ! Each eigenvector is normalized so that the modulus ! of its largest component is 1.0 . ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE QZVEC ! INTEGER I,J,K,M,N,EN,II,JJ,NA,NM,NN,ISW,ENM2 REAL A(NM,*),B(NM,*),ALFR(*),ALFI(*),BETA(*),Z(NM,*) REAL D,Q,R,S,T,W,X,Y,DI,DR,RA,RR,SA,TI,TR,T1,T2 REAL W1,X1,ZZ,Z1,ALFM,ALMI,ALMR,BETM,EPSB ! !***FIRST EXECUTABLE STATEMENT QZVEC EPSB = B(N,1) ISW = 1 ! .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... DO 800 NN = 1, N EN = N + 1 - NN NA = EN - 1 if (ISW == 2) go to 795 if (ALFI(EN) /= 0.0E0) go to 710 ! .......... REAL VECTOR .......... M = EN B(EN,EN) = 1.0E0 if (NA == 0) go to 800 ALFM = ALFR(M) BETM = BETA(M) ! .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... DO 700 II = 1, NA I = EN - II W = BETM * A(I,I) - ALFM * B(I,I) R = 0.0E0 ! DO 610 J = M, EN 610 R = R + (BETM * A(I,J) - ALFM * B(I,J)) * B(J,EN) ! if (I == 1 .OR. ISW == 2) go to 630 if (BETM * A(I,I-1) == 0.0E0) go to 630 ZZ = W S = R go to 690 630 M = I if (ISW == 2) go to 640 ! .......... REAL 1-BY-1 BLOCK .......... T = W if (W == 0.0E0) T = EPSB B(I,EN) = -R / T go to 700 ! .......... REAL 2-BY-2 BLOCK .......... 640 X = BETM * A(I,I+1) - ALFM * B(I,I+1) Y = BETM * A(I+1,I) Q = W * ZZ - X * Y T = (X * S - ZZ * R) / Q B(I,EN) = T if (ABS(X) <= ABS(ZZ)) go to 650 B(I+1,EN) = (-R - W * T) / X go to 690 650 B(I+1,EN) = (-S - Y * T) / ZZ 690 ISW = 3 - ISW 700 CONTINUE ! .......... END REAL VECTOR .......... go to 800 ! .......... COMPLEX VECTOR .......... 710 M = NA ALMR = ALFR(M) ALMI = ALFI(M) BETM = BETA(M) ! .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT ! EIGENVECTOR MATRIX IS TRIANGULAR .......... Y = BETM * A(EN,NA) B(NA,NA) = -ALMI * B(EN,EN) / Y B(NA,EN) = (ALMR * B(EN,EN) - BETM * A(EN,EN)) / Y B(EN,NA) = 0.0E0 B(EN,EN) = 1.0E0 ENM2 = NA - 1 if (ENM2 == 0) go to 795 ! .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... DO 790 II = 1, ENM2 I = NA - II W = BETM * A(I,I) - ALMR * B(I,I) W1 = -ALMI * B(I,I) RA = 0.0E0 SA = 0.0E0 ! DO 760 J = M, EN X = BETM * A(I,J) - ALMR * B(I,J) X1 = -ALMI * B(I,J) RA = RA + X * B(J,NA) - X1 * B(J,EN) SA = SA + X * B(J,EN) + X1 * B(J,NA) 760 CONTINUE ! if (I == 1 .OR. ISW == 2) go to 770 if (BETM * A(I,I-1) == 0.0E0) go to 770 ZZ = W Z1 = W1 R = RA S = SA ISW = 2 go to 790 770 M = I if (ISW == 2) go to 780 ! .......... COMPLEX 1-BY-1 BLOCK .......... TR = -RA TI = -SA 773 DR = W DI = W1 ! .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) .......... 775 if (ABS(DI) > ABS(DR)) go to 777 RR = DI / DR D = DR + DI * RR T1 = (TR + TI * RR) / D T2 = (TI - TR * RR) / D go to (787,782), ISW 777 RR = DR / DI D = DR * RR + DI T1 = (TR * RR + TI) / D T2 = (TI * RR - TR) / D go to (787,782), ISW ! .......... COMPLEX 2-BY-2 BLOCK .......... 780 X = BETM * A(I,I+1) - ALMR * B(I,I+1) X1 = -ALMI * B(I,I+1) Y = BETM * A(I+1,I) TR = Y * RA - W * R + W1 * S TI = Y * SA - W * S - W1 * R DR = W * ZZ - W1 * Z1 - X * Y DI = W * Z1 + W1 * ZZ - X1 * Y if (DR == 0.0E0 .AND. DI == 0.0E0) DR = EPSB go to 775 782 B(I+1,NA) = T1 B(I+1,EN) = T2 ISW = 1 if (ABS(Y) > ABS(W) + ABS(W1)) go to 785 TR = -RA - X * B(I+1,NA) + X1 * B(I+1,EN) TI = -SA - X * B(I+1,EN) - X1 * B(I+1,NA) go to 773 785 T1 = (-R - ZZ * B(I+1,NA) + Z1 * B(I+1,EN)) / Y T2 = (-S - ZZ * B(I+1,EN) - Z1 * B(I+1,NA)) / Y 787 B(I,NA) = T1 B(I,EN) = T2 790 CONTINUE ! .......... END COMPLEX VECTOR .......... 795 ISW = 3 - ISW 800 CONTINUE ! .......... END BACK SUBSTITUTION. ! TRANSFORM TO ORIGINAL COORDINATE SYSTEM. ! FOR J=N STEP -1 UNTIL 1 DO -- .......... DO 880 JJ = 1, N J = N + 1 - JJ ! DO 880 I = 1, N ZZ = 0.0E0 ! DO 860 K = 1, J 860 ZZ = ZZ + Z(I,K) * B(K,J) ! Z(I,J) = ZZ 880 CONTINUE ! .......... NORMALIZE SO THAT MODULUS OF LARGEST ! COMPONENT OF EACH VECTOR IS 1. ! (ISW IS 1 INITIALLY FROM BEFORE) .......... DO 950 J = 1, N D = 0.0E0 if (ISW == 2) go to 920 if (ALFI(J) /= 0.0E0) go to 945 ! DO 890 I = 1, N if (ABS(Z(I,J)) > D) D = ABS(Z(I,J)) 890 CONTINUE ! DO 900 I = 1, N 900 Z(I,J) = Z(I,J) / D ! go to 950 ! 920 DO 930 I = 1, N R = ABS(Z(I,J-1)) + ABS(Z(I,J)) if (R /= 0.0E0) R = R * SQRT((Z(I,J-1)/R)**2 & +(Z(I,J)/R)**2) if (R > D) D = R 930 CONTINUE ! DO 940 I = 1, N Z(I,J-1) = Z(I,J-1) / D Z(I,J) = Z(I,J) / D 940 CONTINUE ! 945 ISW = 3 - ISW 950 CONTINUE ! return end FUNCTION R1MACH (I) ! !! R1MACH returns floating point machine dependent constants. ! !***LIBRARY SLATEC !***CATEGORY R1 !***TYPE SINGLE PRECISION (R1MACH-S, D1MACH-D) !***KEYWORDS MACHINE CONSTANTS !***AUTHOR Fox, P. A., (Bell Labs) ! Hall, A. D., (Bell Labs) ! Schryer, N. L., (Bell Labs) !***DESCRIPTION ! ! R1MACH can be used to obtain machine-dependent parameters for the ! local machine environment. It is a function subprogram with one ! (input) argument, and can be referenced as follows: ! ! A = R1MACH(I) ! ! where I=1,...,5. The (output) value of A above is determined by ! the (input) value of I. The results for various values of I are ! discussed below. ! ! R1MACH(1) = B**(EMIN-1), the smallest positive magnitude. ! R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude. ! R1MACH(3) = B**(-T), the smallest relative spacing. ! R1MACH(4) = B**(1-T), the largest relative spacing. ! R1MACH(5) = LOG10(B) ! ! Assume single precision numbers are represented in the T-digit, ! base-B form ! ! sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) ! ! where 0 <= X(I) < B for I=1,...,T, 0 < X(1), and ! EMIN <= E <= EMAX. ! ! The values of B, T, EMIN and EMAX are provided in I1MACH as ! follows: ! I1MACH(10) = B, the base. ! I1MACH(11) = T, the number of base-B digits. ! I1MACH(12) = EMIN, the smallest exponent E. ! I1MACH(13) = EMAX, the largest exponent E. ! ! To alter this function for a particular environment, the desired ! set of DATA statements should be activated by removing the C from ! column 1. Also, the values of R1MACH(1) - R1MACH(4) should be ! checked for consistency with the local operating system. ! !***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for ! a portable library, ACM Transactions on Mathematical ! Software 4, 2 (June 1978), pp. 177-188. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 790101 DATE WRITTEN ! 890213 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900618 Added DEC RISC constants. (WRB) ! 900723 Added IBM RS 6000 constants. (WRB) ! 910710 Added HP 730 constants. (SMR) ! 911114 Added Convex IEEE constants. (WRB) ! 920121 Added SUN -r8 compiler option constants. (WRB) ! 920229 Added Touchstone Delta i860 constants. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 920625 Added CONVEX -p8 and -pd8 compiler option constants. ! (BKS, WRB) ! 930201 Added DEC Alpha and SGI constants. (RWC and WRB) !***END PROLOGUE R1MACH ! real r1mach INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) ! REAL RMACH(5) SAVE RMACH ! EQUIVALENCE (RMACH(1),SMALL(1)) EQUIVALENCE (RMACH(2),LARGE(1)) EQUIVALENCE (RMACH(3),RIGHT(1)) EQUIVALENCE (RMACH(4),DIVER(1)) EQUIVALENCE (RMACH(5),LOG10(1)) ! ! MACHINE CONSTANTS FOR THE AMIGA ! ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION ! ! DATA SMALL(1) / Z'00800000' / ! DATA LARGE(1) / Z'7F7FFFFF' / ! DATA RIGHT(1) / Z'33800000' / ! DATA DIVER(1) / Z'34000000' / ! DATA LOG10(1) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE AMIGA ! ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT ! ! DATA SMALL(1) / Z'00800000' / ! DATA LARGE(1) / Z'7EFFFFFF' / ! DATA RIGHT(1) / Z'33800000' / ! DATA DIVER(1) / Z'34000000' / ! DATA LOG10(1) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE APOLLO ! ! DATA SMALL(1) / 16#00800000 / ! DATA LARGE(1) / 16#7FFFFFFF / ! DATA RIGHT(1) / 16#33800000 / ! DATA DIVER(1) / 16#34000000 / ! DATA LOG10(1) / 16#3E9A209B / ! ! MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM ! ! DATA RMACH(1) / Z400800000 / ! DATA RMACH(2) / Z5FFFFFFFF / ! DATA RMACH(3) / Z4E9800000 / ! DATA RMACH(4) / Z4EA800000 / ! DATA RMACH(5) / Z500E730E8 / ! ! MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS ! ! DATA RMACH(1) / O1771000000000000 / ! DATA RMACH(2) / O0777777777777777 / ! DATA RMACH(3) / O1311000000000000 / ! DATA RMACH(4) / O1301000000000000 / ! DATA RMACH(5) / O1157163034761675 / ! ! MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE ! ! DATA RMACH(1) / Z"3001800000000000" / ! DATA RMACH(2) / Z"4FFEFFFFFFFFFFFE" / ! DATA RMACH(3) / Z"3FD2800000000000" / ! DATA RMACH(4) / Z"3FD3800000000000" / ! DATA RMACH(5) / Z"3FFF9A209A84FBCF" / ! ! MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES ! ! DATA RMACH(1) / 00564000000000000000B / ! DATA RMACH(2) / 37767777777777777776B / ! DATA RMACH(3) / 16414000000000000000B / ! DATA RMACH(4) / 16424000000000000000B / ! DATA RMACH(5) / 17164642023241175720B / ! ! MACHINE CONSTANTS FOR THE CELERITY C1260 ! ! DATA SMALL(1) / Z'00800000' / ! DATA LARGE(1) / Z'7F7FFFFF' / ! DATA RIGHT(1) / Z'33800000' / ! DATA DIVER(1) / Z'34000000' / ! DATA LOG10(1) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE CONVEX ! USING THE -fn COMPILER OPTION ! ! DATA RMACH(1) / Z'00800000' / ! DATA RMACH(2) / Z'7FFFFFFF' / ! DATA RMACH(3) / Z'34800000' / ! DATA RMACH(4) / Z'35000000' / ! DATA RMACH(5) / Z'3F9A209B' / ! ! MACHINE CONSTANTS FOR THE CONVEX ! USING THE -fi COMPILER OPTION ! ! DATA RMACH(1) / Z'00800000' / ! DATA RMACH(2) / Z'7F7FFFFF' / ! DATA RMACH(3) / Z'33800000' / ! DATA RMACH(4) / Z'34000000' / ! DATA RMACH(5) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE CONVEX ! USING THE -p8 OR -pd8 COMPILER OPTION ! ! DATA RMACH(1) / Z'0010000000000000' / ! DATA RMACH(2) / Z'7FFFFFFFFFFFFFFF' / ! DATA RMACH(3) / Z'3CC0000000000000' / ! DATA RMACH(4) / Z'3CD0000000000000' / ! DATA RMACH(5) / Z'3FF34413509F79FF' / ! ! MACHINE CONSTANTS FOR THE CRAY ! ! DATA RMACH(1) / 200034000000000000000B / ! DATA RMACH(2) / 577767777777777777776B / ! DATA RMACH(3) / 377224000000000000000B / ! DATA RMACH(4) / 377234000000000000000B / ! DATA RMACH(5) / 377774642023241175720B / ! ! MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 ! NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - ! STATIC RMACH(5) ! ! DATA SMALL / 20K, 0 / ! DATA LARGE / 77777K, 177777K / ! DATA RIGHT / 35420K, 0 / ! DATA DIVER / 36020K, 0 / ! DATA LOG10 / 40423K, 42023K / ! ! MACHINE CONSTANTS FOR THE DEC ALPHA ! USING G_FLOAT ! ! DATA RMACH(1) / '00000080'X / ! DATA RMACH(2) / 'FFFF7FFF'X / ! DATA RMACH(3) / '00003480'X / ! DATA RMACH(4) / '00003500'X / ! DATA RMACH(5) / '209B3F9A'X / ! ! MACHINE CONSTANTS FOR THE DEC ALPHA ! USING IEEE_FLOAT ! DATA RMACH(1) / Z'00800000' / DATA RMACH(2) / Z'7F7FFFFF' / DATA RMACH(3) / Z'33800000' / DATA RMACH(4) / Z'34000000' / DATA RMACH(5) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE DEC RISC ! ! DATA RMACH(1) / Z'00800000' / ! DATA RMACH(2) / Z'7F7FFFFF' / ! DATA RMACH(3) / Z'33800000' / ! DATA RMACH(4) / Z'34000000' / ! DATA RMACH(5) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE DEC VAX ! (EXPRESSED IN INTEGER AND HEXADECIMAL) ! THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS ! THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS ! ! DATA SMALL(1) / 128 / ! DATA LARGE(1) / -32769 / ! DATA RIGHT(1) / 13440 / ! DATA DIVER(1) / 13568 / ! DATA LOG10(1) / 547045274 / ! ! DATA SMALL(1) / Z00000080 / ! DATA LARGE(1) / ZFFFF7FFF / ! DATA RIGHT(1) / Z00003480 / ! DATA DIVER(1) / Z00003500 / ! DATA LOG10(1) / Z209B3F9A / ! ! MACHINE CONSTANTS FOR THE ELXSI 6400 ! (ASSUMING REAL*4 IS THE DEFAULT REAL) ! ! DATA SMALL(1) / '00800000'X / ! DATA LARGE(1) / '7F7FFFFF'X / ! DATA RIGHT(1) / '33800000'X / ! DATA DIVER(1) / '34000000'X / ! DATA LOG10(1) / '3E9A209B'X / ! ! MACHINE CONSTANTS FOR THE HARRIS 220 ! ! DATA SMALL(1), SMALL(2) / '20000000, '00000201 / ! DATA LARGE(1), LARGE(2) / '37777777, '00000177 / ! DATA RIGHT(1), RIGHT(2) / '20000000, '00000352 / ! DATA DIVER(1), DIVER(2) / '20000000, '00000353 / ! DATA LOG10(1), LOG10(2) / '23210115, '00000377 / ! ! MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES ! ! DATA RMACH(1) / O402400000000 / ! DATA RMACH(2) / O376777777777 / ! DATA RMACH(3) / O714400000000 / ! DATA RMACH(4) / O716400000000 / ! DATA RMACH(5) / O776464202324 / ! ! MACHINE CONSTANTS FOR THE HP 730 ! ! DATA RMACH(1) / Z'00800000' / ! DATA RMACH(2) / Z'7F7FFFFF' / ! DATA RMACH(3) / Z'33800000' / ! DATA RMACH(4) / Z'34000000' / ! DATA RMACH(5) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE HP 2100 ! 3 WORD DOUBLE PRECISION WITH FTN4 ! ! DATA SMALL(1), SMALL(2) / 40000B, 1 / ! DATA LARGE(1), LARGE(2) / 77777B, 177776B / ! DATA RIGHT(1), RIGHT(2) / 40000B, 325B / ! DATA DIVER(1), DIVER(2) / 40000B, 327B / ! DATA LOG10(1), LOG10(2) / 46420B, 46777B / ! ! MACHINE CONSTANTS FOR THE HP 2100 ! 4 WORD DOUBLE PRECISION WITH FTN4 ! ! DATA SMALL(1), SMALL(2) / 40000B, 1 / ! DATA LARGE(1), LARGE(2) / 77777B, 177776B / ! DATA RIGHT(1), RIGHT(2) / 40000B, 325B / ! DATA DIVER(1), DIVER(2) / 40000B, 327B / ! DATA LOG10(1), LOG10(2) / 46420B, 46777B / ! ! MACHINE CONSTANTS FOR THE HP 9000 ! ! DATA SMALL(1) / 00004000000B / ! DATA LARGE(1) / 17677777777B / ! DATA RIGHT(1) / 06340000000B / ! DATA DIVER(1) / 06400000000B / ! DATA LOG10(1) / 07646420233B / ! ! MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, ! THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86 AND ! THE PERKIN ELMER (INTERDATA) 7/32. ! ! DATA RMACH(1) / Z00100000 / ! DATA RMACH(2) / Z7FFFFFFF / ! DATA RMACH(3) / Z3B100000 / ! DATA RMACH(4) / Z3C100000 / ! DATA RMACH(5) / Z41134413 / ! ! MACHINE CONSTANTS FOR THE IBM PC ! ! DATA SMALL(1) / 1.18E-38 / ! DATA LARGE(1) / 3.40E+38 / ! DATA RIGHT(1) / 0.595E-07 / ! DATA DIVER(1) / 1.19E-07 / ! DATA LOG10(1) / 0.30102999566 / ! ! MACHINE CONSTANTS FOR THE IBM RS 6000 ! ! DATA RMACH(1) / Z'00800000' / ! DATA RMACH(2) / Z'7F7FFFFF' / ! DATA RMACH(3) / Z'33800000' / ! DATA RMACH(4) / Z'34000000' / ! DATA RMACH(5) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE INTEL i860 ! ! DATA RMACH(1) / Z'00800000' / ! DATA RMACH(2) / Z'7F7FFFFF' / ! DATA RMACH(3) / Z'33800000' / ! DATA RMACH(4) / Z'34000000' / ! DATA RMACH(5) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR) ! ! DATA RMACH(1) / "000400000000 / ! DATA RMACH(2) / "377777777777 / ! DATA RMACH(3) / "146400000000 / ! DATA RMACH(4) / "147400000000 / ! DATA RMACH(5) / "177464202324 / ! ! MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING ! 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). ! ! DATA SMALL(1) / 8388608 / ! DATA LARGE(1) / 2147483647 / ! DATA RIGHT(1) / 880803840 / ! DATA DIVER(1) / 889192448 / ! DATA LOG10(1) / 1067065499 / ! ! DATA RMACH(1) / O00040000000 / ! DATA RMACH(2) / O17777777777 / ! DATA RMACH(3) / O06440000000 / ! DATA RMACH(4) / O06500000000 / ! DATA RMACH(5) / O07746420233 / ! ! MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING ! 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). ! ! DATA SMALL(1), SMALL(2) / 128, 0 / ! DATA LARGE(1), LARGE(2) / 32767, -1 / ! DATA RIGHT(1), RIGHT(2) / 13440, 0 / ! DATA DIVER(1), DIVER(2) / 13568, 0 / ! DATA LOG10(1), LOG10(2) / 16282, 8347 / ! ! DATA SMALL(1), SMALL(2) / O000200, O000000 / ! DATA LARGE(1), LARGE(2) / O077777, O177777 / ! DATA RIGHT(1), RIGHT(2) / O032200, O000000 / ! DATA DIVER(1), DIVER(2) / O032400, O000000 / ! DATA LOG10(1), LOG10(2) / O037632, O020233 / ! ! MACHINE CONSTANTS FOR THE SILICON GRAPHICS ! ! DATA RMACH(1) / Z'00800000' / ! DATA RMACH(2) / Z'7F7FFFFF' / ! DATA RMACH(3) / Z'33800000' / ! DATA RMACH(4) / Z'34000000' / ! DATA RMACH(5) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE SUN ! ! DATA RMACH(1) / Z'00800000' / ! DATA RMACH(2) / Z'7F7FFFFF' / ! DATA RMACH(3) / Z'33800000' / ! DATA RMACH(4) / Z'34000000' / ! DATA RMACH(5) / Z'3E9A209B' / ! ! MACHINE CONSTANTS FOR THE SUN ! USING THE -r8 COMPILER OPTION ! ! DATA RMACH(1) / Z'0010000000000000' / ! DATA RMACH(2) / Z'7FEFFFFFFFFFFFFF' / ! DATA RMACH(3) / Z'3CA0000000000000' / ! DATA RMACH(4) / Z'3CB0000000000000' / ! DATA RMACH(5) / Z'3FD34413509F79FF' / ! ! MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES ! ! DATA RMACH(1) / O000400000000 / ! DATA RMACH(2) / O377777777777 / ! DATA RMACH(3) / O146400000000 / ! DATA RMACH(4) / O147400000000 / ! DATA RMACH(5) / O177464202324 / ! ! MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR ! ! DATA SMALL(1), SMALL(2) / 0, 256/ ! DATA LARGE(1), LARGE(2) / -1, -129/ ! DATA RIGHT(1), RIGHT(2) / 0, 26880/ ! DATA DIVER(1), DIVER(2) / 0, 27136/ ! DATA LOG10(1), LOG10(2) / 8347, 32538/ ! !***FIRST EXECUTABLE STATEMENT R1MACH ! if ( I < 1 .OR. I > 5 ) then call XERMSG ('SLATEC', 'R1MACH', 'I OUT OF BOUNDS', 1, 2) end if R1MACH = RMACH(I) return end subroutine R1MPYQ (M, N, A, LDA, V, W) ! !! R1MPYQ is subsidiary to SNSQ and SNSQE. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (R1MPYQ-S, D1MPYQ-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an M by N matrix A, this subroutine computes A*Q where ! Q is the product of 2*(N - 1) transformations ! ! GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) ! ! and GV(I), GW(I) are Givens rotations in the (I,N) plane which ! eliminate elements in the I-th and N-th planes, respectively. ! Q itself is not given, rather the information to recover the ! GV, GW rotations is supplied. ! ! The subroutine statement is ! ! SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) ! ! where ! ! M is a positive integer input variable set to the number ! of rows of A. ! ! N is a positive integer input variable set to the number ! of columns of A. ! ! A is an M by N ARRAY. On input A must contain the matrix ! to be postmultiplied by the orthogonal matrix Q ! described above. On output A*Q has replaced A. ! ! LDA is a positive integer input variable not less than M ! which specifies the leading dimension of the array A. ! ! V is an input array of length N. V(I) must contain the ! information necessary to recover the Givens rotation GV(I) ! described above. ! ! W is an input array of length N. W(I) must contain the ! information necessary to recover the Givens rotation GW(I) ! described above. ! !***SEE ALSO SNSQ, SNSQE !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE R1MPYQ INTEGER M,N,LDA REAL A(LDA,*),V(*),W(*) INTEGER I,J,NMJ,NM1 REAL COS,ONE,SIN,TEMP SAVE ONE DATA ONE /1.0E0/ !***FIRST EXECUTABLE STATEMENT R1MPYQ NM1 = N - 1 if (NM1 < 1) go to 50 DO 20 NMJ = 1, NM1 J = N - NMJ if (ABS(V(J)) > ONE) COS = ONE/V(J) if (ABS(V(J)) > ONE) SIN = SQRT(ONE-COS**2) if (ABS(V(J)) <= ONE) SIN = V(J) if (ABS(V(J)) <= 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 ! ! APPLY THE SECOND SET OF GIVENS ROTATIONS TO A. ! DO 40 J = 1, NM1 if (ABS(W(J)) > ONE) COS = ONE/W(J) if (ABS(W(J)) > ONE) SIN = SQRT(ONE-COS**2) if (ABS(W(J)) <= ONE) SIN = W(J) if (ABS(W(J)) <= 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 ! ! LAST CARD OF SUBROUTINE R1MPYQ. ! end subroutine R1UPDT (M, N, S, LS, U, V, W, SING) ! !! R1UPDT is subsidiary to SNSQ and SNSQE. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (R1UPDT-S, D1UPDT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an M by N lower trapezoidal matrix S, an M-vector U, ! and an N-vector V, the problem is to determine an ! orthogonal matrix Q such that ! ! T ! (S + U*V )*Q ! ! is again lower trapezoidal. ! ! This subroutine determines Q as the product of 2*(N - 1) ! transformations ! ! GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) ! ! where GV(I), GW(I) are Givens rotations in the (I,N) plane ! which eliminate elements in the I-th and N-th planes, ! respectively. Q Itself is not accumulated, rather the ! information to recover the GV, GW rotations is returned. ! ! The subroutine statement is ! ! SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) ! ! where ! ! M is a positive integer input variable set to the number ! of rows of S. ! ! N is a positive integer input variable set to the number ! of columns of S. N must not exceed M. ! ! S is an array of length LS. On input S must contain the lower ! trapezoidal matrix S stored by columns. On output S contains ! the lower trapezoidal matrix produced as described above. ! ! LS is a positive integer input variable not less than ! (N*(2*M-N+1))/2. ! ! U is an input array of length M which must contain the ! vector U. ! ! V is an array of length N. On input V must contain the vector ! V. On output V(I) contains the information necessary to ! recover the Givens rotation GV(I) described above. ! ! W is an output array of length M. W(I) contains information ! necessary to recover the Givens rotation GW(I) described ! above. ! ! SING is a logical output variable. SING is set .TRUE. if any ! of the diagonal elements of the output S are zero. Otherwise ! SING is set .FALSE. ! !***SEE ALSO SNSQ, SNSQE !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE R1UPDT INTEGER M,N,LS LOGICAL SING REAL S(*),U(*),V(*),W(*) INTEGER I,J,JJ,L,NMJ,NM1 REAL COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,ZERO REAL R1MACH SAVE ONE, P5, P25, ZERO DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/ !***FIRST EXECUTABLE STATEMENT R1UPDT GIANT = R1MACH(2) ! ! INITIALIZE THE DIAGONAL ELEMENT POINTER. ! JJ = (N*(2*M - N + 1))/2 - (M - N) ! ! MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W. ! L = JJ DO 10 I = N, M W(I) = S(L) L = L + 1 10 CONTINUE ! ! ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR ! IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W. ! NM1 = N - 1 if (NM1 < 1) go to 70 DO 60 NMJ = 1, NM1 J = N - NMJ JJ = JJ - (M - J + 1) W(J) = ZERO if (V(J) == ZERO) go to 50 ! ! DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE ! J-TH ELEMENT OF V. ! if (ABS(V(N)) >= 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 > 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 ! ! APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION ! NECESSARY TO RECOVER THE GIVENS ROTATION. ! V(N) = SIN*V(J) + COS*V(N) V(J) = TAU ! ! APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W. ! 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 ! ! ADD THE SPIKE FROM THE RANK 1 UPDATE TO W. ! DO 80 I = 1, M W(I) = W(I) + V(N)*U(I) 80 CONTINUE ! ! ELIMINATE THE SPIKE. ! SING = .FALSE. if (NM1 < 1) go to 140 DO 130 J = 1, NM1 if (W(J) == ZERO) go to 120 ! ! DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE ! J-TH ELEMENT OF THE SPIKE. ! if (ABS(S(JJ)) >= 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 > 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 ! ! APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W. ! 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 ! ! STORE THE INFORMATION NECESSARY TO RECOVER THE ! GIVENS ROTATION. ! W(J) = TAU 120 CONTINUE ! ! TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S. ! if (S(JJ) == ZERO) SING = .TRUE. JJ = JJ + (M - J + 1) 130 CONTINUE 140 CONTINUE ! ! MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S. ! L = JJ DO 150 I = N, M S(L) = W(I) L = L + 1 150 CONTINUE if (S(JJ) == ZERO) SING = .TRUE. return ! ! LAST CARD OF SUBROUTINE R1UPDT. ! end subroutine R9AIMP (X, AMPL, THETA) ! !! R9AIMP evaluates the Airy modulus and phase. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10D !***TYPE SINGLE PRECISION (R9AIMP-S, D9AIMP-D) !***KEYWORDS AIRY FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate the Airy modulus and phase for X <= -1.0 ! ! Series for AM21 on the interval -1.25000D-01 to 0. ! with weighted error 2.89E-17 ! log weighted error 16.54 ! significant figures required 14.15 ! decimal places required 17.34 ! ! Series for ATH1 on the interval -1.25000D-01 to 0. ! with weighted error 2.53E-17 ! log weighted error 16.60 ! significant figures required 15.15 ! decimal places required 17.38 ! ! Series for AM22 on the interval -1.00000D+00 to -1.25000D-01 ! with weighted error 2.99E-17 ! log weighted error 16.52 ! significant figures required 14.57 ! decimal places required 17.28 ! ! Series for ATH2 on the interval -1.00000D+00 to -1.25000D-01 ! with weighted error 2.57E-17 ! log weighted error 16.59 ! significant figures required 15.07 ! decimal places required 17.34 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE R9AIMP DIMENSION AM21CS(40), ATH1CS(36), AM22CS(33), ATH2CS(32) LOGICAL FIRST SAVE AM21CS, ATH1CS, AM22CS, ATH2CS, PI4, NAM21, & NATH1, NAM22, NATH2, XSML, FIRST DATA AM21CS( 1) / .0065809191761485E0 / DATA AM21CS( 2) / .0023675984685722E0 / DATA AM21CS( 3) / .0001324741670371E0 / DATA AM21CS( 4) / .0000157600904043E0 / DATA AM21CS( 5) / .0000027529702663E0 / DATA AM21CS( 6) / .0000006102679017E0 / DATA AM21CS( 7) / .0000001595088468E0 / DATA AM21CS( 8) / .0000000471033947E0 / DATA AM21CS( 9) / .0000000152933871E0 / DATA AM21CS(10) / .0000000053590722E0 / DATA AM21CS(11) / .0000000020000910E0 / DATA AM21CS(12) / .0000000007872292E0 / DATA AM21CS(13) / .0000000003243103E0 / DATA AM21CS(14) / .0000000001390106E0 / DATA AM21CS(15) / .0000000000617011E0 / DATA AM21CS(16) / .0000000000282491E0 / DATA AM21CS(17) / .0000000000132979E0 / DATA AM21CS(18) / .0000000000064188E0 / DATA AM21CS(19) / .0000000000031697E0 / DATA AM21CS(20) / .0000000000015981E0 / DATA AM21CS(21) / .0000000000008213E0 / DATA AM21CS(22) / .0000000000004296E0 / DATA AM21CS(23) / .0000000000002284E0 / DATA AM21CS(24) / .0000000000001232E0 / DATA AM21CS(25) / .0000000000000675E0 / DATA AM21CS(26) / .0000000000000374E0 / DATA AM21CS(27) / .0000000000000210E0 / DATA AM21CS(28) / .0000000000000119E0 / DATA AM21CS(29) / .0000000000000068E0 / DATA AM21CS(30) / .0000000000000039E0 / DATA AM21CS(31) / .0000000000000023E0 / DATA AM21CS(32) / .0000000000000013E0 / DATA AM21CS(33) / .0000000000000008E0 / DATA AM21CS(34) / .0000000000000005E0 / DATA AM21CS(35) / .0000000000000003E0 / DATA AM21CS(36) / .0000000000000001E0 / DATA AM21CS(37) / .0000000000000001E0 / DATA AM21CS(38) / .0000000000000000E0 / DATA AM21CS(39) / .0000000000000000E0 / DATA AM21CS(40) / .0000000000000000E0 / DATA ATH1CS( 1) / -.07125837815669365E0 / DATA ATH1CS( 2) / -.00590471979831451E0 / DATA ATH1CS( 3) / -.00012114544069499E0 / DATA ATH1CS( 4) / -.00000988608542270E0 / DATA ATH1CS( 5) / -.00000138084097352E0 / DATA ATH1CS( 6) / -.00000026142640172E0 / DATA ATH1CS( 7) / -.00000006050432589E0 / DATA ATH1CS( 8) / -.00000001618436223E0 / DATA ATH1CS( 9) / -.00000000483464911E0 / DATA ATH1CS(10) / -.00000000157655272E0 / DATA ATH1CS(11) / -.00000000055231518E0 / DATA ATH1CS(12) / -.00000000020545441E0 / DATA ATH1CS(13) / -.00000000008043412E0 / DATA ATH1CS(14) / -.00000000003291252E0 / DATA ATH1CS(15) / -.00000000001399875E0 / DATA ATH1CS(16) / -.00000000000616151E0 / DATA ATH1CS(17) / -.00000000000279614E0 / DATA ATH1CS(18) / -.00000000000130428E0 / DATA ATH1CS(19) / -.00000000000062373E0 / DATA ATH1CS(20) / -.00000000000030512E0 / DATA ATH1CS(21) / -.00000000000015239E0 / DATA ATH1CS(22) / -.00000000000007758E0 / DATA ATH1CS(23) / -.00000000000004020E0 / DATA ATH1CS(24) / -.00000000000002117E0 / DATA ATH1CS(25) / -.00000000000001132E0 / DATA ATH1CS(26) / -.00000000000000614E0 / DATA ATH1CS(27) / -.00000000000000337E0 / DATA ATH1CS(28) / -.00000000000000188E0 / DATA ATH1CS(29) / -.00000000000000105E0 / DATA ATH1CS(30) / -.00000000000000060E0 / DATA ATH1CS(31) / -.00000000000000034E0 / DATA ATH1CS(32) / -.00000000000000020E0 / DATA ATH1CS(33) / -.00000000000000011E0 / DATA ATH1CS(34) / -.00000000000000007E0 / DATA ATH1CS(35) / -.00000000000000004E0 / DATA ATH1CS(36) / -.00000000000000002E0 / DATA AM22CS( 1) / -.01562844480625341E0 / DATA AM22CS( 2) / .00778336445239681E0 / DATA AM22CS( 3) / .00086705777047718E0 / DATA AM22CS( 4) / .00015696627315611E0 / DATA AM22CS( 5) / .00003563962571432E0 / DATA AM22CS( 6) / .00000924598335425E0 / DATA AM22CS( 7) / .00000262110161850E0 / DATA AM22CS( 8) / .00000079188221651E0 / DATA AM22CS( 9) / .00000025104152792E0 / DATA AM22CS(10) / .00000008265223206E0 / DATA AM22CS(11) / .00000002805711662E0 / DATA AM22CS(12) / .00000000976821090E0 / DATA AM22CS(13) / .00000000347407923E0 / DATA AM22CS(14) / .00000000125828132E0 / DATA AM22CS(15) / .00000000046298826E0 / DATA AM22CS(16) / .00000000017272825E0 / DATA AM22CS(17) / .00000000006523192E0 / DATA AM22CS(18) / .00000000002490471E0 / DATA AM22CS(19) / .00000000000960156E0 / DATA AM22CS(20) / .00000000000373448E0 / DATA AM22CS(21) / .00000000000146417E0 / DATA AM22CS(22) / .00000000000057826E0 / DATA AM22CS(23) / .00000000000022991E0 / DATA AM22CS(24) / .00000000000009197E0 / DATA AM22CS(25) / .00000000000003700E0 / DATA AM22CS(26) / .00000000000001496E0 / DATA AM22CS(27) / .00000000000000608E0 / DATA AM22CS(28) / .00000000000000248E0 / DATA AM22CS(29) / .00000000000000101E0 / DATA AM22CS(30) / .00000000000000041E0 / DATA AM22CS(31) / .00000000000000017E0 / DATA AM22CS(32) / .00000000000000007E0 / DATA AM22CS(33) / .00000000000000002E0 / DATA ATH2CS( 1) / .00440527345871877E0 / DATA ATH2CS( 2) / -.03042919452318455E0 / DATA ATH2CS( 3) / -.00138565328377179E0 / DATA ATH2CS( 4) / -.00018044439089549E0 / DATA ATH2CS( 5) / -.00003380847108327E0 / DATA ATH2CS( 6) / -.00000767818353522E0 / DATA ATH2CS( 7) / -.00000196783944371E0 / DATA ATH2CS( 8) / -.00000054837271158E0 / DATA ATH2CS( 9) / -.00000016254615505E0 / DATA ATH2CS(10) / -.00000005053049981E0 / DATA ATH2CS(11) / -.00000001631580701E0 / DATA ATH2CS(12) / -.00000000543420411E0 / DATA ATH2CS(13) / -.00000000185739855E0 / DATA ATH2CS(14) / -.00000000064895120E0 / DATA ATH2CS(15) / -.00000000023105948E0 / DATA ATH2CS(16) / -.00000000008363282E0 / DATA ATH2CS(17) / -.00000000003071196E0 / DATA ATH2CS(18) / -.00000000001142367E0 / DATA ATH2CS(19) / -.00000000000429811E0 / DATA ATH2CS(20) / -.00000000000163389E0 / DATA ATH2CS(21) / -.00000000000062693E0 / DATA ATH2CS(22) / -.00000000000024260E0 / DATA ATH2CS(23) / -.00000000000009461E0 / DATA ATH2CS(24) / -.00000000000003716E0 / DATA ATH2CS(25) / -.00000000000001469E0 / DATA ATH2CS(26) / -.00000000000000584E0 / DATA ATH2CS(27) / -.00000000000000233E0 / DATA ATH2CS(28) / -.00000000000000093E0 / DATA ATH2CS(29) / -.00000000000000037E0 / DATA ATH2CS(30) / -.00000000000000015E0 / DATA ATH2CS(31) / -.00000000000000006E0 / DATA ATH2CS(32) / -.00000000000000002E0 / DATA PI4 / 0.78539816339744831E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT R9AIMP if (FIRST) THEN ETA = 0.1*R1MACH(3) NAM21 = INITS (AM21CS, 40, ETA) NATH1 = INITS (ATH1CS, 36, ETA) NAM22 = INITS (AM22CS, 33, ETA) NATH2 = INITS (ATH2CS, 32, ETA) ! XSML = -1.0/R1MACH(3)**0.3333 end if FIRST = .FALSE. ! if (X >= (-2.0)) go to 20 Z = 1.0 if (X > XSML) Z = 16.0/X**3 + 1.0 AMPL = 0.3125 + CSEVL(Z, AM21CS, NAM21) THETA = -0.625 + CSEVL (Z, ATH1CS, NATH1) go to 30 ! 20 if (X > (-1.0)) call XERMSG ('SLATEC', 'R9AIMP', & 'X MUST BE LE -1.0', 1, 2) ! Z = (16.0/X**3 + 9.0)/7.0 AMPL = 0.3125 + CSEVL (Z, AM22CS, NAM22) THETA = -0.625 + CSEVL (Z, ATH2CS, NATH2) ! 30 SQRTX = SQRT(-X) AMPL = SQRT (AMPL/SQRTX) THETA = PI4 - X*SQRTX * THETA ! return end function R9ATN1 (X) ! !! R9ATN1 evaluates ATAN(X) from first order relative accuracy so that ... ! ATAN(X) = X + X**3*R9ATN1(X). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE SINGLE PRECISION (R9ATN1-S, D9ATN1-D) !***KEYWORDS ARC TANGENT, ELEMENTARY FUNCTIONS, FIRST ORDER, FNLIB, ! TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate ATAN(X) from first order, that is, evaluate ! (ATAN(X)-X)/X**3 with relative error accuracy so that ! ATAN(X) = X + X**3*R9ATN1(X). ! ! Series for ATN1 on the interval 0. to 1.00000D+00 ! with weighted error 2.21E-17 ! log weighted error 16.66 ! significant figures required 15.44 ! decimal places required 17.32 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 780401 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE R9ATN1 DIMENSION ATN1CS(21) LOGICAL FIRST SAVE ATN1CS, NTATN1, XSML, XBIG, XMAX, FIRST DATA ATN1CS( 1) / -.03283997535355202E0 / DATA ATN1CS( 2) / .05833432343172412E0 / DATA ATN1CS( 3) / -.00740036969671964E0 / DATA ATN1CS( 4) / .00100978419933728E0 / DATA ATN1CS( 5) / -.00014397871635652E0 / DATA ATN1CS( 6) / .00002114512648992E0 / DATA ATN1CS( 7) / -.00000317232107425E0 / DATA ATN1CS( 8) / .00000048366203654E0 / DATA ATN1CS( 9) / -.00000007467746546E0 / DATA ATN1CS(10) / .00000001164800896E0 / DATA ATN1CS(11) / -.00000000183208837E0 / DATA ATN1CS(12) / .00000000029019082E0 / DATA ATN1CS(13) / -.00000000004623885E0 / DATA ATN1CS(14) / .00000000000740552E0 / DATA ATN1CS(15) / -.00000000000119135E0 / DATA ATN1CS(16) / .00000000000019240E0 / DATA ATN1CS(17) / -.00000000000003118E0 / DATA ATN1CS(18) / .00000000000000506E0 / DATA ATN1CS(19) / -.00000000000000082E0 / DATA ATN1CS(20) / .00000000000000013E0 / DATA ATN1CS(21) / -.00000000000000002E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT R9ATN1 if (FIRST) THEN EPS = R1MACH(3) NTATN1 = INITS (ATN1CS, 21, 0.1*EPS) ! XSML = SQRT (0.1*EPS) XBIG = 1.571/SQRT(EPS) XMAX = 1.571/EPS end if FIRST = .FALSE. ! Y = ABS(X) if (Y > 1.0) go to 20 ! if (Y <= XSML) R9ATN1 = -1.0/3.0 if (Y <= XSML) RETURN ! R9ATN1 = -0.25 + CSEVL (2.0*Y*Y-1., ATN1CS, NTATN1) return ! 20 if (Y > XMAX) call XERMSG ('SLATEC', 'R9ATN1', & 'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 2, 2) if (Y > XBIG) call XERMSG ('SLATEC', 'R9ATN1', & 'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 1, 1) ! R9ATN1 = (ATAN(X) - X) / X**3 return ! end function R9CHU (A, B, Z) ! !! R9CHU evaluates for large Z Z**A * U(A,B,Z) where U is the logarithmic ... ! confluent hypergeometric function. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C11 !***TYPE SINGLE PRECISION (R9CHU-S, D9CHU-D) !***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate for large Z Z**A * U(A,B,Z) where U is the logarithmic ! confluent hypergeometric function. A rational approximation due to Y. ! L. Luke is used. When U is not in the asymptotic region, i.e., when A ! or B is large compared with Z, considerable significance loss occurs. ! A warning is provided when the computed result is less than half ! precision. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE R9CHU DIMENSION AA(4), BB(4) LOGICAL FIRST SAVE EPS, SQEPS, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT R9CHU if (FIRST) THEN EPS = 4.0*R1MACH(4) SQEPS = SQRT (R1MACH(4)) end if FIRST = .FALSE. ! BP = 1.0 + A - B AB = A*BP CT2 = 2.0*(Z-AB) SAB = A + BP ! BB(1) = 1.0 AA(1) = 1.0 ! CT3 = SAB + 1.0 + AB BB(2) = 1.0 + 2.0*Z/CT3 AA(2) = 1.0 + CT2/CT3 ! ANBN = CT3 + SAB + 3.0 CT1 = 1.0 + 2.0*Z/ANBN BB(3) = 1.0 + 6.0*CT1*Z/CT3 AA(3) = 1.0 + 6.0*AB/ANBN + 3.0*CT1*CT2/CT3 ! DO 30 I=4,300 X2I1 = 2*I - 3 CT1 = X2I1/(X2I1-2.0) ANBN = ANBN + X2I1 + SAB CT2 = (X2I1 - 1.0) / ANBN C2 = X2I1*CT2 - 1.0 D1Z = X2I1*2.0*Z/ANBN ! CT3 = SAB*CT2 G1 = D1Z + CT1*(C2+CT3) G2 = D1Z - C2 G3 = CT1*(1.0 - CT3 - 2.0*CT2) ! BB(4) = G1*BB(3) + G2*BB(2) + G3*BB(1) AA(4) = G1*AA(3) + G2*AA(2) + G3*AA(1) if (ABS(AA(4)*BB(1)-AA(1)*BB(4)) < EPS*ABS(BB(4)*BB(1))) & go to 40 ! ! if OVERFLOWS OR UNDERFLOWS PROVE TO BE A PROBLEM, THE STATEMENTS ! BELOW COULD BE ALTERED TO INCORPORATE A DYNAMICALLY ADJUSTED SCALE ! FACTOR. ! DO 20 J=1,3 BB(J) = BB(J+1) AA(J) = AA(J+1) 20 CONTINUE 30 CONTINUE call XERMSG ('SLATEC', 'R9CHU', 'NO CONVERGENCE IN 300 TERMS', 1, & 2) ! 40 R9CHU = AA(4)/BB(4) ! if (R9CHU < SQEPS .OR. R9CHU > 1.0/SQEPS) call XERMSG & ('SLATEC', 'R9CHU', 'ANSWER LESS THAN HALF PRECISION', 2, 1) ! return end function R9GMIC (A, X, ALX) ! !! R9GMIC computes the complementary incomplete Gamma function for A ... ! near a negative integer and for small X. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE SINGLE PRECISION (R9GMIC-S, D9GMIC-D) !***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, ! SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute the complementary incomplete gamma function for A near ! a negative integer and for small X. ! !***REFERENCES (NONE) !***ROUTINES CALLED ALNGAM, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE R9GMIC SAVE EULER, EPS, BOT DATA EULER / .5772156649015329E0 / DATA EPS, BOT / 2*0.0 / !***FIRST EXECUTABLE STATEMENT R9GMIC if (EPS == 0.0) EPS = 0.5*R1MACH(3) if (BOT == 0.0) BOT = LOG(R1MACH(1)) ! if (A > 0.0) call XERMSG ('SLATEC', 'R9GMIC', & 'A MUST BE NEAR A NEGATIVE INTEGER', 2, 2) if (X <= 0.0) call XERMSG ('SLATEC', 'R9GMIC', & 'X MUST BE GT ZERO', 3, 2) ! MA = A - 0.5 FM = -MA M = -MA ! TE = 1.0 T = 1.0 S = T DO 20 K=1,200 FKP1 = K + 1 TE = -X*TE/(FM+FKP1) T = TE/FKP1 S = S + T if (ABS(T) < EPS*S) go to 30 20 CONTINUE call XERMSG ('SLATEC', 'R9GMIC', & 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 4, 2) ! 30 R9GMIC = -ALX - EULER + X*S/(FM+1.0) if (M == 0) RETURN ! if (M == 1) R9GMIC = -R9GMIC - 1.0 + 1.0/X if (M == 1) RETURN ! TE = FM T = 1.0 S = T MM1 = M - 1 DO 40 K=1,MM1 FK = K TE = -X*TE/FK T = TE/(FM-FK) S = S + T if (ABS(T) < EPS*ABS(S)) go to 50 40 CONTINUE ! 50 DO 60 K=1,M R9GMIC = R9GMIC + 1.0/K 60 CONTINUE ! SGNG = 1.0 if (MOD(M,2) == 1) SGNG = -1.0 ALNG = LOG(R9GMIC) - ALNGAM(FM+1.0) ! R9GMIC = 0.0 if (ALNG > BOT) R9GMIC = SGNG*EXP(ALNG) if (S /= 0.0) R9GMIC = R9GMIC + SIGN (EXP(-FM*ALX+LOG(ABS(S)/FM)) & , S) ! if (R9GMIC == 0.0 .AND. S == 0.0) call XERMSG ('SLATEC', & 'R9GMIC', 'RESULT UNDERFLOWS', 1, 1) return ! end function R9GMIT (A, X, ALGAP1, SGNGAM, ALX) ! !! R9GMIT computes Tricomi's incomplete Gamma function for small arguments. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE SINGLE PRECISION (R9GMIT-S, D9GMIT-D) !***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, ! SPECIAL FUNCTIONS, TRICOMI !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute Tricomi's incomplete gamma function for small X. ! !***REFERENCES (NONE) !***ROUTINES CALLED ALNGAM, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE R9GMIT SAVE EPS, BOT DATA EPS, BOT / 2*0.0 / !***FIRST EXECUTABLE STATEMENT R9GMIT if (EPS == 0.0) EPS = 0.5*R1MACH(3) if (BOT == 0.0) BOT = LOG(R1MACH(1)) ! if (X <= 0.0) call XERMSG ('SLATEC', 'R9GMIT', & 'X SHOULD BE GT 0', 1, 2) ! MA = A + 0.5 if (A < 0.0) MA = A - 0.5 AEPS = A - MA ! AE = A if (A < (-0.5)) AE = AEPS ! T = 1.0 TE = AE S = T DO 20 K=1,200 FK = K TE = -X*TE/FK T = TE/(AE+FK) S = S + T if (ABS(T) < EPS*ABS(S)) go to 30 20 CONTINUE call XERMSG ('SLATEC', 'R9GMIT', & 'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2) ! 30 if (A >= (-0.5)) ALGS = -ALGAP1 + LOG(S) if (A >= (-0.5)) go to 60 ! ALGS = -ALNGAM(1.0+AEPS) + LOG(S) S = 1.0 M = -MA - 1 if (M == 0) go to 50 T = 1.0 DO 40 K=1,M T = X*T/(AEPS-M-1+K) S = S + T if (ABS(T) < EPS*ABS(S)) go to 50 40 CONTINUE ! 50 R9GMIT = 0.0 ALGS = -MA*LOG(X) + ALGS if (S == 0.0 .OR. AEPS == 0.0) go to 60 ! SGNG2 = SGNGAM*SIGN(1.0,S) ALG2 = -X - ALGAP1 + LOG(ABS(S)) ! if (ALG2 > BOT) R9GMIT = SGNG2*EXP(ALG2) if (ALGS > BOT) R9GMIT = R9GMIT + EXP(ALGS) return ! 60 R9GMIT = EXP(ALGS) return ! end subroutine R9KNUS (XNU, X, BKNU, BKNU1, ISWTCH) ! !! R9KNUS: Bessel functions EXP(X)*K-SUB-XNU(X) and EXP(X)*K-SUB-XNU+1(X) ... ! for 0.0 <= XNU < 1.0. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C10B3 !***TYPE SINGLE PRECISION (R9KNUS-S, D9KNUS-D) !***KEYWORDS BESSEL FUNCTION, FNLIB, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute Bessel functions EXP(X) * K-sub-XNU (X) and ! EXP(X) * K-sub-XNU+1 (X) for 0.0 <= XNU < 1.0 . ! ! Series for C0K on the interval 0. to 2.50000D-01 ! with weighted error 1.60E-17 ! log weighted error 16.79 ! significant figures required 15.99 ! decimal places required 17.40 ! ! Series for ZNU1 on the interval -7.00000D-01 to 0. ! with weighted error 1.43E-17 ! log weighted error 16.85 ! significant figures required 16.08 ! decimal places required 17.38 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, GAMMA, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) ! 900727 Added EXTERNAL statement. (WRB) ! 920618 Removed space from variable names. (RWC, WRB) !***END PROLOGUE R9KNUS DIMENSION ALPHA(15), BETA(15), A(15), C0KCS(16), ZNU1CS(12) LOGICAL FIRST EXTERNAL GAMMA SAVE C0KCS, ZNU1CS, EULER, SQPI2, ALN2, NTC0K, NTZNU1, & XNUSML, XSML, ALNSML, ALNBIG, ALNEPS, FIRST DATA C0KCS( 1) / .060183057242626108E0 / DATA C0KCS( 2) / -.15364871433017286E0 / DATA C0KCS( 3) / -.011751176008210492E0 / DATA C0KCS( 4) / -.000852487888919795E0 / DATA C0KCS( 5) / -.000061329838767496E0 / DATA C0KCS( 6) / -.000004405228124551E0 / DATA C0KCS( 7) / -.000000316312467283E0 / DATA C0KCS( 8) / -.000000022710719382E0 / DATA C0KCS( 9) / -.000000001630564460E0 / DATA C0KCS(10) / -.000000000117069392E0 / DATA C0KCS(11) / -.000000000008405206E0 / DATA C0KCS(12) / -.000000000000603466E0 / DATA C0KCS(13) / -.000000000000043326E0 / DATA C0KCS(14) / -.000000000000003110E0 / DATA C0KCS(15) / -.000000000000000223E0 / DATA C0KCS(16) / -.000000000000000016E0 / DATA ZNU1CS( 1) / .20330675699419173E0 / DATA ZNU1CS( 2) / .14007793341321977E0 / DATA ZNU1CS( 3) / .007916796961001613E0 / DATA ZNU1CS( 4) / .000339801182532104E0 / DATA ZNU1CS( 5) / .000011741975688989E0 / DATA ZNU1CS( 6) / .000000339357570612E0 / DATA ZNU1CS( 7) / .000000008425941769E0 / DATA ZNU1CS( 8) / .000000000183336677E0 / DATA ZNU1CS( 9) / .000000000003549698E0 / DATA ZNU1CS(10) / .000000000000061903E0 / DATA ZNU1CS(11) / .000000000000000981E0 / DATA ZNU1CS(12) / .000000000000000014E0 / DATA EULER / 0.57721566490153286E0 / DATA SQPI2 / 1.2533141373155003E0 / DATA ALN2 / 0.69314718055994531E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT R9KNUS if (FIRST) THEN NTC0K = INITS (C0KCS, 16, 0.1*R1MACH(3)) NTZNU1 = INITS (ZNU1CS, 12, 0.1*R1MACH(3)) ! XNUSML = SQRT (R1MACH(3)/8.0) XSML = 0.1*R1MACH(3) ALNSML = LOG (R1MACH(1)) ALNBIG = LOG (R1MACH(2)) ALNEPS = LOG (0.1*R1MACH(3)) end if FIRST = .FALSE. ! if (XNU < 0. .OR. XNU >= 1.0) call XERMSG ('SLATEC', & 'R9KNUS', 'XNU MUST BE GE 0 AND LT 1', 1, 2) if (X <= 0.) call XERMSG ('SLATEC', 'R9KNUS', 'X MUST BE GT 0', & 2, 2) ! ISWTCH = 0 if (X > 2.0) go to 50 ! ! X IS SMALL. COMPUTE K-SUB-XNU (X) AND THE DERIVATIVE OF K-SUB-XNU (X) ! THEN FIND K-SUB-XNU+1 (X). XNU IS REDUCED TO THE INTERVAL (-.5,+.5) ! THEN TO (0., .5), BECAUSE K OF NEGATIVE ORDER (-NU) = K OF POSITIVE ! ORDER (+NU). ! V = XNU if (XNU > 0.5) V = 1.0 - XNU ! ! CAREFULLY FIND (X/2)**XNU AND Z**XNU WHERE Z = X*X/4. ALNZ = 2.0 * (LOG(X) - ALN2) ! if (X > XNU) go to 20 if (-0.5*XNU*ALNZ-ALN2-LOG(XNU) > ALNBIG) call XERMSG & ('SLATEC', 'R9KNUS', 'X SO SMALL BESSEL K-SUB-XNU OVERFLOWS', & 3, 2) ! 20 VLNZ = V*ALNZ X2TOV = EXP (0.5*VLNZ) ZTOV = 0.0 if (VLNZ > ALNSML) ZTOV = X2TOV**2 ! A0 = 0.5*GAMMA(1.0+V) B0 = 0.5*GAMMA(1.0-V) C0 = -EULER if (ZTOV > 0.5 .AND. V > XNUSML) C0 = -0.75 + & CSEVL ((8.0*V)*V-1., C0KCS, NTC0K) ! if (ZTOV <= 0.5) ALPHA(1) = (A0-ZTOV*B0)/V if (ZTOV > 0.5) ALPHA(1) = C0 - ALNZ*(0.75 + & CSEVL (VLNZ/0.35+1.0, ZNU1CS, NTZNU1))*B0 BETA(1) = -0.5*(A0+ZTOV*B0) ! Z = 0.0 if (X > XSML) Z = 0.25*X*X NTERMS = MAX (2.0, 11.0+(8.*ALNZ-25.19-ALNEPS)/(4.28-ALNZ)) DO 30 I=2,NTERMS XI = I - 1 A0 = A0/(XI*(XI-V)) B0 = B0/(XI*(XI+V)) ALPHA(I) = (ALPHA(I-1)+2.0*XI*A0)/(XI*(XI+V)) BETA(I) = (XI-0.5*V)*ALPHA(I) - ZTOV*B0 30 CONTINUE ! BKNU = ALPHA(NTERMS) BKNUD = BETA(NTERMS) DO 40 II=2,NTERMS I = NTERMS + 1 - II BKNU = ALPHA(I) + BKNU*Z BKNUD = BETA(I) + BKNUD*Z 40 CONTINUE ! EXPX = EXP(X) BKNU = EXPX*BKNU/X2TOV ! if (-0.5*(XNU+1.)*ALNZ-2.0*ALN2 > ALNBIG) ISWTCH = 1 if (ISWTCH == 1) RETURN BKNUD = EXPX*BKNUD*2.0/(X2TOV*X) ! if (XNU <= 0.5) BKNU1 = V*BKNU/X - BKNUD if (XNU <= 0.5) RETURN ! BKNU0 = BKNU BKNU = -V*BKNU/X - BKNUD BKNU1 = 2.0*XNU*BKNU/X + BKNU0 return ! ! X IS LARGE. FIND K-SUB-XNU (X) AND K-SUB-XNU+1 (X) WITH Y. L. LUKE-S ! RATIONAL EXPANSION. ! 50 SQRTX = SQRT(X) if (X > 1.0/XSML) go to 90 AN = -1.56 + 4.0/X BN = -0.29 - 0.22/X NTERMS = MIN (15, MAX1 (3.0, AN+BN*ALNEPS)) ! DO 80 INU=1,2 XMU = 0. if (INU == 1 .AND. XNU > XNUSML) XMU = (4.0*XNU)*XNU if (INU == 2) XMU = 4.0*(ABS(XNU)+1.)**2 ! A(1) = 1.0 - XMU A(2) = 9.0 - XMU A(3) = 25.0 - XMU if (A(2) == 0.) RESULT = SQPI2*(16.*X+XMU+7.)/(16.*X*SQRTX) if (A(2) == 0.) go to 70 ! ALPHA(1) = 1.0 ALPHA(2) = (16.*X+A(2))/A(2) ALPHA(3) = ((768.*X+48.*A(3))*X + A(2)*A(3))/(A(2)*A(3)) ! BETA(1) = 1.0 BETA(2) = (16.*X+(XMU+7.))/A(2) BETA(3) = ((768.*X+48.*(XMU+23.))*X + ((XMU+62.)*XMU+129.)) & / (A(2)*A(3)) ! if (NTERMS < 4) go to 65 DO 60 I=4,NTERMS N = I - 1 X2N = 2*N - 1 ! A(I) = (X2N+2.)**2 - XMU QQ = 16.*X2N/A(I) P1 = -X2N*(12*N*N-20*N-A(1))/((X2N-2.)*A(I)) - QQ*X P2 = (12*N*N-28*N+8-A(1))/A(I) - QQ*X P3 = -X2N*A(I-3)/((X2N-2.)*A(I)) ! ALPHA(I) = -P1*ALPHA(I-1) - P2*ALPHA(I-2) - P3*ALPHA(I-3) BETA(I) = -P1*BETA(I-1) - P2*BETA(I-2) - P3*BETA(I-3) 60 CONTINUE ! 65 RESULT = SQPI2*BETA(NTERMS)/(SQRTX*ALPHA(NTERMS)) ! 70 if (INU == 1) BKNU = RESULT if (INU == 2) BKNU1 = RESULT 80 CONTINUE return ! 90 BKNU = SQPI2/SQRTX BKNU1 = BKNU return ! end function R9LGIC (A, X, ALX) ! !! R9LGIC computes the log complementary incomplete Gamma function ... ! for large X and for A <= X. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE SINGLE PRECISION (R9LGIC-S, D9LGIC-D) !***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X, ! LOGARITHM, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute the log complementary incomplete gamma function for large X ! and for A <= X. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE R9LGIC SAVE EPS DATA EPS / 0.0 / !***FIRST EXECUTABLE STATEMENT R9LGIC if (EPS == 0.0) EPS = 0.5*R1MACH(3) ! XPA = X + 1.0 - A XMA = X - 1.0 - A ! R = 0.0 P = 1.0 S = P DO 10 K=1,200 FK = K T = FK*(A-FK)*(1.0+R) R = -T/((XMA+2.0*FK)*(XPA+2.0*FK)+T) P = R*P S = S + P if (ABS(P) < EPS*S) go to 20 10 CONTINUE call XERMSG ('SLATEC', 'R9LGIC', & 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 1, 2) ! 20 R9LGIC = A*ALX - X + LOG(S/XPA) ! return end function R9LGIT (A, X, ALGAP1) ! !! R9LGIT computes the logarithm of Tricomi's incomplete Gamma ... ! function with Perron's continued fraction for large X and ... ! A >= X. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE SINGLE PRECISION (R9LGIT-S, D9LGIT-D) !***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM, ! PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute the log of Tricomi's incomplete gamma function with Perron's ! continued fraction for large X and for A >= X. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE R9LGIT SAVE EPS, SQEPS DATA EPS, SQEPS / 2*0.0 / !***FIRST EXECUTABLE STATEMENT R9LGIT if (EPS == 0.0) EPS = 0.5*R1MACH(3) if (SQEPS == 0.0) SQEPS = SQRT(R1MACH(4)) ! if (X <= 0.0 .OR. A < X) call XERMSG ('SLATEC', 'R9LGIT', & 'X SHOULD BE GT 0.0 AND LE A', 2, 2) ! AX = A + X A1X = AX + 1.0 R = 0.0 P = 1.0 S = P DO 20 K=1,200 FK = K T = (A+FK)*X*(1.0+R) R = T/((AX+FK)*(A1X+FK)-T) P = R*P S = S + P if (ABS(P) < EPS*S) go to 30 20 CONTINUE call XERMSG ('SLATEC', 'R9LGIT', & 'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 3, 2) ! 30 HSTAR = 1.0 - X*S/A1X if (HSTAR < SQEPS) call XERMSG ('SLATEC', 'R9LGIT', & 'RESULT LESS THAN HALF PRECISION', 1, 1) ! R9LGIT = -X - ALGAP1 - LOG(HSTAR) ! return end function R9LGMC (X) ! !! R9LGMC computes the log Gamma correction factor so that ... ! LOG(GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C7E !***TYPE SINGLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) !***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, ! LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Compute the log gamma correction factor for X >= 10.0 so that ! LOG (GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X) ! ! Series for ALGM on the interval 0. to 1.00000D-02 ! with weighted error 3.40E-16 ! log weighted error 15.47 ! significant figures required 14.39 ! decimal places required 15.86 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 770801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE R9LGMC DIMENSION ALGMCS(6) LOGICAL FIRST SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST DATA ALGMCS( 1) / .166638948045186E0 / DATA ALGMCS( 2) / -.0000138494817606E0 / DATA ALGMCS( 3) / .0000000098108256E0 / DATA ALGMCS( 4) / -.0000000000180912E0 / DATA ALGMCS( 5) / .0000000000000622E0 / DATA ALGMCS( 6) / -.0000000000000003E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT R9LGMC if (FIRST) THEN NALGM = INITS (ALGMCS, 6, R1MACH(3)) XBIG = 1.0/SQRT(R1MACH(3)) XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.0*R1MACH(1))) ) end if FIRST = .FALSE. ! if (X < 10.0) call XERMSG ('SLATEC', 'R9LGMC', & 'X MUST BE GE 10', 1, 2) if (X >= XMAX) go to 20 ! R9LGMC = 1.0/(12.0*X) if (X < XBIG) R9LGMC = CSEVL (2.0*(10./X)**2-1., ALGMCS, NALGM)/X return ! 20 R9LGMC = 0.0 call XERMSG ('SLATEC', 'R9LGMC', 'X SO BIG R9LGMC UNDERFLOWS', 2, & 1) return ! end function R9LN2R (X) ! !! R9LN2R evaluates LOG(1+X) from second order relative accuracy so ... ! that LOG(1+X) = X - X**2/2 + X**3*R9LN2R(X). ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4B !***TYPE SINGLE PRECISION (R9LN2R-S, D9LN2R-D, C9LN2R-C) !***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM, SECOND ORDER !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate LOG(1+X) from 2-nd order with relative error accuracy so ! that LOG(1+X) = X - X**2/2 + X**3*R9LN2R(X) ! ! Series for LN21 on the interval -6.25000D-01 to 0. ! with weighted error 2.49E-17 ! log weighted error 16.60 ! significant figures required 15.87 ! decimal places required 17.31 ! ! Series for LN22 on the interval 0. to 8.12500D-01 ! with weighted error 1.42E-17 ! log weighted error 16.85 ! significant figures required 15.95 ! decimal places required 17.50 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 780401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900720 Routine changed from user-callable to subsidiary. (WRB) !***END PROLOGUE R9LN2R REAL LN21CS(26), LN22CS(20) LOGICAL FIRST SAVE LN21CS, LN22CS, NTLN21, NTLN22, XMIN, XBIG, XMAX, FIRST DATA LN21CS( 1) / .18111962513478810E0 / DATA LN21CS( 2) / -.15627123192872463E0 / DATA LN21CS( 3) / .028676305361557275E0 / DATA LN21CS( 4) / -.005558699655948139E0 / DATA LN21CS( 5) / .001117897665229983E0 / DATA LN21CS( 6) / -.000230805089823279E0 / DATA LN21CS( 7) / .000048598853341100E0 / DATA LN21CS( 8) / -.000010390127388903E0 / DATA LN21CS( 9) / .000002248456370739E0 / DATA LN21CS(10) / -.000000491405927392E0 / DATA LN21CS(11) / .000000108282565070E0 / DATA LN21CS(12) / -.000000024025872763E0 / DATA LN21CS(13) / .000000005362460047E0 / DATA LN21CS(14) / -.000000001202995136E0 / DATA LN21CS(15) / .000000000271078892E0 / DATA LN21CS(16) / -.000000000061323562E0 / DATA LN21CS(17) / .000000000013920858E0 / DATA LN21CS(18) / -.000000000003169930E0 / DATA LN21CS(19) / .000000000000723837E0 / DATA LN21CS(20) / -.000000000000165700E0 / DATA LN21CS(21) / .000000000000038018E0 / DATA LN21CS(22) / -.000000000000008741E0 / DATA LN21CS(23) / .000000000000002013E0 / DATA LN21CS(24) / -.000000000000000464E0 / DATA LN21CS(25) / .000000000000000107E0 / DATA LN21CS(26) / -.000000000000000024E0 / DATA LN22CS( 1) / -.22242532535020461E0 / DATA LN22CS( 2) / -.061047100108078624E0 / DATA LN22CS( 3) / .007427235009750394E0 / DATA LN22CS( 4) / -.000933501826163697E0 / DATA LN22CS( 5) / .000120049907687260E0 / DATA LN22CS( 6) / -.000015704722952820E0 / DATA LN22CS( 7) / .000002081874781051E0 / DATA LN22CS( 8) / -.000000278919557764E0 / DATA LN22CS( 9) / .000000037693558237E0 / DATA LN22CS(10) / -.000000005130902896E0 / DATA LN22CS(11) / .000000000702714117E0 / DATA LN22CS(12) / -.000000000096748595E0 / DATA LN22CS(13) / .000000000013381046E0 / DATA LN22CS(14) / -.000000000001858102E0 / DATA LN22CS(15) / .000000000000258929E0 / DATA LN22CS(16) / -.000000000000036195E0 / DATA LN22CS(17) / .000000000000005074E0 / DATA LN22CS(18) / -.000000000000000713E0 / DATA LN22CS(19) / .000000000000000100E0 / DATA LN22CS(20) / -.000000000000000014E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT R9LN2R if (FIRST) THEN EPS = R1MACH(3) NTLN21 = INITS (LN21CS, 26, 0.1*EPS) NTLN22 = INITS (LN22CS, 20, 0.1*EPS) ! XMIN = -1.0 + SQRT(R1MACH(4)) SQEPS = SQRT(EPS) TXMAX = 6.0/SQEPS XMAX = TXMAX - (EPS*TXMAX**2 - 2.0*LOG(TXMAX)) / & (2.0*EPS*TXMAX) TXBIG = 4.0/SQRT(SQEPS) XBIG = TXBIG - (SQEPS*TXBIG**2 - 2.0*LOG(TXBIG)) / & (2.*SQEPS*TXBIG) end if FIRST = .FALSE. ! if (X < (-0.625) .OR. X > 0.8125) go to 20 ! if (X < 0.0) R9LN2R = 0.375 + CSEVL (16.*X/5.+1.0, LN21CS, & NTLN21) if (X >= 0.0) R9LN2R = 0.375 + CSEVL (32.*X/13.-1.0, LN22CS, & NTLN22) return ! 20 if (X < XMIN) call XERMSG ('SLATEC', 'R9LN2R', & 'ANSWER LT HALF PRECISION BECAUSE X IS TOO NEAR -1', 1, 1) if (X > XMAX) call XERMSG ('SLATEC', 'R9LN2R', & 'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 3, 2) if (X > XBIG) call XERMSG ('SLATEC', 'R9LN2R', & 'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 2, 1) ! R9LN2R = (LOG(1.0+X) - X*(1.0-0.5*X) ) / X**3 return ! end function R9PAK (Y, N) ! !! R9PAK packs a base 2 exponent into a floating point number. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY A6B !***TYPE SINGLE PRECISION (R9PAK-S, D9PAK-D) !***KEYWORDS FNLIB, PACK !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Pack a base 2 exponent into floating point number Y. This ! routine is almost the inverse of R9UPAK. It is not exactly ! the inverse, because ABS(X) need not be between 0.5 and ! 1.0. If both R9PAK and 2.0**N were known to be in range, we ! could compute ! R9PAK = Y * 2.0**N . ! !***REFERENCES (NONE) !***ROUTINES CALLED I1MACH, R1MACH, R9UPAK, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 901009 Routine used I1MACH(7) where it should use I1MACH(10), ! Corrected (RWC) !***END PROLOGUE R9PAK LOGICAL FIRST SAVE NMIN, NMAX, A1N210, FIRST DATA A1N210 / 3.321928094887362E0/ DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT R9PAK if (FIRST) THEN A1N2B = 1.0 if (I1MACH(10) /= 2) A1N2B = R1MACH(5)*A1N210 NMIN = A1N2B*I1MACH(12) NMAX = A1N2B*I1MACH(13) end if FIRST = .FALSE. ! call R9UPAK(Y,R9PAK,NY) ! NSUM = N + NY if (NSUM < NMIN) go to 40 if (NSUM > NMAX) call XERMSG ('SLATEC', 'R9PAK', & 'PACKED NUMBER OVERFLOWS', 2, 2) ! if (NSUM == 0) RETURN if (NSUM > 0) go to 30 ! 20 R9PAK = 0.5*R9PAK NSUM = NSUM + 1 if ( NSUM /= 0) go to 20 return ! 30 R9PAK = 2.0*R9PAK NSUM = NSUM - 1 if ( NSUM /= 0) go to 30 return ! 40 call XERMSG ('SLATEC', 'R9PAK', 'PACKED NUMBER UNDERFLOWS', 1, 1) R9PAK = 0.0 return ! end subroutine R9UPAK (X, Y, N) ! !! R9UPAK unpacks a floating point number X so that X = Y*2**N. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY A6B !***TYPE SINGLE PRECISION (R9UPAK-S, D9UPAK-D) !***KEYWORDS FNLIB, UNPACK !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Unpack a floating point number X so that X = Y*2.0**N, where ! 0.5 <= ABS(Y) < 1.0. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780701 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE R9UPAK !***FIRST EXECUTABLE STATEMENT R9UPAK ABSX = ABS(X) N = 0 if (X == 0.0E0) go to 30 ! 10 if (ABSX >= 0.5E0) go to 20 N = N-1 ABSX = ABSX*2.0E0 go to 10 ! 20 if (ABSX < 1.0E0) go to 30 N = N+1 ABSX = ABSX*0.5E0 go to 20 ! 30 Y = SIGN(ABSX,X) return ! end subroutine RADB2 (IDO, L1, CC, CH, WA1) ! !! RADB2 calculates the fast Fourier transform of subvectors of length two. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (RADB2-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE RADB2 DIMENSION CC(IDO,2,*), CH(IDO,L1,2), WA1(*) !***FIRST EXECUTABLE STATEMENT RADB2 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 < L1) go to 108 DO 104 K=1,L1 !DIR$ IVDEP 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 !DIR$ IVDEP 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) == 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) ! !! RADB3 calculates the fast Fourier transform of subvectors of length three. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (RADB3-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variable TAUI by using ! FORTRAN intrinsic function SQRT instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE RADB3 DIMENSION CC(IDO,3,*), CH(IDO,L1,3), WA1(*), WA2(*) !***FIRST EXECUTABLE STATEMENT RADB3 TAUR = -.5 TAUI = .5*SQRT(3.) 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 == 1) RETURN IDP2 = IDO+2 if ( (IDO-1)/2 < L1) go to 104 DO 103 K=1,L1 !DIR$ IVDEP 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 !DIR$ IVDEP 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) ! !! RADB4 calculates the fast Fourier transform of subvectors of length four. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (RADB4-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variable SQRT2 by using ! FORTRAN intrinsic function SQRT instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE RADB4 DIMENSION CC(IDO,4,*), CH(IDO,L1,4), WA1(*), WA2(*), WA3(*) !***FIRST EXECUTABLE STATEMENT RADB4 SQRT2 = SQRT(2.) 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 < L1) go to 108 DO 104 K=1,L1 !DIR$ IVDEP 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 !DIR$ IVDEP 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) == 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) ! !! RADB5 calculates the fast Fourier transform of subvectors of length five. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (RADB5-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variables PI, TI11, TI12, ! TR11, TR12 by using FORTRAN intrinsic functions ATAN ! and SIN instead of DATA statements. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE RADB5 DIMENSION CC(IDO,5,*), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*), & WA4(*) !***FIRST EXECUTABLE STATEMENT RADB5 PI = 4.*ATAN(1.) TR11 = SIN(.1*PI) TI11 = SIN(.4*PI) TR12 = -SIN(.3*PI) TI12 = SIN(.2*PI) 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 == 1) RETURN IDP2 = IDO+2 if ( (IDO-1)/2 < L1) go to 104 DO 103 K=1,L1 !DIR$ IVDEP 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 !DIR$ IVDEP 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) ! !! RADBG calculates fast Fourier transforms of subvectors of arbitrary length. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (RADBG-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing references to intrinsic function FLOAT ! to REAL, and ! (c) changing definition of variable TPI by using ! FORTRAN intrinsic function ATAN instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE RADBG DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), & C2(IDL1,*), CH2(IDL1,*), WA(*) !***FIRST EXECUTABLE STATEMENT RADBG TPI = 8.*ATAN(1.) ARG = TPI/IP DCP = COS(ARG) DSP = SIN(ARG) IDP2 = IDO+2 NBD = (IDO-1)/2 IPP2 = IP+2 IPPH = (IP+1)/2 if (IDO < 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 == 1) go to 116 if (NBD < L1) go to 112 DO 111 J=2,IPPH JC = IPP2-J DO 110 K=1,L1 !DIR$ IVDEP 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 !DIR$ IVDEP 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 == 1) go to 132 if (NBD < L1) go to 128 DO 127 J=2,IPPH JC = IPP2-J DO 126 K=1,L1 !DIR$ IVDEP 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 == 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 > 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 !DIR$ IVDEP 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 subroutine RADF2 (IDO, L1, CC, CH, WA1) ! !! RADF2 calculates the fast Fourier transform of subvectors of length two. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (RADF2-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE RADF2 DIMENSION CH(IDO,2,*), CC(IDO,L1,2), WA1(*) !***FIRST EXECUTABLE STATEMENT RADF2 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 < L1) go to 108 DO 104 K=1,L1 !DIR$ IVDEP 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 !DIR$ IVDEP 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) == 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) ! !! RADF3 calculates the fast Fourier transform of subvectors of length three. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (RADF3-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variable TAUI by using ! FORTRAN intrinsic function SQRT instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE RADF3 DIMENSION CH(IDO,3,*), CC(IDO,L1,3), WA1(*), WA2(*) !***FIRST EXECUTABLE STATEMENT RADF3 TAUR = -.5 TAUI = .5*SQRT(3.) 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 == 1) RETURN IDP2 = IDO+2 if ( (IDO-1)/2 < L1) go to 104 DO 103 K=1,L1 !DIR$ IVDEP 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 !DIR$ IVDEP 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) ! !! RADF4 calculates the fast Fourier transform of subvectors of length four. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (RADF4-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*). ! (b) changing definition of variable HSQT2 by using ! FORTRAN intrinsic function SQRT instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE RADF4 DIMENSION CC(IDO,L1,4), CH(IDO,4,*), WA1(*), WA2(*), WA3(*) !***FIRST EXECUTABLE STATEMENT RADF4 HSQT2 = .5*SQRT(2.) 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 < L1) go to 111 DO 104 K=1,L1 !DIR$ IVDEP 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 !DIR$ IVDEP 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) == 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) ! !! RADF5 calculates the fast Fourier transform of subvectors of length five. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (RADF5-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variables PI, TI11, TI12, ! TR11, TR12 by using FORTRAN intrinsic functions ATAN ! and SIN instead of DATA statements. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE RADF5 DIMENSION CC(IDO,L1,5), CH(IDO,5,*), WA1(*), WA2(*), WA3(*), & WA4(*) !***FIRST EXECUTABLE STATEMENT RADF5 PI = 4.*ATAN(1.) TR11 = SIN(.1*PI) TI11 = SIN(.4*PI) TR12 = -SIN(.3*PI) TI12 = SIN(.2*PI) 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 == 1) RETURN IDP2 = IDO+2 if ( (IDO-1)/2 < L1) go to 104 DO 103 K=1,L1 !DIR$ IVDEP 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 !DIR$ IVDEP 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) ! !! RADFG calculates fast Fourier transform of subvectors of arbitrary length. ! !***LIBRARY SLATEC (FFTPACK) !***TYPE SINGLE PRECISION (RADFG-S) !***AUTHOR Swarztrauber, P. N., (NCAR) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing references to intrinsic function FLOAT ! to REAL, and ! (c) changing definition of variable TPI by using ! FORTRAN intrinsic function ATAN instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE RADFG DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), & C2(IDL1,*), CH2(IDL1,*), WA(*) !***FIRST EXECUTABLE STATEMENT RADFG TPI = 8.*ATAN(1.) ARG = TPI/IP DCP = COS(ARG) DSP = SIN(ARG) IPPH = (IP+1)/2 IPP2 = IP+2 IDP2 = IDO+2 NBD = (IDO-1)/2 if (IDO == 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 > 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 !DIR$ IVDEP 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 < L1) go to 115 DO 114 J=2,IPPH JC = IPP2-J DO 113 K=1,L1 !DIR$ IVDEP 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 ! 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 ! if (IDO < 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 == 1) RETURN if (NBD < L1) go to 141 DO 140 J=2,IPPH JC = IPP2-J J2 = J+J DO 139 K=1,L1 !DIR$ IVDEP 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 function RAND ( R ) ! !! RAND generates a uniformly distributed random number. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY L6A21 !***TYPE SINGLE PRECISION (RAND-S) !***KEYWORDS FNLIB, RANDOM NUMBER, SPECIAL FUNCTIONS, UNIFORM !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! This pseudo-random number generator is portable among a wide ! variety of computers. RAND(R) undoubtedly is not as good as many ! readily available installation dependent versions, and so this ! routine is not recommended for widespread usage. Its redeeming ! feature is that the exact same random numbers (to within final round- ! off error) can be generated from machine to machine. Thus, programs ! that make use of random numbers can be easily transported to and ! checked in a new environment. ! ! The random numbers are generated by the linear congruential ! method described, e.g., by Knuth in Seminumerical Methods (p.9), ! Addison-Wesley, 1969. Given the I-th number of a pseudo-random ! sequence, the I+1 -st number is generated from ! X(I+1) = (A*X(I) + C) MOD M, ! where here M = 2**22 = 4194304, C = 1731 and several suitable values ! of the multiplier A are discussed below. Both the multiplier A and ! random number X are represented in double precision as two 11-bit ! words. The constants are chosen so that the period is the maximum ! possible, 4194304. ! ! In order that the same numbers be generated from machine to ! machine, it is necessary that 23-bit integers be reducible modulo ! 2**11 exactly, that 23-bit integers be added exactly, and that 11-bit ! integers be multiplied exactly. Furthermore, if the restart option ! is used (where R is between 0 and 1), then the product R*2**22 = ! R*4194304 must be correct to the nearest integer. ! ! The first four random numbers should be .0004127026, ! .6750836372, .1614754200, and .9086198807. The tenth random number ! is .5527787209, and the hundredth is .3600893021 . The thousandth ! number should be .2176990509 . ! ! In order to generate several effectively independent sequences ! with the same generator, it is necessary to know the random number ! for several widely spaced calls. The I-th random number times 2**22, ! where I=K*P/8 and P is the period of the sequence (P = 2**22), is ! still of the form L*P/8. In particular we find the I-th random ! number multiplied by 2**22 is given by ! I = 0 1*P/8 2*P/8 3*P/8 4*P/8 5*P/8 6*P/8 7*P/8 8*P/8 ! RAND= 0 5*P/8 2*P/8 7*P/8 4*P/8 1*P/8 6*P/8 3*P/8 0 ! Thus the 4*P/8 = 2097152 random number is 2097152/2**22. ! ! Several multipliers have been subjected to the spectral test ! (see Knuth, p. 82). Four suitable multipliers roughly in order of ! goodness according to the spectral test are ! 3146757 = 1536*2048 + 1029 = 2**21 + 2**20 + 2**10 + 5 ! 2098181 = 1024*2048 + 1029 = 2**21 + 2**10 + 5 ! 3146245 = 1536*2048 + 517 = 2**21 + 2**20 + 2**9 + 5 ! 2776669 = 1355*2048 + 1629 = 5**9 + 7**7 + 1 ! ! In the table below LOG10(NU(I)) gives roughly the number of ! random decimal digits in the random numbers considered I at a time. ! C is the primary measure of goodness. In both cases bigger is better. ! ! LOG10 NU(I) C(I) ! A I=2 I=3 I=4 I=5 I=2 I=3 I=4 I=5 ! ! 3146757 3.3 2.0 1.6 1.3 3.1 1.3 4.6 2.6 ! 2098181 3.3 2.0 1.6 1.2 3.2 1.3 4.6 1.7 ! 3146245 3.3 2.2 1.5 1.1 3.2 4.2 1.1 0.4 ! 2776669 3.3 2.1 1.6 1.3 2.5 2.0 1.9 2.6 ! Best ! Possible 3.3 2.3 1.7 1.4 3.6 5.9 9.7 14.9 ! ! Input Argument -- ! R If R=0., the next random number of the sequence is generated. ! If R < 0., the last generated number will be returned for ! possible use in a restart procedure. ! If R > 0., the sequence of random numbers will start with ! the seed R mod 1. This seed is also returned as the value of ! RAND provided the arithmetic is done exactly. ! ! Output Value -- ! RAND a pseudo-random number between 0. and 1. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE RAND SAVE IA1, IA0, IA1MA0, IC, IX1, IX0 DATA IA1, IA0, IA1MA0 /1536, 1029, 507/ DATA IC /1731/ DATA IX1, IX0 /0, 0/ !***FIRST EXECUTABLE STATEMENT RAND if (R < 0.) go to 10 if (R > 0.) go to 20 ! ! A*X = 2**22*IA1*IX1 + 2**11*(IA1*IX1 + (IA1-IA0)*(IX0-IX1) ! + IA0*IX0) + IA0*IX0 ! IY0 = IA0*IX0 IY1 = IA1*IX1 + IA1MA0*(IX0-IX1) + IY0 IY0 = IY0 + IC IX0 = MOD (IY0, 2048) IY1 = IY1 + (IY0-IX0)/2048 IX1 = MOD (IY1, 2048) ! 10 RAND = IX1*2048 + IX0 RAND = RAND / 4194304. return ! 20 IX1 = MOD(R,1.)*4194304. + 0.5 IX0 = MOD (IX1, 2048) IX1 = (IX1-IX0)/2048 go to 10 ! end subroutine RATQR (N, EPS1, D, E, E2, M, W, IND, BD, TYPE, IDEF, IERR ) ! !! RATQR computes the largest or smallest eigenvalues of a symmetric... ! tridiagonal matrix using the rational QR method with Newton ! correction. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5, D4C2A !***TYPE SINGLE PRECISION (RATQR-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure RATQR, ! NUM. MATH. 11, 264-272(1968) by REINSCH and BAUER. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 257-265(1971). ! ! This subroutine finds the algebraically smallest or largest ! eigenvalues of a SYMMETRIC TRIDIAGONAL matrix by the ! rational QR method with Newton corrections. ! ! On Input ! ! N is the order of the matrix. N is an INTEGER variable. ! ! EPS1 is a theoretical absolute error tolerance for the ! computed eigenvalues. If the input EPS1 is non-positive, or ! indeed smaller than its default value, it is reset at each ! iteration to the respective default value, namely, the ! product of the relative machine precision and the magnitude ! of the current eigenvalue iterate. The theoretical absolute ! error in the K-th eigenvalue is usually not greater than ! K times EPS1. EPS1 is a REAL variable. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is ! arbitrary. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! E2 contains the squares of the corresponding elements of E in ! its last N-1 positions. E2(1) is arbitrary. E2 is a one- ! dimensional REAL array, dimensioned E2(N). ! ! M is the number of eigenvalues to be found. M is an INTEGER ! variable. ! ! IDEF should be set to 1 if the input matrix is known to be ! positive definite, to -1 if the input matrix is known to ! be negative definite, and to 0 otherwise. IDEF is an ! INTEGER variable. ! ! TYPE should be set to .TRUE. if the smallest eigenvalues are ! to be found, and to .FALSE. if the largest eigenvalues are ! to be found. TYPE is a LOGICAL variable. ! ! On Output ! ! EPS1 is unaltered unless it has been reset to its ! (last) default value. ! ! D and E are unaltered (unless W overwrites D). ! ! Elements of E2, corresponding to elements of E regarded as ! negligible, have been replaced by zero causing the matrix ! to split into a direct sum of submatrices. E2(1) is set ! to 0.0e0 if the smallest eigenvalues have been found, and ! to 2.0e0 if the largest eigenvalues have been found. E2 ! is otherwise unaltered (unless overwritten by BD). ! ! W contains the M algebraically smallest eigenvalues in ! ascending order, or the M largest eigenvalues in descending ! order. If an error exit is made because of an incorrect ! specification of IDEF, no eigenvalues are found. If the ! Newton iterates for a particular eigenvalue are not monotone, ! the best estimate obtained is returned and IERR is set. ! W is a one-dimensional REAL array, dimensioned W(N). W need ! not be distinct from D. ! ! IND contains in its first M positions the submatrix indices ! associated with the corresponding eigenvalues in W -- ! 1 for eigenvalues belonging to the first submatrix from ! the top, 2 for those belonging to the second submatrix, etc. ! IND is an one-dimensional INTEGER array, dimensioned IND(N). ! ! BD contains refined bounds for the theoretical errors of the ! corresponding eigenvalues in W. These bounds are usually ! within the tolerance specified by EPS1. BD is a one- ! dimensional REAL array, dimensioned BD(N). BD need not be ! distinct from E2. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 6*N+1 if IDEF is set to 1 and TYPE to .TRUE. ! when the matrix is NOT positive definite, or ! if IDEF is set to -1 and TYPE to .FALSE. ! when the matrix is NOT negative definite, ! no eigenvalues are computed, or ! M is greater than N, ! 5*N+K if successive iterates to the K-th eigenvalue ! are NOT monotone increasing, where K refers ! to the last such occurrence. ! ! Note that subroutine TRIDIB is generally faster and more ! accurate than RATQR if the eigenvalues are clustered. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RATQR ! INTEGER I,J,K,M,N,II,JJ,K1,IDEF,IERR,JDEF REAL D(*),E(*),E2(*),W(*),BD(*) REAL F,P,Q,R,S,EP,QP,ERR,TOT,EPS1,DELTA,MACHEP INTEGER IND(*) LOGICAL FIRST, TYPE ! SAVE FIRST, MACHEP DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT RATQR if (FIRST) THEN MACHEP = R1MACH(4) end if FIRST = .FALSE. ! IERR = 0 JDEF = IDEF ! .......... COPY D ARRAY INTO W .......... DO 20 I = 1, N 20 W(I) = D(I) ! if (TYPE) go to 40 J = 1 go to 400 40 ERR = 0.0E0 S = 0.0E0 ! .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DEFINE ! INITIAL SHIFT FROM LOWER GERSCHGORIN BOUND. ! COPY E2 ARRAY INTO BD .......... TOT = W(1) Q = 0.0E0 J = 0 ! DO 100 I = 1, N P = Q if (I == 1) go to 60 if (P > MACHEP * (ABS(D(I)) + ABS(D(I-1)))) go to 80 60 E2(I) = 0.0E0 80 BD(I) = E2(I) ! .......... COUNT ALSO if ELEMENT OF E2 HAS UNDERFLOWED .......... if (E2(I) == 0.0E0) J = J + 1 IND(I) = J Q = 0.0E0 if (I /= N) Q = ABS(E(I+1)) TOT = MIN(W(I)-P-Q,TOT) 100 CONTINUE ! if (JDEF == 1 .AND. TOT < 0.0E0) go to 140 ! DO 110 I = 1, N 110 W(I) = W(I) - TOT ! go to 160 140 TOT = 0.0E0 ! 160 DO 360 K = 1, M ! .......... NEXT QR TRANSFORMATION .......... 180 TOT = TOT + S DELTA = W(N) - S I = N F = ABS(MACHEP*TOT) if (EPS1 < F) EPS1 = F if (DELTA > EPS1) go to 190 if (DELTA < (-EPS1)) go to 1000 go to 300 ! .......... REPLACE SMALL SUB-DIAGONAL SQUARES BY ZERO ! TO REDUCE THE INCIDENCE OF UNDERFLOWS .......... 190 if (K == N) go to 210 K1 = K + 1 DO 200 J = K1, N if (BD(J) <= (MACHEP*(W(J)+W(J-1))) ** 2) BD(J) = 0.0E0 200 CONTINUE ! 210 F = BD(N) / DELTA QP = DELTA + F P = 1.0E0 if (K == N) go to 260 K1 = N - K ! .......... FOR I=N-1 STEP -1 UNTIL K DO -- .......... DO 240 II = 1, K1 I = N - II Q = W(I) - S - F R = Q / QP P = P * R + 1.0E0 EP = F * R W(I+1) = QP + EP DELTA = Q - EP if (DELTA > EPS1) go to 220 if (DELTA < (-EPS1)) go to 1000 go to 300 220 F = BD(I) / Q QP = DELTA + F BD(I+1) = QP * EP 240 CONTINUE ! 260 W(K) = QP S = QP / P if (TOT + S > TOT) go to 180 ! .......... SET ERROR -- IRREGULAR END OF ITERATION. ! DEFLATE MINIMUM DIAGONAL ELEMENT .......... IERR = 5 * N + K S = 0.0E0 DELTA = QP ! DO 280 J = K, N if (W(J) > DELTA) go to 280 I = J DELTA = W(J) 280 CONTINUE ! .......... CONVERGENCE .......... 300 if (I < N) BD(I+1) = BD(I) * F / QP II = IND(I) if (I == K) go to 340 K1 = I - K ! .......... FOR J=I-1 STEP -1 UNTIL K DO -- .......... DO 320 JJ = 1, K1 J = I - JJ W(J+1) = W(J) - S BD(J+1) = BD(J) IND(J+1) = IND(J) 320 CONTINUE ! 340 W(K) = TOT ERR = ERR + ABS(DELTA) BD(K) = ERR IND(K) = II 360 CONTINUE ! if (TYPE) go to 1001 F = BD(1) E2(1) = 2.0E0 BD(1) = F J = 2 ! .......... NEGATE ELEMENTS OF W FOR LARGEST VALUES .......... 400 DO 500 I = 1, N 500 W(I) = -W(I) ! JDEF = -JDEF go to (40,1001), J ! .......... SET ERROR -- IDEF SPECIFIED INCORRECTLY .......... 1000 IERR = 6 * N + 1 1001 RETURN end subroutine RC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER) ! !! RC3JJ evaluates the 3j symbol f(L1) = ( L1 L2 L3) ... ! (-M2-M3 M2 M3) ! for all allowed values of L1, the other parameters ! being held fixed. ! !***LIBRARY SLATEC !***CATEGORY C19 !***TYPE SINGLE PRECISION (RC3JJ-S, DRC3JJ-D) !***KEYWORDS 3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, ! RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, ! WIGNER COEFFICIENTS !***AUTHOR Gordon, R. G., Harvard University ! Schulten, K., Max Planck Institute !***DESCRIPTION ! ! *Usage: ! ! REAL L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM) ! INTEGER NDIM, IER ! ! call RC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER) ! ! *Arguments: ! ! L2 :IN Parameter in 3j symbol. ! ! L3 :IN Parameter in 3j symbol. ! ! M2 :IN Parameter in 3j symbol. ! ! M3 :IN Parameter in 3j symbol. ! ! L1MIN :OUT Smallest allowable L1 in 3j symbol. ! ! L1MAX :OUT Largest allowable L1 in 3j symbol. ! ! THRCOF :OUT Set of 3j coefficients generated by evaluating the ! 3j symbol for all allowed values of L1. THRCOF(I) ! will contain f(L1MIN+I-1), I=1,2,...,L1MAX+L1MIN+1. ! ! NDIM :IN Declared length of THRCOF in calling program. ! ! IER :OUT Error flag. ! IER=0 No errors. ! IER=1 Either L2 < ABS(M2) or L3 < ABS(M3). ! IER=2 Either L2+ABS(M2) or L3+ABS(M3) non-integer. ! IER=3 L1MAX-L1MIN not an integer. ! IER=4 L1MAX less than L1MIN. ! IER=5 NDIM less than L1MAX-L1MIN+1. ! ! *Description: ! ! Although conventionally the parameters of the vector addition ! coefficients satisfy certain restrictions, such as being integers ! or integers plus 1/2, the restrictions imposed on input to this ! subroutine are somewhat weaker. See, for example, Section 27.9 of ! Abramowitz and Stegun or Appendix C of Volume II of A. Messiah. ! The restrictions imposed by this subroutine are ! 1. L2 >= ABS(M2) and L3 >= ABS(M3); ! 2. L2+ABS(M2) and L3+ABS(M3) must be integers; ! 3. L1MAX-L1MIN must be a non-negative integer, where ! L1MAX=L2+L3 and L1MIN=MAX(ABS(L2-L3),ABS(M2+M3)). ! If the conventional restrictions are satisfied, then these ! restrictions are met. ! ! The user should be cautious in using input parameters that do ! not satisfy the conventional restrictions. For example, the ! the subroutine produces values of ! f(L1) = ( L1 2.5 5.8) ! (-0.31.5 -1.2) ! for L1=3.3,4.3,...,8.3 but none of the symmetry properties of the 3j ! symbol, set forth on page 1056 of Messiah, is satisfied. ! ! The subroutine generates f(L1MIN), f(L1MIN+1), ..., f(L1MAX) ! where L1MIN and L1MAX are defined above. The sequence f(L1) is ! generated by a three-term recurrence algorithm with scaling to ! control overflow. Both backward and forward recurrence are used to ! maintain numerical stability. The two recurrence sequences are ! matched at an interior point and are normalized from the unitary ! property of 3j coefficients and Wigner's phase convention. ! ! The algorithm is suited to applications in which large quantum ! numbers arise, such as in molecular dynamics. ! !***REFERENCES 1. Abramowitz, M., and Stegun, I. A., Eds., Handbook ! of Mathematical Functions with Formulas, Graphs ! and Mathematical Tables, NBS Applied Mathematics ! Series 55, June 1964 and subsequent printings. ! 2. Messiah, Albert., Quantum Mechanics, Volume II, ! North-Holland Publishing Company, 1963. ! 3. Schulten, Klaus and Gordon, Roy G., Exact recursive ! evaluation of 3j and 6j coefficients for quantum- ! mechanical coupling of angular momenta, J Math ! Phys, v 16, no. 10, October 1975, pp. 1961-1970. ! 4. Schulten, Klaus and Gordon, Roy G., Semiclassical ! approximations to 3j and 6j coefficients for ! quantum-mechanical coupling of angular momenta, ! J Math Phys, v 16, no. 10, October 1975, ! pp. 1971-1988. ! 5. Schulten, Klaus and Gordon, Roy G., Recursive ! evaluation of 3j and 6j coefficients, Computer ! Phys Comm, v 11, 1976, pp. 269-278. !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters ! HUGE and TINY revised to depend on R1MACH. ! 891229 Prologue description rewritten; other prologue sections ! revised; LMATCH (location of match point for recurrences) ! removed from argument list; argument IER changed to serve ! only as an error flag (previously, in cases without error, ! it returned the number of scalings); number of error codes ! increased to provide more precise error information; ! program comments revised; SLATEC error handler calls ! introduced to enable printing of error messages to meet ! SLATEC standards. These changes were done by D. W. Lozier, ! M. A. McClain and J. M. Smith of the National Institute ! of Standards and Technology, formerly NBS. ! 910415 Mixed type expressions eliminated; variable C1 initialized; ! description of THRCOF expanded. These changes were done by ! D. W. Lozier. !***END PROLOGUE RC3JJ ! INTEGER NDIM, IER REAL L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM) ! INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, & NSTEP2 REAL A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, R1MACH, & DENOM, DV, EPS, HUGE, L1, M1, NEWFAC, OLDFAC, & ONE, RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, & SUM2, SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, & TINY, TWO, X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO ! DATA ZERO,EPS,ONE,TWO,THREE /0.0,0.01,1.0,2.0,3.0/ ! !***FIRST EXECUTABLE STATEMENT RC3JJ IER=0 ! HUGE is the square root of one twentieth of the largest floating ! point number, approximately. HUGE = SQRT(R1MACH(2)/20.0) SRHUGE = SQRT(HUGE) TINY = 1.0/HUGE SRTINY = 1.0/SRHUGE ! ! LMATCH = ZERO M1 = - M2 - M3 ! ! Check error conditions 1 and 2. if ( (L2-ABS(M2)+EPS < ZERO).OR. & (L3-ABS(M3)+EPS < ZERO))THEN IER=1 call XERMSG('SLATEC','RC3JJ','L2-ABS(M2) or L3-ABS(M3) '// & 'less than zero.',IER,1) return ELSEIF((MOD(L2+ABS(M2)+EPS,ONE) >= EPS+EPS).OR. & (MOD(L3+ABS(M3)+EPS,ONE) >= EPS+EPS))THEN IER=2 call XERMSG('SLATEC','RC3JJ','L2+ABS(M2) or L3+ABS(M3) '// & 'not integer.',IER,1) return end if ! ! ! ! Limits for L1 ! L1MIN = MAX(ABS(L2-L3),ABS(M1)) L1MAX = L2 + L3 ! ! Check error condition 3. if ( MOD(L1MAX-L1MIN+EPS,ONE) >= EPS+EPS)THEN IER=3 call XERMSG('SLATEC','RC3JJ','L1MAX-L1MIN not integer.',IER,1) return end if if ( L1MIN < L1MAX-EPS) go to 20 if ( L1MIN < L1MAX+EPS) go to 10 ! ! Check error condition 4. IER=4 call XERMSG('SLATEC','RC3JJ','L1MIN greater than L1MAX.',IER,1) return ! ! This is reached in case that L1 can take only one value, ! i.e. L1MIN = L1MAX ! 10 CONTINUE ! LSCALE = 0 THRCOF(1) = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) / & SQRT(L1MIN + L2 + L3 + ONE) return ! ! This is reached in case that L1 takes more than one value, ! i.e. L1MIN < L1MAX. ! 20 CONTINUE ! LSCALE = 0 NFIN = INT(L1MAX-L1MIN+ONE+EPS) if ( NDIM-NFIN) 21, 23, 23 ! ! Check error condition 5. 21 IER = 5 call XERMSG('SLATEC','RC3JJ','Dimension of result array for 3j '// & 'coefficients too small.',IER,1) return ! ! ! Starting forward recursion from L1MIN taking NSTEP1 steps ! 23 L1 = L1MIN NEWFAC = 0.0 C1 = 0.0 THRCOF(1) = SRTINY SUM1 = (L1+L1+ONE) * TINY ! ! LSTEP = 1 30 LSTEP = LSTEP + 1 L1 = L1 + ONE ! ! OLDFAC = NEWFAC A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE) A2 = (L1+M1) * (L1-M1) NEWFAC = SQRT(A1*A2) if ( L1 < ONE+EPS) go to 40 ! ! DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2) DENOM = (L1-ONE) * NEWFAC ! if ( LSTEP-2) 32, 32, 31 ! 31 C1OLD = ABS(C1) 32 C1 = - (L1+L1-ONE) * DV / DENOM go to 50 ! ! If L1 = 1, (L1-1) has to be factored out of DV, hence ! 40 C1 = - (L1+L1-ONE) * L1 * (M3-M2) / NEWFAC ! 50 if ( LSTEP > 2) go to 60 ! ! ! If L1 = L1MIN + 1, the third term in the recursion equation vanishes, ! hence X = SRTINY * C1 THRCOF(2) = X SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1*C1 if ( LSTEP == NFIN) go to 220 go to 30 ! ! 60 C2 = - L1 * OLDFAC / DENOM ! ! Recursion to the next 3j coefficient X ! X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2) THRCOF(LSTEP) = X SUMFOR = SUM1 SUM1 = SUM1 + (L1+L1+ONE) * X*X if ( LSTEP == NFIN) go to 100 ! ! See if last unnormalized 3j coefficient exceeds SRHUGE ! if ( ABS(X) < SRHUGE) go to 80 ! ! This is reached if last 3j coefficient larger than SRHUGE, ! so that the recursion series THRCOF(1), ... , THRCOF(LSTEP) ! has to be rescaled to prevent overflow ! ! LSCALE = LSCALE + 1 DO 70 I=1,LSTEP if ( ABS(THRCOF(I)) < SRTINY) THRCOF(I) = ZERO 70 THRCOF(I) = THRCOF(I) / SRHUGE SUM1 = SUM1 / HUGE SUMFOR = SUMFOR / HUGE X = X / SRHUGE ! ! As long as ABS(C1) is decreasing, the recursion proceeds towards ! increasing 3j values and, hence, is numerically stable. Once ! an increase of ABS(C1) is detected, the recursion direction is ! reversed. ! 80 if ( C1OLD-ABS(C1)) 100, 100, 30 ! ! ! Keep three 3j coefficients around LMATCH for comparison with ! backward recursion. ! 100 CONTINUE ! LMATCH = L1 - 1 X1 = X X2 = THRCOF(LSTEP-1) X3 = THRCOF(LSTEP-2) NSTEP2 = NFIN - LSTEP + 3 ! ! ! ! ! Starting backward recursion from L1MAX taking NSTEP2 steps, so ! that forward and backward recursion overlap at three points ! L1 = LMATCH+1, LMATCH, LMATCH-1. ! NFINP1 = NFIN + 1 NFINP2 = NFIN + 2 NFINP3 = NFIN + 3 L1 = L1MAX THRCOF(NFIN) = SRTINY SUM2 = TINY * (L1+L1+ONE) ! L1 = L1 + TWO LSTEP = 1 110 LSTEP = LSTEP + 1 L1 = L1 - ONE ! OLDFAC = NEWFAC A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO) A2S = (L1+M1-ONE) * (L1-M1-ONE) NEWFAC = SQRT(A1S*A2S) ! DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2) ! DENOM = L1 * NEWFAC C1 = - (L1+L1-ONE) * DV / DENOM if ( LSTEP > 2) go to 120 ! ! If L1 = L1MAX + 1, the third term in the recursion formula vanishes ! Y = SRTINY * C1 THRCOF(NFIN-1) = Y SUMBAC = SUM2 SUM2 = SUM2 + TINY * (L1+L1-THREE) * C1*C1 ! go to 110 ! ! 120 C2 = - (L1 - ONE) * OLDFAC / DENOM ! ! Recursion to the next 3j coefficient Y ! Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP) ! if ( LSTEP == NSTEP2) go to 200 ! THRCOF(NFINP1-LSTEP) = Y SUMBAC = SUM2 SUM2 = SUM2 + (L1+L1-THREE) * Y*Y ! ! See if last unnormalized 3j coefficient exceeds SRHUGE ! if ( ABS(Y) < SRHUGE) go to 110 ! ! This is reached if last 3j coefficient larger than SRHUGE, ! so that the recursion series THRCOF(NFIN), ... ,THRCOF(NFIN-LSTEP+1) ! has to be rescaled to prevent overflow ! ! LSCALE = LSCALE + 1 DO 130 I=1,LSTEP INDEX = NFIN - I + 1 if ( ABS(THRCOF(INDEX)) < SRTINY) THRCOF(INDEX) = ZERO 130 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE SUM2 = SUM2 / HUGE SUMBAC = SUMBAC / HUGE ! ! go to 110 ! ! ! The forward recursion 3j coefficients X1, X2, X3 are to be matched ! with the corresponding backward recursion values Y1, Y2, Y3. ! 200 Y3 = Y Y2 = THRCOF(NFINP2-LSTEP) Y1 = THRCOF(NFINP3-LSTEP) ! ! ! Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds ! with minimal error. ! RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) NLIM = NFIN - NSTEP2 + 1 ! if ( ABS(RATIO) < ONE) go to 211 ! DO 210 N=1,NLIM 210 THRCOF(N) = RATIO * THRCOF(N) SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC go to 230 ! 211 NLIM = NLIM + 1 RATIO = ONE / RATIO DO 212 N=NLIM,NFIN 212 THRCOF(N) = RATIO * THRCOF(N) SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC go to 230 ! 220 SUMUNI = SUM1 ! ! ! Normalize 3j coefficients ! 230 CNORM = ONE / SQRT(SUMUNI) ! ! Sign convention for last 3j coefficient determines overall phase ! SIGN1 = SIGN(ONE,THRCOF(NFIN)) SIGN2 = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) if ( SIGN1*SIGN2) 235,235,236 235 CNORM = - CNORM ! 236 if ( ABS(CNORM) < ONE) go to 250 ! DO 240 N=1,NFIN 240 THRCOF(N) = CNORM * THRCOF(N) return ! 250 THRESH = TINY / ABS(CNORM) DO 251 N=1,NFIN if ( ABS(THRCOF(N)) < THRESH) THRCOF(N) = ZERO 251 THRCOF(N) = CNORM * THRCOF(N) ! return end subroutine RC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, IER) ! !! RC3JM evaluates the 3j symbol g(M2) = (L1 L2 L3 ) ... ! (M1 M2 -M1-M2) ! for all allowed values of M2, the other parameters ! being held fixed. ! !***LIBRARY SLATEC !***CATEGORY C19 !***TYPE SINGLE PRECISION (RC3JM-S, DRC3JM-D) !***KEYWORDS 3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, ! RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, ! WIGNER COEFFICIENTS !***AUTHOR Gordon, R. G., Harvard University ! Schulten, K., Max Planck Institute !***DESCRIPTION ! ! *Usage: ! ! REAL L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM) ! INTEGER NDIM, IER ! ! call RC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, IER) ! ! *Arguments: ! ! L1 :IN Parameter in 3j symbol. ! ! L2 :IN Parameter in 3j symbol. ! ! L3 :IN Parameter in 3j symbol. ! ! M1 :IN Parameter in 3j symbol. ! ! M2MIN :OUT Smallest allowable M2 in 3j symbol. ! ! M2MAX :OUT Largest allowable M2 in 3j symbol. ! ! THRCOF :OUT Set of 3j coefficients generated by evaluating the ! 3j symbol for all allowed values of M2. THRCOF(I) ! will contain g(M2MIN+I-1), I=1,2,...,M2MAX-M2MIN+1. ! ! NDIM :IN Declared length of THRCOF in calling program. ! ! IER :OUT Error flag. ! IER=0 No errors. ! IER=1 Either L1 < ABS(M1) or L1+ABS(M1) non-integer. ! IER=2 ABS(L1-L2) <= L3 <= L1+L2 not satisfied. ! IER=3 L1+L2+L3 not an integer. ! IER=4 M2MAX-M2MIN not an integer. ! IER=5 M2MAX less than M2MIN. ! IER=6 NDIM less than M2MAX-M2MIN+1. ! ! *Description: ! ! Although conventionally the parameters of the vector addition ! coefficients satisfy certain restrictions, such as being integers ! or integers plus 1/2, the restrictions imposed on input to this ! subroutine are somewhat weaker. See, for example, Section 27.9 of ! Abramowitz and Stegun or Appendix C of Volume II of A. Messiah. ! The restrictions imposed by this subroutine are ! 1. L1 >= ABS(M1) and L1+ABS(M1) must be an integer; ! 2. ABS(L1-L2) <= L3 <= L1+L2; ! 3. L1+L2+L3 must be an integer; ! 4. M2MAX-M2MIN must be an integer, where ! M2MAX=MIN(L2,L3-M1) and M2MIN=MAX(-L2,-L3-M1). ! If the conventional restrictions are satisfied, then these ! restrictions are met. ! ! The user should be cautious in using input parameters that do ! not satisfy the conventional restrictions. For example, the ! the subroutine produces values of ! g(M2) = (0.751.50 1.75 ) ! (0.25 M2 -0.25-M2) ! for M2=-1.5,-0.5,0.5,1.5 but none of the symmetry properties of the ! 3j symbol, set forth on page 1056 of Messiah, is satisfied. ! ! The subroutine generates g(M2MIN), g(M2MIN+1), ..., g(M2MAX) ! where M2MIN and M2MAX are defined above. The sequence g(M2) is ! generated by a three-term recurrence algorithm with scaling to ! control overflow. Both backward and forward recurrence are used to ! maintain numerical stability. The two recurrence sequences are ! matched at an interior point and are normalized from the unitary ! property of 3j coefficients and Wigner's phase convention. ! ! The algorithm is suited to applications in which large quantum ! numbers arise, such as in molecular dynamics. ! !***REFERENCES 1. Abramowitz, M., and Stegun, I. A., Eds., Handbook ! of Mathematical Functions with Formulas, Graphs ! and Mathematical Tables, NBS Applied Mathematics ! Series 55, June 1964 and subsequent printings. ! 2. Messiah, Albert., Quantum Mechanics, Volume II, ! North-Holland Publishing Company, 1963. ! 3. Schulten, Klaus and Gordon, Roy G., Exact recursive ! evaluation of 3j and 6j coefficients for quantum- ! mechanical coupling of angular momenta, J Math ! Phys, v 16, no. 10, October 1975, pp. 1961-1970. ! 4. Schulten, Klaus and Gordon, Roy G., Semiclassical ! approximations to 3j and 6j coefficients for ! quantum-mechanical coupling of angular momenta, ! J Math Phys, v 16, no. 10, October 1975, ! pp. 1971-1988. ! 5. Schulten, Klaus and Gordon, Roy G., Recursive ! evaluation of 3j and 6j coefficients, Computer ! Phys Comm, v 11, 1976, pp. 269-278. !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters ! HUGE and TINY revised to depend on R1MACH. ! 891229 Prologue description rewritten; other prologue sections ! revised; MMATCH (location of match point for recurrences) ! removed from argument list; argument IER changed to serve ! only as an error flag (previously, in cases without error, ! it returned the number of scalings); number of error codes ! increased to provide more precise error information; ! program comments revised; SLATEC error handler calls ! introduced to enable printing of error messages to meet ! SLATEC standards. These changes were done by D. W. Lozier, ! M. A. McClain and J. M. Smith of the National Institute ! of Standards and Technology, formerly NBS. ! 910415 Mixed type expressions eliminated; variable C1 initialized; ! description of THRCOF expanded. These changes were done by ! D. W. Lozier. !***END PROLOGUE RC3JM ! INTEGER NDIM, IER REAL L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM) ! INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, & NSTEP2 REAL A1, A1S, C1, C1OLD, C2, CNORM, R1MACH, DV, EPS, & HUGE, M2, M3, NEWFAC, OLDFAC, ONE, RATIO, SIGN1, & SIGN2, SRHUGE, SRTINY, SUM1, SUM2, SUMBAC, & SUMFOR, SUMUNI, THRESH, TINY, TWO, X, X1, X2, X3, & Y, Y1, Y2, Y3, ZERO ! DATA ZERO,EPS,ONE,TWO /0.0,0.01,1.0,2.0/ ! !***FIRST EXECUTABLE STATEMENT RC3JM IER=0 ! HUGE is the square root of one twentieth of the largest floating ! point number, approximately. HUGE = SQRT(R1MACH(2)/20.0) SRHUGE = SQRT(HUGE) TINY = 1.0/HUGE SRTINY = 1.0/SRHUGE ! ! MMATCH = ZERO ! ! ! Check error conditions 1, 2, and 3. if ( (L1-ABS(M1)+EPS < ZERO).OR. & (MOD(L1+ABS(M1)+EPS,ONE) >= EPS+EPS))THEN IER=1 call XERMSG('SLATEC','RC3JM','L1-ABS(M1) less than zero or '// & 'L1+ABS(M1) not integer.',IER,1) return ELSEIF((L1+L2-L3 < -EPS).OR.(L1-L2+L3 < -EPS).OR. & (-L1+L2+L3 < -EPS))THEN IER=2 call XERMSG('SLATEC','RC3JM','L1, L2, L3 do not satisfy '// & 'triangular condition.',IER,1) return ELSEIF(MOD(L1+L2+L3+EPS,ONE) >= EPS+EPS)THEN IER=3 call XERMSG('SLATEC','RC3JM','L1+L2+L3 not integer.',IER,1) return end if ! ! ! Limits for M2 M2MIN = MAX(-L2,-L3-M1) M2MAX = MIN(L2,L3-M1) ! ! Check error condition 4. if ( MOD(M2MAX-M2MIN+EPS,ONE) >= EPS+EPS)THEN IER=4 call XERMSG('SLATEC','RC3JM','M2MAX-M2MIN not integer.',IER,1) return end if if ( M2MIN < M2MAX-EPS) go to 20 if ( M2MIN < M2MAX+EPS) go to 10 ! ! Check error condition 5. IER=5 call XERMSG('SLATEC','RC3JM','M2MIN greater than M2MAX.',IER,1) return ! ! ! This is reached in case that M2 and M3 can take only one value. 10 CONTINUE ! MSCALE = 0 THRCOF(1) = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) / & SQRT(L1+L2+L3+ONE) return ! ! This is reached in case that M1 and M2 take more than one value. 20 CONTINUE ! MSCALE = 0 NFIN = INT(M2MAX-M2MIN+ONE+EPS) if ( NDIM-NFIN) 21, 23, 23 ! ! Check error condition 6. 21 IER = 6 call XERMSG('SLATEC','RC3JM','Dimension of result array for 3j '// & 'coefficients too small.',IER,1) return ! ! ! ! Start of forward recursion from M2 = M2MIN ! 23 M2 = M2MIN THRCOF(1) = SRTINY NEWFAC = 0.0 C1 = 0.0 SUM1 = TINY ! ! LSTEP = 1 30 LSTEP = LSTEP + 1 M2 = M2 + ONE M3 = - M1 - M2 ! ! OLDFAC = NEWFAC A1 = (L2-M2+ONE) * (L2+M2) * (L3+M3+ONE) * (L3-M3) NEWFAC = SQRT(A1) ! ! DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE) & - (L2+M2-ONE)*(L3-M3-ONE) ! if ( LSTEP-2) 32, 32, 31 ! 31 C1OLD = ABS(C1) 32 C1 = - DV / NEWFAC ! if ( LSTEP > 2) go to 60 ! ! ! If M2 = M2MIN + 1, the third term in the recursion equation vanishes, ! hence ! X = SRTINY * C1 THRCOF(2) = X SUM1 = SUM1 + TINY * C1*C1 if ( LSTEP == NFIN) go to 220 go to 30 ! ! 60 C2 = - OLDFAC / NEWFAC ! ! Recursion to the next 3j coefficient X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2) THRCOF(LSTEP) = X SUMFOR = SUM1 SUM1 = SUM1 + X*X if ( LSTEP == NFIN) go to 100 ! ! See if last unnormalized 3j coefficient exceeds SRHUGE ! if ( ABS(X) < SRHUGE) go to 80 ! ! This is reached if last 3j coefficient larger than SRHUGE, ! so that the recursion series THRCOF(1), ... , THRCOF(LSTEP) ! has to be rescaled to prevent overflow ! ! MSCALE = MSCALE + 1 DO 70 I=1,LSTEP if ( ABS(THRCOF(I)) < SRTINY) THRCOF(I) = ZERO 70 THRCOF(I) = THRCOF(I) / SRHUGE SUM1 = SUM1 / HUGE SUMFOR = SUMFOR / HUGE X = X / SRHUGE ! ! ! As long as ABS(C1) is decreasing, the recursion proceeds towards ! increasing 3j values and, hence, is numerically stable. Once ! an increase of ABS(C1) is detected, the recursion direction is ! reversed. ! 80 if ( C1OLD-ABS(C1)) 100, 100, 30 ! ! ! Keep three 3j coefficients around MMATCH for comparison later ! with backward recursion values. ! 100 CONTINUE ! MMATCH = M2 - 1 NSTEP2 = NFIN - LSTEP + 3 X1 = X X2 = THRCOF(LSTEP-1) X3 = THRCOF(LSTEP-2) ! ! Starting backward recursion from M2MAX taking NSTEP2 steps, so ! that forwards and backwards recursion overlap at the three points ! M2 = MMATCH+1, MMATCH, MMATCH-1. ! NFINP1 = NFIN + 1 NFINP2 = NFIN + 2 NFINP3 = NFIN + 3 THRCOF(NFIN) = SRTINY SUM2 = TINY ! ! ! M2 = M2MAX + TWO LSTEP = 1 110 LSTEP = LSTEP + 1 M2 = M2 - ONE M3 = - M1 - M2 OLDFAC = NEWFAC A1S = (L2-M2+TWO) * (L2+M2-ONE) * (L3+M3+TWO) * (L3-M3-ONE) NEWFAC = SQRT(A1S) DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE) & - (L2+M2-ONE)*(L3-M3-ONE) C1 = - DV / NEWFAC if ( LSTEP > 2) go to 120 ! ! If M2 = M2MAX + 1 the third term in the recursion equation vanishes ! Y = SRTINY * C1 THRCOF(NFIN-1) = Y if ( LSTEP == NSTEP2) go to 200 SUMBAC = SUM2 SUM2 = SUM2 + Y*Y go to 110 ! 120 C2 = - OLDFAC / NEWFAC ! ! Recursion to the next 3j coefficient ! Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP) ! if ( LSTEP == NSTEP2) go to 200 ! THRCOF(NFINP1-LSTEP) = Y SUMBAC = SUM2 SUM2 = SUM2 + Y*Y ! ! ! See if last 3j coefficient exceeds SRHUGE ! if ( ABS(Y) < SRHUGE) go to 110 ! ! This is reached if last 3j coefficient larger than SRHUGE, ! so that the recursion series THRCOF(NFIN), ... , THRCOF(NFIN-LSTEP+1) ! has to be rescaled to prevent overflow. ! ! MSCALE = MSCALE + 1 DO 111 I=1,LSTEP INDEX = NFIN - I + 1 if ( ABS(THRCOF(INDEX)) < SRTINY) & THRCOF(INDEX) = ZERO 111 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE SUM2 = SUM2 / HUGE SUMBAC = SUMBAC / HUGE ! go to 110 ! ! ! ! The forward recursion 3j coefficients X1, X2, X3 are to be matched ! with the corresponding backward recursion values Y1, Y2, Y3. ! 200 Y3 = Y Y2 = THRCOF(NFINP2-LSTEP) Y1 = THRCOF(NFINP3-LSTEP) ! ! ! Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds ! with minimal error. ! RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) NLIM = NFIN - NSTEP2 + 1 ! if ( ABS(RATIO) < ONE) go to 211 ! DO 210 N=1,NLIM 210 THRCOF(N) = RATIO * THRCOF(N) SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC go to 230 ! 211 NLIM = NLIM + 1 RATIO = ONE / RATIO DO 212 N=NLIM,NFIN 212 THRCOF(N) = RATIO * THRCOF(N) SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC go to 230 ! 220 SUMUNI = SUM1 ! ! ! Normalize 3j coefficients ! 230 CNORM = ONE / SQRT((L1+L1+ONE) * SUMUNI) ! ! Sign convention for last 3j coefficient determines overall phase ! SIGN1 = SIGN(ONE,THRCOF(NFIN)) SIGN2 = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) if ( SIGN1*SIGN2) 235,235,236 235 CNORM = - CNORM ! 236 if ( ABS(CNORM) < ONE) go to 250 ! DO 240 N=1,NFIN 240 THRCOF(N) = CNORM * THRCOF(N) return ! 250 THRESH = TINY / ABS(CNORM) DO 251 N=1,NFIN if ( ABS(THRCOF(N)) < THRESH) THRCOF(N) = ZERO 251 THRCOF(N) = CNORM * THRCOF(N) ! ! ! return end subroutine RC6J (L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, & IER) ! !! RC6J evaluates the 6j symbol h(L1) = {L1 L2 L3} ... ! {L4 L5 L6} ! for all allowed values of L1, the other parameters ! being held fixed. ! !***LIBRARY SLATEC !***CATEGORY C19 !***TYPE SINGLE PRECISION (RC6J-S, DRC6J-D) !***KEYWORDS 6J COEFFICIENTS, 6J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, ! RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, ! WIGNER COEFFICIENTS !***AUTHOR Gordon, R. G., Harvard University ! Schulten, K., Max Planck Institute !***DESCRIPTION ! ! *Usage: ! ! REAL L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) ! INTEGER NDIM, IER ! ! call RC6J(L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, IER) ! ! *Arguments: ! ! L2 :IN Parameter in 6j symbol. ! ! L3 :IN Parameter in 6j symbol. ! ! L4 :IN Parameter in 6j symbol. ! ! L5 :IN Parameter in 6j symbol. ! ! L6 :IN Parameter in 6j symbol. ! ! L1MIN :OUT Smallest allowable L1 in 6j symbol. ! ! L1MAX :OUT Largest allowable L1 in 6j symbol. ! ! SIXCOF :OUT Set of 6j coefficients generated by evaluating the ! 6j symbol for all allowed values of L1. SIXCOF(I) ! will contain h(L1MIN+I-1), I=1,2,...,L1MAX-L1MIN+1. ! ! NDIM :IN Declared length of SIXCOF in calling program. ! ! IER :OUT Error flag. ! IER=0 No errors. ! IER=1 L2+L3+L5+L6 or L4+L2+L6 not an integer. ! IER=2 L4, L2, L6 triangular condition not satisfied. ! IER=3 L4, L5, L3 triangular condition not satisfied. ! IER=4 L1MAX-L1MIN not an integer. ! IER=5 L1MAX less than L1MIN. ! IER=6 NDIM less than L1MAX-L1MIN+1. ! ! *Description: ! ! The definition and properties of 6j symbols can be found, for ! example, in Appendix C of Volume II of A. Messiah. Although the ! parameters of the vector addition coefficients satisfy certain ! conventional restrictions, the restriction that they be non-negative ! integers or non-negative integers plus 1/2 is not imposed on input ! to this subroutine. The restrictions imposed are ! 1. L2+L3+L5+L6 and L2+L4+L6 must be integers; ! 2. ABS(L2-L4) <= L6 <= L2+L4 must be satisfied; ! 3. ABS(L4-L5) <= L3 <= L4+L5 must be satisfied; ! 4. L1MAX-L1MIN must be a non-negative integer, where ! L1MAX=MIN(L2+L3,L5+L6) and L1MIN=MAX(ABS(L2-L3),ABS(L5-L6)). ! If all the conventional restrictions are satisfied, then these ! restrictions are met. Conversely, if input to this subroutine meets ! all of these restrictions and the conventional restriction stated ! above, then all the conventional restrictions are satisfied. ! ! The user should be cautious in using input parameters that do ! not satisfy the conventional restrictions. For example, the ! the subroutine produces values of ! h(L1) = { L12/3 1 } ! {2/32/32/3} ! for L1=1/3 and 4/3 but none of the symmetry properties of the 6j ! symbol, set forth on pages 1063 and 1064 of Messiah, is satisfied. ! ! The subroutine generates h(L1MIN), h(L1MIN+1), ..., h(L1MAX) ! where L1MIN and L1MAX are defined above. The sequence h(L1) is ! generated by a three-term recurrence algorithm with scaling to ! control overflow. Both backward and forward recurrence are used to ! maintain numerical stability. The two recurrence sequences are ! matched at an interior point and are normalized from the unitary ! property of 6j coefficients and Wigner's phase convention. ! ! The algorithm is suited to applications in which large quantum ! numbers arise, such as in molecular dynamics. ! !***REFERENCES 1. Messiah, Albert., Quantum Mechanics, Volume II, ! North-Holland Publishing Company, 1963. ! 2. Schulten, Klaus and Gordon, Roy G., Exact recursive ! evaluation of 3j and 6j coefficients for quantum- ! mechanical coupling of angular momenta, J Math ! Phys, v 16, no. 10, October 1975, pp. 1961-1970. ! 3. Schulten, Klaus and Gordon, Roy G., Semiclassical ! approximations to 3j and 6j coefficients for ! quantum-mechanical coupling of angular momenta, ! J Math Phys, v 16, no. 10, October 1975, ! pp. 1971-1988. ! 4. Schulten, Klaus and Gordon, Roy G., Recursive ! evaluation of 3j and 6j coefficients, Computer ! Phys Comm, v 11, 1976, pp. 269-278. !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters ! HUGE and TINY revised to depend on R1MACH. ! 891229 Prologue description rewritten; other prologue sections ! revised; LMATCH (location of match point for recurrences) ! removed from argument list; argument IER changed to serve ! only as an error flag (previously, in cases without error, ! it returned the number of scalings); number of error codes ! increased to provide more precise error information; ! program comments revised; SLATEC error handler calls ! introduced to enable printing of error messages to meet ! SLATEC standards. These changes were done by D. W. Lozier, ! M. A. McClain and J. M. Smith of the National Institute ! of Standards and Technology, formerly NBS. ! 910415 Mixed type expressions eliminated; variable C1 initialized; ! description of SIXCOF expanded. These changes were done by ! D. W. Lozier. !***END PROLOGUE RC6J ! INTEGER NDIM, IER REAL L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) ! INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM, & NSTEP2 REAL A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, R1MACH, & DENOM, DV, EPS, HUGE, L1, NEWFAC, OLDFAC, ONE, & RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, SUM2, & SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, TINY, TWO, & X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO ! DATA ZERO,EPS,ONE,TWO,THREE /0.0,0.01,1.0,2.0,3.0/ ! !***FIRST EXECUTABLE STATEMENT RC6J IER=0 ! HUGE is the square root of one twentieth of the largest floating ! point number, approximately. HUGE = SQRT(R1MACH(2)/20.0) SRHUGE = SQRT(HUGE) TINY = 1.0/HUGE SRTINY = 1.0/SRHUGE ! ! LMATCH = ZERO ! ! Check error conditions 1, 2, and 3. if ( (MOD(L2+L3+L5+L6+EPS,ONE) >= EPS+EPS).OR. & (MOD(L4+L2+L6+EPS,ONE) >= EPS+EPS))THEN IER=1 call XERMSG('SLATEC','RC6J','L2+L3+L5+L6 or L4+L2+L6 not '// & 'integer.',IER,1) return ELSEIF((L4+L2-L6 < ZERO).OR.(L4-L2+L6 < ZERO).OR. & (-L4+L2+L6 < ZERO))THEN IER=2 call XERMSG('SLATEC','RC6J','L4, L2, L6 triangular '// & 'condition not satisfied.',IER,1) return ELSEIF((L4-L5+L3 < ZERO).OR.(L4+L5-L3 < ZERO).OR. & (-L4+L5+L3 < ZERO))THEN IER=3 call XERMSG('SLATEC','RC6J','L4, L5, L3 triangular '// & 'condition not satisfied.',IER,1) return end if ! ! Limits for L1 ! L1MIN = MAX(ABS(L2-L3),ABS(L5-L6)) L1MAX = MIN(L2+L3,L5+L6) ! ! Check error condition 4. if ( MOD(L1MAX-L1MIN+EPS,ONE) >= EPS+EPS)THEN IER=4 call XERMSG('SLATEC','RC6J','L1MAX-L1MIN not integer.',IER,1) return end if if ( L1MIN < L1MAX-EPS) go to 20 if ( L1MIN < L1MAX+EPS) go to 10 ! ! Check error condition 5. IER=5 call XERMSG('SLATEC','RC6J','L1MIN greater than L1MAX.',IER,1) return ! ! ! This is reached in case that L1 can take only one value ! 10 CONTINUE ! LSCALE = 0 SIXCOF(1) = (-ONE) ** INT(L2+L3+L5+L6+EPS) / & SQRT((L1MIN+L1MIN+ONE)*(L4+L4+ONE)) return ! ! ! This is reached in case that L1 can take more than one value. ! 20 CONTINUE ! LSCALE = 0 NFIN = INT(L1MAX-L1MIN+ONE+EPS) if ( NDIM-NFIN) 21, 23, 23 ! ! Check error condition 6. 21 IER = 6 call XERMSG('SLATEC','RC6J','Dimension of result array for 6j '// & 'coefficients too small.',IER,1) return ! ! ! Start of forward recursion ! 23 L1 = L1MIN NEWFAC = 0.0 C1 = 0.0 SIXCOF(1) = SRTINY SUM1 = (L1+L1+ONE) * TINY ! LSTEP = 1 30 LSTEP = LSTEP + 1 L1 = L1 + ONE ! OLDFAC = NEWFAC A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE) A2 = (L1+L5+L6+ONE) * (L1-L5+L6) * (L1+L5-L6) * (-L1+L5+L6+ONE) NEWFAC = SQRT(A1*A2) ! if ( L1 < ONE+EPS) go to 40 ! DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE) & - L1*(L1-ONE)*L4*(L4+ONE) ) & - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE)) & * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE)) ! DENOM = (L1-ONE) * NEWFAC ! if ( LSTEP-2) 32, 32, 31 ! 31 C1OLD = ABS(C1) 32 C1 = - (L1+L1-ONE) * DV / DENOM go to 50 ! ! If L1 = 1, (L1 - 1) has to be factored out of DV, hence ! 40 C1 = - TWO * ( L2*(L2+ONE) + L5*(L5+ONE) - L4*(L4+ONE) ) & / NEWFAC ! 50 if ( LSTEP > 2) go to 60 ! ! If L1 = L1MIN + 1, the third term in recursion equation vanishes ! X = SRTINY * C1 SIXCOF(2) = X SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1 * C1 ! if ( LSTEP == NFIN) go to 220 go to 30 ! ! 60 C2 = - L1 * OLDFAC / DENOM ! ! Recursion to the next 6j coefficient X ! X = C1 * SIXCOF(LSTEP-1) + C2 * SIXCOF(LSTEP-2) SIXCOF(LSTEP) = X ! SUMFOR = SUM1 SUM1 = SUM1 + (L1+L1+ONE) * X * X if ( LSTEP == NFIN) go to 100 ! ! See if last unnormalized 6j coefficient exceeds SRHUGE ! if ( ABS(X) < SRHUGE) go to 80 ! ! This is reached if last 6j coefficient larger than SRHUGE, ! so that the recursion series SIXCOF(1), ... ,SIXCOF(LSTEP) ! has to be rescaled to prevent overflow ! ! LSCALE = LSCALE + 1 DO 70 I=1,LSTEP if ( ABS(SIXCOF(I)) < SRTINY) SIXCOF(I) = ZERO 70 SIXCOF(I) = SIXCOF(I) / SRHUGE SUM1 = SUM1 / HUGE SUMFOR = SUMFOR / HUGE X = X / SRHUGE ! ! ! As long as the coefficient ABS(C1) is decreasing, the recursion ! proceeds towards increasing 6j values and, hence, is numerically ! stable. Once an increase of ABS(C1) is detected, the recursion ! direction is reversed. ! 80 if ( C1OLD-ABS(C1)) 100, 100, 30 ! ! ! Keep three 6j coefficients around LMATCH for comparison later ! with backward recursion. ! 100 CONTINUE ! LMATCH = L1 - 1 X1 = X X2 = SIXCOF(LSTEP-1) X3 = SIXCOF(LSTEP-2) ! ! ! ! Starting backward recursion from L1MAX taking NSTEP2 steps, so ! that forward and backward recursion overlap at the three points ! L1 = LMATCH+1, LMATCH, LMATCH-1. ! NFINP1 = NFIN + 1 NFINP2 = NFIN + 2 NFINP3 = NFIN + 3 NSTEP2 = NFIN - LSTEP + 3 L1 = L1MAX ! SIXCOF(NFIN) = SRTINY SUM2 = (L1+L1+ONE) * TINY ! ! L1 = L1 + TWO LSTEP = 1 110 LSTEP = LSTEP + 1 L1 = L1 - ONE ! OLDFAC = NEWFAC A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO) A2S = (L1+L5+L6)*(L1-L5+L6-ONE)*(L1+L5-L6-ONE)*(-L1+L5+L6+TWO) NEWFAC = SQRT(A1S*A2S) ! DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE) & - L1*(L1-ONE)*L4*(L4+ONE) ) & - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE)) & * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE)) ! DENOM = L1 * NEWFAC C1 = - (L1+L1-ONE) * DV / DENOM if ( LSTEP > 2) go to 120 ! ! If L1 = L1MAX + 1 the third term in the recursion equation vanishes ! Y = SRTINY * C1 SIXCOF(NFIN-1) = Y if ( LSTEP == NSTEP2) go to 200 SUMBAC = SUM2 SUM2 = SUM2 + (L1+L1-THREE) * C1 * C1 * TINY go to 110 ! ! 120 C2 = - (L1-ONE) * OLDFAC / DENOM ! ! Recursion to the next 6j coefficient Y ! Y = C1 * SIXCOF(NFINP2-LSTEP) + C2 * SIXCOF(NFINP3-LSTEP) if ( LSTEP == NSTEP2) go to 200 SIXCOF(NFINP1-LSTEP) = Y SUMBAC = SUM2 SUM2 = SUM2 + (L1+L1-THREE) * Y * Y ! ! See if last unnormalized 6j coefficient exceeds SRHUGE ! if ( ABS(Y) < SRHUGE) go to 110 ! ! This is reached if last 6j coefficient larger than SRHUGE, ! so that the recursion series SIXCOF(NFIN), ... ,SIXCOF(NFIN-LSTEP+1) ! has to be rescaled to prevent overflow ! ! LSCALE = LSCALE + 1 DO 130 I=1,LSTEP INDEX = NFIN-I+1 if ( ABS(SIXCOF(INDEX)) < SRTINY) SIXCOF(INDEX) = ZERO 130 SIXCOF(INDEX) = SIXCOF(INDEX) / SRHUGE SUMBAC = SUMBAC / HUGE SUM2 = SUM2 / HUGE ! go to 110 ! ! ! The forward recursion 6j coefficients X1, X2, X3 are to be matched ! with the corresponding backward recursion values Y1, Y2, Y3. ! 200 Y3 = Y Y2 = SIXCOF(NFINP2-LSTEP) Y1 = SIXCOF(NFINP3-LSTEP) ! ! ! Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds ! with minimal error. ! RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 ) NLIM = NFIN - NSTEP2 + 1 ! if ( ABS(RATIO) < ONE) go to 211 ! DO 210 N=1,NLIM 210 SIXCOF(N) = RATIO * SIXCOF(N) SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC go to 230 ! 211 NLIM = NLIM + 1 RATIO = ONE / RATIO DO 212 N=NLIM,NFIN 212 SIXCOF(N) = RATIO * SIXCOF(N) SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC go to 230 ! 220 SUMUNI = SUM1 ! ! ! Normalize 6j coefficients ! 230 CNORM = ONE / SQRT((L4+L4+ONE)*SUMUNI) ! ! Sign convention for last 6j coefficient determines overall phase ! SIGN1 = SIGN(ONE,SIXCOF(NFIN)) SIGN2 = (-ONE) ** INT(L2+L3+L5+L6+EPS) if ( SIGN1*SIGN2) 235,235,236 235 CNORM = - CNORM ! 236 if ( ABS(CNORM) < ONE) go to 250 ! DO 240 N=1,NFIN 240 SIXCOF(N) = CNORM * SIXCOF(N) return ! 250 THRESH = TINY / ABS(CNORM) DO 251 N=1,NFIN if ( ABS(SIXCOF(N)) < THRESH) SIXCOF(N) = ZERO 251 SIXCOF(N) = CNORM * SIXCOF(N) ! return end FUNCTION RC (X, Y, IER) ! !! RC approximates the elliptic integral RC(X,Y). ! !***PURPOSE Calculate an approximation to ! RC(X,Y) = Integral from zero to infinity of ! -1/2 -1 ! (1/2)(t+X) (t+Y) dt, ! where X is nonnegative and Y is positive. !***LIBRARY SLATEC !***CATEGORY C14 !***TYPE SINGLE PRECISION (RC-S, DRC-D) !***KEYWORDS DUPLICATION THEOREM, ELEMENTARY FUNCTIONS, ! ELLIPTIC INTEGRAL, TAYLOR SERIES !***AUTHOR Carlson, B. C. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Notis, E. M. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Pexton, R. L. ! Lawrence Livermore National Laboratory ! Livermore, CA 94550 !***DESCRIPTION ! ! 1. RC ! Standard FORTRAN function routine ! Single precision version ! The routine calculates an approximation to ! RC(X,Y) = Integral from zero to infinity of ! ! -1/2 -1 ! (1/2)(t+X) (t+Y) dt, ! ! where X is nonnegative and Y is positive. The duplication ! theorem is iterated until the variables are nearly equal, ! and the function is then expanded in Taylor series to fifth ! order. Logarithmic, inverse circular, and inverse hyper- ! bolic functions can be expressed in terms of RC. ! ! ! 2. Calling Sequence ! RC( X, Y, IER ) ! ! Parameters on Entry ! Values assigned by the calling routine ! ! X - Single precision, nonnegative variable ! ! Y - Single precision, positive variable ! ! ! ! On Return (values assigned by the RC routine) ! ! RC - Single precision approximation to the integral ! ! IER - Integer to indicate normal or abnormal termination. ! ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! ! IER > 0 Abnormal termination of the routine ! ! X and Y are unaltered. ! ! ! 3. Error Messages ! ! Value of IER assigned by the RC routine ! ! Value Assigned Error Message Printed ! IER = 1 X < 0.0E0.OR.Y <= 0.0E0 ! = 2 X+Y < LOLIM ! = 3 MAX(X,Y) > UPLIM ! ! ! 4. Control Parameters ! ! Values of LOLIM, UPLIM, and ERRTOL are set by the ! routine. ! ! LOLIM and UPLIM determine the valid range of X and Y ! ! LOLIM - Lower limit of valid arguments ! ! Not less than 5 * (machine minimum) . ! ! UPLIM - Upper limit of valid arguments ! ! Not greater than (machine maximum) / 5 . ! ! ! Acceptable values for: LOLIM UPLIM ! IBM 360/370 SERIES : 3.0E-78 1.0E+75 ! CDC 6000/7000 SERIES : 1.0E-292 1.0E+321 ! UNIVAC 1100 SERIES : 1.0E-37 1.0E+37 ! CRAY : 2.3E-2466 1.09E+2465 ! VAX 11 SERIES : 1.5E-38 3.0E+37 ! ! ERRTOL determines the accuracy of the answer ! ! The value assigned by the routine will result ! in solution precision within 1-2 decimals of ! "machine precision". ! ! ! ERRTOL - Relative error due to truncation is less than ! 16 * ERRTOL ** 6 / (1 - 2 * ERRTOL). ! ! ! The accuracy of the computed approximation to the inte- ! gral can be controlled by choosing the value of ERRTOL. ! Truncation of a Taylor series after terms of fifth order ! introduces an error less than the amount shown in the ! second column of the following table for each value of ! ERRTOL in the first column. In addition to the trunca- ! tion error there will be round-off error, but in prac- ! tice the total error from both sources is usually less ! than the amount given in the table. ! ! ! ! Sample Choices: ERRTOL Relative Truncation ! error less than ! 1.0E-3 2.0E-17 ! 3.0E-3 2.0E-14 ! 1.0E-2 2.0E-11 ! 3.0E-2 2.0E-8 ! 1.0E-1 2.0E-5 ! ! ! Decreasing ERRTOL by a factor of 10 yields six more ! decimal digits of accuracy at the expense of one or ! two more iterations of the duplication theorem. ! ! *Long Description: ! ! RC Special Comments ! ! ! ! ! Check: RC(X,X+Z) + RC(Y,Y+Z) = RC(0,Z) ! ! where X, Y, and Z are positive and X * Y = Z * Z ! ! ! On Input: ! ! X and Y are the variables in the integral RC(X,Y). ! ! On Output: ! ! X and Y are unaltered. ! ! ! ! RC(0,1/4)=RC(1/16,1/8)=PI=3.14159... ! ! RC(9/4,2)=LN(2) ! ! ! ! ******************************************************** ! ! Warning: Changes in the program may improve speed at the ! expense of robustness. ! ! ! -------------------------------------------------------------------- ! ! Special Functions via RC ! ! ! ! LN X X > 0 ! ! 2 ! LN(X) = (X-1) RC(((1+X)/2) , X ) ! ! ! -------------------------------------------------------------------- ! ! ARCSIN X -1 <= X <= 1 ! ! 2 ! ARCSIN X = X RC (1-X ,1 ) ! ! -------------------------------------------------------------------- ! ! ARCCOS X 0 <= X <= 1 ! ! ! 2 2 ! ARCCOS X = SQRT(1-X ) RC(X ,1 ) ! ! -------------------------------------------------------------------- ! ! ARCTAN X -INF < X < +INF ! ! 2 ! ARCTAN X = X RC(1,1+X ) ! ! -------------------------------------------------------------------- ! ! ARCCOT X 0 <= X < INF ! ! 2 2 ! ARCCOT X = RC(X ,X +1 ) ! ! -------------------------------------------------------------------- ! ! ARCSINH X -INF < X < +INF ! ! 2 ! ARCSINH X = X RC(1+X ,1 ) ! ! -------------------------------------------------------------------- ! ! ARCCOSH X X >= 1 ! ! 2 2 ! ARCCOSH X = SQRT(X -1) RC(X ,1 ) ! ! -------------------------------------------------------------------- ! ! ARCTANH X -1 < X < 1 ! ! 2 ! ARCTANH X = X RC(1,1-X ) ! ! -------------------------------------------------------------------- ! ! ARCCOTH X X > 1 ! ! 2 2 ! ARCCOTH X = RC(X ,X -1 ) ! ! -------------------------------------------------------------------- ! !***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete ! elliptic integrals, ACM Transactions on Mathematical ! Software 7, 3 (September 1981), pp. 398-403. ! B. C. Carlson, Computing elliptic integrals by ! duplication, Numerische Mathematik 33, (1979), ! pp. 1-16. ! B. C. Carlson, Elliptic integrals of the first kind, ! SIAM Journal of Mathematical Analysis 8, (1977), ! pp. 231-242. !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced statement labels. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900510 Changed calls to XERMSG to standard form, and some ! editorial changes. (RWC)) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RC REAL RC CHARACTER*16 XERN3, XERN4, XERN5 INTEGER IER REAL C1, C2, ERRTOL, LAMDA, LOLIM REAL MU, S, SN, UPLIM, X, XN, Y, YN LOGICAL FIRST SAVE ERRTOL,LOLIM,UPLIM,C1,C2,FIRST DATA FIRST /.TRUE./ ! !***FIRST EXECUTABLE STATEMENT RC if (FIRST) THEN ERRTOL = (R1MACH(3)/16.0E0)**(1.0E0/6.0E0) LOLIM = 5.0E0 * R1MACH(1) UPLIM = R1MACH(2) / 5.0E0 ! C1 = 1.0E0/7.0E0 C2 = 9.0E0/22.0E0 end if FIRST = .FALSE. ! ! call ERROR HANDLER if NECESSARY. ! RC = 0.0E0 if (X < 0.0E0.OR.Y <= 0.0E0) THEN IER = 1 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y call XERMSG ('SLATEC', 'RC', & 'X < 0 .OR. Y <= 0 WHERE X = ' // XERN3 // ' AND Y = ' // & XERN4, 1, 1) return end if ! if (MAX(X,Y) > UPLIM) THEN IER = 3 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') UPLIM call XERMSG ('SLATEC', 'RC', & 'MAX(X,Y) > UPLIM WHERE X = ' // XERN3 // ' Y = ' // & XERN4 // ' AND UPLIM = ' // XERN5, 3, 1) return end if ! if (X+Y < LOLIM) THEN IER = 2 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') LOLIM call XERMSG ('SLATEC', 'RC', & 'X+Y < LOLIM WHERE X = ' // XERN3 // ' Y = ' // XERN4 // & ' AND LOLIM = ' // XERN5, 2, 1) return end if ! IER = 0 XN = X YN = Y ! 30 MU = (XN+YN+YN)/3.0E0 SN = (YN+MU)/MU - 2.0E0 if (ABS(SN) < ERRTOL) go to 40 LAMDA = 2.0E0*SQRT(XN)*SQRT(YN) + YN XN = (XN+LAMDA)*0.250E0 YN = (YN+LAMDA)*0.250E0 go to 30 ! 40 S = SN*SN*(0.30E0+SN*(C1+SN*(0.3750E0+SN*C2))) RC = (1.0E0+S)/SQRT(MU) return end FUNCTION RD (X, Y, Z, IER) ! !! RD computes the incomplete or complete elliptic integral of the 2nd kind. ! ! For X and Y nonnegative, X+Y and Z positive, ! RD(X,Y,Z) = Integral from zero to infinity of ! -1/2 -1/2 -3/2 ! (3/2)(t+X) (t+Y) (t+Z) dt. ! If X or Y is zero, the integral is complete. !***LIBRARY SLATEC !***CATEGORY C14 !***TYPE SINGLE PRECISION (RD-S, DRD-D) !***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, ! INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE SECOND KIND, ! TAYLOR SERIES !***AUTHOR Carlson, B. C. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Notis, E. M. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Pexton, R. L. ! Lawrence Livermore National Laboratory ! Livermore, CA 94550 !***DESCRIPTION ! ! 1. RD ! Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL ! of the second kind ! Standard FORTRAN function routine ! Single precision version ! The routine calculates an approximation result to ! RD(X,Y,Z) = Integral from zero to infinity of ! -1/2 -1/2 -3/2 ! (3/2)(t+X) (t+Y) (t+Z) dt, ! where X and Y are nonnegative, X + Y is positive, and Z is ! positive. If X or Y is zero, the integral is COMPLETE. ! The duplication theorem is iterated until the variables are ! nearly equal, and the function is then expanded in Taylor ! series to fifth order. ! ! 2. Calling Sequence ! ! RD( X, Y, Z, IER ) ! ! Parameters on Entry ! Values assigned by the calling routine ! ! X - Single precision, nonnegative variable ! ! Y - Single precision, nonnegative variable ! ! X + Y is positive ! ! Z - Real, positive variable ! ! ! ! On Return (values assigned by the RD routine) ! ! RD - Real approximation to the integral ! ! ! IER - Integer ! ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! ! IER > 0 Abnormal termination of the routine ! ! ! X, Y, Z are unaltered. ! ! 3. Error Messages ! ! Value of IER assigned by the RD routine ! ! Value Assigned Error Message Printed ! IER = 1 MIN(X,Y) < 0.0E0 ! = 2 MIN(X + Y, Z ) < LOLIM ! = 3 MAX(X,Y,Z) > UPLIM ! ! ! 4. Control Parameters ! ! Values of LOLIM, UPLIM, and ERRTOL are set by the ! routine. ! ! LOLIM and UPLIM determine the valid range of X, Y, and Z ! ! LOLIM - Lower limit of valid arguments ! ! Not less than 2 / (machine maximum) ** (2/3). ! ! UPLIM - Upper limit of valid arguments ! ! Not greater than (0.1E0 * ERRTOL / machine ! minimum) ** (2/3), where ERRTOL is described below. ! In the following table it is assumed that ERRTOL ! will never be chosen smaller than 1.0E-5. ! ! ! Acceptable Values For: LOLIM UPLIM ! IBM 360/370 SERIES : 6.0E-51 1.0E+48 ! CDC 6000/7000 SERIES : 5.0E-215 2.0E+191 ! UNIVAC 1100 SERIES : 1.0E-25 2.0E+21 ! CRAY : 3.0E-1644 1.69E+1640 ! VAX 11 SERIES : 1.0E-25 4.5E+21 ! ! ! ERRTOL determines the accuracy of the answer ! ! The value assigned by the routine will result ! in solution precision within 1-2 decimals of ! "machine precision". ! ! ERRTOL Relative error due to truncation is less than ! 3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2. ! ! ! ! The accuracy of the computed approximation to the inte- ! gral can be controlled by choosing the value of ERRTOL. ! Truncation of a Taylor series after terms of fifth order ! introduces an error less than the amount shown in the ! second column of the following table for each value of ! ERRTOL in the first column. In addition to the trunca- ! tion error there will be round-off error, but in prac- ! tice the total error from both sources is usually less ! than the amount given in the table. ! ! ! ! ! Sample Choices: ERRTOL Relative Truncation ! error less than ! 1.0E-3 4.0E-18 ! 3.0E-3 3.0E-15 ! 1.0E-2 4.0E-12 ! 3.0E-2 3.0E-9 ! 1.0E-1 4.0E-6 ! ! ! Decreasing ERRTOL by a factor of 10 yields six more ! decimal digits of accuracy at the expense of one or ! two more iterations of the duplication theorem. ! ! *Long Description: ! ! RD Special Comments ! ! ! ! Check: RD(X,Y,Z) + RD(Y,Z,X) + RD(Z,X,Y) ! = 3 / SQRT(X * Y * Z), where X, Y, and Z are positive. ! ! ! On Input: ! ! X, Y, and Z are the variables in the integral RD(X,Y,Z). ! ! ! On Output: ! ! ! X, Y, and Z are unaltered. ! ! ! ! ******************************************************** ! ! WARNING: Changes in the program may improve speed at the ! expense of robustness. ! ! ! ! ------------------------------------------------------------------- ! ! ! Special Functions via RD and RF ! ! ! Legendre form of ELLIPTIC INTEGRAL of 2nd kind ! ---------------------------------------------- ! ! ! 2 2 2 ! E(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1) - ! ! 2 3 2 2 2 ! -(K/3) SIN (PHI) RD(COS (PHI),1-K SIN (PHI),1) ! ! ! 2 2 2 ! E(K) = RF(0,1-K ,1) - (K/3) RD(0,1-K ,1) ! ! ! PI/2 2 2 1/2 ! = INT (1-K SIN (PHI) ) D PHI ! 0 ! ! ! ! Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind ! ---------------------------------------------- ! ! 22 2 ! EL2(X,KC,A,B) = AX RF(1,1+KC X ,1+X ) + ! ! 3 22 2 ! +(1/3)(B-A) X RD(1,1+KC X ,1+X ) ! ! ! ! Legendre form of alternative ELLIPTIC INTEGRAL of 2nd ! ----------------------------------------------------- ! kind ! ---- ! ! Q 2 2 2 -1/2 ! D(Q,K) = INT SIN P (1-K SIN P) DP ! 0 ! ! ! ! 3 2 2 2 ! D(Q,K) =(1/3)(SIN Q) RD(COS Q,1-K SIN Q,1) ! ! ! ! ! ! Lemniscate constant B ! --------------------- ! ! ! ! 1 2 4 -1/2 ! B = INT S (1-S ) DS ! 0 ! ! ! B =(1/3)RD (0,2,1) ! ! ! ! ! Heuman's LAMBDA function ! ------------------------ ! ! ! ! (PI/2) LAMBDA0(A,B) = ! ! 2 2 ! = SIN(B) (RF(0,COS (A),1)-(1/3) SIN (A) * ! ! 2 2 2 2 ! *RD(0,COS (A),1)) RF(COS (B),1-COS (A) SIN (B),1) ! ! 2 3 2 ! -(1/3) COS (A) SIN (B) RF(0,COS (A),1) * ! ! 2 2 2 ! *RD(COS (B),1-COS (A) SIN (B),1) ! ! ! ! Jacobi ZETA function ! -------------------- ! ! ! 2 2 2 2 ! Z(B,K) = (K/3) SIN(B) RF(COS (B),1-K SIN (B),1) ! ! ! 2 2 ! *RD(0,1-K ,1)/RF(0,1-K ,1) ! ! 2 3 2 2 2 ! -(K /3) SIN (B) RD(COS (B),1-K SIN (B),1) ! ! ! ------------------------------------------------------------------- ! !***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete ! elliptic integrals, ACM Transactions on Mathematical ! Software 7, 3 (September 1981), pp. 398-403. ! B. C. Carlson, Computing elliptic integrals by ! duplication, Numerische Mathematik 33, (1979), ! pp. 1-16. ! B. C. Carlson, Elliptic integrals of the first kind, ! SIAM Journal of Mathematical Analysis 8, (1977), ! pp. 231-242. !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900510 Modify calls to XERMSG to put in standard form. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RD real RD CHARACTER*16 XERN3, XERN4, XERN5, XERN6 INTEGER IER REAL LOLIM, UPLIM, EPSLON, ERRTOL REAL C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA REAL MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, ZNROOT LOGICAL FIRST SAVE ERRTOL, LOLIM, UPLIM, C1, C2, C3, C4, FIRST DATA FIRST /.TRUE./ ! !***FIRST EXECUTABLE STATEMENT RD if (FIRST) THEN ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0) LOLIM = 2.0E0/(R1MACH(2))**(2.0E0/3.0E0) TUPLIM = R1MACH(1)**(1.0E0/3.0E0) TUPLIM = (0.10E0*ERRTOL)**(1.0E0/3.0E0)/TUPLIM UPLIM = TUPLIM**2.0E0 ! C1 = 3.0E0/14.0E0 C2 = 1.0E0/6.0E0 C3 = 9.0E0/22.0E0 C4 = 3.0E0/26.0E0 end if FIRST = .FALSE. ! ! call ERROR HANDLER if NECESSARY. ! RD = 0.0E0 if ( MIN(X,Y) < 0.0E0) THEN IER = 1 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y call XERMSG ('SLATEC', 'RD', & 'MIN(X,Y) < 0 WHERE X = ' // XERN3 // ' AND Y = ' // & XERN4, 1, 1) return end if ! if (MAX(X,Y,Z) > UPLIM) THEN IER = 3 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') UPLIM call XERMSG ('SLATEC', 'RD', & 'MAX(X,Y,Z) > UPLIM WHERE X = ' // XERN3 // ' Y = ' // & XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, & 3, 1) return end if ! if (MIN(X+Y,Z) < LOLIM) THEN IER = 2 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') LOLIM call XERMSG ('SLATEC', 'RD', & 'MIN(X+Y,Z) < LOLIM WHERE X = ' // XERN3 // ' Y = ' // & XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // XERN6, & 2, 1) return end if ! IER = 0 XN = X YN = Y ZN = Z SIGMA = 0.0E0 POWER4 = 1.0E0 ! 30 MU = (XN+YN+3.0E0*ZN)*0.20E0 XNDEV = (MU-XN)/MU YNDEV = (MU-YN)/MU ZNDEV = (MU-ZN)/MU EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV)) if (EPSLON < ERRTOL) go to 40 XNROOT = SQRT(XN) YNROOT = SQRT(YN) ZNROOT = SQRT(ZN) LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA)) POWER4 = POWER4*0.250E0 XN = (XN+LAMDA)*0.250E0 YN = (YN+LAMDA)*0.250E0 ZN = (ZN+LAMDA)*0.250E0 go to 30 ! 40 EA = XNDEV*YNDEV EB = ZNDEV*ZNDEV EC = EA - EB ED = EA - 6.0E0*EB EF = ED + EC + EC S1 = ED*(-C1+0.250E0*C3*ED-1.50E0*C4*ZNDEV*EF) S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA)) RD = 3.0E0*SIGMA + POWER4*(1.0E0+S1+S2)/(MU* SQRT(MU)) ! return end subroutine REBAKB (NM, N, B, DL, M, Z) ! !! REBAKB forms the eigenvectors of a generalized symmetric ... ! eigensystem from the eigenvectors of derived matrix output ! from REDUC2. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (REBAKB-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure REBAKB, ! NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). ! ! This subroutine forms the eigenvectors of a generalized ! SYMMETRIC eigensystem by back transforming those of the ! derived symmetric matrix determined by REDUC2. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, B and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix system. N is an INTEGER ! variable. N must be less than or equal to NM. ! ! B contains information about the similarity transformation ! (Cholesky decomposition) used in the reduction by REDUC2 ! in its strict lower triangle. B is a two-dimensional ! REAL array, dimensioned B(NM,N). ! ! DL contains further information about the transformation. ! DL is a one-dimensional REAL array, dimensioned DL(N). ! ! M is the number of eigenvectors to be back transformed. ! M is an INTEGER variable. ! ! Z contains the eigenvectors to be back transformed in its ! first M columns. Z is a two-dimensional REAL array ! dimensioned Z(NM,M). ! ! On Output ! ! Z contains the transformed eigenvectors in its first ! M columns. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE REBAKB ! INTEGER I,J,K,M,N,I1,II,NM REAL B(NM,*),DL(*),Z(NM,*) REAL X ! !***FIRST EXECUTABLE STATEMENT REBAKB if (M == 0) go to 200 ! DO 100 J = 1, M ! .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... DO 100 II = 1, N I1 = N - II I = I1 + 1 X = DL(I) * Z(I,J) if (I == 1) go to 80 ! DO 60 K = 1, I1 60 X = X + B(I,K) * Z(K,J) ! 80 Z(I,J) = X 100 CONTINUE ! 200 RETURN end subroutine REBAK (NM, N, B, DL, M, Z) ! !! REBAK forms the eigenvectors of a generalized symmetric ... ! eigensystem from the eigenvectors of derived matrix output ! from REDUC or REDUC2. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (REBAK-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure REBAKA, ! NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). ! ! This subroutine forms the eigenvectors of a generalized ! SYMMETRIC eigensystem by back transforming those of the ! derived symmetric matrix determined by REDUC or REDUC2. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, B and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix system. N is an INTEGER ! variable. N must be less than or equal to NM. ! ! B contains information about the similarity transformation ! (Cholesky decomposition) used in the reduction by REDUC ! or REDUC2 in its strict lower triangle. B is a two- ! dimensional REAL array, dimensioned B(NM,N). ! ! DL contains further information about the transformation. ! DL is a one-dimensional REAL array, dimensioned DL(N). ! ! M is the number of eigenvectors to be back transformed. ! M is an INTEGER variable. ! ! Z contains the eigenvectors to be back transformed in its ! first M columns. Z is a two-dimensional REAL array ! dimensioned Z(NM,M). ! ! On Output ! ! Z contains the transformed eigenvectors in its first ! M columns. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE REBAK ! INTEGER I,J,K,M,N,I1,II,NM REAL B(NM,*),DL(*),Z(NM,*) REAL X ! !***FIRST EXECUTABLE STATEMENT REBAK if (M == 0) go to 200 ! DO 100 J = 1, M ! .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... DO 100 II = 1, N I = N + 1 - II I1 = I + 1 X = Z(I,J) if (I == N) go to 80 ! DO 60 K = I1, N 60 X = X - B(K,I) * Z(K,J) ! 80 Z(I,J) = X / DL(I) 100 CONTINUE ! 200 RETURN end subroutine REDUC2 (NM, N, A, B, DL, IERR) ! !! REDUC2 reduces a certain generalized symmetric eigenproblem to a ... ! standard symmetric eigenproblem using Cholesky ! factorization. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1C !***TYPE SINGLE PRECISION (REDUC2-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure REDUC2, ! NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). ! ! This subroutine reduces the generalized SYMMETRIC eigenproblems ! ABx=(LAMBDA)x OR BAy=(LAMBDA)y, where B is POSITIVE DEFINITE, ! to the standard symmetric eigenproblem using the Cholesky ! factorization of B. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and B, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrices A and B. If the Cholesky ! factor L of B is already available, N should be prefixed ! with a minus sign. N is an INTEGER variable. ! ! A and B contain the real symmetric input matrices. Only ! the full upper triangles of the matrices need be supplied. ! If N is negative, the strict lower triangle of B contains, ! instead, the strict lower triangle of its Cholesky factor L. ! A and B are two-dimensional REAL arrays, dimensioned A(NM,N) ! and B(NM,N). ! ! DL contains, if N is negative, the diagonal elements of L. ! DL is a one-dimensional REAL array, dimensioned DL(N). ! ! On Output ! ! A contains in its full lower triangle the full lower triangle ! of the symmetric matrix derived from the reduction to the ! standard form. The strict upper triangle of A is unaltered. ! ! B contains in its strict lower triangle the strict lower ! triangle of its Cholesky factor L. The full upper triangle ! of B is unaltered. ! ! DL contains the diagonal elements of L. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 7*N+1 if B is not positive definite. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE REDUC2 ! INTEGER I,J,K,N,I1,J1,NM,NN,IERR REAL A(NM,*),B(NM,*),DL(*) REAL X,Y ! !***FIRST EXECUTABLE STATEMENT REDUC2 IERR = 0 NN = ABS(N) if (N < 0) go to 100 ! .......... FORM L IN THE ARRAYS B AND DL .......... DO 80 I = 1, N I1 = I - 1 ! DO 80 J = I, N X = B(I,J) if (I == 1) go to 40 ! DO 20 K = 1, I1 20 X = X - B(I,K) * B(J,K) ! 40 if (J /= I) go to 60 if (X <= 0.0E0) go to 1000 Y = SQRT(X) DL(I) = Y go to 80 60 B(J,I) = X / Y 80 CONTINUE ! .......... FORM THE LOWER TRIANGLE OF A*L ! IN THE LOWER TRIANGLE OF THE ARRAY A .......... 100 DO 200 I = 1, NN I1 = I + 1 ! DO 200 J = 1, I X = A(J,I) * DL(J) if (J == I) go to 140 J1 = J + 1 ! DO 120 K = J1, I 120 X = X + A(K,I) * B(K,J) ! 140 if (I == NN) go to 180 ! DO 160 K = I1, NN 160 X = X + A(I,K) * B(K,J) ! 180 A(I,J) = X 200 CONTINUE ! .......... PRE-MULTIPLY BY TRANSPOSE(L) AND OVERWRITE .......... DO 300 I = 1, NN I1 = I + 1 Y = DL(I) ! DO 300 J = 1, I X = Y * A(I,J) if (I == NN) go to 280 ! DO 260 K = I1, NN 260 X = X + A(K,J) * B(K,I) ! 280 A(I,J) = X 300 CONTINUE ! go to 1001 ! .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... 1000 IERR = 7 * N + 1 1001 RETURN end subroutine REDUC (NM, N, A, B, DL, IERR) ! !! REDUC reduces a generalized symmetric eigenproblem to a standard ... ! symmetric eigenproblem using Cholesky factorization. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1C !***TYPE SINGLE PRECISION (REDUC-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure REDUC1, ! NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). ! ! This subroutine reduces the generalized SYMMETRIC eigenproblem ! Ax=(LAMBDA)Bx, where B is POSITIVE DEFINITE, to the standard ! symmetric eigenproblem using the Cholesky factorization of B. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and B, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrices A and B. If the Cholesky ! factor L of B is already available, N should be prefixed ! with a minus sign. N is an INTEGER variable. ! ! A and B contain the real symmetric input matrices. Only ! the full upper triangles of the matrices need be supplied. ! If N is negative, the strict lower triangle of B contains, ! instead, the strict lower triangle of its Cholesky factor L. ! A and B are two-dimensional REAL arrays, dimensioned A(NM,N) ! and B(NM,N). ! ! DL contains, if N is negative, the diagonal elements of L. ! DL is a one-dimensional REAL array, dimensioned DL(N). ! ! On Output ! ! A contains in its full lower triangle the full lower triangle ! of the symmetric matrix derived from the reduction to the ! standard form. The strict upper triangle of A is unaltered. ! ! B contains in its strict lower triangle the strict lower ! triangle of its Cholesky factor L. The full upper triangle ! of B is unaltered. ! ! DL contains the diagonal elements of L. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 7*N+1 if B is not positive definite. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE REDUC ! INTEGER I,J,K,N,I1,J1,NM,NN,IERR REAL A(NM,*),B(NM,*),DL(*) REAL X,Y ! !***FIRST EXECUTABLE STATEMENT REDUC IERR = 0 NN = ABS(N) if (N < 0) go to 100 ! .......... FORM L IN THE ARRAYS B AND DL .......... DO 80 I = 1, N I1 = I - 1 ! DO 80 J = I, N X = B(I,J) if (I == 1) go to 40 ! DO 20 K = 1, I1 20 X = X - B(I,K) * B(J,K) ! 40 if (J /= I) go to 60 if (X <= 0.0E0) go to 1000 Y = SQRT(X) DL(I) = Y go to 80 60 B(J,I) = X / Y 80 CONTINUE ! .......... FORM THE TRANSPOSE OF THE UPPER TRIANGLE OF INV(L)*A ! IN THE LOWER TRIANGLE OF THE ARRAY A .......... 100 DO 200 I = 1, NN I1 = I - 1 Y = DL(I) ! DO 200 J = I, NN X = A(I,J) if (I == 1) go to 180 ! DO 160 K = 1, I1 160 X = X - B(I,K) * A(J,K) ! 180 A(J,I) = X / Y 200 CONTINUE ! .......... PRE-MULTIPLY BY INV(L) AND OVERWRITE .......... DO 300 J = 1, NN J1 = J - 1 ! DO 300 I = J, NN X = A(I,J) if (I == J) go to 240 I1 = I - 1 ! DO 220 K = J, I1 220 X = X - A(K,J) * B(I,K) ! 240 if (J == 1) go to 280 ! DO 260 K = 1, J1 260 X = X - A(J,K) * B(I,K) ! 280 A(I,J) = X / DL(I) 300 CONTINUE ! go to 1001 ! .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... 1000 IERR = 7 * N + 1 1001 RETURN end subroutine REORT (NCOMP, Y, YP, YHP, NIV, W, S, P, IP, STOWA, & IFLAG) ! !! REORT is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (REORT-S, DREORT-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! INPUT ! ********* ! Y, YP and YHP = homogeneous solution matrix and particular ! solution vector to be orthonormalized. ! IFLAG = 1 -- store YHP into Y and YP, test for ! reorthonormalization, orthonormalize if needed, ! save restart data. ! 2 -- store YHP into Y and YP, reorthonormalization, ! no restarts. ! (preset orthonormalization mode) ! 3 -- store YHP into Y and YP, reorthonormalization ! (when INHOMO=3 and X=XEND). ! ********************************************************************** ! OUTPUT ! ********* ! Y, YP = orthonormalized solutions. ! NIV = number of independent vectors returned from DMGSBV. ! IFLAG = 0 -- reorthonormalization was performed. ! 10 -- solution process must be restarted at the last ! orthonormalization point. ! 30 -- solutions are linearly dependent, problem must ! be restarted from the beginning. ! W, P, IP = orthonormalization information. ! ********************************************************************** ! !***SEE ALSO BVSUP !***ROUTINES CALLED MGSBV, SDOT, STOR1, STWAY !***COMMON BLOCKS ML15TO, ML18JR, ML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE REORT ! DIMENSION Y(NCOMP,*),YP(*),W(*),S(*),P(*),IP(*), & STOWA(*),YHP(NCOMP,*) ! ! ********************************************************************** ! COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFC COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, & ICOCO ! ! ********************************************************************** !***FIRST EXECUTABLE STATEMENT REORT NFCP=NFC+1 ! ! CHECK TO SEE if ORTHONORMALIZATION TEST IS TO BE PERFORMED ! if (IFLAG /= 1) go to 5 KNSWOT=KNSWOT+1 if (KNSWOT >= NSWOT) go to 5 if ((XEND-X)*(X-XOT) < 0.) RETURN 5 call STOR1(Y,YHP,YP,YHP(1,NFCP),1,0,0) ! ! **************************************** ! ! ORTHOGONALIZE THE HOMOGENEOUS SOLUTIONS Y ! AND PARTICULAR SOLUTION YP. ! NIV=NFC call MGSBV(NCOMP,NFC,Y,NCOMP,NIV,MFLAG,S,P,IP,INHOMO,YP,W,WCND) ! ! **************************************** ! ! CHECK FOR LINEAR DEPENDENCE OF THE SOLUTIONS. ! if (MFLAG == 0) go to 25 if (IFLAG == 2) go to 15 if (NSWOT > 1 .OR. LOTJP == 0) go to 20 15 IFLAG=30 return ! ! RETRIEVE DATA FOR A RESTART AT LAST ORTHONORMALIZATION POINT ! 20 call STWAY(Y,YP,YHP,1,STOWA) LOTJP=1 NSWOT=1 KNSWOT=0 MNSWOT=MNSWOT/2 TND=TND+1. IFLAG=10 return ! ! **************************************** ! 25 if (IFLAG /= 1) go to 60 ! ! TEST FOR ORTHONORMALIZATION ! if (WCND < 50.*TOL) go to 60 DO 30 IJK=1,NFCP if (S(IJK) > 1.0E+20) go to 60 30 CONTINUE ! ! USE LINEAR EXTRAPOLATION ON LOGARITHMIC VALUES OF THE NORM ! DECREMENTS TO DETERMINE NEXT ORTHONORMALIZATION CHECKPOINT. ! OTHER CONTROLS ON THE NUMBER OF STEPS TO THE NEXT CHECKPOINT ! ARE ADDED FOR SAFETY PURPOSES. ! NSWOT=KNSWOT KNSWOT=0 LOTJP=0 WCND=LOG10(WCND) if (WCND > TND+3.) NSWOT=2*NSWOT if (WCND >= PWCND) go to 40 DX=X-PX DND=PWCND-WCND if (DND >= 4) NSWOT=NSWOT/2 DNDT=WCND-TND if (ABS(DX*DNDT) > DND*ABS(XEND-X)) go to 40 XOT=X+DX*DNDT/DND go to 50 40 XOT=XEND 50 NSWOT=MIN(MNSWOT,NSWOT) PWCND=WCND PX=X return ! ! **************************************** ! ! ORTHONORMALIZATION NECESSARY SO WE NORMALIZE THE HOMOGENEOUS ! SOLUTION VECTORS AND CHANGE W ACCORDINGLY. ! 60 NSWOT=1 KNSWOT=0 LOTJP=1 KK = 1 L=1 DO 70 K = 1,NFCC SRP=SQRT(P(KK)) if (INHOMO == 1) W(K)=SRP*W(K) VNORM=1./SRP P(KK)=VNORM KK = KK + NFCC + 1 - K if (NFC == NFCC) go to 63 if (L /= K/2) go to 70 63 DO 65 J = 1,NCOMP 65 Y(J,L) = Y(J,L)*VNORM L=L+1 70 CONTINUE ! if (INHOMO /= 1 .OR. NPS == 1) go to 100 ! ! NORMALIZE THE PARTICULAR SOLUTION ! YPNM=SDOT(NCOMP,YP,1,YP,1) if (YPNM == 0.0) YPNM = 1.0 YPNM = SQRT(YPNM) S(NFCP) = YPNM DO 80 J = 1,NCOMP 80 YP(J) = YP(J) / YPNM DO 90 J = 1,NFCC 90 W(J) = C * W(J) ! 100 if (IFLAG == 1) call STWAY(Y,YP,YHP,0,STOWA) IFLAG=0 return end FUNCTION RF (X, Y, Z, IER) ! !! RF computes the incomplete or complete elliptic integral of the 1st kind. ! ! For X, Y, and Z non-negative and at most one of ! them zero, RF(X,Y,Z) = Integral from zero to infinity of ! -1/2 -1/2 -1/2 ! (1/2)(t+X) (t+Y) (t+Z) dt. ! If X, Y or Z is zero, the integral is complete. !***LIBRARY SLATEC !***CATEGORY C14 !***TYPE SINGLE PRECISION (RF-S, DRF-D) !***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, ! INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE FIRST KIND, ! TAYLOR SERIES !***AUTHOR Carlson, B. C. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Notis, E. M. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Pexton, R. L. ! Lawrence Livermore National Laboratory ! Livermore, CA 94550 !***DESCRIPTION ! ! 1. RF ! Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL ! of the first kind ! Standard FORTRAN function routine ! Single precision version ! The routine calculates an approximation result to ! RF(X,Y,Z) = Integral from zero to infinity of ! ! -1/2 -1/2 -1/2 ! (1/2)(t+X) (t+Y) (t+Z) dt, ! ! where X, Y, and Z are nonnegative and at most one of them ! is zero. If one of them is zero, the integral is COMPLETE. ! The duplication theorem is iterated until the variables are ! nearly equal, and the function is then expanded in Taylor ! series to fifth order. ! ! 2. Calling Sequence ! RF( X, Y, Z, IER ) ! ! Parameters on Entry ! Values assigned by the calling routine ! ! X - Single precision, nonnegative variable ! ! Y - Single precision, nonnegative variable ! ! Z - Single precision, nonnegative variable ! ! ! ! On Return (values assigned by the RF routine) ! ! RF - Single precision approximation to the integral ! ! IER - Integer ! ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! ! IER > 0 Abnormal termination of the routine ! ! X, Y, Z are unaltered. ! ! ! 3. Error Messages ! ! Value of IER assigned by the RF routine ! ! Value assigned Error Message Printed ! IER = 1 MIN(X,Y,Z) < 0.0E0 ! = 2 MIN(X+Y,X+Z,Y+Z) < LOLIM ! = 3 MAX(X,Y,Z) > UPLIM ! ! ! ! 4. Control Parameters ! ! Values of LOLIM, UPLIM, and ERRTOL are set by the ! routine. ! ! LOLIM and UPLIM determine the valid range of X, Y and Z ! ! LOLIM - Lower limit of valid arguments ! ! Not less than 5 * (machine minimum). ! ! UPLIM - Upper limit of valid arguments ! ! Not greater than (machine maximum) / 5. ! ! ! Acceptable Values For: LOLIM UPLIM ! IBM 360/370 SERIES : 3.0E-78 1.0E+75 ! CDC 6000/7000 SERIES : 1.0E-292 1.0E+321 ! UNIVAC 1100 SERIES : 1.0E-37 1.0E+37 ! CRAY : 2.3E-2466 1.09E+2465 ! VAX 11 SERIES : 1.5E-38 3.0E+37 ! ! ! ! ERRTOL determines the accuracy of the answer ! ! The value assigned by the routine will result ! in solution precision within 1-2 decimals of ! "machine precision". ! ! ! ! ERRTOL - Relative error due to truncation is less than ! ERRTOL ** 6 / (4 * (1-ERRTOL) . ! ! ! ! The accuracy of the computed approximation to the inte- ! gral can be controlled by choosing the value of ERRTOL. ! Truncation of a Taylor series after terms of fifth order ! introduces an error less than the amount shown in the ! second column of the following table for each value of ! ERRTOL in the first column. In addition to the trunca- ! tion error there will be round-off error, but in prac- ! tice the total error from both sources is usually less ! than the amount given in the table. ! ! ! ! ! ! Sample Choices: ERRTOL Relative Truncation ! error less than ! 1.0E-3 3.0E-19 ! 3.0E-3 2.0E-16 ! 1.0E-2 3.0E-13 ! 3.0E-2 2.0E-10 ! 1.0E-1 3.0E-7 ! ! ! Decreasing ERRTOL by a factor of 10 yields six more ! decimal digits of accuracy at the expense of one or ! two more iterations of the duplication theorem. ! ! *Long Description: ! ! RF Special Comments ! ! ! ! Check by addition theorem: RF(X,X+Z,X+W) + RF(Y,Y+Z,Y+W) ! = RF(0,Z,W), where X,Y,Z,W are positive and X * Y = Z * W. ! ! ! On Input: ! ! X, Y, and Z are the variables in the integral RF(X,Y,Z). ! ! ! On Output: ! ! ! X, Y, and Z are unaltered. ! ! ! ! ******************************************************** ! ! Warning: Changes in the program may improve speed at the ! expense of robustness. ! ! ! ! Special Functions via RF ! ! ! Legendre form of ELLIPTIC INTEGRAL of 1st kind ! ---------------------------------------------- ! ! ! 2 2 2 ! F(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1) ! ! ! 2 ! K(K) = RF(0,1-K ,1) ! ! PI/2 2 2 -1/2 ! = INT (1-K SIN (PHI) ) D PHI ! 0 ! ! ! ! ! ! Bulirsch form of ELLIPTIC INTEGRAL of 1st kind ! ---------------------------------------------- ! ! ! 22 2 ! EL1(X,KC) = X RF(1,1+KC X ,1+X ) ! ! ! ! ! Lemniscate constant A ! --------------------- ! ! ! 1 4 -1/2 ! A = INT (1-S ) DS = RF(0,1,2) = RF(0,2,1) ! 0 ! ! ! ------------------------------------------------------------------- ! !***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete ! elliptic integrals, ACM Transactions on Mathematical ! Software 7, 3 (September 1981), pp. 398-403. ! B. C. Carlson, Computing elliptic integrals by ! duplication, Numerische Mathematik 33, (1979), ! pp. 1-16. ! B. C. Carlson, Elliptic integrals of the first kind, ! SIAM Journal of Mathematical Analysis 8, (1977), ! pp. 231-242. !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced statement labels. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900510 Changed calls to XERMSG to standard form, and some ! editorial changes. (RWC)) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RF real RF CHARACTER*16 XERN3, XERN4, XERN5, XERN6 INTEGER IER REAL LOLIM, UPLIM, EPSLON, ERRTOL REAL C1, C2, C3, E2, E3, LAMDA REAL MU, S, X, XN, XNDEV REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, & ZNROOT LOGICAL FIRST SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,FIRST DATA FIRST /.TRUE./ ! !***FIRST EXECUTABLE STATEMENT RF ! if (FIRST) THEN ERRTOL = (4.0E0*R1MACH(3))**(1.0E0/6.0E0) LOLIM = 5.0E0 * R1MACH(1) UPLIM = R1MACH(2)/5.0E0 ! C1 = 1.0E0/24.0E0 C2 = 3.0E0/44.0E0 C3 = 1.0E0/14.0E0 end if FIRST = .FALSE. ! ! call ERROR HANDLER if NECESSARY. ! RF = 0.0E0 if (MIN(X,Y,Z) < 0.0E0) THEN IER = 1 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z call XERMSG ('SLATEC', 'RF', & 'MIN(X,Y,Z) < 0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 // & ' AND Z = ' // XERN5, 1, 1) return end if ! if (MAX(X,Y,Z) > UPLIM) THEN IER = 3 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') UPLIM call XERMSG ('SLATEC', 'RF', & 'MAX(X,Y,Z) > UPLIM WHERE X = ' // XERN3 // ' Y = ' // & XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, 3, 1) return end if ! if (MIN(X+Y,X+Z,Y+Z) < LOLIM) THEN IER = 2 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') LOLIM call XERMSG ('SLATEC', 'RF', & 'MIN(X+Y,X+Z,Y+Z) < LOLIM WHERE X = ' // XERN3 // & ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // & XERN6, 2, 1) return end if ! IER = 0 XN = X YN = Y ZN = Z ! 30 MU = (XN+YN+ZN)/3.0E0 XNDEV = 2.0E0 - (MU+XN)/MU YNDEV = 2.0E0 - (MU+YN)/MU ZNDEV = 2.0E0 - (MU+ZN)/MU EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV)) if (EPSLON < ERRTOL) go to 40 XNROOT = SQRT(XN) YNROOT = SQRT(YN) ZNROOT = SQRT(ZN) LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT XN = (XN+LAMDA)*0.250E0 YN = (YN+LAMDA)*0.250E0 ZN = (ZN+LAMDA)*0.250E0 go to 30 ! 40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV E3 = XNDEV*YNDEV*ZNDEV S = 1.0E0 + (C1*E2-0.10E0-C2*E3)*E2 + C3*E3 RF = S/SQRT(MU) ! return end subroutine RFFTB1 (N, C, CH, WA, IFAC) ! !! RFFTB1 computes the backward fast Fourier transform of a real array. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A1 !***TYPE SINGLE PRECISION (RFFTB1-S, CFFTB1-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine RFFTB1 computes the real periodic sequence from its ! Fourier coefficients (Fourier synthesis). The transform is defined ! below at output parameter C. ! ! The arrays WA and IFAC which are used by subroutine RFFTB1 must be ! initialized by calling subroutine RFFTI1. ! ! Input Arguments ! ! N the length of the array R to be transformed. The method ! is most efficient when N is a product of small primes. ! N may change so long as different work arrays are provided. ! ! C a real array of length N which contains the sequence ! to be transformed. ! ! CH a real work array of length at least N. ! ! WA a real work array which must be dimensioned at least N. ! ! IFAC an integer work array which must be dimensioned at least 15. ! ! The WA and IFAC arrays must be initialized by calling ! subroutine RFFTI1, and different WA and IFAC arrays must be ! used for each different value of N. This initialization ! does not have to be repeated so long as N remains unchanged. ! Thus subsequent transforms can be obtained faster than the ! first. The same WA and IFAC arrays can be used by RFFTF1 ! and RFFTB1. ! ! Output Argument ! ! C For N even and for I = 1,...,N ! ! C(I) = C(1)+(-1)**(I-1)*C(N) ! ! plus the sum from K=2 to K=N/2 of ! ! 2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N) ! ! -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) ! ! For N odd and for I = 1,...,N ! ! C(I) = C(1) plus the sum from K=2 to K=(N+1)/2 of ! ! 2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N) ! ! -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) ! ! Notes: This transform is unnormalized since a call of RFFTF1 ! followed by a call of RFFTB1 will multiply the input ! sequence by N. ! ! WA and IFAC contain initialization calculations which must ! not be destroyed between calls of subroutine RFFTF1 or ! RFFTB1. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RADB2, RADB3, RADB4, RADB5, RADBG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from subsidiary to user-callable. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RFFTB1 DIMENSION CH(*), C(*), WA(*), IFAC(*) !***FIRST EXECUTABLE STATEMENT RFFTB1 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 /= 4) go to 103 IX2 = IW+IDO IX3 = IX2+IDO if (NA /= 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 /= 2) go to 106 if (NA /= 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 /= 3) go to 109 IX2 = IW+IDO if (NA /= 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 /= 5) go to 112 IX2 = IW+IDO IX3 = IX2+IDO IX4 = IX3+IDO if (NA /= 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 /= 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 == 1) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDO 116 CONTINUE if (NA == 0) RETURN DO 117 I=1,N C(I) = CH(I) 117 CONTINUE return end subroutine RFFTB (N, R, WSAVE) ! !! RFFTB computes the backward fast Fourier transform of a real array. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A1 !***TYPE SINGLE PRECISION (RFFTB-S, CFFTB-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! ******************************************************************** ! * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * ! ******************************************************************** ! * * ! * This routine uses non-standard Fortran 77 constructs and will * ! * be removed from the library at a future date. You are * ! * requested to use RFFTB1. * ! * * ! ******************************************************************** ! ! Subroutine RFFTB computes the real periodic sequence from its ! Fourier coefficients (Fourier synthesis). The transform is defined ! below at output parameter R. ! ! Input Arguments ! ! N the length of the array R to be transformed. The method ! is most efficient when N is a product of small primes. ! N may change so long as different work arrays are provided. ! ! R a real array of length N which contains the sequence ! to be transformed. ! ! WSAVE a work array which must be dimensioned at least 2*N+15 ! in the program that calls RFFTB. The WSAVE array must be ! initialized by calling subroutine RFFTI, and a different ! WSAVE array must be used for each different value of N. ! This initialization does not have to be repeated so long as ! remains unchanged. Thus subsequent transforms can be ! obtained faster than the first. Moreover, the same WSAVE ! array can be used by RFFTF and RFFTB as long as N remains ! unchanged. ! ! Output Argument ! ! R For N even and for I = 1,...,N ! ! R(I) = R(1)+(-1)**(I-1)*R(N) ! ! plus the sum from K=2 to K=N/2 of ! ! 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) ! ! -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) ! ! For N odd and for I = 1,...,N ! ! R(I) = R(1) plus the sum from K=2 to K=(N+1)/2 of ! ! 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) ! ! -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) ! ! Note: This transform is unnormalized since a call of RFFTF ! followed by a call of RFFTB will multiply the input ! sequence by N. ! ! WSAVE contains results which must not be destroyed between ! calls of RFFTB or RFFTF. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTB1 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from user-callable to subsidiary ! because of non-standard Fortran 77 arguments in the ! call to CFFTB1. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RFFTB DIMENSION R(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT RFFTB if (N == 1) RETURN call RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) return end subroutine RFFTF1 (N, C, CH, WA, IFAC) ! !! RFFTF1 computes the forward transform of a real, periodic sequence. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A1 !***TYPE SINGLE PRECISION (RFFTF1-S, CFFTF1-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine RFFTF1 computes the Fourier coefficients of a real ! periodic sequence (Fourier analysis). The transform is defined ! below at output parameter C. ! ! The arrays WA and IFAC which are used by subroutine RFFTB1 must be ! initialized by calling subroutine RFFTI1. ! ! Input Arguments ! ! N the length of the array R to be transformed. The method ! is most efficient when N is a product of small primes. ! N may change so long as different work arrays are provided. ! ! C a real array of length N which contains the sequence ! to be transformed. ! ! CH a real work array of length at least N. ! ! WA a real work array which must be dimensioned at least N. ! ! IFAC an integer work array which must be dimensioned at least 15. ! ! The WA and IFAC arrays must be initialized by calling ! subroutine RFFTI1, and different WA and IFAC arrays must be ! used for each different value of N. This initialization ! does not have to be repeated so long as N remains unchanged. ! Thus subsequent transforms can be obtained faster than the ! first. The same WA and IFAC arrays can be used by RFFTF1 ! and RFFTB1. ! ! Output Argument ! ! C C(1) = the sum from I=1 to I=N of R(I) ! ! If N is even set L = N/2; if N is odd set L = (N+1)/2 ! ! then for K = 2,...,L ! ! C(2*K-2) = the sum from I = 1 to I = N of ! ! C(I)*COS((K-1)*(I-1)*2*PI/N) ! ! C(2*K-1) = the sum from I = 1 to I = N of ! ! -C(I)*SIN((K-1)*(I-1)*2*PI/N) ! ! If N is even ! ! C(N) = the sum from I = 1 to I = N of ! ! (-1)**(I-1)*C(I) ! ! Notes: This transform is unnormalized since a call of RFFTF1 ! followed by a call of RFFTB1 will multiply the input ! sequence by N. ! ! WA and IFAC contain initialization calculations which must ! not be destroyed between calls of subroutine RFFTF1 or ! RFFTB1. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RADF2, RADF3, RADF4, RADF5, RADFG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from subsidiary to user-callable. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RFFTF1 DIMENSION CH(*), C(*), WA(*), IFAC(*) !***FIRST EXECUTABLE STATEMENT RFFTF1 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 /= 4) go to 102 IX2 = IW+IDO IX3 = IX2+IDO if (NA /= 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 /= 2) go to 104 if (NA /= 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 /= 3) go to 106 IX2 = IW+IDO if (NA /= 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 /= 5) go to 108 IX2 = IW+IDO IX3 = IX2+IDO IX4 = IX3+IDO if (NA /= 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 == 1) NA = 1-NA if (NA /= 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 == 1) RETURN DO 112 I=1,N C(I) = CH(I) 112 CONTINUE return end subroutine RFFTF (N, R, WSAVE) ! !! RFFTF computes the forward transform of a real, periodic sequence. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A1 !***TYPE SINGLE PRECISION (RFFTF-S, CFFTF-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! ******************************************************************** ! * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * ! ******************************************************************** ! * * ! * This routine uses non-standard Fortran 77 constructs and will * ! * be removed from the library at a future date. You are * ! * requested to use RFFTF1. * ! * * ! ******************************************************************** ! ! Subroutine RFFTF computes the Fourier coefficients of a real ! periodic sequence (Fourier analysis). The transform is defined ! below at output parameter R. ! ! Input Arguments ! ! N the length of the array R to be transformed. The method ! is most efficient when N is a product of small primes. ! N may change so long as different work arrays are provided. ! ! R a real array of length N which contains the sequence ! to be transformed. ! ! WSAVE a work array which must be dimensioned at least 2*N+15 ! in the program that calls RFFTF. The WSAVE array must be ! initialized by calling subroutine RFFTI, and a different ! WSAVE array must be used for each different value of N. ! This initialization does not have to be repeated so long as ! remains unchanged. Thus subsequent transforms can be ! obtained faster than the first. Moreover, the same WSAVE ! array can be used by RFFTF and RFFTB as long as N remains ! unchanged. ! ! Output Argument ! ! R R(1) = the sum from I=1 to I=N of R(I) ! ! If N is even set L = N/2; if N is odd set L = (N+1)/2 ! ! then for K = 2,...,L ! ! R(2*K-2) = the sum from I = 1 to I = N of ! ! R(I)*COS((K-1)*(I-1)*2*PI/N) ! ! R(2*K-1) = the sum from I = 1 to I = N of ! ! -R(I)*SIN((K-1)*(I-1)*2*PI/N) ! ! If N is even ! ! R(N) = the sum from I = 1 to I = N of ! ! (-1)**(I-1)*R(I) ! ! Note: This transform is unnormalized since a call of RFFTF ! followed by a call of RFFTB will multiply the input ! sequence by N. ! ! WSAVE contains results which must not be destroyed between ! calls of RFFTF or RFFTB. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTF1 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from user-callable to subsidiary ! because of non-standard Fortran 77 arguments in the ! call to CFFTB1. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RFFTF DIMENSION R(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT RFFTF if (N == 1) RETURN call RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) return end subroutine RFFTI1 (N, WA, IFAC) ! !! RFFTI1 initializes a real and an integer work array for RFFTF1 and RFFTB1. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A1 !***TYPE SINGLE PRECISION (RFFTI1-S, CFFTI1-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine RFFTI1 initializes the work arrays WA and IFAC which are ! used in both RFFTF1 and RFFTB1. The prime factorization of N and a ! tabulation of the trigonometric functions are computed and stored in ! IFAC and WA, respectively. ! ! Input Argument ! ! N the length of the sequence to be transformed. ! ! Output Arguments ! ! WA a real work array which must be dimensioned at least N. ! ! IFAC an integer work array which must be dimensioned at least 15. ! ! The same work arrays can be used for both RFFTF1 and RFFTB1 as long ! as N remains unchanged. Different WA and IFAC arrays are required ! for different values of N. The contents of WA and IFAC must not be ! changed between calls of RFFTF1 or RFFTB1. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing references to intrinsic function FLOAT ! to REAL, and ! (c) changing definition of variable TPI by using ! FORTRAN intrinsic functions instead of DATA ! statements. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from subsidiary to user-callable. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RFFTI1 DIMENSION WA(*), IFAC(*), NTRYH(4) SAVE NTRYH DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ !***FIRST EXECUTABLE STATEMENT RFFTI1 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 /= 2) go to 107 if (NF == 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 /= 1) go to 104 IFAC(1) = N IFAC(2) = NF TPI = 8.*ATAN(1.) ARGH = TPI/N IS = 0 NFM1 = NF-1 L1 = 1 if (NFM1 == 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 = 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 subroutine RFFTI (N, WSAVE) ! !! RFFTI initializes a work array for RFFTF and RFFTB. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A1 !***TYPE SINGLE PRECISION (RFFTI-S, CFFTI-C) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! ******************************************************************** ! * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * ! ******************************************************************** ! * * ! * This routine uses non-standard Fortran 77 constructs and will * ! * be removed from the library at a future date. You are * ! * requested to use RFFTI1. * ! * * ! ******************************************************************** ! ! Subroutine RFFTI initializes the array WSAVE which is used in ! both RFFTF and RFFTB. The prime factorization of N together with ! a tabulation of the trigonometric functions are computed and ! stored in WSAVE. ! ! Input Argument ! ! N the length of the sequence to be transformed. ! ! Output Argument ! ! WSAVE a work array which must be dimensioned at least 2*N+15. ! The same work array can be used for both RFFTF and RFFTB ! as long as N remains unchanged. Different WSAVE arrays ! are required for different values of N. The contents of ! WSAVE must not be changed between calls of RFFTF or RFFTB. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTI1 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900131 Routine changed from user-callable to subsidiary ! because of non-standard Fortran 77 arguments in the ! call to CFFTB1. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RFFTI DIMENSION WSAVE(*) !***FIRST EXECUTABLE STATEMENT RFFTI if (N == 1) RETURN call RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) return end function RGAUSS (XMEAN, SD) ! !! RGAUSS generate a normally distributed (Gaussian) random number. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY L6A14 !***TYPE SINGLE PRECISION (RGAUSS-S) !***KEYWORDS FNLIB, GAUSSIAN, NORMAL, RANDOM NUMBER, SPECIAL FUNCTIONS !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Generate a normally distributed random number, i.e., generate random ! numbers with a Gaussian distribution. These random numbers are not ! exceptionally good -- especially in the tails of the distribution, ! but this implementation is simple and suitable for most applications. ! See R. W. Hamming, Numerical Methods for Scientists and Engineers, ! McGraw-Hill, 1962, pages 34 and 389. ! ! Input Arguments -- ! XMEAN the mean of the Guassian distribution. ! SD the standard deviation of the Guassian function ! EXP (-1/2 * (X-XMEAN)**2 / SD**2) ! !***REFERENCES (NONE) !***ROUTINES CALLED RAND !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910819 Added EXTERNAL statement for RAND due to problem on IBM ! RS 6000. (WRB) !***END PROLOGUE RGAUSS EXTERNAL RAND !***FIRST EXECUTABLE STATEMENT RGAUSS RGAUSS = -6.0 DO 10 I=1,12 RGAUSS = RGAUSS + RAND(0.0) 10 CONTINUE ! RGAUSS = XMEAN + SD*RGAUSS ! return end subroutine RG (NM, N, A, WR, WI, MATZ, Z, IV1, FV1, IERR) ! !! RG computes the eigenvalues and eigenvectors of a real general matrix. !! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A2 !***TYPE SINGLE PRECISION (RG-S, CG-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! To find the eigenvalues and eigenvectors (if desired) ! of a REAL GENERAL matrix. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! A contains the real general matrix. A is a two-dimensional ! REAL array, dimensioned A(NM,N). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On Output ! ! A has been destroyed. ! ! WR and WI contain the real and imaginary parts, respectively, ! of the eigenvalues. The eigenvalues are unordered except ! that complex conjugate pairs of eigenvalues appear consecu- ! tively with the eigenvalue having the positive imaginary part ! first. If an error exit is made, the eigenvalues should be ! correct for indices IERR+1, IERR+2, ..., N. WR and WI are ! one-dimensional REAL arrays, dimensioned WR(N) and WI(N). ! ! Z contains the real and imaginary parts of the eigenvectors ! if MATZ is not zero. If the J-th eigenvalue is real, the ! J-th column of Z contains its eigenvector. If the J-th ! eigenvalue is complex with positive imaginary part, the ! J-th and (J+1)-th columns of Z contain the real and ! imaginary parts of its eigenvector. The conjugate of this ! vector is the eigenvector for the conjugate eigenvalue. ! Z is a two-dimensional REAL array, dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! J if the J-th eigenvalue has not been ! determined after a total of 30 iterations. ! The eigenvalues should be correct for indices ! IERR+1, IERR+2, ..., N, but no eigenvectors are ! computed. ! ! IV1 and FV1 are one-dimensional temporary storage arrays of ! dimension N. IV1 is of type INTEGER and FV1 of type REAL. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED BALANC, BALBAK, ELMHES, ELTRAN, HQR, HQR2 !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) ! 921103 Corrected description of IV1. (DWL, FNF and WRB) !***END PROLOGUE RG ! INTEGER N,NM,IS1,IS2,IERR,MATZ REAL A(NM,*),WR(*),WI(*),Z(NM,*),FV1(*) INTEGER IV1(*) ! !***FIRST EXECUTABLE STATEMENT RG if (N <= NM) go to 10 IERR = 10 * N go to 50 ! 10 call BALANC(NM,N,A,IS1,IS2,FV1) call ELMHES(NM,N,IS1,IS2,A,IV1) if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call HQR(NM,N,IS1,IS2,A,WR,WI,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 call ELTRAN(NM,N,IS1,IS2,A,IV1,Z) call HQR2(NM,N,IS1,IS2,A,WR,WI,Z,IERR) if (IERR /= 0) go to 50 call BALBAK(NM,N,IS1,IS2,FV1,N,Z) 50 RETURN end subroutine RGG (NM, N, A, B, ALFR, ALFI, BETA, MATZ, Z, IERR) ! !! RGG computes eigenvalues and eigenvectors for real generalized eigenproblem. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4B2 !***TYPE SINGLE PRECISION (RGG-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! to find the eigenvalues and eigenvectors (if desired) ! for the REAL GENERAL GENERALIZED eigenproblem Ax = (LAMBDA)Bx. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A, B, and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrices A and B. N is an INTEGER ! variable. N must be less than or equal to NM. ! ! A contains a real general matrix. A is a two-dimensional ! REAL array, dimensioned A(NM,N). ! ! B contains a real general matrix. B is a two-dimensional ! REAL array, dimensioned B(NM,N). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On Output ! ! A and B have been destroyed. ! ! ALFR and ALFI contain the real and imaginary parts, ! respectively, of the numerators of the eigenvalues. ! ALFR and ALFI are one-dimensional REAL arrays, ! dimensioned ALFR(N) and ALFI(N). ! ! BETA contains the denominators of the eigenvalues, ! which are thus given by the ratios (ALFR+I*ALFI)/BETA. ! Complex conjugate pairs of eigenvalues appear consecutively ! with the eigenvalue having the positive imaginary part first. ! BETA is a one-dimensional REAL array, dimensioned BETA(N). ! ! Z contains the real and imaginary parts of the eigenvectors ! if MATZ is not zero. If the J-th eigenvalue is real, the ! J-th column of Z contains its eigenvector. If the J-th ! eigenvalue is complex with positive imaginary part, the ! J-th and (J+1)-th columns of Z contain the real and ! imaginary parts of its eigenvector. The conjugate of this ! vector is the eigenvector for the conjugate eigenvalue. ! Z is a two-dimensional REAL array, dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! J if the J-th eigenvalue has not been ! determined after a total of 30*N iterations. ! The eigenvalues should be correct for indices ! IERR+1, IERR+2, ..., N, but no eigenvectors are ! computed. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED QZHES, QZIT, QZVAL, QZVEC !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RGG ! INTEGER N,NM,IERR,MATZ REAL A(NM,*),B(NM,*),ALFR(*),ALFI(*),BETA(*),Z(NM,*) LOGICAL TF ! !***FIRST EXECUTABLE STATEMENT RGG if (N <= NM) go to 10 IERR = 10 * N go to 50 ! 10 if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... TF = .FALSE. call QZHES(NM,N,A,B,TF,Z) call QZIT(NM,N,A,B,0.0E0,TF,Z,IERR) call QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 TF = .TRUE. call QZHES(NM,N,A,B,TF,Z) call QZIT(NM,N,A,B,0.0E0,TF,Z,IERR) call QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z) if (IERR /= 0) go to 50 call QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z) 50 RETURN end FUNCTION RJ (X, Y, Z, P, IER) ! !! RJ: incomplete or complete (X, Y, or Z = 0) elliptic integral of 3rd kind. ! For X, Y, and Z non-negative, at most one of them zero, and P positive, ! RJ(X,Y,Z,P) = Integral from zero to infinity of ! -1/2 -1/2 -1/2 -1 ! (3/2)(t+X) (t+Y) (t+Z) (t+P) dt. ! !***LIBRARY SLATEC !***CATEGORY C14 !***TYPE SINGLE PRECISION (RJ-S, DRJ-D) !***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, ! INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE THIRD KIND, ! TAYLOR SERIES !***AUTHOR Carlson, B. C. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Notis, E. M. ! Ames Laboratory-DOE ! Iowa State University ! Ames, IA 50011 ! Pexton, R. L. ! Lawrence Livermore National Laboratory ! Livermore, CA 94550 !***DESCRIPTION ! ! 1. RJ ! Standard FORTRAN function routine ! Single precision version ! The routine calculates an approximation result to ! RJ(X,Y,Z,P) = Integral from zero to infinity of ! ! -1/2 -1/2 -1/2 -1 ! (3/2)(t+X) (t+Y) (t+Z) (t+P) dt, ! ! where X, Y, and Z are nonnegative, at most one of them is ! zero, and P is positive. If X or Y or Z is zero, the ! integral is COMPLETE. The duplication theorem is iterated ! until the variables are nearly equal, and the function is ! then expanded in Taylor series to fifth order. ! ! ! 2. Calling Sequence ! RJ( X, Y, Z, P, IER ) ! ! Parameters On Entry ! Values assigned by the calling routine ! ! X - Single precision, nonnegative variable ! ! Y - Single precision, nonnegative variable ! ! Z - Single precision, nonnegative variable ! ! P - Single precision, positive variable ! ! ! On Return (values assigned by the RJ routine) ! ! RJ - Single precision approximation to the integral ! ! IER - Integer ! ! IER = 0 Normal and reliable termination of the ! routine. It is assumed that the requested ! accuracy has been achieved. ! ! IER > 0 Abnormal termination of the routine ! ! ! X, Y, Z, P are unaltered. ! ! ! 3. Error Messages ! ! Value of IER assigned by the RJ routine ! ! Value Assigned Error Message Printed ! IER = 1 MIN(X,Y,Z) < 0.0E0 ! = 2 MIN(X+Y,X+Z,Y+Z,P) < LOLIM ! = 3 MAX(X,Y,Z,P) > UPLIM ! ! ! ! 4. Control Parameters ! ! Values of LOLIM, UPLIM, and ERRTOL are set by the ! routine. ! ! ! LOLIM and UPLIM determine the valid range of X Y, Z, and P ! ! LOLIM is not less than the cube root of the value ! of LOLIM used in the routine for RC. ! ! UPLIM is not greater than 0.3 times the cube root of ! the value of UPLIM used in the routine for RC. ! ! ! Acceptable Values For: LOLIM UPLIM ! IBM 360/370 SERIES : 2.0E-26 3.0E+24 ! CDC 6000/7000 SERIES : 5.0E-98 3.0E+106 ! UNIVAC 1100 SERIES : 5.0E-13 6.0E+11 ! CRAY : 1.32E-822 1.4E+821 ! VAX 11 SERIES : 2.5E-13 9.0E+11 ! ! ! ! ERRTOL determines the accuracy of the answer ! ! The value assigned by the routine will result ! in solution precision within 1-2 decimals of ! "machine precision". ! ! ! ! ! Relative error due to truncation of the series for RJ ! is less than 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2. ! ! ! ! The accuracy of the computed approximation to the inte- ! gral can be controlled by choosing the value of ERRTOL. ! Truncation of a Taylor series after terms of fifth order ! Introduces an error less than the amount shown in the ! second column of the following table for each value of ! ERRTOL in the first column. In addition to the trunca- ! tion error there will be round-off error, but in prac- ! tice the total error from both sources is usually less ! than the amount given in the table. ! ! ! ! Sample choices: ERRTOL Relative Truncation ! error less than ! 1.0E-3 4.0E-18 ! 3.0E-3 3.0E-15 ! 1.0E-2 4.0E-12 ! 3.0E-2 3.0E-9 ! 1.0E-1 4.0E-6 ! ! Decreasing ERRTOL by a factor of 10 yields six more ! decimal digits of accuracy at the expense of one or ! two more iterations of the duplication theorem. ! ! *Long Description: ! ! RJ Special Comments ! ! ! Check by addition theorem: RJ(X,X+Z,X+W,X+P) ! + RJ(Y,Y+Z,Y+W,Y+P) + (A-B) * RJ(A,B,B,A) + 3 / SQRT(A) ! = RJ(0,Z,W,P), where X,Y,Z,W,P are positive and X * Y ! = Z * W, A = P * P * (X+Y+Z+W), B = P * (P+X) * (P+Y), ! and B - A = P * (P-Z) * (P-W). The sum of the third and ! fourth terms on the left side is 3 * RC(A,B). ! ! ! On Input: ! ! X, Y, Z, and P are the variables in the integral RJ(X,Y,Z,P). ! ! ! On Output: ! ! ! X, Y, Z, and P are unaltered. ! ! ******************************************************** ! ! Warning: Changes in the program may improve speed at the ! expense of robustness. ! ! ------------------------------------------------------------ ! ! ! Special Functions via RJ and RF ! ! ! Legendre form of ELLIPTIC INTEGRAL of 3rd kind ! ---------------------------------------------- ! ! ! PHI 2 -1 ! P(PHI,K,N) = INT (1+N SIN (THETA) ) * ! 0 ! ! 2 2 -1/2 ! *(1-K SIN (THETA) ) D THETA ! ! ! 2 2 2 ! = SIN (PHI) RF(COS (PHI), 1-K SIN (PHI),1) ! ! 3 2 2 2 ! -(N/3) SIN (PHI) RJ(COS (PHI),1-K SIN (PHI), ! ! 2 ! 1,1+N SIN (PHI)) ! ! ! ! Bulirsch form of ELLIPTIC INTEGRAL of 3rd kind ! ---------------------------------------------- ! ! ! 22 2 ! EL3(X,KC,P) = X RF(1,1+KC X ,1+X ) + ! ! 3 22 2 2 ! +(1/3)(1-P) X RJ(1,1+KC X ,1+X ,1+PX ) ! ! ! 2 ! CEL(KC,P,A,B) = A RF(0,KC ,1) + ! ! 2 ! +(1/3)(B-PA) RJ(0,KC ,1,P) ! ! ! ! ! Heuman's LAMBDA function ! ------------------------ ! ! ! 2 2 2 1/2 ! L(A,B,P) = (COS(A)SIN(B)COS(B)/(1-COS (A)SIN (B)) ) ! ! 2 2 2 ! *(SIN(P) RF(COS (P),1-SIN (A) SIN (P),1) ! ! 2 3 2 2 ! +(SIN (A) SIN (P)/(3(1-COS (A) SIN (B)))) ! ! 2 2 2 ! *RJ(COS (P),1-SIN (A) SIN (P),1,1- ! ! 2 2 2 2 ! -SIN (A) SIN (P)/(1-COS (A) SIN (B)))) ! ! ! ! ! (PI/2) LAMBDA0(A,B) =L(A,B,PI/2) = ! ! ! 2 2 2 -1/2 ! = COS (A) SIN(B) COS(B) (1-COS (A) SIN (B)) ! ! 2 2 2 ! *RF(0,COS (A),1) + (1/3) SIN (A) COS (A) ! ! 2 2 -3/2 ! *SIN(B) COS(B) (1-COS (A) SIN (B)) ! ! 2 2 2 2 2 ! *RJ(0,COS (A),1,COS (A) COS (B)/(1-COS (A) SIN (B))) ! ! ! ! Jacobi ZETA function ! -------------------- ! ! ! 2 2 2 1/2 ! Z(B,K) = (K/3) SIN(B) COS(B) (1-K SIN (B)) ! ! ! 2 2 2 2 ! *RJ(0,1-K ,1,1-K SIN (B)) / RF (0,1-K ,1) ! ! ! ------------------------------------------------------------------- ! !***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete ! elliptic integrals, ACM Transactions on Mathematical ! Software 7, 3 (September 1981), pp. 398-403. ! B. C. Carlson, Computing elliptic integrals by ! duplication, Numerische Mathematik 33, (1979), ! pp. 1-16. ! B. C. Carlson, Elliptic integrals of the first kind, ! SIAM Journal of Mathematical Analysis 8, (1977), ! pp. 231-242. !***ROUTINES CALLED R1MACH, RC, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced statement labels. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900510 Changed calls to XERMSG to standard form, and some ! editorial changes. (RWC)). ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RJ real RJ CHARACTER*16 XERN3, XERN4, XERN5, XERN6, XERN7 INTEGER IER REAL ALFA, BETA, C1, C2, C3, C4, EA, EB, EC, E2, E3 REAL LOLIM, UPLIM, EPSLON, ERRTOL REAL LAMDA, MU, P, PN, PNDEV REAL POWER4, RC, SIGMA, S1, S2, S3, X, XN, XNDEV REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, & ZNROOT LOGICAL FIRST SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,FIRST DATA FIRST /.TRUE./ ! !***FIRST EXECUTABLE STATEMENT RJ if (FIRST) THEN ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0) LOLIM = (5.0E0 * R1MACH(1))**(1.0E0/3.0E0) UPLIM = 0.30E0*( R1MACH(2) / 5.0E0)**(1.0E0/3.0E0) ! C1 = 3.0E0/14.0E0 C2 = 1.0E0/3.0E0 C3 = 3.0E0/22.0E0 C4 = 3.0E0/26.0E0 end if FIRST = .FALSE. ! ! call ERROR HANDLER if NECESSARY. ! RJ = 0.0E0 if (MIN(X,Y,Z) < 0.0E0) THEN IER = 1 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z call XERMSG ('SLATEC', 'RJ', & 'MIN(X,Y,Z) < 0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 // & ' AND Z = ' // XERN5, 1, 1) return end if ! if (MAX(X,Y,Z,P) > UPLIM) THEN IER = 3 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') P WRITE (XERN7, '(1PE15.6)') UPLIM call XERMSG ('SLATEC', 'RJ', & 'MAX(X,Y,Z,P) > UPLIM WHERE X = ' // XERN3 // ' Y = ' // & XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 // & ' AND UPLIM = ' // XERN7, 3, 1) return end if ! if (MIN(X+Y,X+Z,Y+Z,P) < LOLIM) THEN IER = 2 WRITE (XERN3, '(1PE15.6)') X WRITE (XERN4, '(1PE15.6)') Y WRITE (XERN5, '(1PE15.6)') Z WRITE (XERN6, '(1PE15.6)') P WRITE (XERN7, '(1PE15.6)') LOLIM call XERMSG ('SLATEC', 'RJ', & 'MIN(X+Y,X+Z,Y+Z,P) < LOLIM WHERE X = ' // XERN3 // & ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 // & ' AND LOLIM = ', 2, 1) return end if ! IER = 0 XN = X YN = Y ZN = Z PN = P SIGMA = 0.0E0 POWER4 = 1.0E0 ! 30 MU = (XN+YN+ZN+PN+PN)*0.20E0 XNDEV = (MU-XN)/MU YNDEV = (MU-YN)/MU ZNDEV = (MU-ZN)/MU PNDEV = (MU-PN)/MU EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV), ABS(PNDEV)) if (EPSLON < ERRTOL) go to 40 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) SIGMA = SIGMA + POWER4*RC(ALFA,BETA,IER) POWER4 = POWER4*0.250E0 XN = (XN+LAMDA)*0.250E0 YN = (YN+LAMDA)*0.250E0 ZN = (ZN+LAMDA)*0.250E0 PN = (PN+LAMDA)*0.250E0 go to 30 ! 40 EA = XNDEV*(YNDEV+ZNDEV) + YNDEV*ZNDEV EB = XNDEV*YNDEV*ZNDEV EC = PNDEV*PNDEV E2 = EA - 3.0E0*EC E3 = EB + 2.0E0*PNDEV*(EA-EC) S1 = 1.0E0 + E2*(-C1+0.750E0*C3*E2-1.50E0*C4*E3) S2 = EB*(0.50E0*C2+PNDEV*(-C3-C3+PNDEV*C4)) S3 = PNDEV*EA*(C2-PNDEV*C3) - C2*PNDEV*EC RJ = 3.0E0*SIGMA + POWER4*(S1+S2+S3)/(MU* SQRT(MU)) return end subroutine RKFAB (NCOMP, XPTS, NXPTS, NFC, IFLAG, Z, MXNON, P, & NTP, IP, YHP, NIV, U, V, W, S, STOWA, G, WORK, IWORK, NFCC) ! !! RKFAB integrates an initial value problem for BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (RKFAB-S, DRKFAB-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! ! Subroutine RKFAB integrates the initial value equations using ! the variable-step RUNGE-KUTTA-FEHLBERG integration scheme or ! the variable-order ADAMS method and orthonormalization ! determined by a linear dependence test. ! ! ********************************************************************** ! !***SEE ALSO BVSUP !***ROUTINES CALLED BVDER, DEABM, DERKF, REORT, STOR1 !***COMMON BLOCKS ML15TO, ML17BW, ML18JR, ML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE RKFAB ! DIMENSION P(NTP,*),IP(NFCC,*),U(NCOMP,NFC,*), & V(NCOMP,*),W(NFCC,*),Z(*),YHP(NCOMP,*), & XPTS(*),S(*),STOWA(*),WORK(*),IWORK(*), & G(*) ! ! ********************************************************************** ! COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /ML18JR/ AE,RE,TOL,NXPTSD,NIC,NOPG,MXNOND,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD, & ICOCO COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, & K10,K11,L1,L2,KKKINT,LLLINT ! EXTERNAL BVDER ! ! ********************************************************************** ! INITIALIZATION OF COUNTERS AND VARIABLES. ! !***FIRST EXECUTABLE STATEMENT RKFAB KOD = 1 NON = 1 X = XBEG JON = 1 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 1 WORK(1) = XEND if (NOPG == 0) go to 1 INFO(3) = 0 if (X == Z(1)) JON = 2 1 NFCP1 = NFC + 1 ! ! ********************************************************************** ! *****BEGINNING OF INTEGRATION LOOP AT OUTPUT POINTS.****************** ! ********************************************************************** ! DO 110 KOPP = 2,NXPTS KOP=KOPP ! 5 XOP = XPTS(KOP) if (NDISK == 0) KOD = KOP ! ! STEP BY STEP INTEGRATION LOOP BETWEEN OUTPUT POINTS. ! 10 XXOP = XOP if (NOPG == 0) go to 15 if (XEND > XBEG.AND.XOP > Z(JON)) XXOP=Z(JON) if (XEND < XBEG.AND.XOP < Z(JON)) XXOP=Z(JON) ! ! ********************************************************************** 15 go to (20,25),INTEG ! DERKF INTEGRATOR ! 20 call DERKF(BVDER,NEQ,X,YHP,XXOP,INFO,RE,AE,IDID,WORK,KKKINT, & IWORK,LLLINT,G,IPAR) go to 28 ! DEABM INTEGRATOR ! 25 call DEABM(BVDER,NEQ,X,YHP,XXOP,INFO,RE,AE,IDID,WORK,KKKINT, & IWORK,LLLINT,G,IPAR) 28 if ( IDID >= 1) go to 30 INFO(1) = 1 if ( IDID == -1) go to 15 IFLAG = 20 - IDID return ! ! ********************************************************************** ! GRAM-SCHMIDT ORTHOGONALIZATION TEST FOR ORTHONORMALIZATION ! (TEMPORARILY USING U AND V IN THE TEST) ! 30 if (NOPG == 0) go to 35 if (XXOP /= Z(JON)) go to 100 JFLAG=2 go to 40 35 JFLAG=1 if (INHOMO == 3 .AND. X == XEND) JFLAG=3 ! 40 if (NDISK == 0) NON=NUMORT+1 call REORT(NCOMP,U(1,1,KOD),V(1,KOD),YHP,NIV, & W(1,NON),S,P(1,NON),IP(1,NON),STOWA,JFLAG) ! if (JFLAG /= 30) go to 45 IFLAG=30 return ! 45 if (JFLAG == 10) go to 5 ! if (JFLAG /= 0) go to 100 ! ! ********************************************************************** ! STORE ORTHONORMALIZED VECTORS INTO SOLUTION VECTORS. ! if (NUMORT < MXNON) go to 65 if (X == XEND) go to 65 IFLAG = 13 return ! 65 NUMORT = NUMORT + 1 call STOR1(YHP,U(1,1,KOD),YHP(1,NFCP1),V(1,KOD),1, & NDISK,NTAPE) ! ! ********************************************************************** ! STORE ORTHONORMALIZATION INFORMATION, INITIALIZE ! INTEGRATION FLAG, AND CONTINUE INTEGRATION TO THE NEXT ! ORTHONORMALIZATION POINT OR OUTPUT POINT. ! Z(NUMORT) = X if (INHOMO == 1 .AND. NPS == 0) C = S(NFCP1) * C if (NDISK == 0) go to 90 if (INHOMO == 1) WRITE (NTAPE) (W(J,1), J = 1,NFCC) WRITE(NTAPE) (IP(J,1), J = 1,NFCC),(P(J,1), J = 1,NTP) 90 INFO(1) = 0 JON = JON + 1 if (NOPG == 1 .AND. X /= XOP) go to 10 ! ! ********************************************************************** ! CONTINUE INTEGRATION if WE ARE NOT AT AN OUTPUT POINT. ! 100 if (IDID == 1) go to 15 ! ! STORAGE OF HOMOGENEOUS SOLUTIONS IN U AND THE PARTICULAR ! SOLUTION IN V AT THE OUTPUT POINTS. ! call STOR1(U(1,1,KOD),YHP,V(1,KOD),YHP(1,NFCP1),0,NDISK,NTAPE) 110 CONTINUE ! ********************************************************************** ! ********************************************************************** ! IFLAG = 0 return end subroutine RPQR79 (NDEG, COEFF, ROOT, IERR, WORK) ! !! RPQR79 finds the zeros of a polynomial with real coefficients. ! !***LIBRARY SLATEC !***CATEGORY F1A1A !***TYPE SINGLE PRECISION (RPQR79-S, CPQR79-C) !***KEYWORDS COMPLEX POLYNOMIAL, POLYNOMIAL ROOTS, POLYNOMIAL ZEROS !***AUTHOR Vandevender, W. H., (SNLA) !***DESCRIPTION ! ! Abstract ! This routine computes all zeros of a polynomial of degree NDEG ! with real coefficients by computing the eigenvalues of the ! companion matrix. ! ! Description of Parameters ! The user must dimension all arrays appearing in the call list ! COEFF(NDEG+1), ROOT(NDEG), WORK(NDEG*(NDEG+2)) ! ! --Input-- ! NDEG degree of polynomial ! ! COEFF REAL coefficients in descending order. i.e., ! P(Z)= COEFF(1)*(Z**NDEG) + COEFF(NDEG)*Z + COEFF(NDEG+1) ! ! WORK REAL work array of dimension at least NDEG*(NDEG+2) ! ! --Output-- ! ROOT COMPLEX vector of roots ! ! IERR Output Error Code ! - Normal Code ! 0 means the roots were computed. ! - Abnormal Codes ! 1 more than 30 QR iterations on some eigenvalue of the ! companion matrix ! 2 COEFF(1)=0.0 ! 3 NDEG is invalid (less than or equal to 0) ! !***REFERENCES (NONE) !***ROUTINES CALLED HQR, XERMSG !***REVISION HISTORY (YYMMDD) ! 800601 DATE WRITTEN ! 890505 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 911010 Code reworked and simplified. (RWC and WRB) !***END PROLOGUE RPQR79 REAL COEFF(*), WORK(*), SCALE COMPLEX ROOT(*) INTEGER NDEG, IERR, K, KH, KWR, KWI, KCOL !***FIRST EXECUTABLE STATEMENT RPQR79 IERR = 0 if (ABS(COEFF(1)) == 0.0) THEN IERR = 2 call XERMSG ('SLATEC', 'RPQR79', & 'LEADING COEFFICIENT IS ZERO.', 2, 1) return end if ! if (NDEG <= 0) THEN IERR = 3 call XERMSG ('SLATEC', 'RPQR79', 'DEGREE INVALID.', 3, 1) return end if ! if (NDEG == 1) THEN ROOT(1) = CMPLX(-COEFF(2)/COEFF(1),0.0) return end if ! SCALE = 1.0E0/COEFF(1) KH = 1 KWR = KH+NDEG*NDEG KWI = KWR+NDEG KWEND = KWI+NDEG-1 ! DO 10 K=1,KWEND WORK(K) = 0.0E0 10 CONTINUE ! DO 20 K=1,NDEG KCOL = (K-1)*NDEG+1 WORK(KCOL) = -COEFF(K+1)*SCALE if (K /= NDEG) WORK(KCOL+K) = 1.0E0 20 CONTINUE ! call HQR (NDEG,NDEG,1,NDEG,WORK(KH),WORK(KWR),WORK(KWI),IERR) ! if (IERR /= 0) THEN IERR = 1 call XERMSG ('SLATEC', 'CPQR79', & 'NO CONVERGENCE IN 30 QR ITERATIONS.', 1, 1) return end if ! DO 30 K=1,NDEG KM1 = K-1 ROOT(K) = CMPLX(WORK(KWR+KM1),WORK(KWI+KM1)) 30 CONTINUE return end subroutine RPZERO (N, A, R, T, IFLG, S) ! !! RPZERO finds the zeros of a polynomial with real coefficients. ! !***LIBRARY SLATEC !***CATEGORY F1A1A !***TYPE SINGLE PRECISION (RPZERO-S, CPZERO-C) !***KEYWORDS POLYNOMIAL ROOTS, POLYNOMIAL ZEROS, REAL ROOTS !***AUTHOR Kahaner, D. K., (NBS) !***DESCRIPTION ! ! Find the zeros of the real polynomial ! P(X)= A(1)*X**N + A(2)*X**(N-1) +...+ A(N+1) ! ! Input... ! N = degree of P(X) ! A = real vector containing coefficients of P(X), ! A(I) = coefficient of X**(N+1-I) ! R = N word complex vector containing initial estimates for zeros ! if these are known. ! T = 6(N+1) word array used for temporary storage ! IFLG = flag to indicate if initial estimates of ! zeros are input. ! If IFLG == 0, no estimates are input. ! If IFLG /= 0, the vector R contains estimates of ! the zeros ! ** Warning ****** If estimates are input, they must ! be separated; that is, distinct or ! not repeated. ! S = an N word array ! ! Output... ! R(I) = ith zero, ! S(I) = bound for R(I) . ! IFLG = error diagnostic ! Error Diagnostics... ! If IFLG == 0 on return, all is well. ! If IFLG == 1 on return, A(1)=0.0 or N=0 on input. ! If IFLG == 2 on return, the program failed to converge ! after 25*N iterations. Best current estimates of the ! zeros are in R(I). Error bounds are not calculated. ! !***REFERENCES (NONE) !***ROUTINES CALLED CPZERO !***REVISION HISTORY (YYMMDD) ! 810223 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE RPZERO ! COMPLEX R(*), T(*) REAL A(*), S(*) !***FIRST EXECUTABLE STATEMENT RPZERO N1=N+1 DO 1 I=1,N1 T(I)= CMPLX(A(I),0.0) 1 CONTINUE call CPZERO(N,T,R,T(N+2),IFLG,S) return end subroutine RSB (NM, N, MB, A, W, MATZ, Z, FV1, FV2, IERR) ! !! RSB computes eigenvalues and eigenvectors of a symmetric band matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A6 !***TYPE SINGLE PRECISION (RSB-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! to find the eigenvalues and eigenvectors (if desired) ! of a REAL SYMMETRIC BAND matrix. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! MB is the half band width of the matrix, defined as the ! number of adjacent diagonals, including the principal ! diagonal, required to specify the non-zero portion of the ! lower triangle of the matrix. MB must be less than or ! equal to N. MB is an INTEGER variable. ! ! A contains the lower triangle of the real symmetric band ! matrix. Its lowest subdiagonal is stored in the last ! N+1-MB positions of the first column, its next subdiagonal ! in the last N+2-MB positions of the second column, further ! subdiagonals similarly, and finally its principal diagonal ! in the N positions of the last column. Contents of storage ! locations not part of the matrix are arbitrary. A is a ! two-dimensional REAL array, dimensioned A(NM,MB). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On Output ! ! A has been destroyed. ! ! W contains the eigenvalues in ascending order. W is a one- ! dimensional REAL array, dimensioned W(N). ! ! Z contains the eigenvectors if MATZ is not zero. The ! eigenvectors are orthonormal. Z is a two-dimensional ! REAL array, dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! 12*N if MB is either non-positive or greater than N, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues and eigenvectors, if requested, ! should be correct for indices 1, 2, ..., IERR-1. ! ! FV1 and FV2 are one-dimensional REAL arrays used for temporary ! storage, dimensioned FV1(N) and FV2(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED BANDR, TQL2, TQLRAT !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RSB ! INTEGER N,MB,NM,IERR,MATZ REAL A(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) LOGICAL TF ! !***FIRST EXECUTABLE STATEMENT RSB if (N <= NM) go to 5 IERR = 10 * N go to 50 5 if (MB > 0) go to 10 IERR = 12 * N go to 50 10 if (MB <= N) go to 15 IERR = 12 * N go to 50 ! 15 if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... TF = .FALSE. call BANDR(NM,N,MB,A,W,FV1,FV2,TF,Z) call TQLRAT(N,W,FV2,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 TF = .TRUE. call BANDR(NM,N,MB,A,W,FV1,FV1,TF,Z) call TQL2(NM,N,W,FV1,Z,IERR) 50 RETURN end subroutine RSCO (RSAV, ISAV) ! !! RSCO is subsidiary to DEBDF. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (RSCO-S, DRSCO-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! RSCO transfers data from arrays to a common block within the ! integrator package DEBDF. ! !***SEE ALSO DEBDF !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DEBDF1 !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE RSCO ! ! !----------------------------------------------------------------------- ! THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON ! BLOCK DEBDF1 , WHICH IS USED INTERNALLY IN THE DEBDF ! PACKAGE. THIS PRESUMES THAT RSAV AND ISAV WERE LOADED BY MEANS ! OF SUBROUTINE SVCO OR THE EQUIVALENT. !----------------------------------------------------------------------- INTEGER ISAV, I, ILS, LENILS, LENRLS REAL RSAV, RLS DIMENSION RSAV(*), ISAV(*) COMMON /DEBDF1/ RLS(218), ILS(33) SAVE LENRLS, LENILS DATA LENRLS/218/, LENILS/33/ ! !***FIRST EXECUTABLE STATEMENT RSCO DO 10 I = 1,LENRLS 10 RLS(I) = RSAV(I) DO 20 I = 1,LENILS 20 ILS(I) = ISAV(I) return !----------------------- END OF SUBROUTINE RSCO ----------------------- end subroutine RS (NM, N, A, W, MATZ, Z, FV1, FV2, IERR) ! !! RS computes the eigenvalues and the eigenvectors of a real symmetric matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A1 !***TYPE SINGLE PRECISION (RS-S, CH-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! to find the eigenvalues and eigenvectors (if desired) ! of a REAL SYMMETRIC matrix. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! A contains the real symmetric matrix. A is a two-dimensional ! REAL array, dimensioned A(NM,N). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On Output ! ! A is unaltered. ! ! W contains the eigenvalues in ascending order. W is a one- ! dimensional REAL array, dimensioned W(N). ! ! Z contains the eigenvectors if MATZ is not zero. The ! eigenvectors are orthonormal. Z is a two-dimensional ! REAL array, dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues, and eigenvectors if requested, ! should be correct for indices 1, 2, ..., IERR-1. ! ! FV1 and FV2 are one-dimensional REAL arrays used for temporary ! storage, dimensioned FV1(N) and FV2(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED TQL2, TQLRAT, TRED1, TRED2 !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RS ! INTEGER N,NM,IERR,MATZ REAL A(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) ! !***FIRST EXECUTABLE STATEMENT RS if (N <= NM) go to 10 IERR = 10 * N go to 50 ! 10 if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call TRED1(NM,N,A,W,FV1,FV2) call TQLRAT(N,W,FV2,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 call TRED2(NM,N,A,W,FV1,Z) call TQL2(NM,N,W,FV1,Z,IERR) 50 RETURN end subroutine RSGAB (NM, N, A, B, W, MATZ, Z, FV1, FV2, IERR) ! !! RSGAB: eigenvalues and eigenvectors of a symmetric generalized eigenproblem. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4B1 !***TYPE SINGLE PRECISION (RSGAB-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! to find the eigenvalues and eigenvectors (if desired) ! for the REAL SYMMETRIC generalized eigenproblem ABx = (LAMBDA)x. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A, B, and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrices A and B. N is an INTEGER ! variable. N must be less than or equal to NM. ! ! A contains a real symmetric matrix. A is a two-dimensional ! REAL array, dimensioned A(NM,N). ! ! B contains a positive definite real symmetric matrix. B is a ! two-dimensional REAL array, dimensioned B(NM,N). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On Output ! ! W contains the eigenvalues in ascending order. W is a ! one-dimensional REAL array, dimensioned W(N). ! ! Z contains the eigenvectors if MATZ is not zero. Z is a ! two-dimensional REAL array, dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! 7*N+1 if B is not positive definite, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues should be correct for indices ! 1, 2, ..., IERR-1, but no eigenvectors are ! computed. ! ! FV1 and FV2 are one-dimensional REAL arrays used for temporary ! storage, dimensioned FV1(N) and FV2(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED REBAK, REDUC2, TQL2, TQLRAT, TRED1, TRED2 !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RSGAB ! INTEGER N,NM,IERR,MATZ REAL A(NM,*),B(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) ! !***FIRST EXECUTABLE STATEMENT RSGAB if (N <= NM) go to 10 IERR = 10 * N go to 50 ! 10 call REDUC2(NM,N,A,B,FV2,IERR) if (IERR /= 0) go to 50 if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call TRED1(NM,N,A,W,FV1,FV2) call TQLRAT(N,W,FV2,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 call TRED2(NM,N,A,W,FV1,Z) call TQL2(NM,N,W,FV1,Z,IERR) if (IERR /= 0) go to 50 call REBAK(NM,N,B,FV2,N,Z) 50 RETURN end subroutine RSGBA (NM, N, A, B, W, MATZ, Z, FV1, FV2, IERR) ! !! RSGBA: eigenvalues and eigenvectors of a symmetric generalized eigenproblem. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4B1 !***TYPE SINGLE PRECISION (RSGBA-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! to find the eigenvalues and eigenvectors (if desired) ! for the REAL SYMMETRIC generalized eigenproblem BAx = (LAMBDA)x. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A, B, and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrices A and B. N is an INTEGER ! variable. N must be less than or equal to NM. ! ! A contains a real symmetric matrix. A is a two-dimensional ! REAL array, dimensioned A(NM,N). ! ! B contains a positive definite real symmetric matrix. B is a ! two-dimensional REAL array, dimensioned B(NM,N). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On Output ! ! W contains the eigenvalues in ascending order. W is a ! one-dimensional REAL array, dimensioned W(N). ! ! Z contains the eigenvectors if MATZ is not zero. Z is a ! two-dimensional REAL array, dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! 7*N+1 if B is not positive definite, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues should be correct for indices ! 1, 2, ..., IERR-1, but no eigenvectors are ! computed. ! ! FV1 and FV2 are one-dimensional REAL arrays used for temporary ! storage, dimensioned FV1(N) and FV2(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED REBAKB, REDUC2, TQL2, TQLRAT, TRED1, TRED2 !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RSGBA ! INTEGER N,NM,IERR,MATZ REAL A(NM,*),B(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) ! !***FIRST EXECUTABLE STATEMENT RSGBA if (N <= NM) go to 10 IERR = 10 * N go to 50 ! 10 call REDUC2(NM,N,A,B,FV2,IERR) if (IERR /= 0) go to 50 if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call TRED1(NM,N,A,W,FV1,FV2) call TQLRAT(N,W,FV2,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 call TRED2(NM,N,A,W,FV1,Z) call TQL2(NM,N,W,FV1,Z,IERR) if (IERR /= 0) go to 50 call REBAKB(NM,N,B,FV2,N,Z) 50 RETURN end subroutine RSG (NM, N, A, B, W, MATZ, Z, FV1, FV2, IERR) ! !! RSG computes eigenvalues, eigenvectors of symmetric generalized eigenproblem. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4B1 !***TYPE SINGLE PRECISION (RSG-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! To find the eigenvalues and eigenvectors (if desired) ! for the REAL SYMMETRIC generalized eigenproblem Ax = (LAMBDA)Bx. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A, B, and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrices A and B. N is an INTEGER ! variable. N must be less than or equal to NM. ! ! A contains a real symmetric matrix. A is a two-dimensional ! REAL array, dimensioned A(NM,N). ! ! B contains a positive definite real symmetric matrix. B is a ! two-dimensional REAL array, dimensioned B(NM,N). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On Output ! ! W contains the eigenvalues in ascending order. W is a ! one-dimensional REAL array, dimensioned W(N). ! ! Z contains the eigenvectors if MATZ is not zero. Z is a ! two-dimensional REAL array, dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! 7*N+1 if B is not positive definite, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues should be correct for indices ! 1, 2, ..., IERR-1, but no eigenvectors are ! computed. ! ! FV1 and FV2 are one-dimensional REAL arrays used for temporary ! storage, dimensioned FV1(N) and FV2(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED REBAK, REDUC, TQL2, TQLRAT, TRED1, TRED2 !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RSG ! INTEGER N,NM,IERR,MATZ REAL A(NM,*),B(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) ! !***FIRST EXECUTABLE STATEMENT RSG if (N <= NM) go to 10 IERR = 10 * N go to 50 ! 10 call REDUC(NM,N,A,B,FV2,IERR) if (IERR /= 0) go to 50 if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call TRED1(NM,N,A,W,FV1,FV2) call TQLRAT(N,W,FV2,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 call TRED2(NM,N,A,W,FV1,Z) call TQL2(NM,N,W,FV1,Z,IERR) if (IERR /= 0) go to 50 call REBAK(NM,N,B,FV2,N,Z) 50 RETURN end subroutine RSP (NM, N, NV, A, W, MATZ, Z, FV1, FV2, IERR) ! !! RSP eigenvalues and eigenvectors of real symmetric packed matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A1 !***TYPE SINGLE PRECISION (RSP-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! to find the eigenvalues and eigenvectors (if desired) ! of a REAL SYMMETRIC PACKED matrix. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, Z, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! NV is an INTEGER variable set equal to the dimension of the ! array A as specified in the calling program. NV must not ! be less than N*(N+1)/2. ! ! A contains the lower triangle, stored row-wise, of the real ! symmetric packed matrix. A is a one-dimensional REAL ! array, dimensioned A(NV). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On Output ! ! A has been destroyed. ! ! W contains the eigenvalues in ascending order. W is a ! one-dimensional REAL array, dimensioned W(N). ! ! Z contains the eigenvectors if MATZ is not zero. The eigen- ! vectors are orthonormal. Z is a two-dimensional REAL array, ! dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! 20*N if NV is less than N*(N+1)/2, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues and eigenvectors in the W and Z ! arrays should be correct for indices ! 1, 2, ..., IERR-1. ! ! FV1 and FV2 are one-dimensional REAL arrays used for temporary ! storage, dimensioned FV1(N) and FV2(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED TQL2, TQLRAT, TRBAK3, TRED3 !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RSP ! INTEGER I,J,N,NM,NV,IERR,MATZ REAL A(*),W(*),Z(NM,*),FV1(*),FV2(*) ! !***FIRST EXECUTABLE STATEMENT RSP if (N <= NM) go to 5 IERR = 10 * N go to 50 5 if (NV >= (N * (N + 1)) / 2) go to 10 IERR = 20 * N go to 50 ! 10 call TRED3(N,NV,A,W,FV1,FV2) if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call TQLRAT(N,W,FV2,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 DO 40 I = 1, N ! DO 30 J = 1, N Z(J,I) = 0.0E0 30 CONTINUE ! Z(I,I) = 1.0E0 40 CONTINUE ! call TQL2(NM,N,W,FV1,Z,IERR) if (IERR /= 0) go to 50 call TRBAK3(NM,N,NV,A,N,Z) 50 RETURN end subroutine RST (NM, N, W, E, MATZ, Z, IERR) ! !! RST eigenvalues and eigenvectors of a real symmetric tridiagonal matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5 !***TYPE SINGLE PRECISION (RST-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of ! subroutines from the eigensystem subroutine package (EISPACK) ! to find the eigenvalues and eigenvectors (if desired) ! of a REAL SYMMETRIC TRIDIAGONAL matrix. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, Z, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! W contains the diagonal elements of the real symmetric ! tridiagonal matrix. W is a one-dimensional REAL array, ! dimensioned W(N). ! ! E contains the subdiagonal elements of the matrix in its last ! N-1 positions. E(1) is arbitrary. E is a one-dimensional ! REAL array, dimensioned E(N). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On Output ! ! W contains the eigenvalues in ascending order. ! ! Z contains the eigenvectors if MATZ is not zero. The eigen- ! vectors are orthonormal. Z is a two-dimensional REAL array, ! dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues and eigenvectors in the W and Z ! arrays should be correct for indices ! 1, 2, ..., IERR-1. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED IMTQL1, IMTQL2 !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RST ! INTEGER I,J,N,NM,IERR,MATZ REAL W(*),E(*),Z(NM,*) ! !***FIRST EXECUTABLE STATEMENT RST if (N <= NM) go to 10 IERR = 10 * N go to 50 ! 10 if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call IMTQL1(N,W,E,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 DO 40 I = 1, N ! DO 30 J = 1, N Z(J,I) = 0.0E0 30 CONTINUE ! Z(I,I) = 1.0E0 40 CONTINUE ! call IMTQL2(NM,N,W,E,Z,IERR) 50 RETURN end subroutine RT (NM, N, A, W, MATZ, Z, FV1, IERR) ! !! RT computes eigenvalues/vectors of a special real tridiagonal matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5 !***TYPE SINGLE PRECISION (RT-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine calls the recommended sequence of subroutines ! from the eigensystem subroutine package (EISPACK) to find the ! eigenvalues and eigenvectors (if desired) of a special REAL ! TRIDIAGONAL matrix. The property of the matrix required for use ! of this subroutine is that the products of pairs of corresponding ! off-diagonal elements be all non-negative. If eigenvectors are ! desired, no product can be zero unless both factors are zero. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! A contains the special real tridiagonal matrix in its first ! three columns. The subdiagonal elements are stored in the ! last N-1 positions of the first column, the diagonal elements ! in the second column, and the superdiagonal elements in the ! first N-1 positions of the third column. Elements A(1,1) and ! A(N,3) are arbitrary. A is a two-dimensional REAL array, ! dimensioned A(NM,3). ! ! MATZ is an INTEGER variable set equal to zero if only ! eigenvalues are desired. Otherwise, it is set to any ! non-zero integer for both eigenvalues and eigenvectors. ! ! On Output ! ! W contains the eigenvalues in ascending order. W is a ! one-dimensional REAL array, dimensioned W(N). ! ! Z contains the eigenvectors if MATZ is not zero. The eigen- ! vectors are not normalized. Z is a two-dimensional REAL ! array, dimensioned Z(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 10*N if N is greater than NM, ! N+J if A(J,1)*A(J-1,3) is negative, ! 2*N+J if the product is zero with one factor non-zero, ! and MATZ is non-zero; ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! The eigenvalues and eigenvectors in the W and Z ! arrays should be correct for indices ! 1, 2, ..., IERR-1. ! ! FV1 is a one-dimensional REAL array used for temporary storage, ! dimensioned FV1(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED FIGI, FIGI2, IMTQL1, IMTQL2 !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE RT ! INTEGER N,NM,IERR,MATZ REAL A(NM,3),W(*),Z(NM,*),FV1(*) ! !***FIRST EXECUTABLE STATEMENT RT if (N <= NM) go to 10 IERR = 10 * N go to 50 ! 10 if (MATZ /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call FIGI(NM,N,A,W,FV1,FV1,IERR) if (IERR > 0) go to 50 call IMTQL1(N,W,FV1,IERR) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 call FIGI2(NM,N,A,W,FV1,Z,IERR) if (IERR /= 0) go to 50 call IMTQL2(NM,N,W,FV1,Z,IERR) 50 RETURN end function RUNIF (T, N) ! !! RUNIF generates a uniformly distributed random number. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY L6A21 !***TYPE SINGLE PRECISION (RUNIF-S) !***KEYWORDS FNLIB, RANDOM NUMBER, SPECIAL FUNCTIONS, UNIFORM !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! This random number generator is portable among a wide variety of ! computers. It generates a random number between 0.0 and 1.0 accord- ! ing to the algorithm presented by Bays and Durham (TOMS, 2, 59, ! 1976). The motivation for using this scheme, which resembles the ! Maclaren-Marsaglia method, is to greatly increase the period of the ! random sequence. If the period of the basic generator (RAND) is P, ! then the expected mean period of the sequence generated by RUNIF is ! given by new mean P = SQRT (PI*FACTORIAL(N)/(8*P)), ! where FACTORIAL(N) must be much greater than P in this asymptotic ! formula. Generally, N should be around 32 if P=4.E6 as for RAND. ! ! Input Argument -- ! N ABS(N) is the number of random numbers in an auxiliary table. ! Note though that ABS(N)+1 is the number of items in array T. ! If N is positive and differs from its value in the previous ! invocation, then the table is initialized for the new value of ! N. If N is negative, ABS(N) is the number of items in an ! auxiliary table, but the tables are now assumed already to ! be initialized. This option enables the user to save the ! table T at the end of a long computer run and to restart with ! the same sequence. Normally, RUNIF would be called at most ! once with negative N. Subsequent invocations would have N ! positive and of the correct magnitude. ! ! Input and Output Argument -- ! T an array of ABS(N)+1 random numbers from a previous invocation ! of RUNIF. Whenever N is positive and differs from the old ! N, the table is initialized. The first ABS(N) numbers are the ! table discussed in the reference, and the N+1 -st value is Y. ! This array may be saved in order to restart a sequence. ! ! Output Value -- ! RUNIF a random number between 0.0 and 1.0. ! !***REFERENCES (NONE) !***ROUTINES CALLED RAND !***REVISION HISTORY (YYMMDD) ! 770401 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910819 Added EXTERNAL statement for RAND due to problem on IBM ! RS 6000. (WRB) !***END PROLOGUE RUNIF DIMENSION T(*) EXTERNAL RAND SAVE NOLD, FLOATN DATA NOLD /-1/ !***FIRST EXECUTABLE STATEMENT RUNIF if (N == NOLD) go to 20 ! NOLD = ABS(N) FLOATN = NOLD if (N < 0) DUMMY = RAND (T(NOLD+1)) if (N < 0) go to 20 ! DO 10 I=1,NOLD T(I) = RAND (0.) 10 CONTINUE T(NOLD+1) = RAND (0.) ! 20 J = T(NOLD+1)*FLOATN + 1. T(NOLD+1) = T(J) RUNIF = T(J) T(J) = RAND (0.) ! return end subroutine RWUPDT (N, R, LDR, W, B, ALPHA, COS, SIN) ! !! RWUPDT is subsidiary to SNLS1 and SNLS1E. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (RWUPDT-S, DWUPDT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given an N by N upper triangular matrix R, this subroutine ! computes the QR decomposition of the matrix formed when a row ! is added to R. If the row is specified by the vector W, then ! RWUPDT determines an orthogonal matrix Q such that when the ! N+1 by N matrix composed of R augmented by W is premultiplied ! by (Q TRANSPOSE), the resulting matrix is upper trapezoidal. ! The orthogonal matrix Q is the product of N transformations ! ! G(1)*G(2)* ... *G(N) ! ! where G(I) is a Givens rotation in the (I,N+1) plane which ! eliminates elements in the I-th plane. RWUPDT also ! computes the product (Q TRANSPOSE)*C where C is the ! (N+1)-vector (b,alpha). Q itself is not accumulated, rather ! the information to recover the G rotations is supplied. ! ! The subroutine statement is ! ! SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) ! ! where ! ! N is a positive integer input variable set to the order of R. ! ! R is an N by N array. On input the upper triangular part of ! R must contain the matrix to be updated. On output R ! contains the updated triangular matrix. ! ! LDR is a positive integer input variable not less than N ! which specifies the leading dimension of the array R. ! ! W is an input array of length N which must contain the row ! vector to be added to R. ! ! B is an array of length N. On input B must contain the ! first N elements of the vector C. On output B contains ! the first N elements of the vector (Q TRANSPOSE)*C. ! ! ALPHA is a variable. On input ALPHA must contain the ! (N+1)-st element of the vector C. On output ALPHA contains ! the (N+1)-st element of the vector (Q TRANSPOSE)*C. ! ! COS is an output array of length N which contains the ! cosines of the transforming Givens rotations. ! ! SIN is an output array of length N which contains the ! sines of the transforming Givens rotations. ! !***SEE ALSO SNLS1, SNLS1E !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE RWUPDT INTEGER N,LDR REAL ALPHA REAL R(LDR,*),W(*),B(*),COS(*),SIN(*) INTEGER I,J,JM1 REAL COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO SAVE ONE, P5, P25, ZERO DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/ !***FIRST EXECUTABLE STATEMENT RWUPDT DO 60 J = 1, N ROWJ = W(J) JM1 = J - 1 ! ! APPLY THE PREVIOUS TRANSFORMATIONS TO ! R(I,J), I=1,2,...,J-1, AND TO W(J). ! if (JM1 < 1) go to 20 DO 10 I = 1, JM1 TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ R(I,J) = TEMP 10 CONTINUE 20 CONTINUE ! ! DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J). ! COS(J) = ONE SIN(J) = ZERO if (ROWJ == ZERO) go to 50 if (ABS(R(J,J)) >= ABS(ROWJ)) go to 30 COTAN = R(J,J)/ROWJ SIN(J) = P5/SQRT(P25+P25*COTAN**2) COS(J) = SIN(J)*COTAN go to 40 30 CONTINUE TAN = ROWJ/R(J,J) COS(J) = P5/SQRT(P25+P25*TAN**2) SIN(J) = COS(J)*TAN 40 CONTINUE ! ! APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA. ! R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ TEMP = COS(J)*B(J) + SIN(J)*ALPHA ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA B(J) = TEMP 50 CONTINUE 60 CONTINUE return ! ! LAST CARD OF SUBROUTINE RWUPDT. ! end subroutine S1MERG (TCOS, I1, M1, I2, M2, I3) ! !! S1MERG merges two strings of ascending real numbers. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (S1MERG-S, D1MERG-D, C1MERG-C, I1MERG-I) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine merges two ascending strings of numbers in the ! array TCOS. The first string is of length M1 and starts at ! TCOS(I1+1). The second string is of length M2 and starts at ! TCOS(I2+1). The merged string goes into TCOS(I3+1). ! !***SEE ALSO GENBUN !***ROUTINES CALLED SCOPY !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 901120 Modified to use IF-THEN-ELSE. Previous spaghetti code did ! not compile correctly with optimization on the IBM RS6000. ! (RWC) ! 920130 Code name changed from MERGE to S1MERG. (WRB) !***END PROLOGUE S1MERG INTEGER I1, I2, I3, M1, M2 REAL TCOS(*) ! INTEGER J1, J2, J3 ! !***FIRST EXECUTABLE STATEMENT S1MERG if (M1 == 0 .AND. M2 == 0) RETURN ! if (M1 == 0 .AND. M2 /= 0) THEN call SCOPY (M2, TCOS(I2+1), 1, TCOS(I3+1), 1) return end if ! if (M1 /= 0 .AND. M2 == 0) THEN call SCOPY (M1, TCOS(I1+1), 1, TCOS(I3+1), 1) return end if ! J1 = 1 J2 = 1 J3 = 1 ! 10 if (TCOS(I1+J1) <= TCOS(I2+J2)) THEN TCOS(I3+J3) = TCOS(I1+J1) J1 = J1+1 if (J1 > M1) THEN call SCOPY (M2-J2+1, TCOS(I2+J2), 1, TCOS(I3+J3+1), 1) return ENDIF ELSE TCOS(I3+J3) = TCOS(I2+J2) J2 = J2+1 if (J2 > M2) THEN call SCOPY (M1-J1+1, TCOS(I1+J1), 1, TCOS(I3+J3+1), 1) return ENDIF end if J3 = J3+1 go to 10 end FUNCTION SASUM (N, SX, INCX) ! !! SASUM compute the sum of the magnitudes of the elements of a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A3A !***TYPE SINGLE PRECISION (SASUM-S, DASUM-D, SCASUM-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, SUM OF MAGNITUDES OF A VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(S) ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! ! --Output-- ! SASUM single precision result (zero if N <= 0) ! ! Returns sum of magnitudes of single precision SX. ! SASUM = sum from 0 to N-1 of ABS(SX(IX+I*INCX)), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900821 Modified to correct problem with a negative increment. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SASUM real SASUM REAL SX(*) INTEGER I, INCX, IX, M, MP1, N !***FIRST EXECUTABLE STATEMENT SASUM SASUM = 0.0E0 if (N <= 0) RETURN ! if (INCX == 1) GOTO 20 ! ! Code for increment not equal to 1. ! IX = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N SASUM = SASUM + ABS(SX(IX)) IX = IX + INCX 10 CONTINUE return ! ! Code for increment equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 6. ! 20 M = MOD(N,6) if (M == 0) GOTO 40 DO 30 I = 1,M SASUM = SASUM + ABS(SX(I)) 30 CONTINUE if (N < 6) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,6 SASUM = SASUM + 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 return end subroutine SAXPY (N, SA, SX, INCX, SY, INCY) ! !! SAXPY computes a constant times a vector plus a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A7 !***TYPE SINGLE PRECISION (SAXPY-S, DAXPY-D, CAXPY-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, TRIAD, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SA single precision scalar multiplier ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! SY single precision vector with N elements ! INCY storage spacing between elements of SY ! ! --Output-- ! SY single precision result (unchanged if N <= 0) ! ! Overwrite single precision SY with single precision SA*SX +SY. ! For I = 0 to N-1, replace SY(LY+I*INCY) with SA*SX(LX+I*INCX) + ! SY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SAXPY REAL SX(*), SY(*), SA !***FIRST EXECUTABLE STATEMENT SAXPY if (N <= 0 .OR. SA == 0.0E0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IX = 1 IY = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 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 ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 4. ! 20 M = MOD(N,4) if (M == 0) go to 40 DO 30 I = 1,M SY(I) = SY(I) + SA*SX(I) 30 CONTINUE if (N < 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 ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX SY(I) = SA*SX(I) + SY(I) 70 CONTINUE return end subroutine SBCG (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, & MSOLVE, MTSOLV, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, & P, RR, ZZ, PP, DZ, RWORK, IWORK) ! !! SBCG is the Preconditioned BiConjugate Gradient Sparse Ax = b Solver. ! ! Routine to solve a Non-Symmetric linear system Ax = b ! using the Preconditioned BiConjugate Gradient method. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SBCG-S, DBCG-D) !***KEYWORDS BICONJUGATE GRADIENT, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), P(N) ! REAL RR(N), ZZ(N), PP(N), DZ(N) ! REAL RWORK(USER DEFINED) ! EXTERNAL MATVEC, MTTVEC, MSOLVE, MTSOLV ! ! call SBCG(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, ! $ MSOLVE, MTSOLV, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, ! $ R, Z, P, RR, ZZ, PP, DZ, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, for more ! details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! operation Y = A*X given A and X. The name of the MATVEC ! routine must be declared external in the calling program. ! The calling sequence of MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X upon ! return, X is an input vector. NELT, IA, JA, A and ISYM ! define the SLAP matrix data structure: see Description,below. ! MTTVEC :EXT External. ! Name of a routine which performs the matrix transpose vector ! multiply y = A'*X given A and X (where ' denotes transpose). ! The name of the MTTVEC routine must be declared external in ! the calling program. The calling sequence to MTTVEC is the ! same as that for MTTVEC, viz.: ! call MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A'*X ! upon return, X is an input vector. NELT, IA, JA, A and ISYM ! define the SLAP matrix data structure: see Description,below. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for Z ! given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine ! must be declared external in the calling program. The ! calling sequence of MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector, and Z is the solution upon return. NELT, IA, JA, A ! and ISYM define the SLAP matrix data structure: see ! Description, below. RWORK is a real array that can be used ! to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for the ! same purpose as RWORK. ! MTSOLV :EXT External. ! Name of a routine which solves a linear system M'ZZ = RR for ! ZZ given RR with the preconditioning matrix M (M is supplied ! via RWORK and IWORK arrays). The name of the MTSOLV routine ! must be declared external in the calling program. The call- ! ing sequence to MTSOLV is: ! call MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, RR is the right-hand side ! vector, and ZZ is the solution upon return. NELT, IA, JA, A ! and ISYM define the SLAP matrix data structure: see ! Description, below. RWORK is a real array that can be used ! to pass necessary preconditioning information and/or ! workspace to MTSOLV. IWORK is an integer work array for the ! same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Real R(N). ! Z :WORK Real Z(N). ! P :WORK Real P(N). ! RR :WORK Real RR(N). ! ZZ :WORK Real ZZ(N). ! PP :WORK Real PP(N). ! DZ :WORK Real DZ(N). ! Real arrays used for workspace. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used for workspace in MSOLVE ! and MTSOLV. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE ! and MTSOLV. ! ! *Description ! This routine does not care what matrix data structure is used ! for A and M. It simply calls MATVEC, MTTVEC, MSOLVE, MTSOLV ! routines, with arguments as above. The user could write any ! type of structure, and appropriate MATVEC, MSOLVE, MTTVEC, ! and MTSOLV routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK in some fashion. The SLAP ! routines SSDBCG and SSLUBC are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the real array A. ! In other words, for each column in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have JA(N+1) ! = NELT+1, where N is the number of columns in the matrix and ! NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SSDBCG, SSLUBC !***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED ISSBCG, R1MACH, SAXPY, SCOPY, SDOT !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC, MTTVEC, MSOLVE, MTSOLV from ROUTINES ! CALLED list. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SBCG ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), DZ(N), P(N), PP(N), R(N), RR(N), RWORK(*), & X(N), Z(N), ZZ(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE, MTSOLV, MTTVEC ! .. Local Scalars .. REAL AK, AKDEN, BK, BKDEN, BKNUM, BNRM, FUZZ, SOLNRM, TOLMIN INTEGER I, K ! .. External Functions .. REAL R1MACH, SDOT INTEGER ISSBCG EXTERNAL R1MACH, SDOT, ISSBCG ! .. External Subroutines .. EXTERNAL SAXPY, SCOPY ! .. Intrinsic Functions .. INTRINSIC ABS !***FIRST EXECUTABLE STATEMENT SBCG ! ! Check some of the input data. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if FUZZ = R1MACH(3) TOLMIN = 500*FUZZ FUZZ = FUZZ*FUZZ if ( TOL < TOLMIN ) THEN TOL = TOLMIN IERR = 4 end if ! ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N R(I) = B(I) - R(I) RR(I) = R(I) 10 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) call MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! if ( ISSBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, PP, & DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) & go to 200 if ( IERR /= 0 ) RETURN ! ! ***** iteration loop ***** ! DO 100 K=1,ITMAX ITER = K ! ! Calculate coefficient BK and direction vectors P and PP. BKNUM = SDOT(N, Z, 1, RR, 1) if ( ABS(BKNUM) <= FUZZ ) THEN IERR = 6 return ENDIF if ( ITER == 1) THEN call SCOPY(N, Z, 1, P, 1) call SCOPY(N, ZZ, 1, PP, 1) ELSE BK = BKNUM/BKDEN DO 20 I = 1, N P(I) = Z(I) + BK*P(I) PP(I) = ZZ(I) + BK*PP(I) 20 CONTINUE ENDIF BKDEN = BKNUM ! ! Calculate coefficient AK, new iterate X, new residuals R and ! RR, and new pseudo-residuals Z and ZZ. call MATVEC(N, P, Z, NELT, IA, JA, A, ISYM) AKDEN = SDOT(N, PP, 1, Z, 1) AK = BKNUM/AKDEN if ( ABS(AKDEN) <= FUZZ ) THEN IERR = 6 return ENDIF call SAXPY(N, AK, P, 1, X, 1) call SAXPY(N, -AK, Z, 1, R, 1) call MTTVEC(N, PP, ZZ, NELT, IA, JA, A, ISYM) call SAXPY(N, -AK, ZZ, 1, RR, 1) call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) call MTSOLV(N, RR, ZZ, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! ! check stopping criterion. if ( ISSBCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, RR, ZZ, & PP, DZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) & go to 200 ! 100 CONTINUE ! ! ***** end of loop ***** ! ! stopping criterion not satisfied. ITER = ITMAX + 1 IERR = 2 ! 200 return !------------- LAST LINE OF SBCG FOLLOWS ---------------------------- end subroutine SBHIN (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) ! !! SBHIN reads a Sparse Linear System in the Boeing/Harwell Format. ! ! The matrix is read in and if the right hand side is also ! present in the input file then it too is read in. The ! matrix is then modified to be in the SLAP Column format. !***LIBRARY SLATEC (SLAP) !***CATEGORY N1 !***TYPE SINGLE PRECISION (SBHIN-S, DBHIN-D) !***KEYWORDS LINEAR SYSTEM, MATRIX READ, SLAP SPARSE !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB ! REAL A(NELT), SOLN(N), RHS(N) ! ! call SBHIN( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) ! ! *Arguments: ! N :OUT Integer ! Order of the Matrix. ! NELT :INOUT Integer. ! On input NELT is the maximum number of non-zeros that ! can be stored in the IA, JA, A arrays. ! On output NELT is the number of non-zeros stored in A. ! IA :OUT Integer IA(NELT). ! JA :OUT Integer JA(NELT). ! A :OUT Real A(NELT). ! On output these arrays hold the matrix A in the SLAP ! Triad format. See "Description", below. ! ISYM :OUT Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! SOLN :OUT Real SOLN(N). ! The solution to the linear system, if present. This array ! is accessed if and only if JOB is set to read it in, see ! below. If the user requests that SOLN be read in, but it is ! not in the file, then it is simply zeroed out. ! RHS :OUT Real RHS(N). ! The right hand side vector. This array is accessed if and ! only if JOB is set to read it in, see below. ! If the user requests that RHS be read in, but it is not in ! the file, then it is simply zeroed out. ! IUNIT :IN Integer. ! Fortran logical I/O device unit number to read the matrix ! from. This unit must be connected in a system dependent ! fashion to a file, or you will get a nasty message ! from the Fortran I/O libraries. ! JOB :INOUT Integer. ! Flag indicating what I/O operations to perform. ! On input JOB indicates what Input operations to try to ! perform. ! JOB = 0 => Read only the matrix. ! JOB = 1 => Read matrix and RHS (if present). ! JOB = 2 => Read matrix and SOLN (if present). ! JOB = 3 => Read matrix, RHS and SOLN (if present). ! On output JOB indicates what operations were actually ! performed. ! JOB = -3 => Unable to parse matrix "CODE" from input file ! to determine if only the lower triangle of matrix ! is stored. ! JOB = -2 => Number of non-zeros (NELT) too large. ! JOB = -1 => System size (N) too large. ! JOB = 0 => Read in only the matrix. ! JOB = 1 => Read in the matrix and RHS. ! JOB = 2 => Read in the matrix and SOLN. ! JOB = 3 => Read in the matrix, RHS and SOLN. ! JOB = 10 => Read in only the matrix *STRUCTURE*, but no ! non-zero entries. Hence, A(*) is not referenced ! and has the return values the same as the input. ! JOB = 11 => Read in the matrix *STRUCTURE* and RHS. ! JOB = 12 => Read in the matrix *STRUCTURE* and SOLN. ! JOB = 13 => Read in the matrix *STRUCTURE*, RHS and SOLN. ! ! *Description: ! The format for the input is as follows. The first line contains ! a title to identify the data file. On the second line (5I4) are ! counters: NLINE, NPLS, NRILS, NNVLS, NRHSLS. ! NLINE Number of data lines (after the header) in the file. ! NPLS Number of lines for the Column Pointer data in the file. ! NRILS Number of lines for the Row indices in the file. ! NNVLS Number of lines for the Matrix elements in the file. ! NRHSLS Number of lines for the RHS in the file. ! The third line (A3,11X,4I4) contains a symmetry code and some ! additional counters: CODE, NROW, NCOL, NIND, NELE. ! On the fourth line (2A16,2A20) are formats to be used to read ! the following data: PNTFNT, RINFMT, NVLFMT, RHSFMT. ! Following that are the blocks of data in the order indicated. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! *Portability: ! You must make sure that IUNIT is a valid Fortran logical ! I/O device unit number and that the unit number has been ! associated with a file or the console. This is a system ! dependent function. ! ! *Implementation note: ! SOLN is not read by this version. It will simply be ! zeroed out if JOB = 2 or 3 and the returned value of ! JOB will indicate SOLN has not been read. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 881107 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 911122 Added loop to zero out RHS if user wants to read RHS, but ! it's not in the input file. (MKS) ! 911125 Minor improvements to prologue. (FNF) ! 920511 Added complete declaration section. (WRB) ! 921007 Corrected description of input format. (FNF) ! 921208 Added Implementation Note and code to zero out SOLN. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SBHIN ! .. Scalar Arguments .. INTEGER ISYM, IUNIT, JOB, N, NELT ! .. Array Arguments .. REAL A(NELT), RHS(N), SOLN(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. REAL TEMP INTEGER I, IBGN, ICOL, IEND, ITEMP, J, JOBRET, NCOL, NELE, NIND, & NLINE, NNVLS, NPLS, NRHSLS, NRILS, NROW CHARACTER CODE*3, PNTFMT*16, RINFMT*16, NVLFMT*20, RHSFMT*20, & TITLE*80 ! .. Intrinsic Functions .. INTRINSIC MOD !***FIRST EXECUTABLE STATEMENT SBHIN ! ! Read Matrices In BOEING-HARWELL format. ! ! TITLE Header line to identify data file. ! NLINE Number of data lines (after the header) in the file. ! NPLS Number of lines for the Column Pointer data in the file. ! NRILS Number of lines for the Row indices in the data file. ! NNVLS Number of lines for the Matrix elements in the data file. ! NRHSLS Number of lines for the RHS in the data file. ! ---- Only those variables needed by SLAP are referenced. ---- ! READ(IUNIT,9000) TITLE READ(IUNIT,9010) NLINE, NPLS, NRILS, NNVLS, NRHSLS READ(IUNIT,9020) CODE, NROW, NCOL, NIND, NELE READ(IUNIT,9030) PNTFMT, RINFMT, NVLFMT, RHSFMT ! if ( NROW > N ) THEN N = NROW JOBRET = -1 GOTO 999 end if if ( NIND > NELT ) THEN NELT = NIND JOBRET = -2 GOTO 999 end if ! ! Set the parameters. ! N = NROW NELT = NIND if ( CODE == 'RUA' ) THEN ISYM = 0 ELSE if ( CODE == 'RSA' ) THEN ISYM = 1 ELSE JOBRET = -3 GOTO 999 end if READ(IUNIT,PNTFMT) (JA(I), I = 1, N+1) READ(IUNIT,RINFMT) (IA(I), I = 1, NELT) JOBRET = 10 if ( NNVLS > 0 ) THEN READ(IUNIT,NVLFMT) (A(I), I = 1, NELT) JOBRET = 0 end if if ( MOD(JOB,2) == 1 ) THEN ! ! User requests that the RHS be read in. If it is in the input ! file, read it in; otherwise just zero it out. ! if ( NRHSLS > 0 ) THEN READ(5,RHSFMT) (RHS(I), I = 1, N) JOBRET = JOBRET + 1 ELSE DO 10 I = 1, N RHS(I) = 0 10 CONTINUE ENDIF end if if ( (JOB == 2).OR.(JOB == 3) ) THEN ! ! User requests that the SOLN be read in. ! Just zero out the array. ! DO 20 I = 1, N SOLN(I) = 0 20 CONTINUE end if ! ! Now loop through the IA array making sure that the diagonal ! matrix element appears first in the column. Then sort the ! rest of the column in ascending order. ! !VD$R NOCONCUR !VD$R NOVECTOR DO 70 ICOL = 1, N IBGN = JA(ICOL) IEND = JA(ICOL+1)-1 DO 30 I = IBGN, IEND if ( IA(I) == ICOL ) THEN ! ! Swap the diagonal element with the first element in the ! column. ! ITEMP = IA(I) IA(I) = IA(IBGN) IA(IBGN) = ITEMP TEMP = A(I) A(I) = A(IBGN) A(IBGN) = TEMP GOTO 40 ENDIF 30 CONTINUE 40 IBGN = IBGN + 1 if ( IBGN < IEND ) THEN DO 60 I = IBGN, IEND DO 50 J = I+1, IEND if ( IA(I) > IA(J) ) THEN ITEMP = IA(I) IA(I) = IA(J) IA(J) = ITEMP TEMP = A(I) A(I) = A(J) A(J) = TEMP ENDIF 50 CONTINUE 60 CONTINUE ENDIF 70 CONTINUE ! ! Set return flag. 999 JOB = JOBRET return 9000 FORMAT( A80 ) 9010 FORMAT( 5I14 ) 9020 FORMAT( A3, 11X, 4I14 ) 9030 FORMAT( 2A16, 2A20 ) !------------- LAST LINE OF SBHIN FOLLOWS ------------------------------ end subroutine SBOCLS (W, MDW, MCON, MROWS, NCOLS, BL, BU, IND, IOPT, & X, RNORMC, RNORM, MODE, RW, IW) ! !! SBOCLS solves the bounded and constrained least squares problem ... ! consisting of solving the equation ! E*X = F (in the least squares sense) ! subject to the linear constraints ! C*X = Y. !***LIBRARY SLATEC !***CATEGORY K1A2A, G2E, G2H1, G2H2 !***TYPE SINGLE PRECISION (SBOCLS-S, DBOCLS-D) !***KEYWORDS BOUNDS, CONSTRAINTS, INEQUALITY, LEAST SQUARES, LINEAR !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! This subprogram solves the bounded and constrained least squares ! problem. The problem statement is: ! ! Solve E*X = F (least squares sense), subject to constraints ! C*X=Y. ! ! In this formulation both X and Y are unknowns, and both may ! have bounds on any of their components. This formulation ! of the problem allows the user to have equality and inequality ! constraints as well as simple bounds on the solution components. ! ! This constrained linear least squares subprogram solves E*X=F ! subject to C*X=Y, where E is MROWS by NCOLS, C is MCON by NCOLS. ! ! The user must have dimension statements of the form ! ! DIMENSION W(MDW,NCOLS+MCON+1), BL(NCOLS+MCON), BU(NCOLS+MCON), ! * X(2*(NCOLS+MCON)+2+NX), RW(6*NCOLS+5*MCON) ! INTEGER IND(NCOLS+MCON), IOPT(17+NI), IW(2*(NCOLS+MCON)) ! ! (here NX=number of extra locations required for the options; NX=0 ! if no options are in use. Also NI=number of extra locations ! for options 1-9.) ! ! INPUT ! ----- ! ! ------------------------- ! W(MDW,*),MCON,MROWS,NCOLS ! ------------------------- ! The array W contains the (possibly null) matrix [C:*] followed by ! [E:F]. This must be placed in W as follows: ! [C : *] ! W = [ ] ! [E : F] ! The (*) after C indicates that this data can be undefined. The ! matrix [E:F] has MROWS rows and NCOLS+1 columns. The matrix C is ! placed in the first MCON rows of W(*,*) while [E:F] ! follows in rows MCON+1 through MCON+MROWS of W(*,*). The vector F ! is placed in rows MCON+1 through MCON+MROWS, column NCOLS+1. The ! values of MDW and NCOLS must be positive; the value of MCON must ! be nonnegative. An exception to this occurs when using option 1 ! for accumulation of blocks of equations. In that case MROWS is an ! OUTPUT variable only, and the matrix data for [E:F] is placed in ! W(*,*), one block of rows at a time. See IOPT(*) contents, option ! number 1, for further details. The row dimension, MDW, of the ! array W(*,*) must satisfy the inequality: ! ! If using option 1, ! MDW .ge. MCON + max(max. number of ! rows accumulated, NCOLS) + 1. ! If using option 8, ! MDW .ge. MCON + MROWS. ! Else ! MDW .ge. MCON + max(MROWS, NCOLS). ! ! Other values are errors, but this is checked only when using ! option=2. The value of MROWS is an output parameter when ! using option number 1 for accumulating large blocks of least ! squares equations before solving the problem. ! See IOPT(*) contents for details about option 1. ! ! ------------------ ! BL(*),BU(*),IND(*) ! ------------------ ! These arrays contain the information about the bounds that the ! solution values are to satisfy. The value of IND(J) tells the ! type of bound and BL(J) and BU(J) give the explicit values for ! the respective upper and lower bounds on the unknowns X and Y. ! The first NVARS entries of IND(*), BL(*) and BU(*) specify ! bounds on X; the next MCON entries specify bounds on Y. ! ! 1. For IND(J)=1, require X(J) .ge. BL(J); ! if J.gt.NCOLS, Y(J-NCOLS) .ge. BL(J). ! (the value of BU(J) is not used.) ! 2. For IND(J)=2, require X(J) .le. BU(J); ! if J.gt.NCOLS, Y(J-NCOLS) .le. BU(J). ! (the value of BL(J) is not used.) ! 3. For IND(J)=3, require X(J) .ge. BL(J) and ! X(J) .le. BU(J); ! if J.gt.NCOLS, Y(J-NCOLS) .ge. BL(J) and ! Y(J-NCOLS) .le. BU(J). ! (to impose equality constraints have BL(J)=BU(J)= ! constraining value.) ! 4. For IND(J)=4, no bounds on X(J) or Y(J-NCOLS) are required. ! (the values of BL(J) and BU(J) are not used.) ! ! Values other than 1,2,3 or 4 for IND(J) are errors. In the case ! IND(J)=3 (upper and lower bounds) the condition BL(J) .gt. BU(J) ! is an error. The values BL(J), BU(J), J .gt. NCOLS, will be ! changed. Significant changes mean that the constraints are ! infeasible. (Users must make this decision themselves.) ! The new values for BL(J), BU(J), J .gt. NCOLS, define a ! region such that the perturbed problem is feasible. If users ! know that their problem is feasible, this step can be skipped ! by using option number 8 described below. ! ! See IOPT(*) description. ! ! ! ------- ! IOPT(*) ! ------- ! This is the array where the user can specify nonstandard options ! for SBOCLS( ). Most of the time this feature can be ignored by ! setting the input value IOPT(1)=99. Occasionally users may have ! needs that require use of the following subprogram options. For ! details about how to use the options see below: IOPT(*) CONTENTS. ! ! Option Number Brief Statement of Purpose ! ------ ------ ----- --------- -- ------- ! 1 Return to user for accumulation of blocks ! of least squares equations. The values ! of IOPT(*) are changed with this option. ! The changes are updates to pointers for ! placing the rows of equations into position ! for processing. ! 2 Check lengths of all arrays used in the ! subprogram. ! 3 Column scaling of the data matrix, [C]. ! [E] ! 4 User provides column scaling for matrix [C]. ! [E] ! 5 Provide option array to the low-level ! subprogram SBOLS( ). ! 6 Provide option array to the low-level ! subprogram SBOLSM( ). ! 7 Move the IOPT(*) processing pointer. ! 8 Do not preprocess the constraints to ! resolve infeasibilities. ! 9 Do not pretriangularize the least squares matrix. ! 99 No more options to change. ! ! ---- ! X(*) ! ---- ! This array is used to pass data associated with options 4,5 and ! 6. Ignore this parameter (on input) if no options are used. ! Otherwise see below: IOPT(*) CONTENTS. ! ! ! OUTPUT ! ------ ! ! ----------------- ! X(*),RNORMC,RNORM ! ----------------- ! The array X(*) contains a solution (if MODE .ge.0 or .eq.-22) for ! the constrained least squares problem. The value RNORMC is the ! minimum residual vector length for the constraints C*X - Y = 0. ! The value RNORM is the minimum residual vector length for the ! least squares equations. Normally RNORMC=0, but in the case of ! inconsistent constraints this value will be nonzero. ! The values of X are returned in the first NVARS entries of X(*). ! The values of Y are returned in the last MCON entries of X(*). ! ! ---- ! MODE ! ---- ! The sign of MODE determines whether the subprogram has completed ! normally, or encountered an error condition or abnormal status. A ! value of MODE .ge. 0 signifies that the subprogram has completed ! normally. The value of mode (.ge. 0) is the number of variables ! in an active status: not at a bound nor at the value zero, for ! the case of free variables. A negative value of MODE will be one ! of the cases (-57)-(-41), (-37)-(-22), (-19)-(-2). Values .lt. -1 ! correspond to an abnormal completion of the subprogram. These ! error messages are in groups for the subprograms SBOCLS(), ! SBOLSM(), and SBOLS(). An approximate solution will be returned ! to the user only when max. iterations is reached, MODE=-22. ! ! ----------- ! RW(*),IW(*) ! ----------- ! These are working arrays. (normally the user can ignore the ! contents of these arrays.) ! ! IOPT(*) CONTENTS ! ------- -------- ! The option array allows a user to modify some internal variables ! in the subprogram without recompiling the source code. A central ! goal of the initial software design was to do a good job for most ! people. Thus the use of options will be restricted to a select ! group of users. The processing of the option array proceeds as ! follows: a pointer, here called LP, is initially set to the value ! 1. At the pointer position the option number is extracted and ! used for locating other information that allows for options to be ! changed. The portion of the array IOPT(*) that is used for each ! option is fixed; the user and the subprogram both know how many ! locations are needed for each option. The value of LP is updated ! for each option based on the amount of storage in IOPT(*) that is ! required. A great deal of error checking is done by the ! subprogram on the contents of the option array. Nevertheless it ! is still possible to give the subprogram optional input that is ! meaningless. For example option 4 uses the locations ! X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) for passing scaling data. ! The user must manage the allocation of these locations. ! ! 1 ! - ! This option allows the user to solve problems with a large number ! of rows compared to the number of variables. The idea is that the ! subprogram returns to the user (perhaps many times) and receives ! new least squares equations from the calling program unit. ! Eventually the user signals "that's all" and a solution is then ! computed. The value of MROWS is an output variable when this ! option is used. Its value is always in the range 0 .le. MROWS ! .le. NCOLS+1. It is the number of rows after the ! triangularization of the entire set of equations. If LP is the ! processing pointer for IOPT(*), the usage for the sequential ! processing of blocks of equations is ! ! ! IOPT(LP)=1 ! Move block of equations to W(*,*) starting at ! the first row of W(*,*). ! IOPT(LP+3)=# of rows in the block; user defined ! ! The user now calls SBOCLS( ) in a loop. The value of IOPT(LP+1) ! directs the user's action. The value of IOPT(LP+2) points to ! where the subsequent rows are to be placed in W(*,*). Both of ! these values are first defined in the subprogram. The user ! changes the value of IOPT(LP+1) (to 2) as a signal that all of ! the rows have been processed. ! ! ! .= 0 ! . ELSE ! . ERROR CONDITION; SHOULD NOT HAPPEN. ! .= THE NUMBER ! OF EFFECTIVE ROWS=(I2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 41 ! ! WARNING IN... ! SBOCLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE >= NCOLS+ ! MCON+1=(I2). ! IN ABOVE MESSAGE, I1= 2 ! IN ABOVE MESSAGE, I2= 3 ! ERROR NUMBER = 42 ! ! WARNING IN... ! SBOCLS(). THE DIMENSIONS OF THE ARRAYS BL(),BU(), AND IND()=(I1) ! MUST BE >= NCOLS+MCON=(I2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 43 ! ! WARNING IN... ! SBOCLS(). THE DIMENSION OF X()=(I1) MUST BE ! >= THE REQD.LENGTH=(I2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 44 ! ! WARNING IN... ! SBOCLS(). THE . ! SBOCLS() THE DIMENSION OF IW()=(I1) MUST BE >= 2*NCOLS+2*MCON=(I2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 4 ! ERROR NUMBER = 46 ! ! WARNING IN... ! SBOCLS(). THE DIMENSION OF IOPT()=(I1) MUST BE >= THE REQD. ! LEN.=(I2). ! IN ABOVE MESSAGE, I1= 16 ! IN ABOVE MESSAGE, I2= 18 ! ERROR NUMBER = 47 ! ! WARNING IN... ! SBOCLS(). ISCALE OPTION=(I1) MUST BE 1-3. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 48 ! ! WARNING IN... ! SBOCLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PROVIDED COLUMN SCALING ! MUST BE POSITIVE. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 49 ! ! WARNING IN... ! SBOCLS(). EACH PROVIDED COL. SCALE FACTOR MUST BE POSITIVE. ! COMPONENT (I1) NOW = (R1). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, R1= 0. ! ERROR NUMBER = 50 ! ! WARNING IN... ! SBOCLS(). THE OPTION NUMBER=(I1) IS NOT DEFINED. ! IN ABOVE MESSAGE, I1= 1001 ! ERROR NUMBER = 51 ! ! WARNING IN... ! SBOCLS(). NO. OF ROWS=(I1) MUST BE >= 0 .AND. <= MDW-MCON=(I2). ! IN ABOVE MESSAGE, I1= 2 ! IN ABOVE MESSAGE, I2= 1 ! ERROR NUMBER = 52 ! ! WARNING IN... ! SBOCLS(). MDW=(I1) MUST BE POSITIVE. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 53 ! ! WARNING IN... ! SBOCLS(). MCON=(I1) MUST BE NONNEGATIVE. ! IN ABOVE MESSAGE, I1= -1 ! ERROR NUMBER = 54 ! ! WARNING IN... ! SBOCLS(). NCOLS=(I1) THE NO. OF VARIABLES MUST BE POSITIVE. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 55 ! ! WARNING IN... ! SBOCLS(). FOR J=(I1), IND(J)=(I2) MUST BE 1-4. ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 0 ! ERROR NUMBER = 56 ! ! WARNING IN... ! SBOCLS(). FOR J=(I1), BOUND BL(J)=(R1) IS > BU(J)=(R2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, R1= .1000000000E+01 ! IN ABOVE MESSAGE, R2= 0. ! ERROR NUMBER = 57 ! LINEAR CONSTRAINTS, SNLA REPT. SAND82-1517, AUG. (1982). ! !***REFERENCES R. J. Hanson, Linear least squares with bounds and ! linear constraints, Report SAND82-1517, Sandia ! Laboratories, August 1982. !***ROUTINES CALLED R1MACH, SASUM, SBOLS, SCOPY, SDOT, SNRM2, SSCAL, ! XERMSG !***REVISION HISTORY (YYMMDD) ! 821220 DATE WRITTEN ! 870803 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 910819 Added variable M for MOUT+MCON in reference to SBOLS. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SBOCLS ! REVISED 850604-0900 ! REVISED YYMMDD-HHMM ! ! PURPOSE ! ------- ! THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE LEAST SQUARES ! PROBLEM CONSISTING OF LINEAR CONSTRAINTS ! ! C*X = Y ! ! AND LEAST SQUARES EQUATIONS ! ! E*X = F ! ! IN THIS FORMULATION THE VECTORS X AND Y ARE BOTH UNKNOWNS. ! FURTHER, X AND Y MAY BOTH HAVE USER-SPECIFIED BOUNDS ON EACH ! COMPONENT. THE USER MUST HAVE DIMENSION STATEMENTS OF THE ! FORM ! ! DIMENSION W(MDW,NCOLS+MCON+1), BL(NCOLS+MCON),BU(NCOLS+MCON), ! X(2*(NCOLS+MCON)+2+NX), RW(6*NCOLS+5*MCON) ! ! INTEGER IND(NCOLS+MCON), IOPT(16+NI), IW(2*(NCOLS+MCON)) ! ! TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN ! EDITING AT THE CARD 'C++'. ! CHANGE THIS SUBPROGRAM TO SBOCLS AND THE STRINGS ! /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/, /SRELPR/ TO /DRELPR/, ! /R1MACH/ TO /D1MACH/, /E0/ TO /D0/, /SCOPY/ TO /DCOPY/, ! /SSCAL/ TO /DSCAL/, /SASUM/ TO /DASUM/, /SBOLS/ TO /DBOLS/, ! /REAL / TO /DOUBLE PRECISION/. ! ++ REAL W(MDW,*),BL(*),BU(*),X(*),RW(*) REAL ANORM, CNORM, ONE, RNORM, RNORMC, SRELPR REAL T, T1, T2, SDOT, SNRM2, WT, ZERO REAL SASUM, R1MACH ! THIS VARIABLE REMAINS TYPED REAL. INTEGER IND(*),IOPT(*),IW(*),JOPT(05) LOGICAL CHECKL,FILTER,ACCUM,PRETRI CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 SAVE IGO,ACCUM,CHECKL DATA IGO/0/ !***FIRST EXECUTABLE STATEMENT SBOCLS NERR = 0 MODE = 0 if (IGO == 0) THEN ! DO(CHECK VALIDITY OF INPUT DATA) ! PROCEDURE(CHECK VALIDITY OF INPUT DATA) ! ! SEE THAT MDW IS > 0. GROSS CHECK ONLY. if (MDW <= 0) THEN WRITE (XERN1, '(I8)') MDW call XERMSG ('SLATEC', 'SBOCLS', 'MDW = ' // XERN1 // & ' MUST BE POSITIVE.', 53, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ! ! SEE THAT NUMBER OF CONSTRAINTS IS NONNEGATIVE. if (MCON < 0) THEN WRITE (XERN1, '(I8)') MCON call XERMSG ('SLATEC', 'SBOCLS', 'MCON = ' // XERN1 // & ' MUST BE NON-NEGATIVE', 54, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ! ! SEE THAT NUMBER OF UNKNOWNS IS POSITIVE. if (NCOLS <= 0) THEN WRITE (XERN1, '(I8)') NCOLS call XERMSG ('SLATEC', 'SBOCLS', 'NCOLS = ' // XERN1 // & ' THE NO. OF VARIABLES, MUST BE POSITIVE.', 55, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ! ! SEE THAT CONSTRAINT INDICATORS ARE ALL WELL-DEFINED. DO 10 J = 1,NCOLS + MCON if (IND(J) < 1 .OR. IND(J) > 4) THEN WRITE (XERN1, '(I8)') J WRITE (XERN2, '(I8)') IND(J) call XERMSG ('SLATEC', 'SBOCLS', & 'IND(' // XERN1 // ') = ' // XERN2 // & ' MUST BE 1-4.', 56, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF 10 CONTINUE ! ! SEE THAT BOUNDS ARE CONSISTENT. DO 20 J = 1,NCOLS + MCON if (IND(J) == 3) THEN if (BL(J) > BU(J)) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') BL(J) WRITE (XERN4, '(1PE15.6)') BU(J) call XERMSG ('SLATEC', 'SBOCLS', & 'BOUND BL(' // XERN1 // ') = ' // XERN3 // & ' IS > BU(' // XERN1 // ') = ' // XERN4, & 57, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ENDIF 20 CONTINUE ! END PROCEDURE ! DO(PROCESS OPTION ARRAY) ! PROCEDURE(PROCESS OPTION ARRAY) ZERO = 0.E0 ONE = 1.E0 SRELPR = R1MACH(4) CHECKL = .FALSE. FILTER = .TRUE. LENX = 2* (NCOLS+MCON) + 2 ISCALE = 1 IGO = 1 ACCUM = .FALSE. PRETRI = .TRUE. LOPT = 0 MOPT = 0 LP = 0 LDS = 0 ! DO FOREVER 30 CONTINUE LP = LP + LDS IP = IOPT(LP+1) JP = ABS(IP) ! ! TEST FOR NO MORE OPTIONS TO CHANGE. if (IP == 99) THEN if (LOPT == 0) LOPT = - (LP+2) if (MOPT == 0) MOPT = - (ABS(LOPT)+7) if (LOPT < 0) THEN LBOU = ABS(LOPT) ELSE LBOU = LOPT - 15 ENDIF ! ! SEND COL. SCALING TO SBOLS(). IOPT(LBOU) = 4 IOPT(LBOU+1) = 1 ! ! PASS AN OPTION ARRAY FOR SBOLSM(). IOPT(LBOU+2) = 5 ! ! LOC. OF OPTION ARRAY FOR SBOLSM( ). IOPT(LBOU+3) = 8 ! ! SKIP TO START OF USER-GIVEN OPTION ARRAY FOR SBOLS(). IOPT(LBOU+4) = 6 IOPT(LBOU+6) = 99 if (LOPT > 0) THEN IOPT(LBOU+5) = LOPT - LBOU + 1 ELSE IOPT(LBOU+4) = -IOPT(LBOU+4) ENDIF if (MOPT < 0) THEN LBOUM = ABS(MOPT) ELSE LBOUM = MOPT - 8 ENDIF ! ! CHANGE PRETRIANGULARIZATION FACTOR IN SBOLSM(). IOPT(LBOUM) = 5 IOPT(LBOUM+1) = NCOLS + MCON + 1 ! ! PASS WEIGHT TO SBOLSM() FOR RANK TEST. IOPT(LBOUM+2) = 6 IOPT(LBOUM+3) = NCOLS + MCON + 2 IOPT(LBOUM+4) = MCON ! ! SKIP TO USER-GIVEN OPTION ARRAY FOR SBOLSM( ). IOPT(LBOUM+5) = 1 IOPT(LBOUM+7) = 99 if (MOPT > 0) THEN IOPT(LBOUM+6) = MOPT - LBOUM + 1 ELSE IOPT(LBOUM+5) = -IOPT(LBOUM+5) ENDIF ! EXIT FOREVER go to 50 ELSE if (JP == 99) THEN LDS = 1 ! CYCLE FOREVER go to 50 ELSE if (JP == 1) THEN if (IP > 0) THEN ! ! SET UP DIRECTION FLAG LOCATION, ROW STACKING POINTER ! LOCATION, AND LOCATION FOR NUMBER OF NEW ROWS. LOCACC = LP + 2 ! ! IOPT(LOCACC-1)=OPTION NUMBER FOR SEQ. ACCUMULATION. ! CONTENTS.. IOPT(LOCACC )=USER DIRECTION FLAG, 1 OR 2. ! IOPT(LOCACC+1)=ROW STACKING POINTER. ! IOPT(LOCACC+2)=NUMBER OF NEW ROWS TO PROCESS. ! USER ACTION WITH THIS OPTION.. ! (SET UP OPTION DATA FOR SEQ. ACCUMULATION IN IOPT(*).) ! (MOVE BLOCK OF EQUATIONS INTO W(*,*) STARTING AT FIRST ! ROW OF W(*,*) BELOW THE ROWS FOR THE CONSTRAINT MATRIX C. ! SET IOPT(LOCACC+2)=NO. OF LEAST SQUARES EQUATIONS IN BLOCK. ! LOOP ! call SBOCLS() ! ! if ( IOPT(LOCACC) == 1) THEN ! STACK EQUAS. INTO W(*,*), STARTING AT ! ROW IOPT(LOCACC+1). ! INTO W(*,*). ! SET IOPT(LOCACC+2)=NO. OF EQUAS. ! if LAST BLOCK OF EQUAS., SET IOPT(LOCACC)=2. ! ELSE if IOPT(LOCACC) == 2) THEN ! (PROCESS IS OVER. EXIT LOOP.) ! ELSE ! (ERROR CONDITION. SHOULD NOT HAPPEN.) ! end if ! END LOOP IOPT(LOCACC+1) = MCON + 1 ACCUM = .TRUE. IOPT(LOCACC) = IGO ENDIF LDS = 4 ! CYCLE FOREVER go to 30 ELSE if (JP == 2) THEN if (IP > 0) THEN ! ! GET ACTUAL LENGTHS OF ARRAYS FOR CHECKING AGAINST NEEDS. LOCDIM = LP + 2 ! ! LMDW >= MCON+MAX(MOUT,NCOLS), if MCON > 0 .AND FILTER ! LMDW >= MCON+MOUT, OTHERWISE ! ! LNDW >= NCOLS+MCON+1 ! LLB >= NCOLS+MCON ! LLX >= 2*(NCOLS+MCON)+2+EXTRA REQD. IN OPTIONS. ! LLRW >= 6*NCOLS+5*MCON ! LLIW >= 2*(NCOLS+MCON) ! LIOP >= AMOUNT REQD. FOR OPTION ARRAY. LMDW = IOPT(LOCDIM) LNDW = IOPT(LOCDIM+1) LLB = IOPT(LOCDIM+2) LLX = IOPT(LOCDIM+3) LLRW = IOPT(LOCDIM+4) LLIW = IOPT(LOCDIM+5) LIOPT = IOPT(LOCDIM+6) CHECKL = .TRUE. ENDIF LDS = 8 ! CYCLE FOREVER go to 30 ! ! OPTION TO MODIFY THE COLUMN SCALING. ELSE if (JP == 3) THEN if (IP > 0) THEN ISCALE = IOPT(LP+2) ! ! SEE THAT ISCALE IS 1 THRU 3. if (ISCALE < 1 .OR. ISCALE > 3) THEN WRITE (XERN1, '(I8)') ISCALE call XERMSG ('SLATEC', 'SBOCLS', & 'ISCALE OPTION = ' // XERN1 // ' MUST BE 1-3', & 48, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! IN THIS OPTION THE USER HAS PROVIDED SCALING. THE ! SCALE FACTORS FOR THE COLUMNS BEGIN IN X(NCOLS+IOPT(LP+2)). ELSE if (JP == 4) THEN if (IP > 0) THEN ISCALE = 4 if (IOPT(LP+2) <= 0) THEN WRITE (XERN1, '(I8)') IOPT(LP+2) call XERMSG ('SLATEC', 'SBOCLS', & 'OFFSET PAST X(NCOLS) (' // XERN1 // & ') FOR USER-PROVIDED COLUMN SCALING MUST BE POSITIVE.', & 49, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF call SCOPY(NCOLS,X(NCOLS+IOPT(LP+2)),1,RW,1) LENX = LENX + NCOLS DO 40 J = 1,NCOLS if (RW(J) <= ZERO) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') RW(J) call XERMSG ('SLATEC', 'SBOCLS', & 'EACH PROVIDED COLUMN SCALE FACTOR ' // & 'MUST BE POSITIVE.$$COMPONENT ' // XERN1 // & ' NOW = ' // XERN3, 50, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF 40 CONTINUE ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO SBOLS(). ELSE if (JP == 5) THEN if (IP > 0) THEN LOPT = IOPT(LP+2) ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO SBOLSM(). ELSE if (JP == 6) THEN if (IP > 0) THEN MOPT = IOPT(LP+2) ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! THIS OPTION USES THE NEXT LOC OF IOPT(*) AS A ! POINTER VALUE TO SKIP TO NEXT. ELSE if (JP == 7) THEN if (IP > 0) THEN LP = IOPT(LP+2) - 1 LDS = 0 ELSE LDS = 2 ENDIF ! CYCLE FOREVER go to 30 ! ! THIS OPTION AVOIDS THE CONSTRAINT RESOLVING PHASE FOR ! THE LINEAR CONSTRAINTS C*X=Y. ELSE if (JP == 8) THEN FILTER = .NOT. (IP > 0) LDS = 1 ! CYCLE FOREVER go to 30 ! ! THIS OPTION SUPPRESSES PRE-TRIANGULARIZATION OF THE LEAST ! SQUARES EQUATIONS. ELSE if (JP == 9) THEN PRETRI = .NOT. (IP > 0) LDS = 1 ! CYCLE FOREVER go to 30 ! ! NO VALID OPTION NUMBER WAS NOTED. THIS IS AN ERROR CONDITION. ELSE WRITE (XERN1, '(I8)') JP call XERMSG ('SLATEC', 'SBOCLS', 'OPTION NUMBER = ' // & XERN1 // ' IS NOT DEFINED.', 51, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ! END FOREVER ! END PROCEDURE 50 CONTINUE if (CHECKL) THEN ! DO(CHECK LENGTHS OF ARRAYS) ! PROCEDURE(CHECK LENGTHS OF ARRAYS) ! ! THIS FEATURE ALLOWS THE USER TO MAKE SURE THAT THE ! ARRAYS ARE LONG ENOUGH FOR THE INTENDED PROBLEM SIZE AND USE. if ( FILTER .AND. .NOT.ACCUM) THEN MDWL=MCON+MAX(MROWS,NCOLS) ELSE MDWL=MCON+NCOLS+1 ENDIF if (LMDW < MDWL) THEN WRITE (XERN1, '(I8)') LMDW WRITE (XERN2, '(I8)') MDWL call XERMSG ('SLATEC', 'SBOCLS', & 'THE ROW DIMENSION OF W(,) = ' // XERN1 // & ' MUST BE >= THE NUMBER OF EFFECTIVE ROWS = ' // & XERN2, 41, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LNDW < NCOLS+MCON+1) THEN WRITE (XERN1, '(I8)') LNDW WRITE (XERN2, '(I8)') NCOLS+MCON+1 call XERMSG ('SLATEC', 'SBOCLS', & 'THE COLUMN DIMENSION OF W(,) = ' // XERN1 // & ' MUST BE >= NCOLS+MCON+1 = ' // XERN2, 42, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LLB < NCOLS+MCON) THEN WRITE (XERN1, '(I8)') LLB WRITE (XERN2, '(I8)') NCOLS+MCON call XERMSG ('SLATEC', 'SBOCLS', & 'THE DIMENSIONS OF THE ARRAYS BS(), BU(), AND IND() = ' & // XERN1 // ' MUST BE >= NCOLS+MCON = ' // XERN2, & 43, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LLX < LENX) THEN WRITE (XERN1, '(I8)') LLX WRITE (XERN2, '(I8)') LENX call XERMSG ('SLATEC', 'SBOCLS', & 'THE DIMENSION OF X() = ' // XERN1 // & ' MUST BE >= THE REQD. LENGTH = ' // XERN2, 44, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LLRW < 6*NCOLS+5*MCON) THEN WRITE (XERN1, '(I8)') LLRW WRITE (XERN2, '(I8)') 6*NCOLS+5*MCON call XERMSG ('SLATEC', 'SBOCLS', & 'THE DIMENSION OF RW() = ' // XERN1 // & ' MUST BE >= 6*NCOLS+5*MCON = ' // XERN2, 45, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LLIW < 2*NCOLS+2*MCON) THEN WRITE (XERN1, '(I8)') LLIW WRITE (XERN2, '(I8)') 2*NCOLS+2*MCON call XERMSG ('SLATEC', 'SBOCLS', & 'THE DIMENSION OF IW() = ' // XERN1 // & ' MUST BE >= 2*NCOLS+2*MCON = ' // XERN2, 46, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF if (LIOPT < LP+17) THEN WRITE (XERN1, '(I8)') LIOPT WRITE (XERN2, '(I8)') LP+17 call XERMSG ('SLATEC', 'SBOCLS', & 'THE DIMENSION OF IOPT() = ' // XERN1 // & ' MUST BE >= THE REQD. LEN = ' // XERN2, 47, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 260 ENDIF ! END PROCEDURE ENDIF end if ! ! OPTIONALLY GO BACK TO THE USER FOR ACCUMULATION OF LEAST SQUARES ! EQUATIONS AND DIRECTIONS FOR PROCESSING THESE EQUATIONS. ! DO(ACCUMULATE LEAST SQUARES EQUATIONS) ! PROCEDURE(ACCUMULATE LEAST SQUARES EQUATIONS) if (ACCUM) THEN MROWS = IOPT(LOCACC+1) - 1 - MCON INROWS = IOPT(LOCACC+2) MNEW = MROWS + INROWS if (MNEW < 0 .OR. MNEW+MCON > MDW) THEN WRITE (XERN1, '(I8)') MNEW WRITE (XERN2, '(I8)') MDW-MCON call XERMSG ('SLATEC', 'SBOCLS', 'NO. OF ROWS = ' // & XERN1 // ' MUST BE >= 0 .AND. <= MDW-MCON = ' // & XERN2, 52, 1) ! (RETURN TO USER PROGRAM UNIT) go to 260 ENDIF end if ! ! USE THE SOFTWARE OF SBOLS( ) FOR THE TRIANGULARIZATION OF THE ! LEAST SQUARES MATRIX. THIS MAY INVOLVE A SYSTALTIC INTERCHANGE ! OF PROCESSING POINTERS BETWEEN THE CALLING AND CALLED (SBOLS()) ! PROGRAM UNITS. JOPT(01) = 1 JOPT(02) = 2 JOPT(04) = MROWS JOPT(05) = 99 IRW = NCOLS + 1 IIW = 1 if (ACCUM .OR. PRETRI) THEN call SBOLS(W(MCON+1,1),MDW,MOUT,NCOLS,BL,BU,IND,JOPT,X,RNORM, & MODE,RW(IRW),IW(IIW)) ELSE MOUT = MROWS end if if (ACCUM) THEN ACCUM = IOPT(LOCACC) == 1 IOPT(LOCACC+1) = JOPT(03) + MCON MROWS = MIN(NCOLS+1,MNEW) end if ! END PROCEDURE if (ACCUM) RETURN ! DO(SOLVE CONSTRAINED AND BOUNDED LEAST SQUARES PROBLEM) ! PROCEDURE(SOLVE CONSTRAINED AND BOUNDED LEAST SQUARES PROBLEM) ! ! MOVE RIGHT HAND SIDE OF LEAST SQUARES EQUATIONS. call SCOPY(MOUT,W(MCON+1,NCOLS+1),1,W(MCON+1,NCOLS+MCON+1),1) if (MCON > 0 .AND. FILTER) THEN ! ! PROJECT THE LINEAR CONSTRAINTS INTO A REACHABLE SET. DO 60 I = 1,MCON call SCOPY(NCOLS,W(I,1),MDW,W(MCON+1,NCOLS+I),1) 60 CONTINUE ! ! PLACE (-)IDENTITY MATRIX AFTER CONSTRAINT DATA. DO 70 J = NCOLS + 1,NCOLS + MCON + 1 W(1,J) = ZERO call SCOPY(MCON,W(1,J),0,W(1,J),1) 70 CONTINUE W(1,NCOLS+1) = -ONE call SCOPY(MCON,W(1,NCOLS+1),0,W(1,NCOLS+1),MDW+1) ! ! OBTAIN A 'FEASIBLE POINT' FOR THE LINEAR CONSTRAINTS. JOPT(01) = 99 IRW = NCOLS + 1 IIW = 1 call SBOLS(W,MDW,MCON,NCOLS+MCON,BL,BU,IND,JOPT,X,RNORMC, & MODEC,RW(IRW),IW(IIW)) ! ! ENLARGE THE BOUNDS SET, if REQUIRED, TO INCLUDE POINTS THAT ! CAN BE REACHED. DO 130 J = NCOLS + 1,NCOLS + MCON ICASE = IND(J) if (ICASE < 4) THEN T = SDOT(NCOLS,W(MCON+1,J),1,X,1) ENDIF go to (80,90,100,110),ICASE go to 120 ! CASE 1 80 BL(J) = MIN(T,BL(J)) go to 120 ! CASE 2 90 BU(J) = MAX(T,BU(J)) go to 120 ! CASE 3 100 BL(J) = MIN(T,BL(J)) BU(J) = MAX(T,BU(J)) go to 120 ! CASE 4 110 CONTINUE 120 CONTINUE 130 CONTINUE ! ! MOVE CONSTRAINT DATA BACK TO THE ORIGINAL AREA. DO 140 J = NCOLS + 1,NCOLS + MCON call SCOPY(NCOLS,W(MCON+1,J),1,W(J-NCOLS,1),MDW) 140 CONTINUE end if if (MCON > 0) THEN DO 150 J = NCOLS + 1,NCOLS + MCON W(MCON+1,J) = ZERO call SCOPY(MOUT,W(MCON+1,J),0,W(MCON+1,J),1) 150 CONTINUE ! ! PUT IN (-)IDENTITY MATRIX (POSSIBLY) ONCE AGAIN. DO 160 J = NCOLS + 1,NCOLS + MCON + 1 W(1,J) = ZERO call SCOPY(MCON,W(1,J),0,W(1,J),1) 160 CONTINUE W(1,NCOLS+1) = -ONE call SCOPY(MCON,W(1,NCOLS+1),0,W(1,NCOLS+1),MDW+1) end if ! ! COMPUTE NOMINAL COLUMN SCALING FOR THE UNWEIGHTED MATRIX. CNORM = ZERO ANORM = ZERO DO 170 J = 1,NCOLS T1 = SASUM(MCON,W(1,J),1) T2 = SASUM(MOUT,W(MCON+1,1),1) T = T1 + T2 if (T == ZERO) T = ONE CNORM = MAX(CNORM,T1) ANORM = MAX(ANORM,T2) X(NCOLS+MCON+J) = ONE/T 170 CONTINUE go to (180,190,210,220),ISCALE go to 230 ! CASE 1 180 CONTINUE go to 230 ! CASE 2 ! ! SCALE COLS. (BEFORE WEIGHTING) TO HAVE LENGTH ONE. 190 DO 200 J = 1,NCOLS T = SNRM2(MCON+MOUT,W(1,J),1) if (T == ZERO) T = ONE X(NCOLS+MCON+J) = ONE/T 200 CONTINUE go to 230 ! CASE 3 ! ! SUPPRESS SCALING (USE UNIT MATRIX). 210 X(NCOLS+MCON+1) = ONE call SCOPY(NCOLS,X(NCOLS+MCON+1),0,X(NCOLS+MCON+1),1) go to 230 ! CASE 4 ! ! THE USER HAS PROVIDED SCALING. 220 call SCOPY(NCOLS,RW,1,X(NCOLS+MCON+1),1) 230 CONTINUE DO 240 J = NCOLS + 1,NCOLS + MCON X(NCOLS+MCON+J) = ONE 240 CONTINUE ! ! WEIGHT THE LEAST SQUARES EQUATIONS. WT = SRELPR if (ANORM > ZERO) WT = WT/ANORM if (CNORM > ZERO) WT = WT*CNORM DO 250 I = 1,MOUT call SSCAL(NCOLS,WT,W(I+MCON,1),MDW) 250 CONTINUE call SSCAL(MOUT,WT,W(MCON+1,MCON+NCOLS+1),1) LRW = 1 LIW = 1 ! ! SET THE NEW TRIANGULARIZATION FACTOR. X(2* (NCOLS+MCON)+1) = ZERO ! ! SET THE WEIGHT TO USE IN COMPONENTS > MCON, ! WHEN MAKING LINEAR INDEPENDENCE TEST. X(2* (NCOLS+MCON)+2) = ONE/WT M=MOUT+MCON call SBOLS(W,MDW,M,NCOLS+MCON,BL,BU,IND,IOPT(LBOU),X, & RNORM,MODE,RW(LRW),IW(LIW)) RNORM = RNORM/WT ! END PROCEDURE ! PROCEDURE(RETURN TO USER PROGRAM UNIT) 260 if ( MODE >= 0)MODE = -NERR IGO = 0 return ! END PROGRAM end subroutine SBOLS (W, MDW, MROWS, NCOLS, BL, BU, IND, IOPT, X, & RNORM, MODE, RW, IW) ! !! SBOLS solves the problem E*X = F (in the least squares sense) ... ! with bounds on selected X values. ! !***LIBRARY SLATEC !***CATEGORY K1A2A, G2E, G2H1, G2H2 !***TYPE SINGLE PRECISION (SBOLS-S, DBOLS-D) !***KEYWORDS BOUNDS, CONSTRAINTS, INEQUALITY, LEAST SQUARES, LINEAR !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! The user must have dimension statements of the form: ! ! DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS), ! * X(NCOLS+NX), RW(5*NCOLS) ! INTEGER IND(NCOLS), IOPT(1+NI), IW(2*NCOLS) ! ! (here NX=number of extra locations required for option 4; NX=0 ! for no options; NX=NCOLS if this option is in use. Here NI=number ! of extra locations required for options 1-6; NI=0 for no ! options.) ! ! INPUT ! ----- ! ! -------------------- ! W(MDW,*),MROWS,NCOLS ! -------------------- ! The array W(*,*) contains the matrix [E:F] on entry. The matrix ! [E:F] has MROWS rows and NCOLS+1 columns. This data is placed in ! the array W(*,*) with E occupying the first NCOLS columns and the ! right side vector F in column NCOLS+1. The row dimension, MDW, of ! the array W(*,*) must satisfy the inequality MDW .ge. MROWS. ! Other values of MDW are errors. The values of MROWS and NCOLS ! must be positive. Other values are errors. There is an exception ! to this when using option 1 for accumulation of blocks of ! equations. In that case MROWS is an OUTPUT variable ONLY, and the ! matrix data for [E:F] is placed in W(*,*), one block of rows at a ! time. MROWS contains the number of rows in the matrix after ! triangularizing several blocks of equations. This is an OUTPUT ! parameter ONLY when option 1 is used. See IOPT(*) CONTENTS ! for details about option 1. ! ! ------------------ ! BL(*),BU(*),IND(*) ! ------------------ ! These arrays contain the information about the bounds that the ! solution values are to satisfy. The value of IND(J) tells the ! type of bound and BL(J) and BU(J) give the explicit values for ! the respective upper and lower bounds. ! ! 1. For IND(J)=1, require X(J) .ge. BL(J). ! (the value of BU(J) is not used.) ! 2. For IND(J)=2, require X(J) .le. BU(J). ! (the value of BL(J) is not used.) ! 3. For IND(J)=3, require X(J) .ge. BL(J) and ! X(J) .le. BU(J). ! 4. For IND(J)=4, no bounds on X(J) are required. ! (the values of BL(J) and BU(J) are not used.) ! ! Values other than 1,2,3 or 4 for IND(J) are errors. In the case ! IND(J)=3 (upper and lower bounds) the condition BL(J) .gt. BU(J) ! is an error. ! ! ------- ! IOPT(*) ! ------- ! This is the array where the user can specify nonstandard options ! for SBOLSM( ). Most of the time this feature can be ignored by ! setting the input value IOPT(1)=99. Occasionally users may have ! needs that require use of the following subprogram options. For ! details about how to use the options see below: IOPT(*) CONTENTS. ! ! Option Number Brief Statement of Purpose ! ------ ------ ----- --------- -- ------- ! 1 Return to user for accumulation of blocks ! of least squares equations. ! 2 Check lengths of all arrays used in the ! subprogram. ! 3 Standard scaling of the data matrix, E. ! 4 User provides column scaling for matrix E. ! 5 Provide option array to the low-level ! subprogram SBOLSM( ). ! 6 Move the IOPT(*) processing pointer. ! 99 No more options to change. ! ! ---- ! X(*) ! ---- ! This array is used to pass data associated with option 4. Ignore ! this parameter if this option is not used. Otherwise see below: ! IOPT(*) CONTENTS. ! ! OUTPUT ! ------ ! ! ---------- ! X(*),RNORM ! ---------- ! The array X(*) contains a solution (if MODE .ge.0 or .eq.-22) for ! the constrained least squares problem. The value RNORM is the ! minimum residual vector length. ! ! ---- ! MODE ! ---- ! The sign of MODE determines whether the subprogram has completed ! normally, or encountered an error condition or abnormal status. A ! value of MODE .ge. 0 signifies that the subprogram has completed ! normally. The value of MODE ( >= 0) is the number of variables ! in an active status: not at a bound nor at the value ZERO, for ! the case of free variables. A negative value of MODE will be one ! of the cases -37,-36,...,-22, or -17,...,-2. Values .lt. -1 ! correspond to an abnormal completion of the subprogram. To ! understand the abnormal completion codes see below: ERROR ! MESSAGES for SBOLS( ). AN approximate solution will be returned ! to the user only when max. iterations is reached, MODE=-22. ! Values for MODE=-37,...,-22 come from the low-level subprogram ! SBOLSM(). See the section ERROR MESSAGES for SBOLSM() in the ! documentation for SBOLSM(). ! ! ----------- ! RW(*),IW(*) ! ----------- ! These are working arrays with 5*NCOLS and 2*NCOLS entries. ! (normally the user can ignore the contents of these arrays, ! but they must be dimensioned properly.) ! ! IOPT(*) CONTENTS ! ------- -------- ! The option array allows a user to modify internal variables in ! the subprogram without recompiling the source code. A central ! goal of the initial software design was to do a good job for most ! people. Thus the use of options will be restricted to a select ! group of users. The processing of the option array proceeds as ! follows: a pointer, here called LP, is initially set to the value ! 1. This value is updated as each option is processed. At the ! pointer position the option number is extracted and used for ! locating other information that allows for options to be changed. ! The portion of the array IOPT(*) that is used for each option is ! fixed; the user and the subprogram both know how many locations ! are needed for each option. A great deal of error checking is ! done by the subprogram on the contents of the option array. ! Nevertheless it is still possible to give the subprogram optional ! input that is meaningless. For example option 4 uses the ! locations X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) for passing ! scaling data. The user must manage the allocation of these ! locations. ! ! 1 ! - ! This option allows the user to solve problems with a large number ! of rows compared to the number of variables. The idea is that the ! subprogram returns to the user (perhaps many times) and receives ! new least squares equations from the calling program unit. ! Eventually the user signals "that's all" and then computes the ! solution with one final call to subprogram SBOLS( ). The value of ! MROWS is an OUTPUT variable when this option is used. Its value ! is always in the range 0 .le. MROWS .le. NCOLS+1. It is equal to ! the number of rows after the triangularization of the entire set ! of equations. If LP is the processing pointer for IOPT(*), the ! usage for the sequential processing of blocks of equations is ! ! IOPT(LP)=1 ! Move block of equations to W(*,*) starting at ! the first row of W(*,*). ! IOPT(LP+3)=# of rows in the block; user defined ! ! The user now calls SBOLS( ) in a loop. The value of IOPT(LP+1) ! directs the user's action. The value of IOPT(LP+2) points to ! where the subsequent rows are to be placed in W(*,*). ! ! .= 0 ! . ELSE ! . ERROR CONDITION; SHOULD NOT HAPPEN. ! . BU(J)=(R2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, R1= 0. ! IN ABOVE MESSAGE, R2= ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 6 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! SBOLS(). ISCALE OPTION=(I1) MUST BE 1-3. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 7 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! SBOLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PROVIDED COLUMN SCALING ! MUST BE POSITIVE. ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 8 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! SBOLS(). EACH PROVIDED COL. SCALE FACTOR MUST BE POSITIVE. ! COMPONENT (I1) NOW = (R1). ! IN ABOVE MESSAGE, I1= ND. <= MDW=(I2). ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 0 ! ERROR NUMBER = 10 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! SBOLS().THE ROW DIMENSION OF W(,)=(I1) MUST BE >= THE NUMBER OF ROWS= ! (I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 1 ! ERROR NUMBER = 11 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! SBOLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE >= NCOLS+1=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 12 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! SBOLS().THE DIMENSIONS OF THE ARRAYS BL(),BU(), AND IND()=(I1) MUST BE ! >= NCOLS=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 1 ! ERROR NUMBER = 13 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! SBOLS(). THE DIMENSION OF X()=(I1) MUST BE >= THE REQD. LENGTH=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 14 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! SBOLS(). THE DIMENSION OF RW()=(I1) MUST BE >= 5*NCOLS=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 3 ! ERROR NUMBER = 15 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! SBOLS() THE DIMENSION OF IW()=(I1) MUST BE >= 2*NCOLS=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 16 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! ! WARNING IN... ! SBOLS() THE DIMENSION OF IOPT()=(I1) MUST BE >= THE REQD. LEN.=(I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 1 ! ERROR NUMBER = 17 ! (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.) ! !***REFERENCES R. J. Hanson, Linear least squares with bounds and ! linear constraints, Report SAND82-1517, Sandia ! Laboratories, August 1982. !***ROUTINES CALLED ISAMAX, SBOLSM, SCOPY, SNRM2, SROT, SROTG, XERMSG !***REVISION HISTORY (YYMMDD) ! 821220 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SBOLS ! ! SOLVE LINEAR LEAST SQUARES SYSTEM WITH BOUNDS ON ! SELECTED VARIABLES. ! REVISED 850329-1400 ! REVISED YYMMDD-HHMM ! TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN ! EDITING AT THE CARD 'C++'. ! CHANGE THIS SUBPROGRAM NAME TO DBOLS AND THE STRINGS ! /SCOPY/ TO /DCOPY/, /SBOL/ TO /DBOL/, ! /SNRM2/ TO /DNRM2/, /ISAMAX/ TO /IDAMAX/, ! /SROTG/ TO /DROTG/, /SROT/ TO /DROT/, /E0/ TO /D0/, ! /REAL / TO /DOUBLE PRECISION/. ! ++ REAL W(MDW,*),BL(*),BU(*),X(*),RW(*) REAL SC, SS, ONE, SNRM2, RNORM, ZERO ! ! THIS VARIABLE SHOULD REMAIN TYPE REAL. INTEGER IND(*),IOPT(*),IW(*) LOGICAL CHECKL CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 SAVE IGO,LOCACC,LOPT,ISCALE DATA IGO/0/ !***FIRST EXECUTABLE STATEMENT SBOLS NERR = 0 MODE = 0 if (IGO == 0) THEN ! DO(CHECK VALIDITY OF INPUT DATA) ! PROCEDURE(CHECK VALIDITY OF INPUT DATA) ! ! SEE THAT MDW IS > 0. GROSS CHECK ONLY. if (MDW <= 0) THEN WRITE (XERN1, '(I8)') MDW call XERMSG ('SLATEC', 'SBOLS', 'MDW = ' // XERN1 // & ' MUST BE POSITIVE.', 2, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF ! ! SEE THAT NUMBER OF UNKNOWNS IS POSITIVE. if (NCOLS <= 0) THEN WRITE (XERN1, '(I8)') NCOLS call XERMSG ('SLATEC', 'SBOLS', 'NCOLS = ' // XERN1 // & ' THE NO. OF VARIABLES MUST BE POSITIVE.', 3, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF ! ! SEE THAT CONSTRAINT INDICATORS ARE ALL WELL-DEFINED. DO 10 J = 1,NCOLS if (IND(J) < 1 .OR. IND(J) > 4) THEN WRITE (XERN1, '(I8)') J WRITE (XERN2, '(I8)') IND(J) call XERMSG ('SLATEC', 'SBOLS', & 'IND(' // XERN1 // ') = ' // XERN2 // & ' MUST BE 1-4.', 4, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF 10 CONTINUE ! ! SEE THAT BOUNDS ARE CONSISTENT. DO 20 J = 1,NCOLS if (IND(J) == 3) THEN if (BL(J) > BU(J)) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') BL(J) WRITE (XERN4, '(1PE15.6)') BU(J) call XERMSG ('SLATEC', 'SBOLS', & 'BOUND BL(' // XERN1 // ') = ' // XERN3 // & ' IS > BU(' // XERN1 // ') = ' // XERN4, & 5, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF ENDIF 20 CONTINUE ! END PROCEDURE ! DO(PROCESS OPTION ARRAY) ! PROCEDURE(PROCESS OPTION ARRAY) ZERO = 0.E0 ONE = 1.E0 CHECKL = .FALSE. LENX = NCOLS ISCALE = 1 IGO = 2 LOPT = 0 LP = 0 LDS = 0 30 CONTINUE LP = LP + LDS IP = IOPT(LP+1) JP = ABS(IP) ! ! TEST FOR NO MORE OPTIONS. if (IP == 99) THEN if (LOPT == 0) LOPT = LP + 1 go to 50 ELSE if (JP == 99) THEN LDS = 1 go to 30 ELSE if (JP == 1) THEN if (IP > 0) THEN ! ! SET UP DIRECTION FLAG, ROW STACKING POINTER ! LOCATION, AND LOCATION FOR NUMBER OF NEW ROWS. LOCACC = LP + 2 ! ! IOPT(LOCACC-1)=OPTION NUMBER FOR SEQ. ACCUMULATION. ! CONTENTS.. IOPT(LOCACC )=USER DIRECTION FLAG, 1 OR 2. ! IOPT(LOCACC+1)=ROW STACKING POINTER. ! IOPT(LOCACC+2)=NUMBER OF NEW ROWS TO PROCESS. ! USER ACTION WITH THIS OPTION.. ! (SET UP OPTION DATA FOR SEQ. ACCUMULATION IN IOPT(*). ! MUST ALSO START PROCESS WITH IOPT(LOCACC)=1.) ! (MOVE BLOCK OF EQUATIONS INTO W(*,*) STARTING AT FIRST ! ROW OF W(*,*). SET IOPT(LOCACC+2)=NO. OF ROWS IN BLOCK.) ! LOOP ! call SBOLS() ! ! if ( IOPT(LOCACC) == 1) THEN ! STACK EQUAS., STARTING AT ROW IOPT(LOCACC+1), ! INTO W(*,*). ! SET IOPT(LOCACC+2)=NO. OF EQUAS. ! if LAST BLOCK OF EQUAS., SET IOPT(LOCACC)=2. ! ELSE if IOPT(LOCACC) == 2) THEN ! (PROCESS IS OVER. EXIT LOOP.) ! ELSE ! (ERROR CONDITION. SHOULD NOT HAPPEN.) ! end if ! END LOOP ! SET IOPT(LOCACC-1)=-OPTION NUMBER FOR SEQ. ACCUMULATION. ! call SBOLS( ) IOPT(LOCACC+1) = 1 IGO = 1 ENDIF LDS = 4 go to 30 ELSE if (JP == 2) THEN if (IP > 0) THEN ! ! GET ACTUAL LENGTHS OF ARRAYS FOR CHECKING AGAINST NEEDS. LOCDIM = LP + 2 ! ! LMDW >= MROWS ! LNDW >= NCOLS+1 ! LLB >= NCOLS ! LLX >= NCOLS+EXTRA REQD. IN OPTIONS. ! LLRW >= 5*NCOLS ! LLIW >= 2*NCOLS ! LIOP >= AMOUNT REQD. FOR IOPTION ARRAY. LMDW = IOPT(LOCDIM) LNDW = IOPT(LOCDIM+1) LLB = IOPT(LOCDIM+2) LLX = IOPT(LOCDIM+3) LLRW = IOPT(LOCDIM+4) LLIW = IOPT(LOCDIM+5) LIOPT = IOPT(LOCDIM+6) CHECKL = .TRUE. ENDIF LDS = 8 go to 30 ! ! OPTION TO MODIFY THE COLUMN SCALING. ELSE if (JP == 3) THEN if (IP > 0) THEN ISCALE = IOPT(LP+2) ! ! SEE THAT ISCALE IS 1 THRU 3. if (ISCALE < 1 .OR. ISCALE > 3) THEN WRITE (XERN1, '(I8)') ISCALE call XERMSG ('SLATEC', 'SBOLS', 'ISCALE OPTION = ' & // XERN1 // ' MUST BE 1-3', 7, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! IN THIS OPTION THE USER HAS PROVIDED SCALING. THE ! SCALE FACTORS FOR THE COLUMNS BEGIN IN X(NCOLS+IOPT(LP+2)). ELSE if (JP == 4) THEN if (IP > 0) THEN ISCALE = 4 if (IOPT(LP+2) <= 0) THEN WRITE (XERN1, '(I8)') IOPT(LP+2) call XERMSG ('SLATEC', 'SBOLS', & 'OFFSET PAST X(NCOLS) (' // XERN1 // & ') FOR USER-PROVIDED COLUMN SCALING MUST BE POSITIVE.', & 8, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF call SCOPY(NCOLS,X(NCOLS+IOPT(LP+2)),1,RW,1) LENX = LENX + NCOLS DO 40 J = 1,NCOLS if (RW(J) <= ZERO) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') RW(J) call XERMSG ('SLATEC', 'SBOLS', & 'EACH PROVIDED COLUMN SCALE FACTOR ' // & 'MUST BE POSITIVE.$$COMPONENT ' // XERN1 // & ' NOW = ' // XERN3, 9, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF 40 CONTINUE ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO SBOLSM(). ELSE if (JP == 5) THEN if (IP > 0) THEN LOPT = IOPT(LP+2) ENDIF LDS = 2 ! CYCLE FOREVER go to 30 ! ! THIS OPTION USES THE NEXT LOC OF IOPT(*) AS AN ! INCREMENT TO SKIP. ELSE if (JP == 6) THEN if (IP > 0) THEN LP = IOPT(LP+2) - 1 LDS = 0 ELSE LDS = 2 ENDIF ! CYCLE FOREVER go to 30 ! ! NO VALID OPTION NUMBER WAS NOTED. THIS IS AN ERROR CONDITION. ELSE WRITE (XERN1, '(I8)') JP call XERMSG ('SLATEC', 'SBOLS', 'THE OPTION NUMBER = ' // & XERN1 // ' IS NOT DEFINED.', 6, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF 50 CONTINUE ! END PROCEDURE if (CHECKL) THEN ! DO(CHECK LENGTHS OF ARRAYS) ! PROCEDURE(CHECK LENGTHS OF ARRAYS) ! ! THIS FEATURE ALLOWS THE USER TO MAKE SURE THAT THE ! ARRAYS ARE LONG ENOUGH FOR THE INTENDED PROBLEM SIZE AND USE. if (LMDW < MROWS) THEN WRITE (XERN1, '(I8)') LMDW WRITE (XERN2, '(I8)') MROWS call XERMSG ('SLATEC', 'SBOLS', & 'THE ROW DIMENSION OF W(,) = ' // XERN1 // & ' MUST BE >= THE NUMBER OF ROWS = ' // XERN2, & 11, 1) go to 190 ENDIF if (LNDW < NCOLS+1) THEN WRITE (XERN1, '(I8)') LNDW WRITE (XERN2, '(I8)') NCOLS+1 call XERMSG ('SLATEC', 'SBOLS', & 'THE COLUMN DIMENSION OF W(,) = ' // XERN1 // & ' MUST BE >= NCOLS+1 = ' // XERN2, 12, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF if (LLB < NCOLS) THEN WRITE (XERN1, '(I8)') LLB WRITE (XERN2, '(I8)') NCOLS call XERMSG ('SLATEC', 'SBOLS', & 'THE DIMENSIONS OF THE ARRAYS BL(), BU(), AND IND() = ' & // XERN1 // ' MUST BE >= NCOLS = ' // XERN2, & 13, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF if (LLX < LENX) THEN WRITE (XERN1, '(I8)') LLX WRITE (XERN2, '(I8)') LENX call XERMSG ('SLATEC', 'SBOLS', & 'THE DIMENSION OF X() = ' // XERN1 // & ' MUST BE >= THE REQUIRED LENGTH = ' // XERN2, & 14, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF if (LLRW < 5*NCOLS) THEN WRITE (XERN1, '(I8)') LLRW WRITE (XERN2, '(I8)') 5*NCOLS call XERMSG ('SLATEC', 'SBOLS', & 'THE DIMENSION OF RW() = ' // XERN1 // & ' MUST BE >= 5*NCOLS = ' // XERN2, 15, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF if (LLIW < 2*NCOLS) THEN WRITE (XERN1, '(I8)') LLIW WRITE (XERN2, '(I8)') 2*NCOLS call XERMSG ('SLATEC', 'SBOLS', & 'THE DIMENSION OF IW() = ' // XERN1 // & ' MUST BE >= 2*NCOLS = ' // XERN2, 16, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF if (LIOPT < LP+1) THEN WRITE (XERN1, '(I8)') LIOPT WRITE (XERN2, '(I8)') LP+1 call XERMSG ('SLATEC', 'SBOLS', & 'THE DIMENSION OF IOPT() = ' // XERN1 // & ' MUST BE >= THE REQD. LEN = ' // XERN2, 17, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 ENDIF ! END PROCEDURE ENDIF end if go to (60,90),IGO go to 180 ! ! GO BACK TO THE USER FOR ACCUMULATION OF LEAST SQUARES ! EQUATIONS AND DIRECTIONS TO QUIT PROCESSING. ! CASE 1 60 CONTINUE ! DO(ACCUMULATE LEAST SQUARES EQUATIONS) ! PROCEDURE(ACCUMULATE LEAST SQUARES EQUATIONS) MROWS = IOPT(LOCACC+1) - 1 INROWS = IOPT(LOCACC+2) MNEW = MROWS + INROWS if (MNEW < 0 .OR. MNEW > MDW) THEN WRITE (XERN1, '(I8)') MNEW WRITE (XERN2, '(I8)') MDW call XERMSG ('SLATEC', 'SBOLS', 'NO. OF ROWS = ' // XERN1 // & ' MUST BE >= 0 .AND. <= MDW = ' // XERN2, 10, 1) ! DO(RETURN TO USER PROGRAM UNIT) go to 190 end if DO 80 J = 1,MIN(NCOLS+1,MNEW) DO 70 I = MNEW,MAX(MROWS,J) + 1,-1 IBIG = ISAMAX(I-J,W(J,J),1) + J - 1 ! ! PIVOT FOR INCREASED STABILITY. call SROTG(W(IBIG,J),W(I,J),SC,SS) call SROT(NCOLS+1-J,W(IBIG,J+1),MDW,W(I,J+1),MDW,SC,SS) W(I,J) = ZERO 70 CONTINUE 80 CONTINUE MROWS = MIN(NCOLS+1,MNEW) IOPT(LOCACC+1) = MROWS + 1 IGO = IOPT(LOCACC) ! END PROCEDURE if (IGO == 2) THEN IGO = 0 end if go to 180 ! CASE 2 90 CONTINUE ! DO(INITIALIZE VARIABLES AND DATA VALUES) ! PROCEDURE(INITIALIZE VARIABLES AND DATA VALUES) DO 150 J = 1,NCOLS go to (100,110,120,130),ISCALE go to 140 100 CONTINUE ! CASE 1 ! ! THIS IS THE NOMINAL SCALING. EACH NONZERO ! COL. HAS MAX. NORM EQUAL TO ONE. IBIG = ISAMAX(MROWS,W(1,J),1) RW(J) = ABS(W(IBIG,J)) if (RW(J) == ZERO) THEN RW(J) = ONE ELSE RW(J) = ONE/RW(J) ENDIF go to 140 110 CONTINUE ! CASE 2 ! ! THIS CHOICE OF SCALING MAKES EACH NONZERO COLUMN ! HAVE EUCLIDEAN LENGTH EQUAL TO ONE. RW(J) = SNRM2(MROWS,W(1,J),1) if (RW(J) == ZERO) THEN RW(J) = ONE ELSE RW(J) = ONE/RW(J) ENDIF go to 140 120 CONTINUE ! CASE 3 ! ! THIS CASE EFFECTIVELY SUPPRESSES SCALING BY SETTING ! THE SCALING MATRIX TO THE IDENTITY MATRIX. RW(1) = ONE call SCOPY(NCOLS,RW,0,RW,1) go to 160 130 CONTINUE ! CASE 4 go to 160 140 CONTINUE 150 CONTINUE 160 CONTINUE ! END PROCEDURE ! DO(SOLVE BOUNDED LEAST SQUARES PROBLEM) ! PROCEDURE(SOLVE BOUNDED LEAST SQUARES PROBLEM) ! ! INITIALIZE IBASIS(*), J=1,NCOLS, AND IBB(*), J=1,NCOLS, ! TO =J,AND =1, FOR USE IN SBOLSM( ). DO 170 J = 1,NCOLS IW(J) = J IW(J+NCOLS) = 1 RW(3*NCOLS+J) = BL(J) RW(4*NCOLS+J) = BU(J) 170 CONTINUE call SBOLSM(W,MDW,MROWS,NCOLS,RW(3*NCOLS+1),RW(4*NCOLS+1),IND, & IOPT(LOPT),X,RNORM,MODE,RW(NCOLS+1),RW(2*NCOLS+1),RW, & IW,IW(NCOLS+1)) ! END PROCEDURE IGO = 0 180 CONTINUE return ! PROCEDURE(RETURN TO USER PROGRAM UNIT) 190 if ( MODE >= 0)MODE = -NERR IGO = 0 return ! END PROCEDURE end subroutine SBOLSM (W, MDW, MINPUT, NCOLS, BL, BU, IND, IOPT, X, & RNORM, MODE, RW, WW, SCL, IBASIS, IBB) ! !! SBOLSM is subsidiary to SBOCLS and SBOLS. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SBOLSM-S, DBOLSM-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Solve E*X = F (least squares sense) with bounds on ! selected X values. ! The user must have DIMENSION statements of the form: ! ! DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS), ! * X(NCOLS+NX), RW(NCOLS), WW(NCOLS), SCL(NCOLS) ! INTEGER IND(NCOLS), IOPT(1+NI), IBASIS(NCOLS), IBB(NCOLS) ! ! (Here NX=number of extra locations required for options 1,...,7; ! NX=0 for no options; here NI=number of extra locations possibly ! required for options 1-7; NI=0 for no options; NI=14 if all the ! options are simultaneously in use.) ! ! INPUT ! ----- ! ! -------------------- ! W(MDW,*),MINPUT,NCOLS ! -------------------- ! The array W(*,*) contains the matrix [E:F] on entry. The matrix ! [E:F] has MINPUT rows and NCOLS+1 columns. This data is placed in ! the array W(*,*) with E occupying the first NCOLS columns and the ! right side vector F in column NCOLS+1. The row dimension, MDW, of ! the array W(*,*) must satisfy the inequality MDW .ge. MINPUT. ! Other values of MDW are errors. The values of MINPUT and NCOLS ! must be positive. Other values are errors. ! ! ------------------ ! BL(*),BU(*),IND(*) ! ------------------ ! These arrays contain the information about the bounds that the ! solution values are to satisfy. The value of IND(J) tells the ! type of bound and BL(J) and BU(J) give the explicit values for ! the respective upper and lower bounds. ! ! 1. For IND(J)=1, require X(J) .ge. BL(J). ! 2. For IND(J)=2, require X(J) .le. BU(J). ! 3. For IND(J)=3, require X(J) .ge. BL(J) and ! X(J) .le. BU(J). ! 4. For IND(J)=4, no bounds on X(J) are required. ! The values of BL(*),BL(*) are modified by the subprogram. Values ! other than 1,2,3 or 4 for IND(J) are errors. In the case IND(J)=3 ! (upper and lower bounds) the condition BL(J) .gt. BU(J) is an ! error. ! ! ------- ! IOPT(*) ! ------- ! This is the array where the user can specify nonstandard options ! for SBOLSM. Most of the time this feature can be ignored by ! setting the input value IOPT(1)=99. Occasionally users may have ! needs that require use of the following subprogram options. For ! details about how to use the options see below: IOPT(*) CONTENTS. ! ! Option Number Brief Statement of Purpose ! ----- ------ ----- --------- -- ------- ! 1 Move the IOPT(*) processing pointer. ! 2 Change rank determination tolerance. ! 3 Change blow-up factor that determines the ! size of variables being dropped from active ! status. ! 4 Reset the maximum number of iterations to use ! in solving the problem. ! 5 The data matrix is triangularized before the ! problem is solved whenever (NCOLS/MINPUT) .lt. ! FAC. Change the value of FAC. ! 6 Redefine the weighting matrix used for ! linear independence checking. ! 7 Debug output is desired. ! 99 No more options to change. ! ! ---- ! X(*) ! ---- ! This array is used to pass data associated with options 1,2,3 and ! 5. Ignore this input parameter if none of these options are used. ! Otherwise see below: IOPT(*) CONTENTS. ! ! ---------------- ! IBASIS(*),IBB(*) ! ---------------- ! These arrays must be initialized by the user. The values ! IBASIS(J)=J, J=1,...,NCOLS ! IBB(J) =1, J=1,...,NCOLS ! are appropriate except when using nonstandard features. ! ! ------ ! SCL(*) ! ------ ! This is the array of scaling factors to use on the columns of the ! matrix E. These values must be defined by the user. To suppress ! any column scaling set SCL(J)=1.0, J=1,...,NCOLS. ! ! OUTPUT ! ------ ! ! ---------- ! X(*),RNORM ! ---------- ! The array X(*) contains a solution (if MODE .ge. 0 or .eq. -22) ! for the constrained least squares problem. The value RNORM is the ! minimum residual vector length. ! ! ---- ! MODE ! ---- ! The sign of mode determines whether the subprogram has completed ! normally, or encountered an error condition or abnormal status. ! A value of MODE .ge. 0 signifies that the subprogram has completed ! normally. The value of MODE (.ge. 0) is the number of variables ! in an active status: not at a bound nor at the value ZERO, for ! the case of free variables. A negative value of MODE will be one ! of the 18 cases -38,-37,...,-22, or -1. Values .lt. -1 correspond ! to an abnormal completion of the subprogram. To understand the ! abnormal completion codes see below: ERROR MESSAGES for SBOLSM ! An approximate solution will be returned to the user only when ! maximum iterations is reached, MODE=-22. ! ! ----------- ! RW(*),WW(*) ! ----------- ! These are working arrays each with NCOLS entries. The array RW(*) ! contains the working (scaled, nonactive) solution values. The ! array WW(*) contains the working (scaled, active) gradient vector ! values. ! ! ---------------- ! IBASIS(*),IBB(*) ! ---------------- ! These arrays contain information about the status of the solution ! when MODE .ge. 0. The indices IBASIS(K), K=1,...,MODE, show the ! nonactive variables; indices IBASIS(K), K=MODE+1,..., NCOLS are ! the active variables. The value (IBB(J)-1) is the number of times ! variable J was reflected from its upper bound. (Normally the user ! can ignore these parameters.) ! ! IOPT(*) CONTENTS ! ------- -------- ! The option array allows a user to modify internal variables in ! the subprogram without recompiling the source code. A central ! goal of the initial software design was to do a good job for most ! people. Thus the use of options will be restricted to a select ! group of users. The processing of the option array proceeds as ! follows: a pointer, here called LP, is initially set to the value ! 1. The value is updated as the options are processed. At the ! pointer position the option number is extracted and used for ! locating other information that allows for options to be changed. ! The portion of the array IOPT(*) that is used for each option is ! fixed; the user and the subprogram both know how many locations ! are needed for each option. A great deal of error checking is ! done by the subprogram on the contents of the option array. ! Nevertheless it is still possible to give the subprogram optional ! input that is meaningless. For example, some of the options use ! the location X(NCOLS+IOFF) for passing data. The user must manage ! the allocation of these locations when more than one piece of ! option data is being passed to the subprogram. ! ! 1 ! - ! Move the processing pointer (either forward or backward) to the ! location IOPT(LP+1). The processing pointer is moved to location ! LP+2 of IOPT(*) in case IOPT(LP)=-1. For example to skip over ! locations 3,...,NCOLS+2 of IOPT(*), ! ! IOPT(1)=1 ! IOPT(2)=NCOLS+3 ! (IOPT(I), I=3,...,NCOLS+2 are not defined here.) ! IOPT(NCOLS+3)=99 ! call SBOLSM ! ! CAUTION: Misuse of this option can yield some very hard-to-find ! bugs. Use it with care. ! ! 2 ! - ! The algorithm that solves the bounded least squares problem ! iteratively drops columns from the active set. This has the ! effect of joining a new column vector to the QR factorization of ! the rectangular matrix consisting of the partially triangularized ! nonactive columns. After triangularizing this matrix a test is ! made on the size of the pivot element. The column vector is ! rejected as dependent if the magnitude of the pivot element is ! .le. TOL* magnitude of the column in components strictly above ! the pivot element. Nominally the value of this (rank) tolerance ! is TOL = SQRT(R1MACH(4)). To change only the value of TOL, for ! example, ! ! X(NCOLS+1)=TOL ! IOPT(1)=2 ! IOPT(2)=1 ! IOPT(3)=99 ! call SBOLSM ! ! Generally, if LP is the processing pointer for IOPT(*), ! ! X(NCOLS+IOFF)=TOL ! IOPT(LP)=2 ! IOPT(LP+1)=IOFF ! . ! call SBOLSM ! ! The required length of IOPT(*) is increased by 2 if option 2 is ! used; The required length of X(*) is increased by 1. A value of ! IOFF .le. 0 is an error. A value of TOL .le. R1MACH(4) gives a ! warning message; it is not considered an error. ! ! 3 ! - ! A solution component is left active (not used) if, roughly ! speaking, it seems too large. Mathematically the new component is ! left active if the magnitude is .ge.((vector norm of F)/(matrix ! norm of E))/BLOWUP. Nominally the factor BLOWUP = SQRT(R1MACH(4)). ! To change only the value of BLOWUP, for example, ! ! X(NCOLS+2)=BLOWUP ! IOPT(1)=3 ! IOPT(2)=2 ! IOPT(3)=99 ! call SBOLSM ! ! Generally, if LP is the processing pointer for IOPT(*), ! ! X(NCOLS+IOFF)=BLOWUP ! IOPT(LP)=3 ! IOPT(LP+1)=IOFF ! . ! call SBOLSM ! ! The required length of IOPT(*) is increased by 2 if option 3 is ! used; the required length of X(*) is increased by 1. A value of ! IOFF .le. 0 is an error. A value of BLOWUP .le. 0.0 is an error. ! ! 4 ! - ! Normally the algorithm for solving the bounded least squares ! problem requires between NCOLS/3 and NCOLS drop-add steps to ! converge. (this remark is based on examining a small number of ! test cases.) The amount of arithmetic for such problems is ! typically about twice that required for linear least squares if ! there are no bounds and if plane rotations are used in the ! solution method. Convergence of the algorithm, while ! mathematically certain, can be much slower than indicated. To ! avoid this potential but unlikely event ITMAX drop-add steps are ! permitted. Nominally ITMAX=5*(MAX(MINPUT,NCOLS)). To change the ! value of ITMAX, for example, ! ! IOPT(1)=4 ! IOPT(2)=ITMAX ! IOPT(3)=99 ! call SBOLSM ! ! Generally, if LP is the processing pointer for IOPT(*), ! ! IOPT(LP)=4 ! IOPT(LP+1)=ITMAX ! . ! call SBOLSM ! ! The value of ITMAX must be .gt. 0. Other values are errors. Use ! of this option increases the required length of IOPT(*) by 2. ! ! 5 ! - ! For purposes of increased efficiency the MINPUT by NCOLS+1 data ! matrix [E:F] is triangularized as a first step whenever MINPUT ! satisfies FAC*MINPUT .gt. NCOLS. Nominally FAC=0.75. To change the ! value of FAC, ! ! X(NCOLS+3)=FAC ! IOPT(1)=5 ! IOPT(2)=3 ! IOPT(3)=99 ! call SBOLSM ! ! Generally, if LP is the processing pointer for IOPT(*), ! ! X(NCOLS+IOFF)=FAC ! IOPT(LP)=5 ! IOPT(LP+1)=IOFF ! . ! call SBOLSM ! ! The value of FAC must be nonnegative. Other values are errors. ! Resetting FAC=0.0 suppresses the initial triangularization step. ! Use of this option increases the required length of IOPT(*) by 2; ! The required length of of X(*) is increased by 1. ! ! 6 ! - ! The norm used in testing the magnitudes of the pivot element ! compared to the mass of the column above the pivot line can be ! changed. The type of change that this option allows is to weight ! the components with an index larger than MVAL by the parameter ! WT. Normally MVAL=0 and WT=1. To change both the values MVAL and ! WT, where LP is the processing pointer for IOPT(*), ! ! X(NCOLS+IOFF)=WT ! IOPT(LP)=6 ! IOPT(LP+1)=IOFF ! IOPT(LP+2)=MVAL ! ! Use of this option increases the required length of IOPT(*) by 3. ! The length of X(*) is increased by 1. Values of MVAL must be ! nonnegative and not greater than MINPUT. Other values are errors. ! The value of WT must be positive. Any other value is an error. If ! either error condition is present a message will be printed. ! ! 7 ! - ! Debug output, showing the detailed add-drop steps for the ! constrained least squares problem, is desired. This option is ! intended to be used to locate suspected bugs. ! ! 99 ! -- ! There are no more options to change. ! ! The values for options are 1,...,7,99, and are the only ones ! permitted. Other values are errors. Options -99,-1,...,-7 mean ! that the repective options 99,1,...,7 are left at their default ! values. An example is the option to modify the (rank) tolerance: ! ! X(NCOLS+1)=TOL ! IOPT(1)=-2 ! IOPT(2)=1 ! IOPT(3)=99 ! ! Error Messages for SBOLSM ! ----- -------- --- --------- ! -22 MORE THAN ITMAX = ... ITERATIONS SOLVING BOUNDED LEAST ! SQUARES PROBLEM. ! ! -23 THE OPTION NUMBER = ... IS NOT DEFINED. ! ! -24 THE OFFSET = ... BEYOND POSTION NCOLS = ... MUST BE POSITIVE ! FOR OPTION NUMBER 2. ! ! -25 THE TOLERANCE FOR RANK DETERMINATION = ... IS LESS THAN ! MACHINE PRECISION = .... ! ! -26 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE ! FOR OPTION NUMBER 3. ! ! -27 THE RECIPROCAL OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES ! MUST BE POSITIVE. NOW = .... ! ! -28 THE MAXIMUM NUMBER OF ITERATIONS = ... MUST BE POSITIVE. ! ! -29 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE ! FOR OPTION NUMBER 5. ! ! -30 THE FACTOR (NCOLS/MINPUT) WHERE PRETRIANGULARIZING IS ! PERFORMED MUST BE NONNEGATIVE. NOW = .... ! ! -31 THE NUMBER OF ROWS = ... MUST BE POSITIVE. ! ! -32 THE NUMBER OF COLUMNS = ... MUST BE POSTIVE. ! ! -33 THE ROW DIMENSION OF W(,) = ... MUST BE >= THE NUMBER OF ! ROWS = .... ! ! -34 FOR J = ... THE CONSTRAINT INDICATOR MUST BE 1-4. ! ! -35 FOR J = ... THE LOWER BOUND = ... IS > THE UPPER BOUND = ! .... ! ! -36 THE INPUT ORDER OF COLUMNS = ... IS NOT BETWEEN 1 AND NCOLS ! = .... ! ! -37 THE BOUND POLARITY FLAG IN COMPONENT J = ... MUST BE ! POSITIVE. NOW = .... ! ! -38 THE ROW SEPARATOR TO APPLY WEIGHTING (...) MUST LIE BETWEEN ! 0 AND MINPUT = .... WEIGHT = ... MUST BE POSITIVE. ! !***SEE ALSO SBOCLS, SBOLS !***ROUTINES CALLED IVOUT, R1MACH, SAXPY, SCOPY, SDOT, SMOUT, SNRM2, ! SROT, SROTG, SSWAP, SVOUT, XERMSG !***REVISION HISTORY (YYMMDD) ! 821220 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920422 Fixed usage of MINPUT. (WRB) ! 901009 Editorial changes, code now reads from top to bottom. (RWC) !***END PROLOGUE SBOLSM ! ! PURPOSE ! ------- ! THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE BOUNDED ! LEAST SQUARES PROBLEM. THE PROBLEM SOLVED HERE IS: ! ! SOLVE E*X = F (LEAST SQUARES SENSE) ! WITH BOUNDS ON SELECTED X VALUES. ! ! TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN ! EDITING AT THE CARD 'C++'. ! CHANGE THE SUBPROGRAM NAME TO DBOLSM AND THE STRINGS ! /SAXPY/ TO /DAXPY/, /SCOPY/ TO /DCOPY/, ! /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/, ! /SROT/ TO /DROT/, /SROTG/ TO /DROTG/, /R1MACH/ TO /D1MACH/, ! /SVOUT/ TO /DVOUT/, /SMOUT/ TO /DMOUT/, ! /SSWAP/ TO /DSWAP/, /E0/ TO /D0/, ! /REAL / TO /DOUBLE PRECISION/. !++ ! REAL W(MDW,*),BL(*),BU(*) REAL X(*),RW(*),WW(*),SCL(*) REAL ALPHA,BETA,BOU,COLABV,COLBLO REAL CL1,CL2,CL3,ONE,BIG REAL FAC,RNORM,SC,SS,T,TOLIND,WT REAL TWO,T1,T2,WBIG,WLARGE,WMAG,XNEW REAL ZERO,SDOT,SNRM2 REAL R1MACH,TOLSZE INTEGER IBASIS(*),IBB(*),IND(*),IOPT(*) LOGICAL FOUND,CONSTR CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 ! PARAMETER (ZERO=0.0E0, ONE=1.0E0, TWO=2.0E0) ! INEXT(IDUM) = MIN(IDUM+1,MROWS) !***FIRST EXECUTABLE STATEMENT SBOLSM ! ! Verify that the problem dimensions are defined properly. ! if (MINPUT <= 0) THEN WRITE (XERN1, '(I8)') MINPUT call XERMSG ('SLATEC', 'SBOLSM', 'THE NUMBER OF ROWS = ' // & XERN1 // ' MUST BE POSITIVE.', 31, 1) MODE = -31 return end if ! if (NCOLS <= 0) THEN WRITE (XERN1, '(I8)') NCOLS call XERMSG ('SLATEC', 'SBOLSM', 'THE NUMBER OF COLUMNS = ' // & XERN1 // ' MUST BE POSITIVE.', 32, 1) MODE = -32 return end if ! if (MDW < MINPUT) THEN WRITE (XERN1, '(I8)') MDW WRITE (XERN2, '(I8)') MINPUT call XERMSG ('SLATEC', 'SBOLSM', & 'THE ROW DIMENSION OF W(,) = ' // XERN1 // & ' MUST BE >= THE NUMBER OF ROWS = ' // XERN2, 33, 1) MODE = -33 return end if ! ! Verify that bound information is correct. ! DO 10 J = 1,NCOLS if (IND(J) < 1 .OR. IND(J) > 4) THEN WRITE (XERN1, '(I8)') J WRITE (XERN2, '(I8)') IND(J) call XERMSG ('SLATEC', 'SBOLSM', 'FOR J = ' // XERN1 // & ' THE CONSTRAINT INDICATOR MUST BE 1-4', 34, 1) MODE = -34 return ENDIF 10 CONTINUE ! DO 20 J = 1,NCOLS if (IND(J) == 3) THEN if (BU(J) < BL(J)) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') BL(J) WRITE (XERN4, '(1PE15.6)') BU(J) call XERMSG ('SLATEC', 'SBOLSM', 'FOR J = ' // XERN1 & // ' THE LOWER BOUND = ' // XERN3 // & ' IS > THE UPPER BOUND = ' // XERN4, 35, 1) MODE = -35 return ENDIF ENDIF 20 CONTINUE ! ! Check that permutation and polarity arrays have been set. ! DO 30 J = 1,NCOLS if (IBASIS(J) < 1 .OR. IBASIS(J) > NCOLS) THEN WRITE (XERN1, '(I8)') IBASIS(J) WRITE (XERN2, '(I8)') NCOLS call XERMSG ('SLATEC', 'SBOLSM', & 'THE INPUT ORDER OF COLUMNS = ' // XERN1 // & ' IS NOT BETWEEN 1 AND NCOLS = ' // XERN2, 36, 1) MODE = -36 return ENDIF ! if (IBB(J) <= 0) THEN WRITE (XERN1, '(I8)') J WRITE (XERN2, '(I8)') IBB(J) call XERMSG ('SLATEC', 'SBOLSM', & 'THE BOUND POLARITY FLAG IN COMPONENT J = ' // XERN1 // & ' MUST BE POSITIVE.$$NOW = ' // XERN2, 37, 1) MODE = -37 return ENDIF 30 CONTINUE ! ! Process the option array. ! FAC = 0.75E0 TOLIND = SQRT(R1MACH(4)) TOLSZE = SQRT(R1MACH(4)) ITMAX = 5*MAX(MINPUT,NCOLS) WT = ONE MVAL = 0 IPRINT = 0 ! ! Changes to some parameters can occur through the option array, ! IOPT(*). Process this array looking carefully for input data ! errors. ! LP = 0 LDS = 0 ! ! Test for no more options. ! 590 LP = LP + LDS IP = IOPT(LP+1) JP = ABS(IP) if (IP == 99) THEN go to 470 ELSE if (JP == 99) THEN LDS = 1 ELSE if (JP == 1) THEN ! ! Move the IOPT(*) processing pointer. ! if (IP > 0) THEN LP = IOPT(LP+2) - 1 LDS = 0 ELSE LDS = 2 ENDIF ELSE if (JP == 2) THEN ! ! Change tolerance for rank determination. ! if (IP > 0) THEN IOFF = IOPT(LP+2) if (IOFF <= 0) THEN WRITE (XERN1, '(I8)') IOFF WRITE (XERN2, '(I8)') NCOLS call XERMSG ('SLATEC', 'SBOLSM', 'THE OFFSET = ' // & XERN1 // ' BEYOND POSITION NCOLS = ' // XERN2 // & ' MUST BE POSITIVE FOR OPTION NUMBER 2.', 24, 1) MODE = -24 return ENDIF ! TOLIND = X(NCOLS+IOFF) if (TOLIND < R1MACH(4)) THEN WRITE (XERN3, '(1PE15.6)') TOLIND WRITE (XERN4, '(1PE15.6)') R1MACH(4) call XERMSG ('SLATEC', 'SBOLSM', & 'THE TOLERANCE FOR RANK DETERMINATION = ' // XERN3 & // ' IS LESS THAN MACHINE PRECISION = ' // XERN4, & 25, 0) MODE = -25 ENDIF ENDIF LDS = 2 ELSE if (JP == 3) THEN ! ! Change blowup factor for allowing variables to become ! inactive. ! if (IP > 0) THEN IOFF = IOPT(LP+2) if (IOFF <= 0) THEN WRITE (XERN1, '(I8)') IOFF WRITE (XERN2, '(I8)') NCOLS call XERMSG ('SLATEC', 'SBOLSM', 'THE OFFSET = ' // & XERN1 // ' BEYOND POSITION NCOLS = ' // XERN2 // & ' MUST BE POSITIVE FOR OPTION NUMBER 3.', 26, 1) MODE = -26 return ENDIF ! TOLSZE = X(NCOLS+IOFF) if (TOLSZE <= ZERO) THEN WRITE (XERN3, '(1PE15.6)') TOLSZE call XERMSG ('SLATEC', 'SBOLSM', 'THE RECIPROCAL ' // & 'OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES ' // & 'MUST BE POSITIVE.$$NOW = ' // XERN3, 27, 1) MODE = -27 return ENDIF ENDIF LDS = 2 ELSE if (JP == 4) THEN ! ! Change the maximum number of iterations allowed. ! if (IP > 0) THEN ITMAX = IOPT(LP+2) if (ITMAX <= 0) THEN WRITE (XERN1, '(I8)') ITMAX call XERMSG ('SLATEC', 'SBOLSM', & 'THE MAXIMUM NUMBER OF ITERATIONS = ' // XERN1 // & ' MUST BE POSITIVE.', 28, 1) MODE = -28 return ENDIF ENDIF LDS = 2 ELSE if (JP == 5) THEN ! ! Change the factor for pretriangularizing the data matrix. ! if (IP > 0) THEN IOFF = IOPT(LP+2) if (IOFF <= 0) THEN WRITE (XERN1, '(I8)') IOFF WRITE (XERN2, '(I8)') NCOLS call XERMSG ('SLATEC', 'SBOLSM', 'THE OFFSET = ' // & XERN1 // ' BEYOND POSITION NCOLS = ' // XERN2 // & ' MUST BE POSITIVE FOR OPTION NUMBER 5.', 29, 1) MODE = -29 return ENDIF ! FAC = X(NCOLS+IOFF) if (FAC < ZERO) THEN WRITE (XERN3, '(1PE15.6)') FAC call XERMSG ('SLATEC', 'SBOLSM', & 'THE FACTOR (NCOLS/MINPUT) WHERE PRE-' // & 'TRIANGULARIZING IS PERFORMED MUST BE NON-' // & 'NEGATIVE.$$NOW = ' // XERN3, 30, 0) MODE = -30 return ENDIF ENDIF LDS = 2 ELSE if (JP == 6) THEN ! ! Change the weighting factor (from 1.0) to apply to components ! numbered .gt. MVAL (initially set to 1.) This trick is needed ! for applications of this subprogram to the heavily weighted ! least squares problem that come from equality constraints. ! if (IP > 0) THEN IOFF = IOPT(LP+2) MVAL = IOPT(LP+3) WT = X(NCOLS+IOFF) ENDIF ! if (MVAL < 0 .OR. MVAL > MINPUT .OR. WT <= ZERO) THEN WRITE (XERN1, '(I8)') MVAL WRITE (XERN2, '(I8)') MINPUT WRITE (XERN3, '(1PE15.6)') WT call XERMSG ('SLATEC', 'SBOLSM', & 'THE ROW SEPARATOR TO APPLY WEIGHTING (' // XERN1 // & ') MUST LIE BETWEEN 0 AND MINPUT = ' // XERN2 // & '.$$WEIGHT = ' // XERN3 // ' MUST BE POSITIVE.', 38, 0) MODE = -38 return ENDIF LDS = 3 ELSE if (JP == 7) THEN ! ! Turn on debug output. ! if (IP > 0) IPRINT = 1 LDS = 2 ELSE WRITE (XERN1, '(I8)') IP call XERMSG ('SLATEC', 'SBOLSM', 'THE OPTION NUMBER = ' // & XERN1 // ' IS NOT DEFINED.', 23, 1) MODE = -23 return end if go to 590 ! ! Pretriangularize rectangular arrays of certain sizes for ! increased efficiency. ! 470 if (FAC*MINPUT > NCOLS) THEN DO 490 J = 1,NCOLS+1 DO 480 I = MINPUT,J+MVAL+1,-1 call SROTG(W(I-1,J),W(I,J),SC,SS) W(I,J) = ZERO call SROT(NCOLS-J+1,W(I-1,J+1),MDW,W(I,J+1),MDW,SC,SS) 480 CONTINUE 490 CONTINUE MROWS = NCOLS + MVAL + 1 ELSE MROWS = MINPUT end if ! ! Set the X(*) array to zero so all components are defined. ! call SCOPY(NCOLS,ZERO,0,X,1) ! ! The arrays IBASIS(*) and IBB(*) are initialized by the calling ! program and the column scaling is defined in the calling program. ! 'BIG' is plus infinity on this machine. ! BIG = R1MACH(2) DO 550 J = 1,NCOLS if (IND(J) == 1) THEN BU(J) = BIG ELSE if (IND(J) == 2) THEN BL(J) = -BIG ELSE if (IND(J) == 4) THEN BL(J) = -BIG BU(J) = BIG ENDIF 550 CONTINUE ! DO 570 J = 1,NCOLS if ((BL(J) <= ZERO.AND.ZERO <= BU(J).AND.ABS(BU(J)) < & ABS(BL(J))) .OR. BU(J) < ZERO) THEN T = BU(J) BU(J) = -BL(J) BL(J) = -T SCL(J) = -SCL(J) DO 560 I = 1,MROWS W(I,J) = -W(I,J) 560 CONTINUE ENDIF ! ! Indices in set T(=TIGHT) are denoted by negative values ! of IBASIS(*). ! if (BL(J) >= ZERO) THEN IBASIS(J) = -IBASIS(J) T = -BL(J) BU(J) = BU(J) + T call SAXPY(MROWS,T,W(1,J),1,W(1,NCOLS+1),1) ENDIF 570 CONTINUE ! NSETB = 0 ITER = 0 ! if (IPRINT > 0) THEN call SMOUT(MROWS,NCOLS+1,MDW,W,'('' PRETRI. INPUT MATRIX'')', & -4) call SVOUT(NCOLS,BL,'('' LOWER BOUNDS'')',-4) call SVOUT(NCOLS,BU,'('' UPPER BOUNDS'')',-4) end if ! 580 ITER = ITER + 1 if (ITER > ITMAX) THEN WRITE (XERN1, '(I8)') ITMAX call XERMSG ('SLATEC', 'SBOLSM', 'MORE THAN ITMAX = ' // XERN1 & // ' ITERATIONS SOLVING BOUNDED LEAST SQUARES PROBLEM.', & 22, 1) MODE = -22 ! ! Rescale and translate variables. ! IGOPR = 1 go to 130 end if ! ! Find a variable to become non-active. ! T ! Compute (negative) of gradient vector, W = E *(F-E*X). ! call SCOPY(NCOLS,ZERO,0,WW,1) DO 200 J = NSETB+1,NCOLS JCOL = ABS(IBASIS(J)) WW(J) = SDOT(MROWS-NSETB,W(INEXT(NSETB),J),1, & W(INEXT(NSETB),NCOLS+1),1)*ABS(SCL(JCOL)) 200 CONTINUE ! if (IPRINT > 0) THEN call SVOUT(NCOLS,WW,'('' GRADIENT VALUES'')',-4) call IVOUT(NCOLS,IBASIS,'('' INTERNAL VARIABLE ORDER'')',-4) call IVOUT(NCOLS,IBB,'('' BOUND POLARITY'')',-4) end if ! ! If active set = number of total rows, quit. ! 210 if (NSETB == MROWS) THEN FOUND = .FALSE. go to 120 end if ! ! Choose an extremal component of gradient vector for a candidate ! to become non-active. ! WLARGE = -BIG WMAG = -BIG DO 220 J = NSETB+1,NCOLS T = WW(J) if (T == BIG) go to 220 ITEMP = IBASIS(J) JCOL = ABS(ITEMP) T1 = SNRM2(MVAL-NSETB,W(INEXT(NSETB),J),1) if (ITEMP < 0) THEN if (MOD(IBB(JCOL),2) == 0) T = -T if (T < ZERO) go to 220 if (MVAL > NSETB) T = T1 if (T > WLARGE) THEN WLARGE = T JLARGE = J ENDIF ELSE if (MVAL > NSETB) T = T1 if (ABS(T) > WMAG) THEN WMAG = ABS(T) JMAG = J ENDIF ENDIF 220 CONTINUE ! ! Choose magnitude of largest component of gradient for candidate. ! JBIG = 0 WBIG = ZERO if (WLARGE > ZERO) THEN JBIG = JLARGE WBIG = WLARGE end if ! if (WMAG >= WBIG) THEN JBIG = JMAG WBIG = WMAG end if ! if (JBIG == 0) THEN FOUND = .FALSE. if (IPRINT > 0) THEN call IVOUT(0,I,'('' FOUND NO VARIABLE TO ENTER'')',-4) ENDIF go to 120 end if ! ! See if the incoming column is sufficiently independent. This ! test is made before an elimination is performed. ! if (IPRINT > 0) & call IVOUT(1,JBIG,'('' TRY TO BRING IN THIS COL.'')',-4) ! if (MVAL <= NSETB) THEN CL1 = SNRM2(MVAL,W(1,JBIG),1) CL2 = ABS(WT)*SNRM2(NSETB-MVAL,W(INEXT(MVAL),JBIG),1) CL3 = ABS(WT)*SNRM2(MROWS-NSETB,W(INEXT(NSETB),JBIG),1) call SROTG(CL1,CL2,SC,SS) COLABV = ABS(CL1) COLBLO = CL3 ELSE CL1 = SNRM2(NSETB,W(1,JBIG),1) CL2 = SNRM2(MVAL-NSETB,W(INEXT(NSETB),JBIG),1) CL3 = ABS(WT)*SNRM2(MROWS-MVAL,W(INEXT(MVAL),JBIG),1) COLABV = CL1 call SROTG(CL2,CL3,SC,SS) COLBLO = ABS(CL2) end if ! if (COLBLO <= TOLIND*COLABV) THEN WW(JBIG) = BIG if (IPRINT > 0) & call IVOUT(0,I,'('' VARIABLE IS DEPENDENT, NOT USED.'')', & -4) go to 210 end if ! ! Swap matrix columns NSETB+1 and JBIG, plus pointer information, ! and gradient values. ! NSETB = NSETB + 1 if (NSETB /= JBIG) THEN call SSWAP(MROWS,W(1,NSETB),1,W(1,JBIG),1) call SSWAP(1,WW(NSETB),1,WW(JBIG),1) ITEMP = IBASIS(NSETB) IBASIS(NSETB) = IBASIS(JBIG) IBASIS(JBIG) = ITEMP end if ! ! Eliminate entries below the pivot line in column NSETB. ! if (MROWS > NSETB) THEN DO 230 I = MROWS,NSETB+1,-1 if (I == MVAL+1) go to 230 call SROTG(W(I-1,NSETB),W(I,NSETB),SC,SS) W(I,NSETB) = ZERO call SROT(NCOLS-NSETB+1,W(I-1,NSETB+1),MDW,W(I,NSETB+1), & MDW,SC,SS) 230 CONTINUE ! if (MVAL >= NSETB .AND. MVAL < MROWS) THEN call SROTG(W(NSETB,NSETB),W(MVAL+1,NSETB),SC,SS) W(MVAL+1,NSETB) = ZERO call SROT(NCOLS-NSETB+1,W(NSETB,NSETB+1),MDW, & W(MVAL+1,NSETB+1),MDW,SC,SS) ENDIF end if ! if (W(NSETB,NSETB) == ZERO) THEN WW(NSETB) = BIG NSETB = NSETB - 1 if (IPRINT > 0) THEN call IVOUT(0,I,'('' PIVOT IS ZERO, NOT USED.'')',-4) ENDIF go to 210 end if ! ! Check that new variable is moving in the right direction. ! ITEMP = IBASIS(NSETB) JCOL = ABS(ITEMP) XNEW = (W(NSETB,NCOLS+1)/W(NSETB,NSETB))/ABS(SCL(JCOL)) if (ITEMP < 0) THEN ! ! if ( WW(NSETB) >= ZERO.AND.XNEW <= ZERO) exit(quit) ! if ( WW(NSETB) <= ZERO.AND.XNEW >= ZERO) exit(quit) ! if ((WW(NSETB) >= ZERO.AND.XNEW <= ZERO) .OR. & (WW(NSETB) <= ZERO.AND.XNEW >= ZERO)) go to 240 end if FOUND = .TRUE. go to 120 ! 240 WW(NSETB) = BIG NSETB = NSETB - 1 if (IPRINT > 0) & call IVOUT(0,I,'('' VARIABLE HAS BAD DIRECTION, NOT USED.'')', & -4) go to 210 ! ! Solve the triangular system. ! 270 call SCOPY(NSETB,W(1,NCOLS+1),1,RW,1) DO 280 J = NSETB,1,-1 RW(J) = RW(J)/W(J,J) JCOL = ABS(IBASIS(J)) T = RW(J) if (MOD(IBB(JCOL),2) == 0) RW(J) = -RW(J) call SAXPY(J-1,-T,W(1,J),1,RW,1) RW(J) = RW(J)/ABS(SCL(JCOL)) 280 CONTINUE ! if (IPRINT > 0) THEN call SVOUT(NSETB,RW,'('' SOLN. VALUES'')',-4) call IVOUT(NSETB,IBASIS,'('' COLS. USED'')',-4) end if ! if (LGOPR == 2) THEN call SCOPY(NSETB,RW,1,X,1) DO 450 J = 1,NSETB ITEMP = IBASIS(J) JCOL = ABS(ITEMP) if (ITEMP < 0) THEN BOU = ZERO ELSE BOU = BL(JCOL) ENDIF ! if ((-BOU) /= BIG) BOU = BOU/ABS(SCL(JCOL)) if (X(J) <= BOU) THEN JDROP1 = J go to 340 ENDIF ! BOU = BU(JCOL) if (BOU /= BIG) BOU = BOU/ABS(SCL(JCOL)) if (X(J) >= BOU) THEN JDROP2 = J go to 340 ENDIF 450 CONTINUE go to 340 end if ! ! See if the unconstrained solution (obtained by solving the ! triangular system) satisfies the problem bounds. ! ALPHA = TWO BETA = TWO X(NSETB) = ZERO DO 310 J = 1,NSETB ITEMP = IBASIS(J) JCOL = ABS(ITEMP) T1 = TWO T2 = TWO if (ITEMP < 0) THEN BOU = ZERO ELSE BOU = BL(JCOL) ENDIF if ((-BOU) /= BIG) BOU = BOU/ABS(SCL(JCOL)) if (RW(J) <= BOU) T1 = (X(J)-BOU)/ (X(J)-RW(J)) BOU = BU(JCOL) if (BOU /= BIG) BOU = BOU/ABS(SCL(JCOL)) if (RW(J) >= BOU) T2 = (BOU-X(J))/ (RW(J)-X(J)) ! ! If not, then compute a step length so that the variables remain ! feasible. ! if (T1 < ALPHA) THEN ALPHA = T1 JDROP1 = J ENDIF ! if (T2 < BETA) THEN BETA = T2 JDROP2 = J ENDIF 310 CONTINUE ! CONSTR = ALPHA < TWO .OR. BETA < TWO if (.NOT.CONSTR) THEN ! ! Accept the candidate because it satisfies the stated bounds ! on the variables. ! call SCOPY(NSETB,RW,1,X,1) go to 580 end if ! ! Take a step that is as large as possible with all variables ! remaining feasible. ! DO 330 J = 1,NSETB X(J) = X(J) + MIN(ALPHA,BETA)* (RW(J)-X(J)) 330 CONTINUE ! if (ALPHA <= BETA) THEN JDROP2 = 0 ELSE JDROP1 = 0 end if ! 340 if (JDROP1+JDROP2 <= 0 .OR. NSETB <= 0) go to 580 350 JDROP = JDROP1 + JDROP2 ITEMP = IBASIS(JDROP) JCOL = ABS(ITEMP) if (JDROP2 > 0) THEN ! ! Variable is at an upper bound. Subtract multiple of this ! column from right hand side. ! T = BU(JCOL) if (ITEMP > 0) THEN BU(JCOL) = T - BL(JCOL) BL(JCOL) = -T ITEMP = -ITEMP SCL(JCOL) = -SCL(JCOL) DO 360 I = 1,JDROP W(I,JDROP) = -W(I,JDROP) 360 CONTINUE ELSE IBB(JCOL) = IBB(JCOL) + 1 if (MOD(IBB(JCOL),2) == 0) T = -T ENDIF ! ! Variable is at a lower bound. ! ELSE if (ITEMP < ZERO) THEN T = ZERO ELSE T = -BL(JCOL) BU(JCOL) = BU(JCOL) + T ITEMP = -ITEMP ENDIF end if ! call SAXPY(JDROP,T,W(1,JDROP),1,W(1,NCOLS+1),1) ! ! Move certain columns left to achieve upper Hessenberg form. ! call SCOPY(JDROP,W(1,JDROP),1,RW,1) DO 370 J = JDROP+1,NSETB IBASIS(J-1) = IBASIS(J) X(J-1) = X(J) call SCOPY(J,W(1,J),1,W(1,J-1),1) 370 CONTINUE ! IBASIS(NSETB) = ITEMP W(1,NSETB) = ZERO call SCOPY(MROWS-JDROP,W(1,NSETB),0,W(JDROP+1,NSETB),1) call SCOPY(JDROP,RW,1,W(1,NSETB),1) ! ! Transform the matrix from upper Hessenberg form to upper ! triangular form. ! NSETB = NSETB - 1 DO 390 I = JDROP,NSETB ! ! Look for small pivots and avoid mixing weighted and ! nonweighted rows. ! if (I == MVAL) THEN T = ZERO DO 380 J = I,NSETB JCOL = ABS(IBASIS(J)) T1 = ABS(W(I,J)*SCL(JCOL)) if (T1 > T) THEN JBIG = J T = T1 ENDIF 380 CONTINUE go to 400 ENDIF call SROTG(W(I,I),W(I+1,I),SC,SS) W(I+1,I) = ZERO call SROT(NCOLS-I+1,W(I,I+1),MDW,W(I+1,I+1),MDW,SC,SS) 390 CONTINUE go to 430 ! ! The triangularization is completed by giving up the Hessenberg ! form and triangularizing a rectangular matrix. ! 400 call SSWAP(MROWS,W(1,I),1,W(1,JBIG),1) call SSWAP(1,WW(I),1,WW(JBIG),1) call SSWAP(1,X(I),1,X(JBIG),1) ITEMP = IBASIS(I) IBASIS(I) = IBASIS(JBIG) IBASIS(JBIG) = ITEMP JBIG = I DO 420 J = JBIG,NSETB DO 410 I = J+1,MROWS call SROTG(W(J,J),W(I,J),SC,SS) W(I,J) = ZERO call SROT(NCOLS-J+1,W(J,J+1),MDW,W(I,J+1),MDW,SC,SS) 410 CONTINUE 420 CONTINUE ! ! See if the remaining coefficients are feasible. They should be ! because of the way MIN(ALPHA,BETA) was chosen. Any that are not ! feasible will be set to their bounds and appropriately translated. ! 430 JDROP1 = 0 JDROP2 = 0 LGOPR = 2 go to 270 ! ! Find a variable to become non-active. ! 120 if (FOUND) THEN LGOPR = 1 go to 270 end if ! ! Rescale and translate variables. ! IGOPR = 2 130 call SCOPY(NSETB,X,1,RW,1) call SCOPY(NCOLS,ZERO,0,X,1) DO 140 J = 1,NSETB JCOL = ABS(IBASIS(J)) X(JCOL) = RW(J)*ABS(SCL(JCOL)) 140 CONTINUE ! DO 150 J = 1,NCOLS if (MOD(IBB(J),2) == 0) X(J) = BU(J) - X(J) 150 CONTINUE ! DO 160 J = 1,NCOLS JCOL = IBASIS(J) if (JCOL < 0) X(-JCOL) = BL(-JCOL) + X(-JCOL) 160 CONTINUE ! DO 170 J = 1,NCOLS if (SCL(J) < ZERO) X(J) = -X(J) 170 CONTINUE ! I = MAX(NSETB,MVAL) RNORM = SNRM2(MROWS-I,W(INEXT(I),NCOLS+1),1) ! if (IGOPR == 2) MODE = NSETB return end function SCASUM (N, CX, INCX) ! !! SCASUM computes the sum of the magnitudes of the real and ... ! imaginary elements of a complex vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A3A !***TYPE COMPLEX (SASUM-S, DASUM-D, SCASUM-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, SUM OF MAGNITUDES OF A VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! CX complex vector with N elements ! INCX storage spacing between elements of CX ! ! --Output-- ! SCASUM single precision result (zero if N <= 0) ! ! Returns sums of magnitudes of real and imaginary parts of ! components of CX. Note that this is not the L1 norm of CX. ! CASUM = sum from 0 to N-1 of ABS(REAL(CX(IX+I*INCX))) + ! ABS(IMAG(CX(IX+I*INCX))), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900821 Modified to correct problem with a negative increment. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SCASUM COMPLEX CX(*) INTEGER I, INCX, IX, N !***FIRST EXECUTABLE STATEMENT SCASUM SCASUM = 0.0E0 if (N <= 0) RETURN ! if (INCX == 1) GOTO 20 ! ! Code for increment not equal to 1. ! IX = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N SCASUM = SCASUM + ABS(REAL(CX(IX))) + ABS(AIMAG(CX(IX))) IX = IX + INCX 10 CONTINUE return ! ! Code for increment equal to 1. ! 20 DO 30 I = 1,N SCASUM = SCASUM + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) 30 CONTINUE return end subroutine SCG (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, & IWORK) ! !! SCG is the Preconditioned Conjugate Gradient Sparse Ax=b Solver. ! ! Routine to solve a symmetric positive definite linear ! system Ax = b using the Preconditioned Conjugate ! Gradient method. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2B4 !***TYPE SINGLE PRECISION (SCG-S, DCG-D) !***KEYWORDS ITERATIVE PRECONDITION, SLAP, SPARSE, ! SYMMETRIC LINEAR SYSTEM !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) ! REAL P(N), DZ(N), RWORK(USER DEFINED) ! EXTERNAL MATVEC, MSOLVE ! ! call SCG(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ! $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, ! $ RWORK, IWORK ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, ! for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! ! Where N is the number of unknowns, Y is the product A*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP IA, JA, A storage for the matrix A. ! ISYM is a flag which, if non-zero, denotest that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a real array that can ! be used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Real R(N). ! Z :WORK Real Z(N). ! P :WORK Real P(N). ! DZ :WORK Real DZ(N). ! Real arrays used for workspace. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! ! *Description ! This routine does not care what matrix data structure is ! used for A and M. It simply calls the MATVEC and MSOLVE ! routines, with the arguments as described above. The user ! could write any type of structure and the appropriate MATVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK in some fashion. The SLAP ! routines SSDCG and SSICCG are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the real array A. ! In other words, for each column in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have JA(N+1) ! = NELT+1, where N is the number of columns in the matrix and ! NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SSDCG, SSICCG !***REFERENCES 1. Louis Hageman and David Young, Applied Iterative ! Methods, Academic Press, New York, 1981. ! 2. Concus, Golub and O'Leary, A Generalized Conjugate ! Gradient Method for the Numerical Solution of ! Elliptic Partial Differential Equations, in Sparse ! Matrix Computations, Bunch and Rose, Eds., Academic ! Press, New York, 1979. ! 3. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED ISSCG, R1MACH, SAXPY, SCOPY, SDOT !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) !***END PROLOGUE SCG ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), DZ(N), P(N), R(N), RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. REAL AK, AKDEN, BK, BKDEN, BKNUM, BNRM, SOLNRM, TOLMIN INTEGER I, K ! .. External Functions .. REAL R1MACH, SDOT INTEGER ISSCG EXTERNAL R1MACH, SDOT, ISSCG ! .. External Subroutines .. EXTERNAL SAXPY, SCOPY !***FIRST EXECUTABLE STATEMENT SCG ! ! Check some of the input data. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if TOLMIN = 500*R1MACH(3) if ( TOL < TOLMIN ) THEN TOL = TOLMIN IERR = 4 end if ! ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N R(I) = B(I) - R(I) 10 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! if ( ISSCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, & RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) go to 200 if ( IERR /= 0 ) RETURN ! ! ***** Iteration loop ***** ! DO 100 K=1,ITMAX ITER = K ! ! Calculate coefficient bk and direction vector p. BKNUM = SDOT(N, Z, 1, R, 1) if ( BKNUM <= 0.0E0 ) THEN IERR = 5 return ENDIF if ( ITER == 1) THEN call SCOPY(N, Z, 1, P, 1) ELSE BK = BKNUM/BKDEN DO 20 I = 1, N P(I) = Z(I) + BK*P(I) 20 CONTINUE ENDIF BKDEN = BKNUM ! ! Calculate coefficient ak, new iterate x, new residual r, ! and new pseudo-residual z. call MATVEC(N, P, Z, NELT, IA, JA, A, ISYM) AKDEN = SDOT(N, P, 1, Z, 1) if ( AKDEN <= 0.0E0 ) THEN IERR = 6 return ENDIF AK = BKNUM/AKDEN call SAXPY(N, AK, P, 1, X, 1) call SAXPY(N, -AK, Z, 1, R, 1) call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! ! check stopping criterion. if ( ISSCG(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, DZ, RWORK, & IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) go to 200 ! 100 CONTINUE ! ! ***** end of loop ***** ! ! stopping criterion not satisfied. ITER = ITMAX + 1 IERR = 2 ! 200 return end subroutine SCGN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, & MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ATP, & ATZ, DZ, ATDZ, RWORK, IWORK) ! !! SCGN is the Preconditioned CG Sparse Ax=b Solver for Normal Equations. ! ! Routine to solve a general linear system Ax = b using the ! Preconditioned Conjugate Gradient method applied to the ! normal equations AA'y = b, x=A'y. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SCGN-S, DCGN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! NORMAL EQUATIONS., SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) ! REAL P(N), ATP(N), ATZ(N), DZ(N), ATDZ(N) ! REAL RWORK(USER DEFINED) ! EXTERNAL MATVEC, MTTVEC, MSOLVE ! ! call SCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, ! $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, ! $ Z, P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, ! for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP-Column IA, JA, A storage for the matrix ! A. ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MTTVEC :EXT External. ! Name of a routine which performs the matrix transpose vector ! multiply y = A'*X given A and X (where ' denotes transpose). ! The name of the MTTVEC routine must be declared external in ! the calling program. The calling sequence to MTTVEC is the ! same as that for MATVEC, viz.: ! call MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A'*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP-Column IA, JA, A storage for the matrix ! A. ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a real array that can ! be used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Real R(N). ! Z :WORK Real Z(N). ! P :WORK Real P(N). ! ATP :WORK Real ATP(N). ! ATZ :WORK Real ATZ(N). ! DZ :WORK Real DZ(N). ! ATDZ :WORK Real ATDZ(N). ! Real arrays used for workspace. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! ! *Description: ! This routine applies the preconditioned conjugate gradient ! (PCG) method to a non-symmetric system of equations Ax=b. To ! do this the normal equations are solved: ! AA' y = b, where x = A'y. ! In PCG method the iteration count is determined by condition ! -1 ! number of the matrix (M A). In the situation where the ! normal equations are used to solve a non-symmetric system ! the condition number depends on AA' and should therefore be ! much worse than that of A. This is the conventional wisdom. ! When one has a good preconditioner for AA' this may not hold. ! The latter is the situation when SCGN should be tried. ! ! If one is trying to solve a symmetric system, SCG should be ! used instead. ! ! This routine does not care what matrix data structure is ! used for A and M. It simply calls MATVEC, MTTVEC and MSOLVE ! routines, with arguments as described above. The user could ! write any type of structure, and appropriate MATVEC, MTTVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK) in some fashion. The SLAP ! routines SSDCGN and SSLUCN are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the real array A. ! In other words, for each column in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have JA(N+1) ! = NELT+1, where N is the number of columns in the matrix and ! NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SSDCGN, SSLUCN, ISSCGN !***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED ISSCGN, R1MACH, SAXPY, SCOPY, SDOT !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC, MTTVEC and MSOLVE from ROUTINES CALLED ! list. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SCGN ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. REAL A(N), ATDZ(N), ATP(N), ATZ(N), B(N), DZ(N), P(N), R(N), & RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE, MTTVEC ! .. Local Scalars .. REAL AK, AKDEN, BK, BKDEN, BKNUM, BNRM, SOLNRM, TOLMIN INTEGER I, K ! .. External Functions .. REAL R1MACH, SDOT INTEGER ISSCGN EXTERNAL R1MACH, SDOT, ISSCGN ! .. External Subroutines .. EXTERNAL SAXPY, SCOPY !***FIRST EXECUTABLE STATEMENT SCGN ! ! Check user input. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if TOLMIN = 500*R1MACH(3) if ( TOL < TOLMIN ) THEN TOL = TOLMIN IERR = 4 end if ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N R(I) = B(I) - R(I) 10 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) call MTTVEC(N, Z, ATZ, NELT, IA, JA, A, ISYM) ! if ( ISSCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ATP, ATZ, & DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) & go to 200 if ( IERR /= 0 ) RETURN ! ! ***** iteration loop ***** ! DO 100 K=1,ITMAX ITER = K ! ! Calculate coefficient BK and direction vector P. BKNUM = SDOT(N, Z, 1, R, 1) if ( BKNUM <= 0.0E0 ) THEN IERR = 6 return ENDIF if ( ITER == 1) THEN call SCOPY(N, Z, 1, P, 1) ELSE BK = BKNUM/BKDEN DO 20 I = 1, N P(I) = Z(I) + BK*P(I) 20 CONTINUE ENDIF BKDEN = BKNUM ! ! Calculate coefficient AK, new iterate X, new residual R, ! and new pseudo-residual ATZ. if ( ITER /= 1) call SAXPY(N, BK, ATP, 1, ATZ, 1) call SCOPY(N, ATZ, 1, ATP, 1) AKDEN = SDOT(N, ATP, 1, ATP, 1) if ( AKDEN <= 0.0E0 ) THEN IERR = 6 return ENDIF AK = BKNUM/AKDEN call SAXPY(N, AK, ATP, 1, X, 1) call MATVEC(N, ATP, Z, NELT, IA, JA, A, ISYM) call SAXPY(N, -AK, Z, 1, R, 1) call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) call MTTVEC(N, Z, ATZ, NELT, IA, JA, A, ISYM) ! ! check stopping criterion. if ( ISSCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, & MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, & Z, P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, & SOLNRM) /= 0) GOTO 200 ! 100 CONTINUE ! ! ***** end of loop ***** ! ! stopping criterion not satisfied. ITER = ITMAX + 1 ! 200 return !------------- LAST LINE OF SCGN FOLLOWS ---------------------------- end subroutine SCGS (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, U, V1, & V2, RWORK, IWORK) ! !! SCGS is the Preconditioned BiConjugate Gradient Squared Ax=b Solver. ! ! Routine to solve a Non-Symmetric linear system Ax = b ! using the Preconditioned BiConjugate Gradient Squared ! method. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SCGS-S, DCGS-D) !***KEYWORDS BICONJUGATE GRADIENT, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(NELT), TOL, ERR, R(N), R0(N), P(N) ! REAL Q(N), U(N), V1(N), V2(N), RWORK(USER DEFINED) ! EXTERNAL MATVEC, MSOLVE ! ! call SCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, ! $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, ! $ R, R0, P, Q, U, V1, V2, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, ! for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! operation Y = A*X given A and X. The name of the MATVEC ! routine must be declared external in the calling program. ! The calling sequence of MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X upon ! return, X is an input vector. NELT, IA, JA, A and ISYM ! define the SLAP matrix data structure: see Description,below. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for Z ! given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine ! must be declared external in the calling program. The ! calling sequence of MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector, and Z is the solution upon return. NELT, IA, JA, A ! and ISYM define the SLAP matrix data structure: see ! Description, below. RWORK is a real array that can be used ! to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for the ! same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! This routine must calculate the residual from R = A*X - B. ! This is unnatural and hence expensive for this type of iter- ! ative method. ITOL=2 is *STRONGLY* recommended. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv time a vector is the pre- ! conditioning step. This is the *NATURAL* stopping for this ! iterative method and is *STRONGLY* recommended. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Breakdown of the method detected. ! (r0,r) approximately 0. ! IERR = 6 => Stagnation of the method detected. ! (r0,v) approximately 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Real R(N). ! R0 :WORK Real R0(N). ! P :WORK Real P(N). ! Q :WORK Real Q(N). ! U :WORK Real U(N). ! V1 :WORK Real V1(N). ! V2 :WORK Real V2(N). ! Real arrays used for workspace. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used for workspace in MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE. ! ! *Description ! This routine does not care what matrix data structure is ! used for A and M. It simply calls the MATVEC and MSOLVE ! routines, with the arguments as described above. The user ! could write any type of structure and the appropriate MATVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK in some fashion. The SLAP ! routines SSDBCG and SSLUCS are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the real array A. ! In other words, for each column in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have JA(N+1) ! = NELT+1, where N is the number of columns in the matrix and ! NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SSDCGS, SSLUCS !***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver ! for nonsymmetric linear systems, Delft University ! of Technology Report 84-16, Department of Mathe- ! matics and Informatics, Delft, The Netherlands. ! 2. E. F. Kaasschieter, The solution of non-symmetric ! linear systems by biconjugate gradients or conjugate ! gradients squared, Delft University of Technology ! Report 86-21, Department of Mathematics and Informa- ! tics, Delft, The Netherlands. ! 3. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED ISSCGS, R1MACH, SAXPY, SDOT !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SCGS ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), P(N), Q(N), R(N), R0(N), RWORK(*), U(N), & V1(N), V2(N), X(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. REAL AK, AKM, BK, BNRM, FUZZ, RHON, RHONM1, SIGMA, SOLNRM, TOLMIN INTEGER I, K ! .. External Functions .. REAL R1MACH, SDOT INTEGER ISSCGS EXTERNAL R1MACH, SDOT, ISSCGS ! .. External Subroutines .. EXTERNAL SAXPY ! .. Intrinsic Functions .. INTRINSIC ABS !***FIRST EXECUTABLE STATEMENT SCGS ! ! Check some of the input data. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if TOLMIN = 500*R1MACH(3) if ( TOL < TOLMIN ) THEN TOL = TOLMIN IERR = 4 end if ! ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N V1(I) = R(I) - B(I) 10 CONTINUE call MSOLVE(N, V1, R, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! if ( ISSCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, & U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) & go to 200 if ( IERR /= 0 ) RETURN ! ! Set initial values. ! FUZZ = R1MACH(3)**2 DO 20 I = 1, N R0(I) = R(I) 20 CONTINUE RHONM1 = 1 ! ! ***** ITERATION LOOP ***** ! DO 100 K=1,ITMAX ITER = K ! ! Calculate coefficient BK and direction vectors U, V and P. RHON = SDOT(N, R0, 1, R, 1) if ( ABS(RHONM1) < FUZZ ) GOTO 998 BK = RHON/RHONM1 if ( ITER == 1 ) THEN DO 30 I = 1, N U(I) = R(I) P(I) = R(I) 30 CONTINUE ELSE DO 40 I = 1, N U(I) = R(I) + BK*Q(I) V1(I) = Q(I) + BK*P(I) 40 CONTINUE DO 50 I = 1, N P(I) = U(I) + BK*V1(I) 50 CONTINUE ENDIF ! ! Calculate coefficient AK, new iterate X, Q call MATVEC(N, P, V2, NELT, IA, JA, A, ISYM) call MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK) SIGMA = SDOT(N, R0, 1, V1, 1) if ( ABS(SIGMA) < FUZZ ) GOTO 999 AK = RHON/SIGMA AKM = -AK DO 60 I = 1, N Q(I) = U(I) + AKM*V1(I) 60 CONTINUE DO 70 I = 1, N V1(I) = U(I) + Q(I) 70 CONTINUE ! X = X - ak*V1. call SAXPY( N, AKM, V1, 1, X, 1 ) ! -1 ! R = R - ak*M *A*V1 call MATVEC(N, V1, V2, NELT, IA, JA, A, ISYM) call MSOLVE(N, V2, V1, NELT, IA, JA, A, ISYM, RWORK, IWORK) call SAXPY( N, AKM, V1, 1, R, 1 ) ! ! check stopping criterion. if ( ISSCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, R0, P, Q, & U, V1, V2, RWORK, IWORK, AK, BK, BNRM, SOLNRM) /= 0 ) & go to 200 ! ! Update RHO. RHONM1 = RHON 100 CONTINUE ! ! ***** end of loop ***** ! Stopping criterion not satisfied. ITER = ITMAX + 1 IERR = 2 200 return ! ! Breakdown of method detected. 998 IERR = 5 return ! ! Stagnation of method detected. 999 IERR = 6 return !------------- LAST LINE OF SCGS FOLLOWS ---------------------------- end subroutine SCHDC (A, LDA, P, WORK, JPVT, JOB, INFO) ! !! SCHDC computes the Cholesky decomposition of a positive definite matrix. ! ! A pivoting option allows the user to estimate the ! condition number of a positive definite matrix or determine ! the rank of a positive semidefinite matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE SINGLE PRECISION (SCHDC-S, DCHDC-D, CCHDC-C) !***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, ! POSITIVE DEFINITE !***AUTHOR Dongarra, J., (ANL) ! Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! SCHDC computes the Cholesky decomposition of a positive definite ! matrix. A pivoting option allows the user to estimate the ! condition of a positive definite matrix or determine the rank ! of a positive semidefinite matrix. ! ! On Entry ! ! A REAL(LDA,P). ! A contains the matrix whose decomposition is to ! be computed. Only the upper half of A need be stored. ! The lower part of the array A is not referenced. ! ! LDA INTEGER. ! LDA is the leading dimension of the array A. ! ! P INTEGER. ! P is the order of the matrix. ! ! WORK REAL. ! WORK is a work array. ! ! JPVT INTEGER(P). ! JPVT contains integers that control the selection ! of the pivot elements, if pivoting has been requested. ! Each diagonal element A(K,K) ! is placed in one of three classes according to the ! value of JPVT(K). ! ! If JPVT(K) > 0, then X(K) is an initial ! element. ! ! If JPVT(K) == 0, then X(K) is a free element. ! ! If JPVT(K) < 0, then X(K) is a final element. ! ! Before the decomposition is computed, initial elements ! are moved by symmetric row and column interchanges to ! the beginning of the array A and final ! elements to the end. Both initial and final elements ! are frozen in place during the computation and only ! free elements are moved. At the K-th stage of the ! reduction, if A(K,K) is occupied by a free element ! it is interchanged with the largest free element ! A(L,L) with L >= K. JPVT is not referenced if ! JOB == 0. ! ! JOB INTEGER. ! JOB is an integer that initiates column pivoting. ! If JOB == 0, no pivoting is done. ! If JOB /= 0, pivoting is done. ! ! On Return ! ! A A contains in its upper half the Cholesky factor ! of the matrix A as it has been permuted by pivoting. ! ! JPVT JPVT(J) contains the index of the diagonal element ! of a that was moved into the J-th position, ! provided pivoting was requested. ! ! INFO contains the index of the last positive diagonal ! element of the Cholesky factor. ! ! For positive definite matrices INFO = P is the normal return. ! For pivoting with positive semidefinite matrices INFO will ! in general be less than P. However, INFO may be greater than ! the rank of A, since rounding error can cause an otherwise zero ! element to be positive. Indefinite systems will always cause ! INFO to be less than P. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SSWAP !***REVISION HISTORY (YYMMDD) ! 790319 DATE WRITTEN ! 890313 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SCHDC INTEGER LDA,P,JPVT(*),JOB,INFO REAL A(LDA,*),WORK(*) ! INTEGER PU,PL,PLP1,J,JP,JT,K,KB,KM1,KP1,L,MAXL REAL TEMP REAL MAXDIA LOGICAL SWAPK,NEGK !***FIRST EXECUTABLE STATEMENT SCHDC PL = 1 PU = 0 INFO = P if (JOB == 0) go to 160 ! ! PIVOTING HAS BEEN REQUESTED. REARRANGE THE ! THE ELEMENTS ACCORDING TO JPVT. ! DO 70 K = 1, P SWAPK = JPVT(K) > 0 NEGK = JPVT(K) < 0 JPVT(K) = K if (NEGK) JPVT(K) = -JPVT(K) if (.NOT.SWAPK) go to 60 if (K == PL) go to 50 call SSWAP(PL-1,A(1,K),1,A(1,PL),1) TEMP = A(K,K) A(K,K) = A(PL,PL) A(PL,PL) = TEMP PLP1 = PL + 1 if (P < PLP1) go to 40 DO 30 J = PLP1, P if (J >= K) go to 10 TEMP = A(PL,J) A(PL,J) = A(J,K) A(J,K) = TEMP go to 20 10 CONTINUE if (J == K) go to 20 TEMP = A(K,J) A(K,J) = A(PL,J) A(PL,J) = TEMP 20 CONTINUE 30 CONTINUE 40 CONTINUE JPVT(K) = JPVT(PL) JPVT(PL) = K 50 CONTINUE PL = PL + 1 60 CONTINUE 70 CONTINUE PU = P if (P < PL) go to 150 DO 140 KB = PL, P K = P - KB + PL if (JPVT(K) >= 0) go to 130 JPVT(K) = -JPVT(K) if (PU == K) go to 120 call SSWAP(K-1,A(1,K),1,A(1,PU),1) TEMP = A(K,K) A(K,K) = A(PU,PU) A(PU,PU) = TEMP KP1 = K + 1 if (P < KP1) go to 110 DO 100 J = KP1, P if (J >= PU) go to 80 TEMP = A(K,J) A(K,J) = A(J,PU) A(J,PU) = TEMP go to 90 80 CONTINUE if (J == PU) go to 90 TEMP = A(K,J) A(K,J) = A(PU,J) A(PU,J) = TEMP 90 CONTINUE 100 CONTINUE 110 CONTINUE JT = JPVT(K) JPVT(K) = JPVT(PU) JPVT(PU) = JT 120 CONTINUE PU = PU - 1 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE DO 270 K = 1, P ! ! REDUCTION LOOP. ! MAXDIA = A(K,K) KP1 = K + 1 MAXL = K ! ! DETERMINE THE PIVOT ELEMENT. ! if (K < PL .OR. K >= PU) go to 190 DO 180 L = KP1, PU if (A(L,L) <= MAXDIA) go to 170 MAXDIA = A(L,L) MAXL = L 170 CONTINUE 180 CONTINUE 190 CONTINUE ! ! QUIT if THE PIVOT ELEMENT IS NOT POSITIVE. ! if (MAXDIA > 0.0E0) go to 200 INFO = K - 1 go to 280 200 CONTINUE if (K == MAXL) go to 210 ! ! START THE PIVOTING AND UPDATE JPVT. ! KM1 = K - 1 call SSWAP(KM1,A(1,K),1,A(1,MAXL),1) A(MAXL,MAXL) = A(K,K) A(K,K) = MAXDIA JP = JPVT(MAXL) JPVT(MAXL) = JPVT(K) JPVT(K) = JP 210 CONTINUE ! ! REDUCTION STEP. PIVOTING IS CONTAINED ACROSS THE ROWS. ! WORK(K) = SQRT(A(K,K)) A(K,K) = WORK(K) if (P < KP1) go to 260 DO 250 J = KP1, P if (K == MAXL) go to 240 if (J >= MAXL) go to 220 TEMP = A(K,J) A(K,J) = A(J,MAXL) A(J,MAXL) = TEMP go to 230 220 CONTINUE if (J == MAXL) go to 230 TEMP = A(K,J) A(K,J) = A(MAXL,J) A(MAXL,J) = TEMP 230 CONTINUE 240 CONTINUE A(K,J) = A(K,J)/WORK(K) WORK(J) = A(K,J) TEMP = -A(K,J) call SAXPY(J-K,TEMP,WORK(KP1),1,A(KP1,J),1) 250 CONTINUE 260 CONTINUE 270 CONTINUE 280 CONTINUE return end subroutine SCHDD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S, INFO) ! !! SCHDD downdates an augmented Cholesky decomposition or the ... ! triangular factor of an augmented QR decomposition. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D7B !***TYPE SINGLE PRECISION (SCHDD-S, DCHDD-D, CCHDD-C) !***KEYWORDS CHOLESKY DECOMPOSITION, DOWNDATE, LINEAR ALGEBRA, LINPACK, ! MATRIX !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! SCHDD downdates an augmented Cholesky decomposition or the ! triangular factor of an augmented QR decomposition. ! Specifically, given an upper triangular matrix R of order P, a ! row vector X, a column vector Z, and a scalar Y, SCHDD ! determines an orthogonal matrix U and a scalar ZETA such that ! ! (R Z ) (RR ZZ) ! U * ( ) = ( ) , ! (0 ZETA) ( X Y) ! ! where RR is upper triangular. If R and Z have been obtained ! from the factorization of a least squares problem, then ! RR and ZZ are the factors corresponding to the problem ! with the observation (X,Y) removed. In this case, if RHO ! is the norm of the residual vector, then the norm of ! the residual vector of the downdated problem is ! SQRT(RHO**2 - ZETA**2). SCHDD will simultaneously downdate ! several triplets (Z,Y,RHO) along with R. ! For a less terse description of what SCHDD does and how ! it may be applied, see the LINPACK guide. ! ! The matrix U is determined as the product U(1)*...*U(P) ! where U(I) is a rotation in the (P+1,I)-plane of the ! form ! ! ( C(I) -S(I) ) ! ( ) . ! ( S(I) C(I) ) ! ! The rotations are chosen so that C(I) is real. ! ! The user is warned that a given downdating problem may ! be impossible to accomplish or may produce ! inaccurate results. For example, this can happen ! if X is near a vector whose removal will reduce the ! rank of R. Beware. ! ! On Entry ! ! R REAL(LDR,P), where LDR >= P. ! R contains the upper triangular matrix ! that is to be downdated. The part of R ! below the diagonal is not referenced. ! ! LDR INTEGER. ! LDR is the leading dimension of the array R. ! ! P INTEGER. ! P is the order of the matrix R. ! ! X REAL(P). ! X contains the row vector that is to ! be removed from R. X is not altered by SCHDD. ! ! Z REAL(LDZ,NZ), where LDZ >= P. ! Z is an array of NZ P-vectors which ! are to be downdated along with R. ! ! LDZ INTEGER. ! LDZ is the leading dimension of the array Z. ! ! NZ INTEGER. ! NZ is the number of vectors to be downdated ! NZ may be zero, in which case Z, Y, and RHO ! are not referenced. ! ! Y REAL(NZ). ! Y contains the scalars for the downdating ! of the vectors Z. Y is not altered by SCHDD. ! ! RHO REAL(NZ). ! RHO contains the norms of the residual ! vectors that are to be downdated. ! ! On Return ! ! R ! Z contain the downdated quantities. ! RHO ! ! C REAL(P). ! C contains the cosines of the transforming ! rotations. ! ! S REAL(P). ! S contains the sines of the transforming ! rotations. ! ! INFO INTEGER. ! INFO is set as follows. ! ! INFO = 0 if the entire downdating ! was successful. ! ! INFO =-1 if R could not be downdated. ! In this case, all quantities ! are left unaltered. ! ! INFO = 1 if some RHO could not be ! downdated. The offending RHOs are ! set to -1. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SDOT, SNRM2 !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SCHDD INTEGER LDR,P,LDZ,NZ,INFO REAL R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) REAL RHO(*),C(*) ! INTEGER I,II,J REAL A,ALPHA,AZETA,NORM,SNRM2 REAL SDOT,T,ZETA,B,XX ! ! SOLVE THE SYSTEM TRANS(R)*A = X, PLACING THE RESULT ! IN THE ARRAY S. ! !***FIRST EXECUTABLE STATEMENT SCHDD INFO = 0 S(1) = X(1)/R(1,1) if (P < 2) go to 20 DO 10 J = 2, P S(J) = X(J) - SDOT(J-1,R(1,J),1,S,1) S(J) = S(J)/R(J,J) 10 CONTINUE 20 CONTINUE NORM = SNRM2(P,S,1) if (NORM < 1.0E0) go to 30 INFO = -1 go to 120 30 CONTINUE ALPHA = SQRT(1.0E0-NORM**2) ! ! DETERMINE THE TRANSFORMATIONS. ! DO 40 II = 1, P I = P - II + 1 SCALE = ALPHA + ABS(S(I)) A = ALPHA/SCALE B = S(I)/SCALE NORM = SQRT(A**2+B**2) C(I) = A/NORM S(I) = B/NORM ALPHA = SCALE*NORM 40 CONTINUE ! ! APPLY THE TRANSFORMATIONS TO R. ! DO 60 J = 1, P XX = 0.0E0 DO 50 II = 1, J I = J - II + 1 T = C(I)*XX + S(I)*R(I,J) R(I,J) = C(I)*R(I,J) - S(I)*XX XX = T 50 CONTINUE 60 CONTINUE ! ! if REQUIRED, DOWNDATE Z AND RHO. ! if (NZ < 1) go to 110 DO 100 J = 1, NZ ZETA = Y(J) DO 70 I = 1, P Z(I,J) = (Z(I,J) - S(I)*ZETA)/C(I) ZETA = C(I)*ZETA - S(I)*Z(I,J) 70 CONTINUE AZETA = ABS(ZETA) if (AZETA <= RHO(J)) go to 80 INFO = 1 RHO(J) = -1.0E0 go to 90 80 CONTINUE RHO(J) = RHO(J)*SQRT(1.0E0-(AZETA/RHO(J))**2) 90 CONTINUE 100 CONTINUE 110 CONTINUE 120 CONTINUE return end subroutine SCHEX (R, LDR, P, K, L, Z, LDZ, NZ, C, S, JOB) ! !! SCHEX updates the Cholesky factorization A=TRANS(R)*R of a positive ... ! definite matrix A of order P under diagonal ! permutations of the form TRANS(E)*A*E, where E is a ! permutation matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D7B !***TYPE SINGLE PRECISION (SCHEX-S, DCHEX-D, CCHEX-C) !***KEYWORDS CHOLESKY DECOMPOSITION, EXCHANGE, LINEAR ALGEBRA, LINPACK, ! MATRIX, POSITIVE DEFINITE !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! SCHEX updates the Cholesky factorization ! ! A = TRANS(R)*R ! ! of a positive definite matrix A of order P under diagonal ! permutations of the form ! ! TRANS(E)*A*E ! ! where E is a permutation matrix. Specifically, given ! an upper triangular matrix R and a permutation matrix ! E (which is specified by K, L, and JOB), SCHEX determines ! an orthogonal matrix U such that ! ! U*R*E = RR, ! ! where RR is upper triangular. At the users option, the ! transformation U will be multiplied into the array Z. ! If A = TRANS(X)*X, so that R is the triangular part of the ! QR factorization of X, then RR is the triangular part of the ! QR factorization of X*E, i.e., X with its columns permuted. ! For a less terse description of what SCHEX does and how ! it may be applied, see the LINPACK guide. ! ! The matrix Q is determined as the product U(L-K)*...*U(1) ! of plane rotations of the form ! ! ( C(I) S(I) ) ! ( ) , ! ( -S(I) C(I) ) ! ! where C(I) is real. The rows these rotations operate on ! are described below. ! ! There are two types of permutations, which are determined ! by the value of JOB. ! ! 1. Right circular shift (JOB = 1). ! ! The columns are rearranged in the following order. ! ! 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. ! ! U is the product of L-K rotations U(I), where U(I) ! acts in the (L-I,L-I+1)-plane. ! ! 2. Left circular shift (JOB = 2). ! The columns are rearranged in the following order ! ! 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. ! ! U is the product of L-K rotations U(I), where U(I) ! acts in the (K+I-1,K+I)-plane. ! ! On Entry ! ! R REAL(LDR,P), where LDR >= P. ! R contains the upper triangular factor ! that is to be updated. Elements of R ! below the diagonal are not referenced. ! ! LDR INTEGER. ! LDR is the leading dimension of the array R. ! ! P INTEGER. ! P is the order of the matrix R. ! ! K INTEGER. ! K is the first column to be permuted. ! ! L INTEGER. ! L is the last column to be permuted. ! L must be strictly greater than K. ! ! Z REAL(LDZ,NZ), where LDZ >= P. ! Z is an array of NZ P-vectors into which the ! transformation U is multiplied. Z is ! not referenced if NZ = 0. ! ! LDZ INTEGER. ! LDZ is the leading dimension of the array Z. ! ! NZ INTEGER. ! NZ is the number of columns of the matrix Z. ! ! JOB INTEGER. ! JOB determines the type of permutation. ! JOB = 1 right circular shift. ! JOB = 2 left circular shift. ! ! On Return ! ! R contains the updated factor. ! ! Z contains the updated matrix Z. ! ! C REAL(P). ! C contains the cosines of the transforming rotations. ! ! S REAL(P). ! S contains the sines of the transforming rotations. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SROTG !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SCHEX INTEGER LDR,P,K,L,LDZ,NZ,JOB REAL R(LDR,*),Z(LDZ,*),S(*) REAL C(*) ! INTEGER I,II,IL,IU,J,JJ,KM1,KP1,LMK,LM1 REAL T ! ! INITIALIZE ! !***FIRST EXECUTABLE STATEMENT SCHEX KM1 = K - 1 KP1 = K + 1 LMK = L - K LM1 = L - 1 ! ! PERFORM THE APPROPRIATE TASK. ! go to (10,130), JOB ! ! RIGHT CIRCULAR SHIFT. ! 10 CONTINUE ! ! REORDER THE COLUMNS. ! DO 20 I = 1, L II = L - I + 1 S(I) = R(II,L) 20 CONTINUE DO 40 JJ = K, LM1 J = LM1 - JJ + K DO 30 I = 1, J R(I,J+1) = R(I,J) 30 CONTINUE R(J+1,J+1) = 0.0E0 40 CONTINUE if (K == 1) go to 60 DO 50 I = 1, KM1 II = L - I + 1 R(I,K) = S(II) 50 CONTINUE 60 CONTINUE ! ! CALCULATE THE ROTATIONS. ! T = S(1) DO 70 I = 1, LMK call SROTG(S(I+1),T,C(I),S(I)) T = S(I+1) 70 CONTINUE R(K,K) = T DO 90 J = KP1, P IL = MAX(1,L-J+1) DO 80 II = IL, LMK I = L - II T = C(II)*R(I,J) + S(II)*R(I+1,J) R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) R(I,J) = T 80 CONTINUE 90 CONTINUE ! ! if REQUIRED, APPLY THE TRANSFORMATIONS TO Z. ! if (NZ < 1) go to 120 DO 110 J = 1, NZ DO 100 II = 1, LMK I = L - II T = C(II)*Z(I,J) + S(II)*Z(I+1,J) Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) Z(I,J) = T 100 CONTINUE 110 CONTINUE 120 CONTINUE go to 260 ! ! LEFT CIRCULAR SHIFT ! 130 CONTINUE ! ! REORDER THE COLUMNS ! DO 140 I = 1, K II = LMK + I S(II) = R(I,K) 140 CONTINUE DO 160 J = K, LM1 DO 150 I = 1, J R(I,J) = R(I,J+1) 150 CONTINUE JJ = J - KM1 S(JJ) = R(J+1,J+1) 160 CONTINUE DO 170 I = 1, K II = LMK + I R(I,L) = S(II) 170 CONTINUE DO 180 I = KP1, L R(I,L) = 0.0E0 180 CONTINUE ! ! REDUCTION LOOP. ! DO 220 J = K, P if (J == K) go to 200 ! ! APPLY THE ROTATIONS. ! IU = MIN(J-1,L-1) DO 190 I = K, IU II = I - K + 1 T = C(II)*R(I,J) + S(II)*R(I+1,J) R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) R(I,J) = T 190 CONTINUE 200 CONTINUE if (J >= L) go to 210 JJ = J - K + 1 T = S(JJ) call SROTG(R(J,J),T,C(JJ),S(JJ)) 210 CONTINUE 220 CONTINUE ! ! APPLY THE ROTATIONS TO Z. ! if (NZ < 1) go to 250 DO 240 J = 1, NZ DO 230 I = K, LM1 II = I - KM1 T = C(II)*Z(I,J) + S(II)*Z(I+1,J) Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) Z(I,J) = T 230 CONTINUE 240 CONTINUE 250 CONTINUE 260 CONTINUE return end subroutine SCHKW (NAME, LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR) ! !! SCHKW is the SLAP WORK/IWORK Array Bounds Checker. ! ! This routine checks the work array lengths and interfaces ! to the SLATEC error handler if a problem is found. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY R2 !***TYPE SINGLE PRECISION (SCHKW-S, DCHKW-D) !***KEYWORDS ERROR CHECKING, SLAP, WORKSPACE CHECKING !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! CHARACTER*(*) NAME ! INTEGER LOCIW, LENIW, LOCW, LENW, IERR, ITER ! REAL ERR ! ! call SCHKW( NAME, LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) ! ! *Arguments: ! NAME :IN Character*(*). ! Name of the calling routine. This is used in the output ! message, if an error is detected. ! LOCIW :IN Integer. ! Location of the first free element in the integer workspace ! array. ! LENIW :IN Integer. ! Length of the integer workspace array. ! LOCW :IN Integer. ! Location of the first free element in the real workspace ! array. ! LENRW :IN Integer. ! Length of the real workspace array. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient storage allocated for ! WORK or IWORK. ! ITER :OUT Integer. ! Set to zero on return. ! ERR :OUT Real. ! Set to the smallest positive magnitude if all went well. ! Set to a very large number if an error is detected. ! !***REFERENCES (NONE) !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 880225 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 900805 Changed XERRWV calls to calls to XERMSG. (RWC) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Corrected XERMSG calls to satisfy Section 6.2.2 of ANSI ! X3.9-1978. (FNF) ! 910506 Made subsidiary. (FNF) ! 920511 Added complete declaration section. (WRB) ! 921015 Added code to initialize ITER and ERR when IERR=0. (FNF) !***END PROLOGUE SCHKW ! .. Scalar Arguments .. REAL ERR INTEGER IERR, ITER, LENIW, LENW, LOCIW, LOCW CHARACTER NAME*(*) ! .. Local Scalars .. CHARACTER XERN1*8, XERN2*8, XERNAM*8 ! .. External Functions .. REAL R1MACH EXTERNAL R1MACH ! .. External Subroutines .. EXTERNAL XERMSG !***FIRST EXECUTABLE STATEMENT SCHKW ! ! Check the Integer workspace situation. ! IERR = 0 ITER = 0 ERR = R1MACH(1) if ( LOCIW > LENIW ) THEN IERR = 1 ERR = R1MACH(2) XERNAM = NAME WRITE (XERN1, '(I8)') LOCIW WRITE (XERN2, '(I8)') LENIW call XERMSG ('SLATEC', 'SCHKW', & 'In ' // XERNAM // ', INTEGER work array too short. ' // & 'IWORK needs ' // XERN1 // '; have allocated ' // XERN2, & 1, 1) end if ! ! Check the Real workspace situation. if ( LOCW > LENW ) THEN IERR = 1 ERR = R1MACH(2) XERNAM = NAME WRITE (XERN1, '(I8)') LOCW WRITE (XERN2, '(I8)') LENW call XERMSG ('SLATEC', 'SCHKW', & 'In ' // XERNAM // ', REAL work array too short. ' // & 'RWORK needs ' // XERN1 // '; have allocated ' // XERN2, & 1, 1) end if return !------------- LAST LINE OF SCHKW FOLLOWS ---------------------------- end subroutine SCHUD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S) ! !! SCHUD updates an augmented Cholesky decomposition of the triangular part ... ! of an augmented QR decomposition. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D7B !***TYPE SINGLE PRECISION (SCHUD-S, DCHUD-D, CCHUD-C) !***KEYWORDS CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX, ! UPDATE !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! SCHUD updates an augmented Cholesky decomposition of the ! triangular part of an augmented QR decomposition. Specifically, ! given an upper triangular matrix R of order P, a row vector ! X, a column vector Z, and a scalar Y, SCHUD determines a ! unitary matrix U and a scalar ZETA such that ! ! ! (R Z) (RR ZZ ) ! U * ( ) = ( ) , ! (X Y) ( 0 ZETA) ! ! where RR is upper triangular. If R and Z have been ! obtained from the factorization of a least squares ! problem, then RR and ZZ are the factors corresponding to ! the problem with the observation (X,Y) appended. In this ! case, if RHO is the norm of the residual vector, then the ! norm of the residual vector of the updated problem is ! SQRT(RHO**2 + ZETA**2). SCHUD will simultaneously update ! several triplets (Z,Y,RHO). ! For a less terse description of what SCHUD does and how ! it may be applied, see the LINPACK guide. ! ! The matrix U is determined as the product U(P)*...*U(1), ! where U(I) is a rotation in the (I,P+1) plane of the ! form ! ! ( C(I) S(I) ) ! ( ) . ! ( -S(I) C(I) ) ! ! The rotations are chosen so that C(I) is real. ! ! On Entry ! ! R REAL(LDR,P), where LDR >= P. ! R contains the upper triangular matrix ! that is to be updated. The part of R ! below the diagonal is not referenced. ! ! LDR INTEGER. ! LDR is the leading dimension of the array R. ! ! P INTEGER. ! P is the order of the matrix R. ! ! X REAL(P). ! X contains the row to be added to R. X is ! not altered by SCHUD. ! ! Z REAL(LDZ,NZ), where LDZ >= P. ! Z is an array containing NZ P-vectors to ! be updated with R. ! ! LDZ INTEGER. ! LDZ is the leading dimension of the array Z. ! ! NZ INTEGER. ! NZ is the number of vectors to be updated. ! NZ may be zero, in which case Z, Y, and RHO ! are not referenced. ! ! Y REAL(NZ). ! Y contains the scalars for updating the vectors ! Z. Y is not altered by SCHUD. ! ! RHO REAL(NZ). ! RHO contains the norms of the residual ! vectors that are to be updated. If RHO(J) ! is negative, it is left unaltered. ! ! On Return ! ! RC ! RHO contain the updated quantities. ! Z ! ! C REAL(P). ! C contains the cosines of the transforming ! rotations. ! ! S REAL(P). ! S contains the sines of the transforming ! rotations. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SROTG !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SCHUD INTEGER LDR,P,LDZ,NZ REAL RHO(*),C(*) REAL R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*) ! INTEGER I,J,JM1 REAL AZETA,SCALE REAL T,XJ,ZETA ! ! UPDATE R. ! !***FIRST EXECUTABLE STATEMENT SCHUD DO 30 J = 1, P XJ = X(J) ! ! APPLY THE PREVIOUS ROTATIONS. ! JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 T = C(I)*R(I,J) + S(I)*XJ XJ = C(I)*XJ - S(I)*R(I,J) R(I,J) = T 10 CONTINUE 20 CONTINUE ! ! COMPUTE THE NEXT ROTATION. ! call SROTG(R(J,J),XJ,C(J),S(J)) 30 CONTINUE ! ! if REQUIRED, UPDATE Z AND RHO. ! if (NZ < 1) go to 70 DO 60 J = 1, NZ ZETA = Y(J) DO 40 I = 1, P T = C(I)*Z(I,J) + S(I)*ZETA ZETA = C(I)*ZETA - S(I)*Z(I,J) Z(I,J) = T 40 CONTINUE AZETA = ABS(ZETA) if (AZETA == 0.0E0 .OR. RHO(J) < 0.0E0) go to 50 SCALE = AZETA + RHO(J) RHO(J) = SCALE*SQRT((AZETA/SCALE)**2+(RHO(J)/SCALE)**2) 50 CONTINUE 60 CONTINUE 70 CONTINUE return end subroutine SCLOSM (IPAGE) ! !! SCLOSM is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE ALL (SCLOSM-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! 1. UNLOAD, RELEASE, OR CLOSE UNIT NUMBER IPAGEF. ! !***SEE ALSO SPLP !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890605 Corrected references to XERRWV. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE SCLOSM CHARACTER*8 XERN1 ! !***FIRST EXECUTABLE STATEMENT SCLOSM IPAGEF=IPAGE CLOSE(UNIT=IPAGEF,IOSTAT=IOS,ERR=100,STATUS='KEEP') return ! 100 WRITE (XERN1, '(I8)') IOS call XERMSG ('SLATEC', 'SCLOSM', & 'IN SPLP, CLOSE HAS ERROR FLAG = ' // XERN1, 100, 1) return end function scnrm2 ( n, x, incx ) !******************************************************************************* ! !! SCNRM2 returns the euclidean norm of a complex vector. ! ! Discussion: ! ! SCNRM2 := sqrt ( sum ( conjg ( x(1:n) ) * x(1:n) ) ) ! = sqrt ( dot_product ( x(1:n), x(1:n) ) ) ! ! Reference: ! ! Lawson, Hanson, Kincaid and Krogh, ! Basic Linear Algebra Subprograms for FORTRAN usage, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, pages 308-323, 1979. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, complex X(*), the vector. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Output, real SCNRM2, the norm of the vector. ! implicit none integer incx integer ix integer n real norm real, parameter :: one = 1.0E+00 real scale real scnrm2 real ssq real temp complex x(*) real, parameter :: zero = 0.0E+00 if ( n < 1 .or. incx < 1 ) then norm = zero else scale = zero ssq = one do ix = 1, 1 + ( n - 1 ) * incx, incx if ( real ( x(ix) ) /= zero ) then temp = abs ( real( x(ix) ) ) if ( scale < temp ) then ssq = one + ssq * ( scale / temp )**2 scale = temp else ssq = ssq + ( temp / scale )**2 end if end if if ( aimag ( x(ix) ) /= zero ) then temp = abs ( aimag ( x(ix) ) ) if ( scale < temp ) then ssq = one + ssq * ( scale / temp )**2 scale = temp else ssq = ssq + ( temp / scale )**2 end if end if end do norm = scale * sqrt ( ssq ) end if scnrm2 = norm return end subroutine SCOEF (YH, YP, NCOMP, NROWB, NFC, NIC, B, BETA, COEF, & INHOMO, RE, AE, BY, CVEC, WORK, IWORK, IFLAG, NFCC) ! !! SCOEF is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SCOEF-S, DCOEF-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! INPUT TO SCOEF ! ********************************************************************** ! ! YH = Matrix of homogeneous solutions. ! YP = Vector containing particular solution. ! NCOMP = Number of components per solution vector. ! NROWB = First dimension of B in calling program. ! NFC = Number of base solution vectors. ! NFCC = 2*NFC for the special treatment of complex valued ! equations. Otherwise, NFCC=NFC. ! NIC = Number of specified initial conditions. ! B = Boundary condition matrix at X = Xfinal. ! BETA = Vector of nonhomogeneous boundary conditions at X = Xfinal. ! 1 - Nonzero particular solution ! INHOMO = 2 - Zero particular solution ! 3 - Eigenvalue problem ! RE = Relative error tolerance ! AE = Absolute error tolerance ! BY = Storage space for the matrix B*YH ! CVEC = Storage space for the vector BETA-B*YP ! WORK = Real array of internal storage. Dimension must be >= ! NFCC*(NFCC+4) ! IWORK = Integer array of internal storage. Dimension must be >= ! 3+NFCC ! ! ********************************************************************** ! OUTPUT FROM SCOEF ! ********************************************************************** ! ! COEF = Array containing superposition constants. ! IFLAG = Indicator of success from SUDS in solving the ! boundary equations ! = 0 Boundary equations are solved ! = 1 Boundary equations appear to have many solutions ! = 2 Boundary equations appear to be inconsistent ! = 3 For this value of an eigenparameter, the boundary ! equations have only the zero solution. ! ! ********************************************************************** ! ! Subroutine SCOEF solves for the superposition constants from the ! linear equations defined by the boundary conditions at X = Xfinal. ! ! B*YP + B*YH*COEF = BETA ! ! ********************************************************************** ! !***SEE ALSO BVSUP !***ROUTINES CALLED SDOT, SUDS, XGETF, XSETF !***COMMON BLOCKS ML5MCO !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE SCOEF ! DIMENSION YH(NCOMP,*),YP(*),B(NROWB,*),BETA(*), & COEF(*),BY(NFCC,*),CVEC(*),WORK(*),IWORK(*) ! COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR ! ! SET UP MATRIX B*YH AND VECTOR BETA - B*YP ! !***FIRST EXECUTABLE STATEMENT SCOEF NCOMP2=NCOMP/2 DO 7 K = 1,NFCC DO 1 J = 1,NFC L=J if (NFC /= NFCC) L=2*J-1 1 BY(K,L) = SDOT(NCOMP,B(K,1),NROWB,YH(1,J),1) if (NFC == NFCC) go to 3 DO 2 J=1,NFC L=2*J BYKL=SDOT(NCOMP2,B(K,1),NROWB,YH(NCOMP2+1,J),1) BY(K,L)=SDOT(NCOMP2,B(K,NCOMP2+1),NROWB,YH(1,J),1) - BYKL 2 CONTINUE 3 go to (4,5,6), INHOMO ! CASE 1 4 CVEC(K) = BETA(K) - SDOT(NCOMP,B(K,1),NROWB,YP,1) go to 7 ! CASE 2 5 CVEC(K) = BETA(K) go to 7 ! CASE 3 6 CVEC(K) = 0. 7 CONTINUE CONS=ABS(CVEC(1)) BYS=ABS(BY(1,1)) ! ! ********************************************************************** ! SOLVE LINEAR SYSTEM ! IFLAG=0 MLSO=0 if (INHOMO == 3) MLSO=1 KFLAG = 0.5 * LOG10(EPS) call XGETF(NF) call XSETF(0) 10 call SUDS(BY,COEF,CVEC,NFCC,NFCC,NFCC,KFLAG,MLSO,WORK,IWORK) if (KFLAG /= 3) go to 13 KFLAG=1 IFLAG=1 go to 10 13 if (KFLAG == 4) IFLAG=2 call XSETF(NF) if (NFCC == 1) go to 25 if (INHOMO /= 3) RETURN if (IWORK(1) < NFCC) go to 17 IFLAG=3 DO 14 K=1,NFCC 14 COEF(K)=0. COEF(NFCC)=1. NFCCM1=NFCC-1 DO 15 K=1,NFCCM1 J=NFCC-K L=NFCC-J+1 GAM=SDOT(L,BY(J,J),NFCC,COEF(J),1)/(WORK(J)*BY(J,J)) DO 15 I=J,NFCC 15 COEF(I)=COEF(I)+GAM*BY(J,I) return 17 DO 20 K=1,NFCC KI=4*NFCC+K 20 COEF(K)=WORK(KI) return ! ! ********************************************************************** ! TESTING FOR EXISTENCE AND UNIQUENESS OF BOUNDARY-VALUE PROBLEM ! SOLUTION IN A SCALAR CASE ! 25 BN = 0. UN = 0. YPN=0. DO 30 K = 1,NCOMP UN = MAX(UN,ABS(YH(K,1))) YPN=MAX(YPN,ABS(YP(K))) 30 BN = MAX(BN,ABS(B(1,K))) BBN = MAX(BN,ABS(BETA(1))) if (BYS > 10.*(RE*UN + AE)*BN) go to 35 BRN = BBN / BN * BYS if (CONS >= 0.1*BRN .AND. CONS <= 10.*BRN) IFLAG=1 if (CONS > 10.*BRN) IFLAG=2 if (CONS <= RE*ABS(BETA(1))+AE + (RE*YPN+AE)*BN) IFLAG=1 if (INHOMO == 3) COEF(1)=1. return 35 if (INHOMO /= 3) RETURN IFLAG=3 COEF(1)=1. return end subroutine SCOPY (N, SX, INCX, SY, INCY) ! !! SCOPY copies a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A5 !***TYPE SINGLE PRECISION (SCOPY-S, DCOPY-D, CCOPY-C, ICOPY-I) !***KEYWORDS BLAS, COPY, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! SY single precision vector with N elements ! INCY storage spacing between elements of SY ! ! --Output-- ! SY copy of vector SX (unchanged if N <= 0) ! ! Copy single precision SX to single precision SY. ! For I = 0 to N-1, copy SX(LX+I*INCX) to SY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SCOPY REAL SX(*), SY(*) !***FIRST EXECUTABLE STATEMENT SCOPY if (N <= 0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IX = 1 IY = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N SY(IY) = SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE return ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 7. ! 20 M = MOD(N,7) if (M == 0) go to 40 DO 30 I = 1,M SY(I) = SX(I) 30 CONTINUE if (N < 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 ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX SY(I) = SX(I) 70 CONTINUE return end subroutine SCOPYM (N, SX, INCX, SY, INCY) ! !! SCOPYM copies the negative of a vector to a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A5 !***TYPE SINGLE PRECISION (SCOPYM-S, DCOPYM-D) !***KEYWORDS BLAS, COPY, VECTOR !***AUTHOR Kahaner, D. K., (NBS) !***DESCRIPTION ! ! Description of Parameters ! The * Flags Output Variables ! ! N Number of elements in vector(s) ! SX Real vector with N elements ! INCX Storage spacing between elements of SX ! SY* Real negative copy of SX ! INCY Storage spacing between elements of SY ! ! *** Note that SY = -SX *** ! ! Copy negative of real SX to real SY. For I=0 to N-1, ! copy -SX(LX+I*INCX) to SY(LY+I*INCY), where LX=1 if ! INCX >= 0, else LX = 1+(1-N)*INCX, and LY is defined ! in a similar way using INCY. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) !***END PROLOGUE SCOPYM REAL SX(*),SY(*) !***FIRST EXECUTABLE STATEMENT SCOPYM if (N <= 0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IX=1 IY=1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N SY(IY) = -SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE return ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 7. ! 20 M = MOD(N,7) if (M == 0) go to 40 DO 30 I = 1,M SY(I) = -SX(I) 30 CONTINUE if (N < 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 ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX SY(I) = -SX(I) 70 CONTINUE return end subroutine SCOV (FCN, IOPT, M, N, X, FVEC, R, LDR, INFO, WA1, WA2, & WA3, WA4) ! !! SCOV calculates the covariance matrix for a nonlinear data fitting problem. ! It is intended to be used after a ! successful return from either SNLS1 or SNLS1E. ! !***LIBRARY SLATEC !***CATEGORY K1B1 !***TYPE SINGLE PRECISION (SCOV-S, DCOV-D) !***KEYWORDS COVARIANCE MATRIX, NONLINEAR DATA FITTING, ! NONLINEAR LEAST SQUARES !***AUTHOR Hiebert, K. L., (SNLA) !***DESCRIPTION ! ! 1. Purpose. ! ! SCOV calculates the covariance matrix for a nonlinear data ! fitting problem. It is intended to be used after a ! successful return from either SNLS1 or SNLS1E. SCOV ! and SNLS1 (and SNLS1E) have compatible parameters. The ! required external subroutine, FCN, is the same ! for all three codes, SCOV, SNLS1, and SNLS1E. ! ! 2. Subroutine and Type Statements. ! ! SUBROUTINE SCOV(FCN,IOPT,M,N,X,FVEC,R,LDR,INFO, ! WA1,WA2,WA3,WA4) ! INTEGER IOPT,M,N,LDR,INFO ! REAL X(N),FVEC(M),R(LDR,N),WA1(N),WA2(N),WA3(N),WA4(M) ! EXTERNAL FCN ! ! 3. Parameters. ! ! FCN is the name of the user-supplied subroutine which calculates ! the functions. If the user wants to supply the Jacobian ! (IOPT=2 or 3), then FCN must be written to calculate the ! Jacobian, as well as the functions. See the explanation ! of the IOPT argument below. FCN must be declared in an ! EXTERNAL statement in the calling program and should be ! written as follows. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! INTEGER IFLAG,LDFJAC,M,N ! REAL X(N),FVEC(M) ! ---------- ! FJAC and LDFJAC may be ignored , if IOPT=1. ! REAL FJAC(LDFJAC,N) , if IOPT=2. ! REAL FJAC(N) , if IOPT=3. ! ---------- ! IFLAG will never be zero when FCN is called by SCOV. ! return ! ---------- ! If IFLAG=1, calculate the functions at X and return ! this vector in FVEC. ! return ! ---------- ! If IFLAG=2, calculate the full Jacobian at X and return ! this matrix in FJAC. Note that IFLAG will never be 2 unless ! IOPT=2. FVEC contains the function values at X and must ! not be altered. FJAC(I,J) must be set to the derivative ! of FVEC(I) with respect to X(J). ! return ! ---------- ! If IFLAG=3, calculate the LDFJAC-th row of the Jacobian ! and return this vector in FJAC. Note that IFLAG will ! never be 3 unless IOPT=3. FJAC(J) must be set to ! the derivative of FVEC(LDFJAC) with respect to X(J). ! return ! ---------- ! END ! ! ! The value of IFLAG should not be changed by FCN unless the ! user wants to terminate execution of SCOV. In this case, set ! IFLAG to a negative integer. ! ! ! IOPT is an input variable which specifies how the Jacobian will ! be calculated. If IOPT=2 or 3, then the user must supply the ! Jacobian, as well as the function values, through the ! subroutine FCN. If IOPT=2, the user supplies the full ! Jacobian with one call to FCN. If IOPT=3, the user supplies ! one row of the Jacobian with each call. (In this manner, ! storage can be saved because the full Jacobian is not stored.) ! If IOPT=1, the code will approximate the Jacobian by forward ! differencing. ! ! M is a positive integer input variable set to the number of ! functions. ! ! N is a positive integer input variable set to the number of ! variables. N must not exceed M. ! ! X is an array of length N. On input X must contain the value ! at which the covariance matrix is to be evaluated. This is ! usually the value for X returned from a successful run of ! SNLS1 (or SNLS1E). The value of X will not be changed. ! ! FVEC is an output array of length M which contains the functions ! evaluated at X. ! ! R is an output array. For IOPT=1 and 2, R is an M by N array. ! For IOPT=3, R is an N by N array. On output, if INFO=1, ! the upper N by N submatrix of R contains the covariance ! matrix evaluated at X. ! ! LDR is a positive integer input variable which specifies ! the leading dimension of the array R. For IOPT=1 and 2, ! LDR must not be less than M. For IOPT=3, LDR must not ! be less than N. ! ! INFO is an integer output variable. If the user has terminated ! execution, INFO is set to the (negative) value of IFLAG. See ! description of FCN. Otherwise, INFO is set as follows. ! ! INFO = 0 Improper input parameters (M <= 0 or N <= 0). ! ! INFO = 1 Successful return. The covariance matrix has been ! calculated and stored in the upper N by N ! submatrix of R. ! ! INFO = 2 The Jacobian matrix is singular for the input value ! of X. The covariance matrix cannot be calculated. ! The upper N by N submatrix of R contains the QR ! factorization of the Jacobian (probably not of ! interest to the user). ! ! WA1 is a work array of length N. ! WA2 is a work array of length N. ! WA3 is a work array of length N. ! WA4 is a work array of length M. ! !***REFERENCES (NONE) !***ROUTINES CALLED ENORM, FDJAC3, QRFAC, RWUPDT, XERMSG !***REVISION HISTORY (YYMMDD) ! 810522 DATE WRITTEN ! 890505 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Fixed an error message. (RWC) !***END PROLOGUE SCOV ! ! REVISED 820707-1100 ! REVISED YYMMDD HHMM ! INTEGER I,IDUM,IFLAG,INFO,IOPT,J,K,KP1,LDR,M,N,NM1,NROW REAL X(*),R(LDR,*),FVEC(*),WA1(*),WA2(*),WA3(*),WA4(*) EXTERNAL FCN REAL ONE,SIGMA,TEMP,ZERO LOGICAL SING SAVE ZERO, ONE DATA ZERO/0.E0/,ONE/1.E0/ !***FIRST EXECUTABLE STATEMENT SCOV SING=.FALSE. IFLAG=0 if (M <= 0 .OR. N <= 0) go to 300 ! ! CALCULATE SIGMA = (SUM OF THE SQUARED RESIDUALS) / (M-N) IFLAG=1 call FCN(IFLAG,M,N,X,FVEC,R,LDR) if (IFLAG < 0) go to 300 TEMP=ENORM(M,FVEC) SIGMA=ONE if (M /= N) SIGMA=TEMP*TEMP/(M-N) ! ! CALCULATE THE JACOBIAN if (IOPT == 3) go to 200 ! ! STORE THE FULL JACOBIAN USING M*N STORAGE if (IOPT == 1) go to 100 ! ! USER SUPPLIES THE JACOBIAN IFLAG=2 call FCN(IFLAG,M,N,X,FVEC,R,LDR) go to 110 ! ! CODE APPROXIMATES THE JACOBIAN 100 call FDJAC3(FCN,M,N,X,FVEC,R,LDR,IFLAG,ZERO,WA4) 110 if (IFLAG < 0) go to 300 ! ! COMPUTE THE QR DECOMPOSITION call QRFAC(M,N,R,LDR,.FALSE.,IDUM,1,WA1,WA1,WA1) DO 120 I=1,N 120 R(I,I)=WA1(I) go to 225 ! ! COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX CALCULATED ONE ! ROW AT A TIME AND STORED IN THE UPPER TRIANGLE OF R. ! ( (Q TRANSPOSE)*FVEC IS ALSO CALCULATED BUT NOT USED.) 200 CONTINUE DO 210 J=1,N WA2(J)=ZERO DO 205 I=1,N R(I,J)=ZERO 205 CONTINUE 210 CONTINUE IFLAG=3 DO 220 I=1,M NROW = I call FCN(IFLAG,M,N,X,FVEC,WA1,NROW) if (IFLAG < 0) go to 300 TEMP=FVEC(I) call RWUPDT(N,R,LDR,WA1,WA2,TEMP,WA3,WA4) 220 CONTINUE ! ! CHECK if R IS SINGULAR. 225 CONTINUE DO 230 I=1,N if (R(I,I) == ZERO) SING=.TRUE. 230 CONTINUE if (SING) go to 300 ! ! R IS UPPER TRIANGULAR. CALCULATE (R TRANSPOSE) INVERSE AND STORE ! IN THE UPPER TRIANGLE OF R. if (N == 1) go to 275 NM1=N-1 DO 270 K=1,NM1 ! ! INITIALIZE THE RIGHT-HAND SIDE (WA1(*)) AS THE K-TH COLUMN OF THE ! IDENTITY MATRIX. DO 240 I=1,N WA1(I)=ZERO 240 CONTINUE WA1(K)=ONE ! R(K,K)=WA1(K)/R(K,K) KP1=K+1 DO 260 I=KP1,N ! ! SUBTRACT R(K,I-1)*R(I-1,*) FROM THE RIGHT-HAND SIDE, WA1(*). DO 250 J=I,N WA1(J)=WA1(J)-R(K,I-1)*R(I-1,J) 250 CONTINUE R(K,I)=WA1(I)/R(I,I) 260 CONTINUE 270 CONTINUE 275 R(N,N)=ONE/R(N,N) ! ! CALCULATE R-INVERSE * (R TRANSPOSE) INVERSE AND STORE IN THE UPPER ! TRIANGLE OF R. DO 290 I=1,N DO 290 J=I,N TEMP=ZERO DO 280 K=J,N TEMP=TEMP+R(I,K)*R(J,K) 280 CONTINUE R(I,J)=TEMP*SIGMA 290 CONTINUE INFO=1 ! 300 CONTINUE if (M <= 0 .OR. N <= 0) INFO=0 if (IFLAG < 0) INFO=IFLAG if (SING) INFO=2 if (INFO < 0) call XERMSG ('SLATEC', 'SCOV', & 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) if (INFO == 0) call XERMSG ('SLATEC', 'SCOV', & 'INVALID INPUT PARAMETER.', 2, 1) if (INFO == 2) call XERMSG ('SLATEC', 'SCOV', & 'SINGULAR JACOBIAN MATRIX, COVARIANCE MATRIX CANNOT BE ' // & 'CALCULATED.', 1, 1) return end subroutine SCPPLT (N, NELT, IA, JA, A, ISYM, IUNIT) ! !! SCPPLT does a Printer Plot of SLAP Column Format Matrix. ! ! Routine to print out a SLAP Column format matrix in a ! "printer plot" graphical representation. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY N1 !***TYPE SINGLE PRECISION (SCPPLT-S, DCPPLT-D) !***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT ! REAL A(NELT) ! ! call SCPPLT( N, NELT, IA, JA, A, ISYM, IUNIT ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! If N.gt.MAXORD, only the leading MAXORD x MAXORD ! submatrix will be printed. (Currently MAXORD = 225.) ! NELT :IN Integer. ! Number of non-zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in the SLAP ! Column format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! IUNIT :IN Integer. ! Fortran logical I/O device unit number to write the matrix ! to. This unit must be connected in a system dependent fashion ! to a file or the console or you will get a nasty message ! from the Fortran I/O libraries. ! ! *Description: ! This routine prints out a SLAP Column format matrix to the ! Fortran logical I/O unit number IUNIT. The numbers them ! selves are not printed out, but rather a one character ! representation of the numbers. Elements of the matrix that ! are not represented in the (IA,JA,A) arrays are denoted by ! ' ' character (a blank). Elements of A that are *ZERO* (and ! hence should really not be stored) are denoted by a '0' ! character. Elements of A that are *POSITIVE* are denoted by ! 'D' if they are Diagonal elements and '#' if they are off ! Diagonal elements. Elements of A that are *NEGATIVE* are ! denoted by 'N' if they are Diagonal elements and '*' if ! they are off Diagonal elements. ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! ! *Portability: ! This routine, as distributed, can generate lines up to 229 ! characters long. Some Fortran systems have more restricted ! line lengths. Change parameter MAXORD and the large number ! in FORMAT 1010 to reduce this line length. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921007 Replaced hard-wired 225 with parameter MAXORD. (FNF) ! 921021 Corrected syntax of CHARACTER declaration. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SCPPLT ! .. Scalar Arguments .. INTEGER ISYM, IUNIT, N, NELT ! .. Array Arguments .. REAL A(NELT) INTEGER IA(NELT), JA(NELT) ! .. Parameters .. INTEGER MAXORD PARAMETER (MAXORD=225) ! .. Local Scalars .. INTEGER I, ICOL, IROW, J, JBGN, JEND, NMAX ! .. Local Arrays .. CHARACTER CHMAT(MAXORD)*(MAXORD) ! .. Intrinsic Functions .. INTRINSIC MIN, MOD, REAL !***FIRST EXECUTABLE STATEMENT SCPPLT ! ! Set up the character matrix... ! NMAX = MIN( MAXORD, N ) DO 10 I = 1, NMAX CHMAT(I)(1:NMAX) = ' ' 10 CONTINUE DO 30 ICOL = 1, NMAX JBGN = JA(ICOL) JEND = JA(ICOL+1)-1 DO 20 J = JBGN, JEND IROW = IA(J) if ( IROW <= NMAX ) THEN if ( ISYM /= 0 ) THEN ! Put in non-sym part as well... if ( A(J) == 0.0E0 ) THEN CHMAT(IROW)(ICOL:ICOL) = '0' ELSEIF( A(J) > 0.0E0 ) THEN CHMAT(IROW)(ICOL:ICOL) = '#' ELSE CHMAT(IROW)(ICOL:ICOL) = '*' ENDIF ENDIF if ( IROW == ICOL ) THEN ! Diagonal entry. if ( A(J) == 0.0E0 ) THEN CHMAT(IROW)(ICOL:ICOL) = '0' ELSEIF( A(J) > 0.0E0 ) THEN CHMAT(IROW)(ICOL:ICOL) = 'D' ELSE CHMAT(IROW)(ICOL:ICOL) = 'N' ENDIF ELSE ! Off-Diagonal entry if ( A(J) == 0.0E0 ) THEN CHMAT(IROW)(ICOL:ICOL) = '0' ELSEIF( A(J) > 0.0E0 ) THEN CHMAT(IROW)(ICOL:ICOL) = '#' ELSE CHMAT(IROW)(ICOL:ICOL) = '*' ENDIF ENDIF ENDIF 20 CONTINUE 30 CONTINUE ! ! Write out the heading. WRITE(IUNIT,1000) N, NELT, REAL(NELT)/(N*N) WRITE(IUNIT,1010) (MOD(I,10),I=1,NMAX) ! ! Write out the character representations matrix elements. DO 40 IROW = 1, NMAX WRITE(IUNIT,1020) IROW, CHMAT(IROW)(1:NMAX) 40 CONTINUE return ! 1000 FORMAT(/'**** Picture of Column SLAP matrix follows ****'/ & ' N, NELT and Density = ',2I10,E16.7) ! The following assumes MAXORD.le.225. 1010 FORMAT(4X,225(I1)) 1020 FORMAT(1X,I3,A) !------------- LAST LINE OF SCPPLT FOLLOWS ---------------------------- end subroutine SDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR, & IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP) ! !! SDAINI is the initialization routine for SDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDAINI-S, DDAINI-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------- ! SDAINI TAKES ONE STEP OF SIZE H OR SMALLER ! WITH THE BACKWARD EULER METHOD, TO ! FIND YPRIME. X AND Y ARE UPDATED TO BE CONSISTENT WITH THE ! NEW STEP. A MODIFIED DAMPED NEWTON ITERATION IS USED TO ! SOLVE THE CORRECTOR ITERATION. ! ! THE INITIAL GUESS FOR YPRIME IS USED IN THE ! PREDICTION, AND IN FORMING THE ITERATION ! MATRIX, BUT IS NOT INVOLVED IN THE ! ERROR TEST. THIS MAY HAVE TROUBLE ! CONVERGING if THE INITIAL GUESS IS NO ! GOOD, OR if G(X,Y,YPRIME) DEPENDS ! NONLINEARLY ON YPRIME. ! ! THE PARAMETERS REPRESENT: ! X -- INDEPENDENT VARIABLE ! Y -- SOLUTION VECTOR AT X ! YPRIME -- DERIVATIVE OF SOLUTION VECTOR ! NEQ -- NUMBER OF EQUATIONS ! H -- STEPSIZE. IMDER MAY USE A STEPSIZE ! SMALLER THAN H. ! WT -- VECTOR OF WEIGHTS FOR ERROR ! CRITERION ! IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS ! IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY ! IDID=-12 -- SDAINI FAILED TO FIND YPRIME ! RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS ! THAT ARE NOT ALTERED BY SDAINI ! PHI -- WORK SPACE FOR SDAINI ! DELTA,E -- WORK SPACE FOR SDAINI ! WM,IWM -- REAL AND INTEGER ARRAYS STORING ! MATRIX INFORMATION ! !----------------------------------------------------------------- !***ROUTINES CALLED SDAJAC, SDANRM, SDASLV !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) ! 901030 Minor corrections to declarations. (FNF) !***END PROLOGUE SDAINI ! INTEGER NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP REAL X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), & E(*), WM(*), HMIN, UROUND EXTERNAL RES, JAC ! EXTERNAL SDAJAC, SDANRM, SDASLV REAL SDANRM ! INTEGER I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF, & NEF, NSF REAL CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM LOGICAL CONVGD ! PARAMETER (LNRE=12) PARAMETER (LNJE=13) ! DATA MAXIT/10/,MJAC/5/ DATA DAMP/0.75E0/ ! ! !--------------------------------------------------- ! BLOCK 1. ! INITIALIZATIONS. !--------------------------------------------------- ! !***FIRST EXECUTABLE STATEMENT SDAINI IDID=1 NEF=0 NCF=0 NSF=0 XOLD=X YNORM=SDANRM(NEQ,Y,WT,RPAR,IPAR) ! ! SAVE Y AND YPRIME IN PHI DO 100 I=1,NEQ PHI(I,1)=Y(I) 100 PHI(I,2)=YPRIME(I) ! ! !---------------------------------------------------- ! BLOCK 2. ! DO ONE BACKWARD EULER STEP. !---------------------------------------------------- ! ! SET UP FOR START OF CORRECTOR ITERATION 200 CJ=1.0E0/H X=X+H ! ! PREDICT SOLUTION AND DERIVATIVE DO 250 I=1,NEQ 250 Y(I)=Y(I)+H*YPRIME(I) ! JCALC=-1 M=0 CONVGD=.TRUE. ! ! ! CORRECTOR LOOP. 300 IWM(LNRE)=IWM(LNRE)+1 IRES=0 ! call RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) if (IRES < 0) go to 430 ! ! ! EVALUATE THE ITERATION MATRIX if (JCALC /= -1) go to 310 IWM(LNJE)=IWM(LNJE)+1 JCALC=0 call SDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, & IER,WT,E,WM,IWM,RES,IRES, & UROUND,JAC,RPAR,IPAR,NTEMP) ! S=1000000.E0 if (IRES < 0) go to 430 if (IER /= 0) go to 430 NSF=0 ! ! ! ! MULTIPLY RESIDUAL BY DAMPING FACTOR 310 CONTINUE DO 320 I=1,NEQ 320 DELTA(I)=DELTA(I)*DAMP ! ! COMPUTE A NEW ITERATE (BACK SUBSTITUTION) ! STORE THE CORRECTION IN DELTA ! call SDASLV(NEQ,DELTA,WM,IWM) ! ! UPDATE Y AND YPRIME DO 330 I=1,NEQ Y(I)=Y(I)-DELTA(I) 330 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) ! ! TEST FOR CONVERGENCE OF THE ITERATION. ! DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR) if (DELNRM <= 100.E0*UROUND*YNORM) & go to 400 ! if (M > 0) go to 340 OLDNRM=DELNRM go to 350 ! 340 RATE=(DELNRM/OLDNRM)**(1.0E0/M) if (RATE > 0.90E0) go to 430 S=RATE/(1.0E0-RATE) ! 350 if (S*DELNRM <= 0.33E0) go to 400 ! ! ! THE CORRECTOR HAS NOT YET CONVERGED. UPDATE ! M AND AND TEST WHETHER THE MAXIMUM ! NUMBER OF ITERATIONS HAVE BEEN TRIED. ! EVERY MJAC ITERATIONS, GET A NEW ! ITERATION MATRIX. ! M=M+1 if (M >= MAXIT) go to 430 ! if ((M/MJAC)*MJAC == M) JCALC=-1 go to 300 ! ! ! THE ITERATION HAS CONVERGED. ! CHECK NONNEGATIVITY CONSTRAINTS 400 if (NONNEG == 0) go to 450 DO 410 I=1,NEQ 410 DELTA(I)=MIN(Y(I),0.0E0) ! DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR) if (DELNRM > 0.33E0) go to 430 ! DO 420 I=1,NEQ Y(I)=Y(I)-DELTA(I) 420 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) go to 450 ! ! ! EXITS FROM CORRECTOR LOOP. 430 CONVGD=.FALSE. 450 if (.NOT.CONVGD) go to 600 ! ! ! !----------------------------------------------------- ! BLOCK 3. ! THE CORRECTOR ITERATION CONVERGED. ! DO ERROR TEST. !----------------------------------------------------- ! DO 510 I=1,NEQ 510 E(I)=Y(I)-PHI(I,1) ERR=SDANRM(NEQ,E,WT,RPAR,IPAR) ! if (ERR <= 1.0E0) RETURN ! ! ! !-------------------------------------------------------- ! BLOCK 4. ! THE BACKWARD EULER STEP FAILED. RESTORE X, Y ! AND YPRIME TO THEIR ORIGINAL VALUES. ! REDUCE STEPSIZE AND TRY AGAIN, IF ! POSSIBLE. !--------------------------------------------------------- ! 600 CONTINUE X = XOLD DO 610 I=1,NEQ Y(I)=PHI(I,1) 610 YPRIME(I)=PHI(I,2) ! if (CONVGD) go to 640 if (IER == 0) go to 620 NSF=NSF+1 H=H*0.25E0 if (NSF < 3.AND.ABS(H) >= HMIN) go to 690 IDID=-12 return 620 if (IRES > -2) go to 630 IDID=-12 return 630 NCF=NCF+1 H=H*0.25E0 if (NCF < 10.AND.ABS(H) >= HMIN) go to 690 IDID=-12 return ! 640 NEF=NEF+1 R=0.90E0/(2.0E0*ERR+0.0001E0) R=MAX(0.1E0,MIN(0.5E0,R)) H=H*R if (ABS(H) >= HMIN.AND.NEF < 10) go to 690 IDID=-12 return 690 go to 200 ! !-------------END OF SUBROUTINE SDAINI---------------------- end subroutine SDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H, IER, WT, E, & WM, IWM, RES, IRES, UROUND, JAC, RPAR, IPAR, NTEMP) ! !! SDAJAC computes and LU factors the iteration matrix for SDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDAJAC-S, DDAJAC-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! THIS ROUTINE COMPUTES THE ITERATION MATRIX ! PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0). ! HERE PD IS COMPUTED BY THE USER-SUPPLIED ! ROUTINE JAC if IWM(MTYPE) IS 1 OR 4, AND ! IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING ! if IWM(MTYPE)IS 2 OR 5 ! THE PARAMETERS HAVE THE FOLLOWING MEANINGS. ! Y = ARRAY CONTAINING PREDICTED VALUES ! YPRIME = ARRAY CONTAINING PREDICTED DERIVATIVES ! DELTA = RESIDUAL EVALUATED AT (X,Y,YPRIME) ! (USED ONLY if IWM(MTYPE)=2 OR 5) ! CJ = SCALAR PARAMETER DEFINING ITERATION MATRIX ! H = CURRENT STEPSIZE IN INTEGRATION ! IER = VARIABLE WHICH IS /= 0 ! if ITERATION MATRIX IS SINGULAR, ! AND 0 OTHERWISE. ! WT = VECTOR OF WEIGHTS FOR COMPUTING NORMS ! E = WORK SPACE (TEMPORARY) OF LENGTH NEQ ! WM = REAL WORK SPACE FOR MATRICES. ON ! OUTPUT IT CONTAINS THE LU DECOMPOSITION ! OF THE ITERATION MATRIX. ! IWM = INTEGER WORK SPACE CONTAINING ! MATRIX INFORMATION ! RES = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE ! TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME) ! IRES = FLAG WHICH IS EQUAL TO ZERO if NO ILLEGAL VALUES ! IN RES, AND LESS THAN ZERO OTHERWISE. (IF IRES ! IS LESS THAN ZERO, THE MATRIX WAS NOT COMPLETED) ! IN THIS CASE (IF IRES < 0), THEN IER = 0. ! UROUND = THE UNIT ROUNDOFF ERROR OF THE MACHINE BEING USED. ! JAC = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE ! TO EVALUATE THE ITERATION MATRIX (THIS ROUTINE ! IS ONLY USED if IWM(MTYPE) IS 1 OR 4) !----------------------------------------------------------------------- !***ROUTINES CALLED SGBFA, SGEFA !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901010 Modified three MAX calls to be all on one line. (FNF) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) ! 901101 Corrected PURPOSE. (FNF) !***END PROLOGUE SDAJAC ! INTEGER NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP REAL X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*), & UROUND, RPAR(*) EXTERNAL RES, JAC ! EXTERNAL SGBFA, SGEFA ! INTEGER I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT, & LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N, & NPD, NPDM1, NROW REAL DEL, DELINV, SQUR, YPSAVE, YSAVE ! PARAMETER (NPD=1) PARAMETER (LML=1) PARAMETER (LMU=2) PARAMETER (LMTYPE=4) PARAMETER (LIPVT=21) ! !***FIRST EXECUTABLE STATEMENT SDAJAC IER = 0 NPDM1=NPD-1 MTYPE=IWM(LMTYPE) go to (100,200,300,400,500),MTYPE ! ! ! DENSE USER-SUPPLIED MATRIX 100 LENPD=NEQ*NEQ DO 110 I=1,LENPD 110 WM(NPDM1+I)=0.0E0 call JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) go to 230 ! ! ! DENSE FINITE-DIFFERENCE-GENERATED MATRIX 200 IRES=0 NROW=NPDM1 SQUR = SQRT(UROUND) DO 210 I=1,NEQ DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(I))) DEL=SIGN(DEL,H*YPRIME(I)) DEL=(Y(I)+DEL)-Y(I) YSAVE=Y(I) YPSAVE=YPRIME(I) Y(I)=Y(I)+DEL YPRIME(I)=YPRIME(I)+CJ*DEL call RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) if (IRES < 0) RETURN DELINV=1.0E0/DEL DO 220 L=1,NEQ 220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV NROW=NROW+NEQ Y(I)=YSAVE YPRIME(I)=YPSAVE 210 CONTINUE ! ! ! DO DENSE-MATRIX LU DECOMPOSITION ON PD 230 call SGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER) return ! ! ! DUMMY SECTION FOR IWM(MTYPE)=3 300 return ! ! ! BANDED USER-SUPPLIED MATRIX 400 LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ DO 410 I=1,LENPD 410 WM(NPDM1+I)=0.0E0 call JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) MEBAND=2*IWM(LML)+IWM(LMU)+1 go to 550 ! ! ! BANDED FINITE-DIFFERENCE-GENERATED MATRIX 500 MBAND=IWM(LML)+IWM(LMU)+1 MBA=MIN(MBAND,NEQ) MEBAND=MBAND+IWM(LML) MEB1=MEBAND-1 MSAVE=(NEQ/MBAND)+1 ISAVE=NTEMP-1 IPSAVE=ISAVE+MSAVE IRES=0 SQUR=SQRT(UROUND) DO 540 J=1,MBA DO 510 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 WM(ISAVE+K)=Y(N) WM(IPSAVE+K)=YPRIME(N) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) Y(N)=Y(N)+DEL 510 YPRIME(N)=YPRIME(N)+CJ*DEL call RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) if (IRES < 0) RETURN DO 530 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 Y(N)=WM(ISAVE+K) YPRIME(N)=WM(IPSAVE+K) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) DELINV=1.0E0/DEL I1=MAX(1,(N-IWM(LMU))) I2=MIN(NEQ,(N+IWM(LML))) II=N*MEB1-IWM(LML)+NPDM1 DO 520 I=I1,I2 520 WM(II+I)=(E(I)-DELTA(I))*DELINV 530 CONTINUE 540 CONTINUE ! ! ! DO LU DECOMPOSITION OF BANDED PD 550 call SGBFA(WM(NPD),MEBAND,NEQ, & IWM(LML),IWM(LMU),IWM(LIPVT),IER) return !------END OF SUBROUTINE SDAJAC------ end FUNCTION SDANRM (NEQ, V, WT, RPAR, IPAR) ! !! SDANRM computes vector norms for SDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDANRM-S, DDANRM-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ! ROOT-MEAN-SQUARE NORM OF THE VECTOR OF LENGTH ! NEQ CONTAINED IN THE ARRAY V,WITH WEIGHTS ! CONTAINED IN THE ARRAY WT OF LENGTH NEQ. ! SDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) !----------------------------------------------------------------------- !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) !***END PROLOGUE SDANRM ! real SDANRM INTEGER NEQ, IPAR(*) REAL V(NEQ), WT(NEQ), RPAR(*) ! INTEGER I REAL SUM, VMAX ! !***FIRST EXECUTABLE STATEMENT SDANRM SDANRM = 0.0E0 VMAX = 0.0E0 DO 10 I = 1,NEQ if ( ABS(V(I)/WT(I)) > VMAX) VMAX = ABS(V(I)/WT(I)) 10 CONTINUE if ( VMAX <= 0.0E0) go to 30 SUM = 0.0E0 DO 20 I = 1,NEQ 20 SUM = SUM + ((V(I)/WT(I))/VMAX)**2 SDANRM = VMAX*SQRT(SUM/NEQ) 30 CONTINUE return !------END OF FUNCTION SDANRM------ end subroutine SDASLV (NEQ, DELTA, WM, IWM) ! !! SDASLV is the linear system solver for SDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDASLV-S, DDASLV-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR ! SYSTEM ARISING IN THE NEWTON ITERATION. ! MATRICES AND REAL TEMPORARY STORAGE AND ! REAL INFORMATION ARE STORED IN THE ARRAY WM. ! INTEGER MATRIX INFORMATION IS STORED IN ! THE ARRAY IWM. ! FOR A DENSE MATRIX, THE LINPACK ROUTINE ! SGESL IS CALLED. ! FOR A BANDED MATRIX,THE LINPACK ROUTINE ! SGBSL IS CALLED. !----------------------------------------------------------------------- !***ROUTINES CALLED SGBSL, SGESL !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) !***END PROLOGUE SDASLV ! INTEGER NEQ, IWM(*) REAL DELTA(*), WM(*) ! EXTERNAL SGBSL, SGESL ! INTEGER LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD PARAMETER (NPD=1) PARAMETER (LML=1) PARAMETER (LMU=2) PARAMETER (LMTYPE=4) PARAMETER (LIPVT=21) ! !***FIRST EXECUTABLE STATEMENT SDASLV MTYPE=IWM(LMTYPE) go to(100,100,300,400,400),MTYPE ! ! DENSE MATRIX 100 call SGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0) return ! ! DUMMY SECTION FOR MTYPE=3 300 CONTINUE return ! ! BANDED MATRIX 400 MEBAND=2*IWM(LML)+IWM(LMU)+1 call SGBSL(WM(NPD),MEBAND,NEQ,IWM(LML), & IWM(LMU),IWM(LIPVT),DELTA,0) return !------END OF SUBROUTINE SDASLV------ end subroutine SDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, & IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) ! !! SDASSL solves a system of differential/algebraic equations ... ! of the form G(T,Y,YPRIME) = 0. ! !***LIBRARY SLATEC (DASSL) !***CATEGORY I1A2 !***TYPE SINGLE PRECISION (SDASSL-S, DDASSL-D) !***KEYWORDS BACKWARD DIFFERENTIATION FORMULAS, DASSL, ! DIFFERENTIAL/ALGEBRAIC, IMPLICIT DIFFERENTIAL SYSTEMS !***AUTHOR Petzold, Linda R., (LLNL) ! Computing and Mathematics Research Division ! Lawrence Livermore National Laboratory ! L - 316, P.O. Box 808, ! Livermore, CA. 94550 !***DESCRIPTION ! ! *Usage: ! ! EXTERNAL RES, JAC ! INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR ! REAL T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, ! * RWORK(LRW), RPAR ! ! call SDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, ! * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) ! ! ! *Arguments: ! ! RES:EXT This is a subroutine which you provide to define the ! differential/algebraic system. ! ! NEQ:IN This is the number of equations to be solved. ! ! T:INOUT This is the current value of the independent variable. ! ! Y(*):INOUT This array contains the solution components at T. ! ! YPRIME(*):INOUT This array contains the derivatives of the solution ! components at T. ! ! TOUT:IN This is a point at which a solution is desired. ! ! INFO(N):IN The basic task of the code is to solve the system from T ! to TOUT and return an answer at TOUT. INFO is an integer ! array which is used to communicate exactly how you want ! this task to be carried out. (See below for details.) ! N must be greater than or equal to 15. ! ! RTOL,ATOL:INOUT These quantities represent relative and absolute ! error tolerances which you provide to indicate how ! accurately you wish the solution to be computed. You ! may choose them to be both scalars or else both vectors. ! Caution: In Fortran 77, a scalar is not the same as an ! array of length 1. Some compilers may object ! to using scalars for RTOL,ATOL. ! ! IDID:OUT This scalar quantity is an indicator reporting what the ! code did. You must monitor this integer variable to ! decide what action to take next. ! ! RWORK:WORK A real work array of length LRW which provides the ! code with needed storage space. ! ! LRW:IN The length of RWORK. (See below for required length.) ! ! IWORK:WORK An integer work array of length LIW which provides the ! code with needed storage space. ! ! LIW:IN The length of IWORK. (See below for required length.) ! ! RPAR,IPAR:IN These are real and integer parameter arrays which ! you can use for communication between your calling ! program and the RES subroutine (and the JAC subroutine) ! ! JAC:EXT This is the name of a subroutine which you may choose ! to provide for defining a matrix of partial derivatives ! described below. ! ! Quantities which may be altered by SDASSL are: ! T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, ! IDID, RWORK(*) AND IWORK(*) ! ! *Description ! ! Subroutine SDASSL uses the backward differentiation formulas of ! orders one through five to solve a system of the above form for Y and ! YPRIME. Values for Y and YPRIME at the initial time must be given as ! input. These values must be consistent, (that is, if T,Y,YPRIME are ! the given initial values, they must satisfy G(T,Y,YPRIME) = 0.). The ! subroutine solves the system from T to TOUT. It is easy to continue ! the solution to get results at additional TOUT. This is the interval ! mode of operation. Intermediate results can also be obtained easily ! by using the intermediate-output capability. ! ! The following detailed description is divided into subsections: ! 1. Input required for the first call to SDASSL. ! 2. Output after any return from SDASSL. ! 3. What to do to continue the integration. ! 4. Error messages. ! ! ! -------- INPUT -- WHAT TO DO ON THE FIRST call TO SDASSL ------------ ! ! The first call of the code is defined to be the start of each new ! problem. Read through the descriptions of all the following items, ! provide sufficient storage space for designated arrays, set ! appropriate variables for the initialization of the problem, and ! give information about how you want the problem to be solved. ! ! ! RES -- Provide a subroutine of the form ! SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR) ! to define the system of differential/algebraic ! equations which is to be solved. For the given values ! of T,Y and YPRIME, the subroutine should ! return the residual of the differential/algebraic ! system ! DELTA = G(T,Y,YPRIME) ! (DELTA(*) is a vector of length NEQ which is ! output for RES.) ! ! Subroutine RES must not alter T,Y or YPRIME. ! You must declare the name RES in an external ! statement in your program that calls SDASSL. ! You must dimension Y,YPRIME and DELTA in RES. ! ! IRES is an integer flag which is always equal to ! zero on input. Subroutine RES should alter IRES ! only if it encounters an illegal value of Y or ! a stop condition. Set IRES = -1 if an input value ! is illegal, and SDASSL will try to solve the problem ! without getting IRES = -1. If IRES = -2, SDASSL ! will return control to the calling program ! with IDID = -11. ! ! RPAR and IPAR are real and integer parameter arrays which ! you can use for communication between your calling program ! and subroutine RES. They are not altered by SDASSL. If you ! do not need RPAR or IPAR, ignore these parameters by treat- ! ing them as dummy arguments. If you do choose to use them, ! dimension them in your calling program and in RES as arrays ! of appropriate length. ! ! NEQ -- Set it to the number of differential equations. ! (NEQ >= 1) ! ! T -- Set it to the initial point of the integration. ! T must be defined as a variable. ! ! Y(*) -- Set this vector to the initial values of the NEQ solution ! components at the initial point. You must dimension Y of ! length at least NEQ in your calling program. ! ! YPRIME(*) -- Set this vector to the initial values of the NEQ ! first derivatives of the solution components at the initial ! point. You must dimension YPRIME at least NEQ in your ! calling program. If you do not know initial values of some ! of the solution components, see the explanation of INFO(11). ! ! TOUT -- Set it to the first point at which a solution ! is desired. You can not take TOUT = T. ! integration either forward in T (TOUT > T) or ! backward in T (TOUT < T) is permitted. ! ! The code advances the solution from T to TOUT using ! step sizes which are automatically selected so as to ! achieve the desired accuracy. If you wish, the code will ! return with the solution and its derivative at ! intermediate steps (intermediate-output mode) so that ! you can monitor them, but you still must provide TOUT in ! accord with the basic aim of the code. ! ! The first step taken by the code is a critical one ! because it must reflect how fast the solution changes near ! the initial point. The code automatically selects an ! initial step size which is practically always suitable for ! the problem. By using the fact that the code will not step ! past TOUT in the first step, you could, if necessary, ! restrict the length of the initial step size. ! ! For some problems it may not be permissible to integrate ! past a point TSTOP because a discontinuity occurs there ! or the solution or its derivative is not defined beyond ! TSTOP. When you have declared a TSTOP point (SEE INFO(4) ! and RWORK(1)), you have told the code not to integrate ! past TSTOP. In this case any TOUT beyond TSTOP is invalid ! input. ! ! INFO(*) -- Use the INFO array to give the code more details about ! how you want your problem solved. This array should be ! dimensioned of length 15, though SDASSL uses only the first ! eleven entries. You must respond to all of the following ! items, which are arranged as questions. The simplest use ! of the code corresponds to answering all questions as yes, ! i.e. setting all entries of INFO to 0. ! ! INFO(1) - This parameter enables the code to initialize ! itself. You must set it to indicate the start of every ! new problem. ! ! **** Is this the first call for this problem ... ! Yes - Set INFO(1) = 0 ! No - Not applicable here. ! See below for continuation calls. **** ! ! INFO(2) - How much accuracy you want of your solution ! is specified by the error tolerances RTOL and ATOL. ! The simplest use is to take them both to be scalars. ! To obtain more flexibility, they can both be vectors. ! The code must be told your choice. ! ! **** Are both error tolerances RTOL, ATOL scalars ... ! Yes - Set INFO(2) = 0 ! and input scalars for both RTOL and ATOL ! No - Set INFO(2) = 1 ! and input arrays for both RTOL and ATOL **** ! ! INFO(3) - The code integrates from T in the direction ! of TOUT by steps. If you wish, it will return the ! computed solution and derivative at the next ! intermediate step (the intermediate-output mode) or ! TOUT, whichever comes first. This is a good way to ! proceed if you want to see the behavior of the solution. ! If you must have solutions at a great many specific ! TOUT points, this code will compute them efficiently. ! ! **** Do you want the solution only at ! TOUT (and not at the next intermediate step) ... ! Yes - Set INFO(3) = 0 ! No - Set INFO(3) = 1 **** ! ! INFO(4) - To handle solutions at a great many specific ! values TOUT efficiently, this code may integrate past ! TOUT and interpolate to obtain the result at TOUT. ! Sometimes it is not possible to integrate beyond some ! point TSTOP because the equation changes there or it is ! not defined past TSTOP. Then you must tell the code ! not to go past. ! ! **** Can the integration be carried out without any ! restrictions on the independent variable T ... ! Yes - Set INFO(4)=0 ! No - Set INFO(4)=1 ! and define the stopping point TSTOP by ! setting RWORK(1)=TSTOP **** ! ! INFO(5) - To solve differential/algebraic problems it is ! necessary to use a matrix of partial derivatives of the ! system of differential equations. If you do not ! provide a subroutine to evaluate it analytically (see ! description of the item JAC in the call list), it will ! be approximated by numerical differencing in this code. ! although it is less trouble for you to have the code ! compute partial derivatives by numerical differencing, ! the solution will be more reliable if you provide the ! derivatives via JAC. Sometimes numerical differencing ! is cheaper than evaluating derivatives in JAC and ! sometimes it is not - this depends on your problem. ! ! **** Do you want the code to evaluate the partial ! derivatives automatically by numerical differences ... ! Yes - Set INFO(5)=0 ! No - Set INFO(5)=1 ! and provide subroutine JAC for evaluating the ! matrix of partial derivatives **** ! ! INFO(6) - SDASSL will perform much better if the matrix of ! partial derivatives, DG/DY + CJ*DG/DYPRIME, ! (here CJ is a scalar determined by SDASSL) ! is banded and the code is told this. In this ! case, the storage needed will be greatly reduced, ! numerical differencing will be performed much cheaper, ! and a number of important algorithms will execute much ! faster. The differential equation is said to have ! half-bandwidths ML (lower) and MU (upper) if equation i ! involves only unknowns Y(J) with ! I-ML <= J <= I+MU ! for all I=1,2,...,NEQ. Thus, ML and MU are the widths ! of the lower and upper parts of the band, respectively, ! with the main diagonal being excluded. If you do not ! indicate that the equation has a banded matrix of partial ! derivatives, the code works with a full matrix of NEQ**2 ! elements (stored in the conventional way). Computations ! with banded matrices cost less time and storage than with ! full matrices if 2*ML+MU < NEQ. If you tell the ! code that the matrix of partial derivatives has a banded ! structure and you want to provide subroutine JAC to ! compute the partial derivatives, then you must be careful ! to store the elements of the matrix in the special form ! indicated in the description of JAC. ! ! **** Do you want to solve the problem using a full ! (dense) matrix (and not a special banded ! structure) ... ! Yes - Set INFO(6)=0 ! No - Set INFO(6)=1 ! and provide the lower (ML) and upper (MU) ! bandwidths by setting ! IWORK(1)=ML ! IWORK(2)=MU **** ! ! ! INFO(7) -- You can specify a maximum (absolute value of) ! stepsize, so that the code ! will avoid passing over very ! large regions. ! ! **** Do you want the code to decide ! on its own maximum stepsize? ! Yes - Set INFO(7)=0 ! No - Set INFO(7)=1 ! and define HMAX by setting ! RWORK(2)=HMAX **** ! ! INFO(8) -- Differential/algebraic problems ! may occasionally suffer from ! severe scaling difficulties on the ! first step. If you know a great deal ! about the scaling of your problem, you can ! help to alleviate this problem by ! specifying an initial stepsize HO. ! ! **** Do you want the code to define ! its own initial stepsize? ! Yes - Set INFO(8)=0 ! No - Set INFO(8)=1 ! and define HO by setting ! RWORK(3)=HO **** ! ! INFO(9) -- If storage is a severe problem, ! you can save some locations by ! restricting the maximum order MAXORD. ! the default value is 5. for each ! order decrease below 5, the code ! requires NEQ fewer locations, however ! it is likely to be slower. In any ! case, you must have 1 <= MAXORD <= 5 ! **** Do you want the maximum order to ! default to 5? ! Yes - Set INFO(9)=0 ! No - Set INFO(9)=1 ! and define MAXORD by setting ! IWORK(3)=MAXORD **** ! ! INFO(10) --If you know that the solutions to your equations ! will always be nonnegative, it may help to set this ! parameter. However, it is probably best to ! try the code without using this option first, ! and only to use this option if that doesn't ! work very well. ! **** Do you want the code to solve the problem without ! invoking any special nonnegativity constraints? ! Yes - Set INFO(10)=0 ! No - Set INFO(10)=1 ! ! INFO(11) --SDASSL normally requires the initial T, ! Y, and YPRIME to be consistent. That is, ! you must have G(T,Y,YPRIME) = 0 at the initial ! time. If you do not know the initial ! derivative precisely, you can let SDASSL try ! to compute it. ! **** Are the initial T, Y, YPRIME consistent? ! Yes - Set INFO(11) = 0 ! No - Set INFO(11) = 1, ! and set YPRIME to an initial approximation ! to YPRIME. (If you have no idea what ! YPRIME should be, set it to zero. Note ! that the initial Y should be such ! that there must exist a YPRIME so that ! G(T,Y,YPRIME) = 0.) ! ! RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL ! error tolerances to tell the code how accurately you ! want the solution to be computed. They must be defined ! as variables because the code may change them. You ! have two choices -- ! Both RTOL and ATOL are scalars. (INFO(2)=0) ! Both RTOL and ATOL are vectors. (INFO(2)=1) ! in either case all components must be non-negative. ! ! The tolerances are used by the code in a local error ! test at each step which requires roughly that ! ABS(LOCAL ERROR) <= RTOL*ABS(Y)+ATOL ! for each vector component. ! (More specifically, a root-mean-square norm is used to ! measure the size of vectors, and the error test uses the ! magnitude of the solution at the beginning of the step.) ! ! The true (global) error is the difference between the ! true solution of the initial value problem and the ! computed approximation. Practically all present day ! codes, including this one, control the local error at ! each step and do not even attempt to control the global ! error directly. ! Usually, but not always, the true accuracy of the ! computed Y is comparable to the error tolerances. This ! code will usually, but not always, deliver a more ! accurate solution if you reduce the tolerances and ! integrate again. By comparing two such solutions you ! can get a fairly reliable idea of the true error in the ! solution at the bigger tolerances. ! ! Setting ATOL=0. results in a pure relative error test on ! that component. Setting RTOL=0. results in a pure ! absolute error test on that component. A mixed test ! with non-zero RTOL and ATOL corresponds roughly to a ! relative error test when the solution component is much ! bigger than ATOL and to an absolute error test when the ! solution component is smaller than the threshhold ATOL. ! ! The code will not attempt to compute a solution at an ! accuracy unreasonable for the machine being used. It will ! advise you if you ask for too much accuracy and inform ! you as to the maximum accuracy it believes possible. ! ! RWORK(*) -- Dimension this real work array of length LRW in your ! calling program. ! ! LRW -- Set it to the declared length of the RWORK array. ! You must have ! LRW >= 40+(MAXORD+4)*NEQ+NEQ**2 ! for the full (dense) JACOBIAN case (when INFO(6)=0), or ! LRW >= 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ ! for the banded user-defined JACOBIAN case ! (when INFO(5)=1 and INFO(6)=1), or ! LRW >= 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ ! +2*(NEQ/(ML+MU+1)+1) ! for the banded finite-difference-generated JACOBIAN case ! (when INFO(5)=0 and INFO(6)=1) ! ! IWORK(*) -- Dimension this integer work array of length LIW in ! your calling program. ! ! LIW -- Set it to the declared length of the IWORK array. ! You must have LIW >= 20+NEQ ! ! RPAR, IPAR -- These are parameter arrays, of real and integer ! type, respectively. You can use them for communication ! between your program that calls SDASSL and the ! RES subroutine (and the JAC subroutine). They are not ! altered by SDASSL. If you do not need RPAR or IPAR, ! ignore these parameters by treating them as dummy ! arguments. If you do choose to use them, dimension ! them in your calling program and in RES (and in JAC) ! as arrays of appropriate length. ! ! JAC -- If you have set INFO(5)=0, you can ignore this parameter ! by treating it as a dummy argument. Otherwise, you must ! provide a subroutine of the form ! SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR) ! to define the matrix of partial derivatives ! PD=DG/DY+CJ*DG/DYPRIME ! CJ is a scalar which is input to JAC. ! For the given values of T,Y,YPRIME, the ! subroutine must evaluate the non-zero partial ! derivatives for each equation and each solution ! component, and store these values in the ! matrix PD. The elements of PD are set to zero ! before each call to JAC so only non-zero elements ! need to be defined. ! ! Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ. ! You must declare the name JAC in an EXTERNAL statement in ! your program that calls SDASSL. You must dimension Y, ! YPRIME and PD in JAC. ! ! The way you must store the elements into the PD matrix ! depends on the structure of the matrix which you ! indicated by INFO(6). ! *** INFO(6)=0 -- Full (dense) matrix *** ! Give PD a first dimension of NEQ. ! When you evaluate the (non-zero) partial derivative ! of equation I with respect to variable J, you must ! store it in PD according to ! PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" ! *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU ! upper diagonal bands (refer to INFO(6) description ! of ML and MU) *** ! Give PD a first dimension of 2*ML+MU+1. ! when you evaluate the (non-zero) partial derivative ! of equation I with respect to variable J, you must ! store it in PD according to ! IROW = I - J + ML + MU + 1 ! PD(IROW,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)" ! ! RPAR and IPAR are real and integer parameter arrays ! which you can use for communication between your calling ! program and your JACOBIAN subroutine JAC. They are not ! altered by SDASSL. If you do not need RPAR or IPAR, ! ignore these parameters by treating them as dummy ! arguments. If you do choose to use them, dimension ! them in your calling program and in JAC as arrays of ! appropriate length. ! ! ! OPTIONALLY REPLACEABLE NORM ROUTINE: ! ! SDASSL uses a weighted norm SDANRM to measure the size ! of vectors such as the estimated error in each step. ! A FUNCTION subprogram ! REAL FUNCTION SDANRM(NEQ,V,WT,RPAR,IPAR) ! DIMENSION V(NEQ),WT(NEQ) ! is used to define this norm. Here, V is the vector ! whose norm is to be computed, and WT is a vector of ! weights. A SDANRM routine has been included with SDASSL ! which computes the weighted root-mean-square norm ! given by ! SDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2) ! this norm is suitable for most problems. In some ! special cases, it may be more convenient and/or ! efficient to define your own norm by writing a function ! subprogram to be called instead of SDANRM. This should, ! however, be attempted only after careful thought and ! consideration. ! ! ! -------- OUTPUT -- AFTER ANY RETURN FROM SDASSL --------------------- ! ! The principal aim of the code is to return a computed solution at ! TOUT, although it is also possible to obtain intermediate results ! along the way. To find out whether the code achieved its goal ! or if the integration process was interrupted before the task was ! completed, you must check the IDID parameter. ! ! ! T -- The solution was successfully advanced to the ! output value of T. ! ! Y(*) -- Contains the computed solution approximation at T. ! ! YPRIME(*) -- Contains the computed derivative ! approximation at T. ! ! IDID -- Reports what the code did. ! ! *** Task completed *** ! Reported by positive values of IDID ! ! IDID = 1 -- A step was successfully taken in the ! intermediate-output mode. The code has not ! yet reached TOUT. ! ! IDID = 2 -- The integration to TSTOP was successfully ! completed (T=TSTOP) by stepping exactly to TSTOP. ! ! IDID = 3 -- The integration to TOUT was successfully ! completed (T=TOUT) by stepping past TOUT. ! Y(*) is obtained by interpolation. ! YPRIME(*) is obtained by interpolation. ! ! *** Task interrupted *** ! Reported by negative values of IDID ! ! IDID = -1 -- A large amount of work has been expended. ! (About 500 steps) ! ! IDID = -2 -- The error tolerances are too stringent. ! ! IDID = -3 -- The local error test cannot be satisfied ! because you specified a zero component in ATOL ! and the corresponding computed solution ! component is zero. Thus, a pure relative error ! test is impossible for this component. ! ! IDID = -6 -- SDASSL had repeated error test ! failures on the last attempted step. ! ! IDID = -7 -- The corrector could not converge. ! ! IDID = -8 -- The matrix of partial derivatives ! is singular. ! ! IDID = -9 -- The corrector could not converge. ! there were repeated error test failures ! in this step. ! ! IDID =-10 -- The corrector could not converge ! because IRES was equal to minus one. ! ! IDID =-11 -- IRES equal to -2 was encountered ! and control is being returned to the ! calling program. ! ! IDID =-12 -- SDASSL failed to compute the initial ! YPRIME. ! ! ! ! IDID = -13,..,-32 -- Not applicable for this code ! ! *** Task terminated *** ! Reported by the value of IDID=-33 ! ! IDID = -33 -- The code has encountered trouble from which ! it cannot recover. A message is printed ! explaining the trouble and control is returned ! to the calling program. For example, this occurs ! when invalid input is detected. ! ! RTOL, ATOL -- These quantities remain unchanged except when ! IDID = -2. In this case, the error tolerances have been ! increased by the code to values which are estimated to ! be appropriate for continuing the integration. However, ! the reported solution at T was obtained using the input ! values of RTOL and ATOL. ! ! RWORK, IWORK -- Contain information which is usually of no ! interest to the user but necessary for subsequent calls. ! However, you may find use for ! ! RWORK(3)--Which contains the step size H to be ! attempted on the next step. ! ! RWORK(4)--Which contains the current value of the ! independent variable, i.e., the farthest point ! integration has reached. This will be different ! from T only when interpolation has been ! performed (IDID=3). ! ! RWORK(7)--Which contains the stepsize used ! on the last successful step. ! ! IWORK(7)--Which contains the order of the method to ! be attempted on the next step. ! ! IWORK(8)--Which contains the order of the method used ! on the last step. ! ! IWORK(11)--Which contains the number of steps taken so ! far. ! ! IWORK(12)--Which contains the number of calls to RES ! so far. ! ! IWORK(13)--Which contains the number of evaluations of ! the matrix of partial derivatives needed so ! far. ! ! IWORK(14)--Which contains the total number ! of error test failures so far. ! ! IWORK(15)--Which contains the total number ! of convergence test failures so far. ! (includes singular iteration matrix ! failures.) ! ! ! -------- INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ------------ ! (CALLS AFTER THE FIRST) ! ! This code is organized so that subsequent calls to continue the ! integration involve little (if any) additional effort on your ! part. You must monitor the IDID parameter in order to determine ! what to do next. ! ! Recalling that the principal task of the code is to integrate ! from T to TOUT (the interval mode), usually all you will need ! to do is specify a new TOUT upon reaching the current TOUT. ! ! Do not alter any quantity not specifically permitted below, ! in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*) ! or the differential equation in subroutine RES. Any such ! alteration constitutes a new problem and must be treated as such, ! i.e., you must start afresh. ! ! You cannot change from vector to scalar error control or vice ! versa (INFO(2)), but you can change the size of the entries of ! RTOL, ATOL. Increasing a tolerance makes the equation easier ! to integrate. Decreasing a tolerance will make the equation ! harder to integrate and should generally be avoided. ! ! You can switch from the intermediate-output mode to the ! interval mode (INFO(3)) or vice versa at any time. ! ! If it has been necessary to prevent the integration from going ! past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the ! code will not integrate to any TOUT beyond the currently ! specified TSTOP. Once TSTOP has been reached you must change ! the value of TSTOP or set INFO(4)=0. You may change INFO(4) ! or TSTOP at any time but you must supply the value of TSTOP in ! RWORK(1) whenever you set INFO(4)=1. ! ! Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) ! unless you are going to restart the code. ! ! *** Following a completed task *** ! If ! IDID = 1, call the code again to continue the integration ! another step in the direction of TOUT. ! ! IDID = 2 or 3, define a new TOUT and call the code again. ! TOUT must be different from T. You cannot change ! the direction of integration without restarting. ! ! *** Following an interrupted task *** ! To show the code that you realize the task was ! interrupted and that you want to continue, you ! must take appropriate action and set INFO(1) = 1 ! If ! IDID = -1, The code has taken about 500 steps. ! If you want to continue, set INFO(1) = 1 and ! call the code again. An additional 500 steps ! will be allowed. ! ! IDID = -2, The error tolerances RTOL, ATOL have been ! increased to values the code estimates appropriate ! for continuing. You may want to change them ! yourself. If you are sure you want to continue ! with relaxed error tolerances, set INFO(1)=1 and ! call the code again. ! ! IDID = -3, A solution component is zero and you set the ! corresponding component of ATOL to zero. If you ! are sure you want to continue, you must first ! alter the error criterion to use positive values ! for those components of ATOL corresponding to zero ! solution components, then set INFO(1)=1 and call ! the code again. ! ! IDID = -4,-5 --- Cannot occur with this code. ! ! IDID = -6, Repeated error test failures occurred on the ! last attempted step in SDASSL. A singularity in the ! solution may be present. If you are absolutely ! certain you want to continue, you should restart ! the integration. (Provide initial values of Y and ! YPRIME which are consistent) ! ! IDID = -7, Repeated convergence test failures occurred ! on the last attempted step in SDASSL. An inaccurate ! or ill-conditioned JACOBIAN may be the problem. If ! you are absolutely certain you want to continue, you ! should restart the integration. ! ! IDID = -8, The matrix of partial derivatives is singular. ! Some of your equations may be redundant. ! SDASSL cannot solve the problem as stated. ! It is possible that the redundant equations ! could be removed, and then SDASSL could ! solve the problem. It is also possible ! that a solution to your problem either ! does not exist or is not unique. ! ! IDID = -9, SDASSL had multiple convergence test ! failures, preceded by multiple error ! test failures, on the last attempted step. ! It is possible that your problem ! is ill-posed, and cannot be solved ! using this code. Or, there may be a ! discontinuity or a singularity in the ! solution. If you are absolutely certain ! you want to continue, you should restart ! the integration. ! ! IDID =-10, SDASSL had multiple convergence test failures ! because IRES was equal to minus one. ! If you are absolutely certain you want ! to continue, you should restart the ! integration. ! ! IDID =-11, IRES=-2 was encountered, and control is being ! returned to the calling program. ! ! IDID =-12, SDASSL failed to compute the initial YPRIME. ! This could happen because the initial ! approximation to YPRIME was not very good, or ! if a YPRIME consistent with the initial Y ! does not exist. The problem could also be caused ! by an inaccurate or singular iteration matrix. ! ! IDID = -13,..,-32 --- Cannot occur with this code. ! ! ! *** Following a terminated task *** ! ! If IDID= -33, you cannot continue the solution of this problem. ! An attempt to do so will result in your ! run being terminated. ! ! ! -------- ERROR MESSAGES --------------------------------------------- ! ! The SLATEC error print routine XERMSG is called in the event of ! unsuccessful completion of a task. Most of these are treated as ! "recoverable errors", which means that (unless the user has directed ! otherwise) control will be returned to the calling program for ! possible action after the message has been printed. ! ! In the event of a negative value of IDID other than -33, an appro- ! priate message is printed and the "error number" printed by XERMSG ! is the value of IDID. There are quite a number of illegal input ! errors that can lead to a returned value IDID=-33. The conditions ! and their printed "error numbers" are as follows: ! ! Error number Condition ! ! 1 Some element of INFO vector is not zero or one. ! 2 NEQ .le. 0 ! 3 MAXORD not in range. ! 4 LRW is less than the required length for RWORK. ! 5 LIW is less than the required length for IWORK. ! 6 Some element of RTOL is .lt. 0 ! 7 Some element of ATOL is .lt. 0 ! 8 All elements of RTOL and ATOL are zero. ! 9 INFO(4)=1 and TSTOP is behind TOUT. ! 10 HMAX .lt. 0.0 ! 11 TOUT is behind T. ! 12 INFO(8)=1 and H0=0.0 ! 13 Some element of WT is .le. 0.0 ! 14 TOUT is too close to T to start integration. ! 15 INFO(4)=1 and TSTOP is behind T. ! 16 --( Not used in this version )-- ! 17 ML illegal. Either .lt. 0 or .gt. NEQ ! 18 MU illegal. Either .lt. 0 or .gt. NEQ ! 19 TOUT = T. ! ! If SDASSL is called again without any action taken to remove the ! cause of an unsuccessful return, XERMSG will be called with a fatal ! error flag, which will cause unconditional termination of the ! program. There are two such fatal errors: ! ! Error number -998: The last step was terminated with a negative ! value of IDID other than -33, and no appropriate action was ! taken. ! ! Error number -999: The previous call was terminated because of ! illegal input (IDID=-33) and there is illegal input in the ! present call, as well. (Suspect infinite loop.) ! ! --------------------------------------------------------------------- ! !***REFERENCES A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC ! SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637, ! SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982. !***ROUTINES CALLED R1MACH, SDAINI, SDANRM, SDASTP, SDATRP, SDAWTS, ! XERMSG !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 880387 Code changes made. All common statements have been ! replaced by a DATA statement, which defines pointers into ! RWORK, and PARAMETER statements which define pointers ! into IWORK. As well the documentation has gone through ! grammatical changes. ! 881005 The prologue has been changed to mixed case. ! The subordinate routines had revision dates changed to ! this date, although the documentation for these routines ! is all upper case. No code changes. ! 890511 Code changes made. The DATA statement in the declaration ! section of SDASSL was replaced with a PARAMETER ! statement. Also the statement S = 100.E0 was removed ! from the top of the Newton iteration in SDASTP. ! The subordinate routines had revision dates changed to ! this date. ! 890517 The revision date syntax was replaced with the revision ! history syntax. Also the "DECK" comment was added to ! the top of all subroutines. These changes are consistent ! with new SLATEC guidelines. ! The subordinate routines had revision dates changed to ! this date. No code changes. ! 891013 Code changes made. ! Removed all occurrences of FLOAT. All operations ! are now performed with "mixed-mode" arithmetic. ! Also, specific function names were replaced with generic ! function names to be consistent with new SLATEC guidelines. ! In particular: ! Replaced AMIN1 with MIN everywhere. ! Replaced MIN0 with MIN everywhere. ! Replaced AMAX1 with MAX everywhere. ! Replaced MAX0 with MAX everywhere. ! Also replaced REVISION DATE with REVISION HISTORY in all ! subordinate routines. ! 901004 Miscellaneous changes to prologue to complete conversion ! to SLATEC 4.0 format. No code changes. (F.N.Fritsch) ! 901009 Corrected GAMS classification code and converted subsidiary ! routines to 4.0 format. No code changes. (F.N.Fritsch) ! 901010 Converted XERRWV calls to XERMSG calls. (R.Clemens, AFWL) ! 901019 Code changes made. ! Merged SLATEC 4.0 changes with previous changes made ! by C. Ulrich. Below is a history of the changes made by ! C. Ulrich. (Changes in subsidiary routines are implied ! by this history) ! 891228 Bug was found and repaired inside the SDASSL ! and SDAINI routines. SDAINI was incorrectly ! returning the initial T with Y and YPRIME ! computed at T+H. The routine now returns T+H ! rather than the initial T. ! Cosmetic changes made to SDASTP. ! 900904 Three modifications were made to fix a bug (inside ! SDASSL) re interpolation for continuation calls and ! cases where TN is very close to TSTOP: ! ! 1) In testing for whether H is too large, just ! compare H to (TSTOP - TN), rather than ! (TSTOP - TN) * (1-4*UROUND), and set H to ! TSTOP - TN. This will force SDASTP to step ! exactly to TSTOP under certain situations ! (i.e. when H returned from SDASTP would otherwise ! take TN beyond TSTOP). ! ! 2) Inside the SDASTP loop, interpolate exactly to ! TSTOP if TN is very close to TSTOP (rather than ! interpolating to within roundoff of TSTOP). ! ! 3) Modified IDID description for IDID = 2 to say ! that the solution is returned by stepping exactly ! to TSTOP, rather than TOUT. (In some cases the ! solution is actually obtained by extrapolating ! over a distance near unit roundoff to TSTOP, ! but this small distance is deemed acceptable in ! these circumstances.) ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue, removed unreferenced labels, ! and improved XERMSG calls. (FNF) ! 901030 Added ERROR MESSAGES section and reworked other sections to ! be of more uniform format. (FNF) ! 910624 Fixed minor bug related to HMAX (six lines after label ! 525). (LRP) !***END PROLOGUE SDASSL ! !**End ! ! Declare arguments. ! INTEGER NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*) REAL T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*), & RPAR(*) EXTERNAL RES, JAC ! ! Declare externals. ! EXTERNAL R1MACH, SDAINI, SDANRM, SDASTP, SDATRP, SDAWTS, XERMSG REAL R1MACH, SDANRM ! ! Declare local variables. ! INTEGER I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA, & LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, LIPVT, & LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD, & LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS, & LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP, & NZFLG REAL ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT, & TSTOP, UROUND, YPNORM LOGICAL DONE ! Auxiliary variables for conversion of values to be included in ! error messages. CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 ! ! SET POINTERS INTO IWORK PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, & LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16, & LIPVT=21, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, & LNS=9, LNSTL=10, LIWM=1) ! ! SET RELATIVE OFFSET INTO RWORK PARAMETER (NPD=1) ! ! SET POINTERS INTO RWORK PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, & LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, & LALPHA=11, LBETA=17, LGAMMA=23, & LPSI=29, LSIGMA=35, LDELTA=41) ! !***FIRST EXECUTABLE STATEMENT SDASSL if ( INFO(1) /= 0)go to 100 ! !----------------------------------------------------------------------- ! THIS BLOCK IS EXECUTED FOR THE INITIAL call ONLY. ! IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS. !----------------------------------------------------------------------- ! ! FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO ! ARE EITHER ZERO OR ONE. DO 10 I=2,11 if ( INFO(I) /= 0.AND.INFO(I) /= 1)go to 701 10 CONTINUE ! if ( NEQ <= 0)go to 702 ! ! CHECK AND COMPUTE MAXIMUM ORDER MXORD=5 if ( INFO(9) == 0)go to 20 MXORD=IWORK(LMXORD) if ( MXORD < 1.OR.MXORD > 5)go to 703 20 IWORK(LMXORD)=MXORD ! ! COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU. if ( INFO(6) /= 0)go to 40 LENPD=NEQ**2 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD if ( INFO(5) /= 0)go to 30 IWORK(LMTYPE)=2 go to 60 30 IWORK(LMTYPE)=1 go to 60 40 if ( IWORK(LML) < 0.OR.IWORK(LML) >= NEQ)go to 717 if ( IWORK(LMU) < 0.OR.IWORK(LMU) >= NEQ)go to 718 LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ if ( INFO(5) /= 0)go to 50 IWORK(LMTYPE)=5 MBAND=IWORK(LML)+IWORK(LMU)+1 MSAVE=(NEQ/MBAND)+1 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE go to 60 50 IWORK(LMTYPE)=4 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD ! ! CHECK LENGTHS OF RWORK AND IWORK 60 LENIW=20+NEQ IWORK(LNPD)=LENPD if ( LRW < LENRW)go to 704 if ( LIW < LENIW)go to 705 ! ! CHECK TO SEE THAT TOUT IS DIFFERENT FROM T if ( TOUT == T)go to 719 ! ! CHECK HMAX if ( INFO(7) == 0)go to 70 HMAX=RWORK(LHMAX) if ( HMAX <= 0.0E0)go to 710 70 CONTINUE ! ! INITIALIZE COUNTERS IWORK(LNST)=0 IWORK(LNRE)=0 IWORK(LNJE)=0 ! IWORK(LNSTL)=0 IDID=1 go to 200 ! !----------------------------------------------------------------------- ! THIS BLOCK IS FOR CONTINUATION CALLS ! ONLY. HERE WE CHECK INFO(1), AND if THE ! LAST STEP WAS INTERRUPTED WE CHECK WHETHER ! APPROPRIATE ACTION WAS TAKEN. !----------------------------------------------------------------------- ! 100 CONTINUE if ( INFO(1) == 1)go to 110 if ( INFO(1) /= -1)go to 701 ! ! if WE ARE HERE, THE LAST STEP WAS INTERRUPTED ! BY AN ERROR CONDITION FROM SDASTP, AND ! APPROPRIATE ACTION WAS NOT TAKEN. THIS ! IS A FATAL ERROR. WRITE (XERN1, '(I8)') IDID call XERMSG ('SLATEC', 'SDASSL', & 'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' // & XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN. ' // & 'RUN TERMINATED', -998, 2) return 110 CONTINUE IWORK(LNSTL)=IWORK(LNST) ! !----------------------------------------------------------------------- ! THIS BLOCK IS EXECUTED ON ALL CALLS. ! THE ERROR TOLERANCE PARAMETERS ARE ! CHECKED, AND THE WORK ARRAY POINTERS ! ARE SET. !----------------------------------------------------------------------- ! 200 CONTINUE ! CHECK RTOL,ATOL NZFLG=0 RTOLI=RTOL(1) ATOLI=ATOL(1) DO 210 I=1,NEQ if ( INFO(2) == 1)RTOLI=RTOL(I) if ( INFO(2) == 1)ATOLI=ATOL(I) if ( RTOLI > 0.0E0.OR.ATOLI > 0.0E0)NZFLG=1 if ( RTOLI < 0.0E0)go to 706 if ( ATOLI < 0.0E0)go to 707 210 CONTINUE if ( NZFLG == 0)go to 708 ! ! SET UP RWORK STORAGE.IWORK STORAGE IS FIXED ! IN DATA STATEMENT. LE=LDELTA+NEQ LWT=LE+NEQ LPHI=LWT+NEQ LPD=LPHI+(IWORK(LMXORD)+1)*NEQ LWM=LPD NTEMP=NPD+IWORK(LNPD) if ( INFO(1) == 1)go to 400 ! !----------------------------------------------------------------------- ! THIS BLOCK IS EXECUTED ON THE INITIAL CALL ! ONLY. SET THE INITIAL STEP SIZE, AND ! THE ERROR WEIGHT VECTOR, AND PHI. ! COMPUTE INITIAL YPRIME, if NECESSARY. !----------------------------------------------------------------------- ! TN=T IDID=1 ! ! SET ERROR WEIGHT VECTOR WT call SDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) DO 305 I = 1,NEQ if ( RWORK(LWT+I-1) <= 0.0E0) go to 713 305 CONTINUE ! ! COMPUTE UNIT ROUNDOFF AND HMIN UROUND = R1MACH(4) RWORK(LROUND) = UROUND HMIN = 4.0E0*UROUND*MAX(ABS(T),ABS(TOUT)) ! ! CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH TDIST = ABS(TOUT - T) if ( TDIST < HMIN) go to 714 ! ! CHECK HO, if THIS WAS INPUT if (INFO(8) == 0) go to 310 HO = RWORK(LH) if ((TOUT - T)*HO < 0.0E0) go to 711 if (HO == 0.0E0) go to 712 go to 320 310 CONTINUE ! ! COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER ! SDASTP OR SDAINI, DEPENDING ON INFO(11) HO = 0.001E0*TDIST YPNORM = SDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) if (YPNORM > 0.5E0/HO) HO = 0.5E0/YPNORM HO = SIGN(HO,TOUT-T) ! ADJUST HO if NECESSARY TO MEET HMAX BOUND 320 if (INFO(7) == 0) go to 330 RH = ABS(HO)/RWORK(LHMAX) if (RH > 1.0E0) HO = HO/RH ! COMPUTE TSTOP, if APPLICABLE 330 if (INFO(4) == 0) go to 340 TSTOP = RWORK(LTSTOP) if ((TSTOP - T)*HO < 0.0E0) go to 715 if ((T + HO - TSTOP)*HO > 0.0E0) HO = TSTOP - T if ((TSTOP - TOUT)*HO < 0.0E0) go to 709 ! ! COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, if APPLICABLE 340 if (INFO(11) == 0) go to 350 call SDAINI(TN,Y,YPRIME,NEQ, & RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, & RWORK(LPHI),RWORK(LDELTA),RWORK(LE), & RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), & INFO(10),NTEMP) if (IDID < 0) go to 390 ! ! LOAD H WITH HO. STORE H IN RWORK(LH) 350 H = HO RWORK(LH) = H ! ! LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2) ITEMP = LPHI + NEQ DO 370 I = 1,NEQ RWORK(LPHI + I - 1) = Y(I) 370 RWORK(ITEMP + I - 1) = H*YPRIME(I) ! 390 go to 500 ! !------------------------------------------------------- ! THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS ! PURPOSE IS TO CHECK STOP CONDITIONS BEFORE ! TAKING A STEP. ! ADJUST H if NECESSARY TO MEET HMAX BOUND !------------------------------------------------------- ! 400 CONTINUE UROUND=RWORK(LROUND) DONE = .FALSE. TN=RWORK(LTN) H=RWORK(LH) if ( INFO(7) == 0) go to 410 RH = ABS(H)/RWORK(LHMAX) if ( RH > 1.0E0) H = H/RH 410 CONTINUE if ( T == TOUT) go to 719 if ( (T - TOUT)*H > 0.0E0) go to 711 if ( INFO(4) == 1) go to 430 if ( INFO(3) == 1) go to 420 if ( (TN-TOUT)*H < 0.0E0)go to 490 call SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. go to 490 420 if ( (TN-T)*H <= 0.0E0) go to 490 if ( (TN - TOUT)*H > 0.0E0) go to 425 call SDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. go to 490 425 CONTINUE call SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. go to 490 430 if ( INFO(3) == 1) go to 440 TSTOP=RWORK(LTSTOP) if ( (TN-TSTOP)*H > 0.0E0) go to 715 if ( (TSTOP-TOUT)*H < 0.0E0)go to 709 if ( (TN-TOUT)*H < 0.0E0)go to 450 call SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. go to 490 440 TSTOP = RWORK(LTSTOP) if ( (TN-TSTOP)*H > 0.0E0) go to 715 if ( (TSTOP-TOUT)*H < 0.0E0) go to 709 if ( (TN-T)*H <= 0.0E0) go to 450 if ( (TN - TOUT)*H > 0.0E0) go to 445 call SDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. go to 490 445 CONTINUE call SDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. go to 490 450 CONTINUE ! CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP if ( ABS(TN-TSTOP) > 100.0E0*UROUND* & (ABS(TN)+ABS(H)))go to 460 call SDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), & RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP DONE = .TRUE. go to 490 460 TNEXT=TN+H if ( (TNEXT-TSTOP)*H <= 0.0E0)go to 490 H=TSTOP-TN RWORK(LH)=H ! 490 if (DONE) go to 580 ! !------------------------------------------------------- ! THE NEXT BLOCK CONTAINS THE call TO THE ! ONE-STEP INTEGRATOR SDASTP. ! THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. ! CHECK FOR TOO MANY STEPS. ! UPDATE WT. ! CHECK FOR TOO MUCH ACCURACY REQUESTED. ! COMPUTE MINIMUM STEPSIZE. !------------------------------------------------------- ! 500 CONTINUE ! CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME if (IDID == -12) go to 527 ! ! CHECK FOR TOO MANY STEPS if ( (IWORK(LNST)-IWORK(LNSTL)) < 500) & go to 510 IDID=-1 go to 527 ! ! UPDATE WT 510 call SDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), & RWORK(LWT),RPAR,IPAR) DO 520 I=1,NEQ if ( RWORK(I+LWT-1) > 0.0E0)go to 520 IDID=-3 go to 527 520 CONTINUE ! ! TEST FOR TOO MUCH ACCURACY REQUESTED. R=SDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* & 100.0E0*UROUND if ( R <= 1.0E0)go to 525 ! MULTIPLY RTOL AND ATOL BY R AND RETURN if ( INFO(2) == 1)go to 523 RTOL(1)=R*RTOL(1) ATOL(1)=R*ATOL(1) IDID=-2 go to 527 523 DO 524 I=1,NEQ RTOL(I)=R*RTOL(I) 524 ATOL(I)=R*ATOL(I) IDID=-2 go to 527 525 CONTINUE ! ! COMPUTE MINIMUM STEPSIZE HMIN=4.0E0*UROUND*MAX(ABS(TN),ABS(TOUT)) ! ! TEST H VS. HMAX if (INFO(7) /= 0) THEN RH = ABS(H)/RWORK(LHMAX) if (RH > 1.0E0) H = H/RH end if ! call SDASTP(TN,Y,YPRIME,NEQ, & RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, & RWORK(LPHI),RWORK(LDELTA),RWORK(LE), & RWORK(LWM),IWORK(LIWM), & RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), & RWORK(LPSI),RWORK(LSIGMA), & RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD), & RWORK(LS),HMIN,RWORK(LROUND), & IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), & IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) 527 if ( IDID < 0)go to 600 ! !-------------------------------------------------------- ! THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN ! FROM SDASTP (IDID=1). TEST FOR STOP CONDITIONS. !-------------------------------------------------------- ! if ( INFO(4) /= 0)go to 540 if ( INFO(3) /= 0)go to 530 if ( (TN-TOUT)*H < 0.0E0)go to 500 call SDATRP(TN,TOUT,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT go to 580 530 if ( (TN-TOUT)*H >= 0.0E0)go to 535 T=TN IDID=1 go to 580 535 call SDATRP(TN,TOUT,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT go to 580 540 if ( INFO(3) /= 0)go to 550 if ( (TN-TOUT)*H < 0.0E0)go to 542 call SDATRP(TN,TOUT,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 go to 580 542 if ( ABS(TN-TSTOP) <= 100.0E0*UROUND* & (ABS(TN)+ABS(H)))go to 545 TNEXT=TN+H if ( (TNEXT-TSTOP)*H <= 0.0E0)go to 500 H=TSTOP-TN go to 500 545 call SDATRP(TN,TSTOP,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP go to 580 550 if ( (TN-TOUT)*H >= 0.0E0)go to 555 if ( ABS(TN-TSTOP) <= 100.0E0*UROUND*(ABS(TN)+ABS(H)))go to 552 T=TN IDID=1 go to 580 552 call SDATRP(TN,TSTOP,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP go to 580 555 call SDATRP(TN,TOUT,Y,YPRIME,NEQ, & IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 go to 580 ! !-------------------------------------------------------- ! ALL SUCCESSFUL RETURNS FROM SDASSL ARE MADE FROM ! THIS BLOCK. !-------------------------------------------------------- ! 580 CONTINUE RWORK(LTN)=TN RWORK(LH)=H return ! !----------------------------------------------------------------------- ! THIS BLOCK HANDLES ALL UNSUCCESSFUL ! returnS OTHER THAN FOR ILLEGAL INPUT. !----------------------------------------------------------------------- ! 600 CONTINUE ITEMP=-IDID go to (610,620,630,690,690,640,650,660,670,675, & 680,685), ITEMP ! ! THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE ! REACHING TOUT 610 WRITE (XERN3, '(1P,E15.6)') TN call XERMSG ('SLATEC', 'SDASSL', & 'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' // & 'CALL BEFORE REACHING TOUT', IDID, 1) go to 690 ! ! TOO MUCH ACCURACY FOR MACHINE PRECISION 620 WRITE (XERN3, '(1P,E15.6)') TN call XERMSG ('SLATEC', 'SDASSL', & 'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' // & 'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' // & 'APPROPRIATE VALUES', IDID, 1) go to 690 ! ! WT(I) <= 0.0 FOR SOME I (NOT AT START OF PROBLEM) 630 WRITE (XERN3, '(1P,E15.6)') TN call XERMSG ('SLATEC', 'SDASSL', & 'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME <= ' // & '0.0', IDID, 1) go to 690 ! ! ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN 640 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H call XERMSG ('SLATEC', 'SDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN', & IDID, 1) go to 690 ! ! CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN 650 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H call XERMSG ('SLATEC', 'SDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' // & 'ABS(H)=HMIN', IDID, 1) go to 690 ! ! THE ITERATION MATRIX IS SINGULAR 660 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H call XERMSG ('SLATEC', 'SDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE ITERATION MATRIX IS SINGULAR', IDID, 1) go to 690 ! ! CORRECTOR FAILURE PRECEDED BY ERROR TEST FAILURES. 670 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H call XERMSG ('SLATEC', 'SDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE CORRECTOR COULD NOT CONVERGE. ALSO, THE ERROR TEST ' // & 'FAILED REPEATEDLY.', IDID, 1) go to 690 ! ! CORRECTOR FAILURE BECAUSE IRES = -1 675 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H call XERMSG ('SLATEC', 'SDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' // & 'TO MINUS ONE', IDID, 1) go to 690 ! ! FAILURE BECAUSE IRES = -2 680 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') H call XERMSG ('SLATEC', 'SDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' IRES WAS EQUAL TO MINUS TWO', IDID, 1) go to 690 ! ! FAILED TO COMPUTE INITIAL YPRIME 685 WRITE (XERN3, '(1P,E15.6)') TN WRITE (XERN4, '(1P,E15.6)') HO call XERMSG ('SLATEC', 'SDASSL', & 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // & ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1) go to 690 ! 690 CONTINUE INFO(1)=-1 T=TN RWORK(LTN)=TN RWORK(LH)=H return ! !----------------------------------------------------------------------- ! THIS BLOCK HANDLES ALL ERROR RETURNS DUE ! TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING ! SDASTP. FIRST THE ERROR MESSAGE ROUTINE IS ! CALLED. if THIS HAPPENS TWICE IN ! SUCCESSION, EXECUTION IS TERMINATED ! !----------------------------------------------------------------------- 701 call XERMSG ('SLATEC', 'SDASSL', & 'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1) go to 750 ! 702 WRITE (XERN1, '(I8)') NEQ call XERMSG ('SLATEC', 'SDASSL', & 'NEQ = ' // XERN1 // ' <= 0', 2, 1) go to 750 ! 703 WRITE (XERN1, '(I8)') MXORD call XERMSG ('SLATEC', 'SDASSL', & 'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1) go to 750 ! 704 WRITE (XERN1, '(I8)') LENRW WRITE (XERN2, '(I8)') LRW call XERMSG ('SLATEC', 'SDASSL', & 'RWORK LENGTH NEEDED, LENRW = ' // XERN1 // & ', EXCEEDS LRW = ' // XERN2, 4, 1) go to 750 ! 705 WRITE (XERN1, '(I8)') LENIW WRITE (XERN2, '(I8)') LIW call XERMSG ('SLATEC', 'SDASSL', & 'IWORK LENGTH NEEDED, LENIW = ' // XERN1 // & ', EXCEEDS LIW = ' // XERN2, 5, 1) go to 750 ! 706 call XERMSG ('SLATEC', 'SDASSL', & 'SOME ELEMENT OF RTOL IS < 0', 6, 1) go to 750 ! 707 call XERMSG ('SLATEC', 'SDASSL', & 'SOME ELEMENT OF ATOL IS < 0', 7, 1) go to 750 ! 708 call XERMSG ('SLATEC', 'SDASSL', & 'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1) go to 750 ! 709 WRITE (XERN3, '(1P,E15.6)') TSTOP WRITE (XERN4, '(1P,E15.6)') TOUT call XERMSG ('SLATEC', 'SDASSL', & 'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' // & XERN4, 9, 1) go to 750 ! 710 WRITE (XERN3, '(1P,E15.6)') HMAX call XERMSG ('SLATEC', 'SDASSL', & 'HMAX = ' // XERN3 // ' < 0.0', 10, 1) go to 750 ! 711 WRITE (XERN3, '(1P,E15.6)') TOUT WRITE (XERN4, '(1P,E15.6)') T call XERMSG ('SLATEC', 'SDASSL', & 'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1) go to 750 ! 712 call XERMSG ('SLATEC', 'SDASSL', & 'INFO(8)=1 AND H0=0.0', 12, 1) go to 750 ! 713 call XERMSG ('SLATEC', 'SDASSL', & 'SOME ELEMENT OF WT IS <= 0.0', 13, 1) go to 750 ! 714 WRITE (XERN3, '(1P,E15.6)') TOUT WRITE (XERN4, '(1P,E15.6)') T call XERMSG ('SLATEC', 'SDASSL', & 'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 // & ' TO START INTEGRATION', 14, 1) go to 750 ! 715 WRITE (XERN3, '(1P,E15.6)') TSTOP WRITE (XERN4, '(1P,E15.6)') T call XERMSG ('SLATEC', 'SDASSL', & 'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4, & 15, 1) go to 750 ! 717 WRITE (XERN1, '(I8)') IWORK(LML) call XERMSG ('SLATEC', 'SDASSL', & 'ML = ' // XERN1 // ' ILLEGAL. EITHER < 0 OR > NEQ', & 17, 1) go to 750 ! 718 WRITE (XERN1, '(I8)') IWORK(LMU) call XERMSG ('SLATEC', 'SDASSL', & 'MU = ' // XERN1 // ' ILLEGAL. EITHER < 0 OR > NEQ', & 18, 1) go to 750 ! 719 WRITE (XERN3, '(1P,E15.6)') TOUT call XERMSG ('SLATEC', 'SDASSL', & 'TOUT = T = ' // XERN3, 19, 1) go to 750 ! 750 IDID=-33 if ( INFO(1) == -1) THEN call XERMSG ('SLATEC', 'SDASSL', & 'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' // & 'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2) end if ! INFO(1)=-1 return !-----------END OF SUBROUTINE SDASSL------------------------------------ end subroutine SDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART, & IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA, & PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC, K, & KOLD, NS, NONNEG, NTEMP) ! !! SDASTP performs one step of the SDASSL integration. ! !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDASTP-S, DDASTP-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! SDASTP SOLVES A SYSTEM OF DIFFERENTIAL/ ! ALGEBRAIC EQUATIONS OF THE FORM ! G(X,Y,YPRIME) = 0, FOR ONE STEP (NORMALLY ! FROM X TO X+H). ! ! THE METHODS USED ARE MODIFIED DIVIDED ! DIFFERENCE,FIXED LEADING COEFFICIENT ! FORMS OF BACKWARD DIFFERENTIATION ! FORMULAS. THE CODE ADJUSTS THE STEPSIZE ! AND ORDER TO CONTROL THE LOCAL ERROR PER ! STEP. ! ! ! THE PARAMETERS REPRESENT ! X -- INDEPENDENT VARIABLE ! Y -- SOLUTION VECTOR AT X ! YPRIME -- DERIVATIVE OF SOLUTION VECTOR ! AFTER SUCCESSFUL STEP ! NEQ -- NUMBER OF EQUATIONS TO BE INTEGRATED ! RES -- EXTERNAL USER-SUPPLIED SUBROUTINE ! TO EVALUATE THE RESIDUAL. THE call IS ! call RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) ! X,Y,YPRIME ARE INPUT. DELTA IS OUTPUT. ! ON INPUT, IRES=0. RES SHOULD ALTER IRES ONLY ! if IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A ! STOP CONDITION. SET IRES=-1 if AN INPUT VALUE ! OF Y IS ILLEGAL, AND SDASTP WILL TRY TO SOLVE ! THE PROBLEM WITHOUT GETTING IRES = -1. IF ! IRES=-2, SDASTP RETURNS CONTROL TO THE CALLING ! PROGRAM WITH IDID = -11. ! JAC -- EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE ! THE ITERATION MATRIX (THIS IS OPTIONAL) ! THE call IS OF THE FORM ! call JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR) ! PD IS THE MATRIX OF PARTIAL DERIVATIVES, ! PD=DG/DY+CJ*DG/DYPRIME ! H -- APPROPRIATE STEP SIZE FOR NEXT STEP. ! NORMALLY DETERMINED BY THE CODE ! WT -- VECTOR OF WEIGHTS FOR ERROR CRITERION. ! JSTART -- INTEGER VARIABLE SET 0 FOR ! FIRST STEP, 1 OTHERWISE. ! IDID -- COMPLETION CODE WITH THE FOLLOWING MEANINGS: ! IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY ! IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY ! IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE ! IDID=-8 -- THE ITERATION MATRIX IS SINGULAR ! IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE. ! THERE WERE REPEATED ERROR TEST ! FAILURES ON THIS STEP. ! IDID=-10-- THE CORRECTOR COULD NOT CONVERGE ! BECAUSE IRES WAS EQUAL TO MINUS ONE ! IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED, ! AND CONTROL IS BEING RETURNED TO ! THE CALLING PROGRAM ! RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS THAT ! ARE USED FOR COMMUNICATION BETWEEN THE ! CALLING PROGRAM AND EXTERNAL USER ROUTINES ! THEY ARE NOT ALTERED BY SDASTP ! PHI -- ARRAY OF DIVIDED DIFFERENCES USED BY ! SDASTP. THE LENGTH IS NEQ*(K+1),WHERE ! K IS THE MAXIMUM ORDER ! DELTA,E -- WORK VECTORS FOR SDASTP OF LENGTH NEQ ! WM,IWM -- REAL AND INTEGER ARRAYS STORING ! MATRIX INFORMATION SUCH AS THE MATRIX ! OF PARTIAL DERIVATIVES,PERMUTATION ! VECTOR, AND VARIOUS OTHER INFORMATION. ! ! THE OTHER PARAMETERS ARE INFORMATION ! WHICH IS NEEDED INTERNALLY BY SDASTP TO ! CONTINUE FROM STEP TO STEP. ! !----------------------------------------------------------------------- !***ROUTINES CALLED SDAJAC, SDANRM, SDASLV, SDATRP !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) !***END PROLOGUE SDASTP ! INTEGER NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K, & KOLD, NS, NONNEG, NTEMP REAL X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), & E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ, & CJOLD, HOLD, S, HMIN, UROUND EXTERNAL RES, JAC ! EXTERNAL SDAJAC, SDANRM, SDASLV, SDATRP REAL SDANRM ! INTEGER I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF, & LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1 REAL ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1, & ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, & TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE LOGICAL CONVGD ! PARAMETER (LMXORD=3) PARAMETER (LNST=11) PARAMETER (LNRE=12) PARAMETER (LNJE=13) PARAMETER (LETF=14) PARAMETER (LCTF=15) ! DATA MAXIT/4/ DATA XRATE/0.25E0/ ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 1. ! INITIALIZE. ON THE FIRST CALL,SET ! THE ORDER TO 1 AND INITIALIZE ! OTHER VARIABLES. !----------------------------------------------------------------------- ! ! INITIALIZATIONS FOR ALL CALLS !***FIRST EXECUTABLE STATEMENT SDASTP IDID=1 XOLD=X NCF=0 NSF=0 NEF=0 if ( JSTART /= 0) go to 120 ! ! if THIS IS THE FIRST STEP,PERFORM ! OTHER INITIALIZATIONS IWM(LETF) = 0 IWM(LCTF) = 0 K=1 KOLD=0 HOLD=0.0E0 JSTART=1 PSI(1)=H CJOLD = 1.0E0/H CJ = CJOLD S = 100.E0 JCALC = -1 DELNRM=1.0E0 IPHASE = 0 NS=0 120 CONTINUE ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 2 ! COMPUTE COEFFICIENTS OF FORMULAS FOR ! THIS STEP. !----------------------------------------------------------------------- 200 CONTINUE KP1=K+1 KP2=K+2 KM1=K-1 XOLD=X if ( H /= HOLD.OR.K /= KOLD) NS = 0 NS=MIN(NS+1,KOLD+2) NSP1=NS+1 if ( KP1 < NS)go to 230 ! BETA(1)=1.0E0 ALPHA(1)=1.0E0 TEMP1=H GAMMA(1)=0.0E0 SIGMA(1)=1.0E0 DO 210 I=2,KP1 TEMP2=PSI(I-1) PSI(I-1)=TEMP1 BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 TEMP1=TEMP2+H ALPHA(I)=H/TEMP1 SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H 210 CONTINUE PSI(KP1)=TEMP1 230 CONTINUE ! ! COMPUTE ALPHAS, ALPHA0 ALPHAS = 0.0E0 ALPHA0 = 0.0E0 DO 240 I = 1,K ALPHAS = ALPHAS - 1.0E0/I ALPHA0 = ALPHA0 - ALPHA(I) 240 CONTINUE ! ! COMPUTE LEADING COEFFICIENT CJ CJLAST = CJ CJ = -ALPHAS/H ! ! COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) CK = MAX(CK,ALPHA(KP1)) ! ! DECIDE WHETHER NEW JACOBIAN IS NEEDED TEMP1 = (1.0E0 - XRATE)/(1.0E0 + XRATE) TEMP2 = 1.0E0/TEMP1 if (CJ/CJOLD < TEMP1 .OR. CJ/CJOLD > TEMP2) JCALC = -1 if (CJ /= CJLAST) S = 100.E0 ! ! CHANGE PHI TO PHI STAR if ( KP1 < NSP1) go to 280 DO 270 J=NSP1,KP1 DO 260 I=1,NEQ 260 PHI(I,J)=BETA(J)*PHI(I,J) 270 CONTINUE 280 CONTINUE ! ! UPDATE TIME X=X+H ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 3 ! PREDICT THE SOLUTION AND DERIVATIVE, ! AND SOLVE THE CORRECTOR EQUATION !----------------------------------------------------------------------- ! ! FIRST,PREDICT THE SOLUTION AND DERIVATIVE 300 CONTINUE DO 310 I=1,NEQ Y(I)=PHI(I,1) 310 YPRIME(I)=0.0E0 DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) 320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 330 CONTINUE PNORM = SDANRM (NEQ,Y,WT,RPAR,IPAR) ! ! ! ! SOLVE THE CORRECTOR EQUATION USING A ! MODIFIED NEWTON SCHEME. CONVGD= .TRUE. M=0 IWM(LNRE)=IWM(LNRE)+1 IRES = 0 call RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) if (IRES < 0) go to 380 ! ! ! if INDICATED,REEVALUATE THE ! ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME ! (WHERE G(X,Y,YPRIME)=0). SET ! JCALC TO 0 AS AN INDICATOR THAT ! THIS HAS BEEN DONE. if ( JCALC /= -1)go to 340 IWM(LNJE)=IWM(LNJE)+1 JCALC=0 call SDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, & IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR, & IPAR,NTEMP) CJOLD=CJ S = 100.E0 if (IRES < 0) go to 380 if ( IER /= 0)go to 380 NSF=0 ! ! ! INITIALIZE THE ERROR ACCUMULATION VECTOR E. 340 CONTINUE DO 345 I=1,NEQ 345 E(I)=0.0E0 ! ! ! CORRECTOR LOOP. 350 CONTINUE ! ! MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE TEMP1 = 2.0E0/(1.0E0 + CJ/CJOLD) DO 355 I = 1,NEQ 355 DELTA(I) = DELTA(I) * TEMP1 ! ! COMPUTE A NEW ITERATE (BACK-SUBSTITUTION). ! STORE THE CORRECTION IN DELTA. call SDASLV(NEQ,DELTA,WM,IWM) ! ! UPDATE Y, E, AND YPRIME DO 360 I=1,NEQ Y(I)=Y(I)-DELTA(I) E(I)=E(I)-DELTA(I) 360 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) ! ! TEST FOR CONVERGENCE OF THE ITERATION DELNRM=SDANRM(NEQ,DELTA,WT,RPAR,IPAR) if (DELNRM <= 100.E0*UROUND*PNORM) go to 375 if (M > 0) go to 365 OLDNRM = DELNRM go to 367 365 RATE = (DELNRM/OLDNRM)**(1.0E0/M) if (RATE > 0.90E0) go to 370 S = RATE/(1.0E0 - RATE) 367 if (S*DELNRM <= 0.33E0) go to 375 ! ! THE CORRECTOR HAS NOT YET CONVERGED. ! UPDATE M AND TEST WHETHER THE ! MAXIMUM NUMBER OF ITERATIONS HAVE ! BEEN TRIED. M=M+1 if ( M >= MAXIT)go to 370 ! ! EVALUATE THE RESIDUAL ! AND GO BACK TO DO ANOTHER ITERATION IWM(LNRE)=IWM(LNRE)+1 IRES = 0 call RES(X,Y,YPRIME,DELTA,IRES, & RPAR,IPAR) if (IRES < 0) go to 380 go to 350 ! ! ! THE CORRECTOR FAILED TO CONVERGE IN MAXIT ! ITERATIONS. if THE ITERATION MATRIX ! IS NOT CURRENT,RE-DO THE STEP WITH ! A NEW ITERATION MATRIX. 370 CONTINUE if ( JCALC == 0)go to 380 JCALC=-1 go to 300 ! ! ! THE ITERATION HAS CONVERGED. if NONNEGATIVITY OF SOLUTION IS ! REQUIRED, SET THE SOLUTION NONNEGATIVE, if THE PERTURBATION ! TO DO IT IS SMALL ENOUGH. if THE CHANGE IS TOO LARGE, THEN ! CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED. 375 if ( NONNEG == 0) go to 390 DO 377 I = 1,NEQ 377 DELTA(I) = MIN(Y(I),0.0E0) DELNRM = SDANRM(NEQ,DELTA,WT,RPAR,IPAR) if ( DELNRM > 0.33E0) go to 380 DO 378 I = 1,NEQ 378 E(I) = E(I) - DELTA(I) go to 390 ! ! ! EXITS FROM BLOCK 3 ! NO CONVERGENCE WITH CURRENT ITERATION ! MATRIX,OR SINGULAR ITERATION MATRIX 380 CONVGD= .FALSE. 390 JCALC = 1 if ( .NOT.CONVGD)go to 600 ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 4 ! ESTIMATE THE ERRORS AT ORDERS K,K-1,K-2 ! AS if CONSTANT STEPSIZE WAS USED. ESTIMATE ! THE LOCAL ERROR AT ORDER K AND TEST ! WHETHER THE CURRENT STEP IS SUCCESSFUL. !----------------------------------------------------------------------- ! ! ESTIMATE ERRORS AT ORDERS K,K-1,K-2 ENORM = SDANRM(NEQ,E,WT,RPAR,IPAR) ERK = SIGMA(K+1)*ENORM TERK = (K+1)*ERK EST = ERK KNEW=K if ( K == 1)go to 430 DO 405 I = 1,NEQ 405 DELTA(I) = PHI(I,KP1) + E(I) ERKM1=SIGMA(K)*SDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKM1 = K*ERKM1 if ( K > 2)go to 410 if ( TERKM1 <= 0.5E0*TERK)go to 420 go to 430 410 CONTINUE DO 415 I = 1,NEQ 415 DELTA(I) = PHI(I,K) + DELTA(I) ERKM2=SIGMA(K-1)*SDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKM2 = (K-1)*ERKM2 if ( MAX(TERKM1,TERKM2) > TERK)go to 430 ! LOWER THE ORDER 420 CONTINUE KNEW=K-1 EST = ERKM1 ! ! ! CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP ! TO SEE if THE STEP WAS SUCCESSFUL 430 CONTINUE ERR = CK * ENORM if ( ERR > 1.0E0)go to 600 ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 5 ! THE STEP IS SUCCESSFUL. DETERMINE ! THE BEST ORDER AND STEPSIZE FOR ! THE NEXT STEP. UPDATE THE DIFFERENCES ! FOR THE NEXT STEP. !----------------------------------------------------------------------- IDID=1 IWM(LNST)=IWM(LNST)+1 KDIFF=K-KOLD KOLD=K HOLD=H ! ! ! ESTIMATE THE ERROR AT ORDER K+1 UNLESS: ! ALREADY DECIDED TO LOWER ORDER, OR ! ALREADY USING MAXIMUM ORDER, OR ! STEPSIZE NOT CONSTANT, OR ! ORDER RAISED IN PREVIOUS STEP if ( KNEW == KM1.OR.K == IWM(LMXORD))IPHASE=1 if ( IPHASE == 0)go to 545 if ( KNEW == KM1)go to 540 if ( K == IWM(LMXORD)) go to 550 if ( KP1 >= NS.OR.KDIFF == 1)go to 550 DO 510 I=1,NEQ 510 DELTA(I)=E(I)-PHI(I,KP2) ERKP1 = (1.0E0/(K+2))*SDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKP1 = (K+2)*ERKP1 if ( K > 1)go to 520 if ( TERKP1 >= 0.5E0*TERK)go to 550 go to 530 520 if ( TERKM1 <= MIN(TERK,TERKP1))go to 540 if ( TERKP1 >= TERK.OR.K == IWM(LMXORD))go to 550 ! ! RAISE ORDER 530 K=KP1 EST = ERKP1 go to 550 ! ! LOWER ORDER 540 K=KM1 EST = ERKM1 go to 550 ! ! if IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY ! FACTOR TWO 545 K = KP1 HNEW = H*2.0E0 H = HNEW go to 575 ! ! ! DETERMINE THE APPROPRIATE STEPSIZE FOR ! THE NEXT STEP. 550 HNEW=H TEMP2=K+1 R=(2.0E0*EST+0.0001E0)**(-1.0E0/TEMP2) if ( R < 2.0E0) go to 555 HNEW = 2.0E0*H go to 560 555 if ( R > 1.0E0) go to 560 R = MAX(0.5E0,MIN(0.9E0,R)) HNEW = H*R 560 H=HNEW ! ! ! UPDATE DIFFERENCES FOR NEXT STEP 575 CONTINUE if ( KOLD == IWM(LMXORD))go to 585 DO 580 I=1,NEQ 580 PHI(I,KP2)=E(I) 585 CONTINUE DO 590 I=1,NEQ 590 PHI(I,KP1)=PHI(I,KP1)+E(I) DO 595 J1=2,KP1 J=KP1-J1+1 DO 595 I=1,NEQ 595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) return ! ! ! ! ! !----------------------------------------------------------------------- ! BLOCK 6 ! THE STEP IS UNSUCCESSFUL. RESTORE X,PSI,PHI ! DETERMINE APPROPRIATE STEPSIZE FOR ! CONTINUING THE INTEGRATION, OR EXIT WITH ! AN ERROR FLAG if THERE HAVE BEEN MANY ! FAILURES. !----------------------------------------------------------------------- 600 IPHASE = 1 ! ! RESTORE X,PHI,PSI X=XOLD if ( KP1 < NSP1)go to 630 DO 620 J=NSP1,KP1 TEMP1=1.0E0/BETA(J) DO 610 I=1,NEQ 610 PHI(I,J)=TEMP1*PHI(I,J) 620 CONTINUE 630 CONTINUE DO 640 I=2,KP1 640 PSI(I-1)=PSI(I)-H ! ! ! TEST WHETHER FAILURE IS DUE TO CORRECTOR ITERATION ! OR ERROR TEST if ( CONVGD)go to 660 IWM(LCTF)=IWM(LCTF)+1 ! ! ! THE NEWTON ITERATION FAILED TO CONVERGE WITH ! A CURRENT ITERATION MATRIX. DETERMINE THE CAUSE ! OF THE FAILURE AND TAKE APPROPRIATE ACTION. if ( IER == 0)go to 650 ! ! THE ITERATION MATRIX IS SINGULAR. REDUCE ! THE STEPSIZE BY A FACTOR OF 4. IF ! THIS HAPPENS THREE TIMES IN A ROW ON ! THE SAME STEP, RETURN WITH AN ERROR FLAG NSF=NSF+1 R = 0.25E0 H=H*R if (NSF < 3 .AND. ABS(H) >= HMIN) go to 690 IDID=-8 go to 675 ! ! ! THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON ! OTHER THAN A SINGULAR ITERATION MATRIX. if IRES = -2, THEN ! return. OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS ! TOO MANY FAILURES HAVE OCCURRED. 650 CONTINUE if (IRES > -2) go to 655 IDID = -11 go to 675 655 NCF = NCF + 1 R = 0.25E0 H = H*R if (NCF < 10 .AND. ABS(H) >= HMIN) go to 690 IDID = -7 if (IRES < 0) IDID = -10 if (NEF >= 3) IDID = -9 go to 675 ! ! ! THE NEWTON SCHEME CONVERGED, AND THE CAUSE ! OF THE FAILURE WAS THE ERROR ESTIMATE ! EXCEEDING THE TOLERANCE. 660 NEF=NEF+1 IWM(LETF)=IWM(LETF)+1 if (NEF > 1) go to 665 ! ! ON FIRST ERROR TEST FAILURE, KEEP CURRENT ORDER OR LOWER ! ORDER BY ONE. COMPUTE NEW STEPSIZE BASED ON DIFFERENCES ! OF THE SOLUTION. K = KNEW TEMP2 = K + 1 R = 0.90E0*(2.0E0*EST+0.0001E0)**(-1.0E0/TEMP2) R = MAX(0.25E0,MIN(0.9E0,R)) H = H*R if (ABS(H) >= HMIN) go to 690 IDID = -6 go to 675 ! ! ON SECOND ERROR TEST FAILURE, USE THE CURRENT ORDER OR ! DECREASE ORDER BY ONE. REDUCE THE STEPSIZE BY A FACTOR OF ! FOUR. 665 if (NEF > 2) go to 670 K = KNEW H = 0.25E0*H if (ABS(H) >= HMIN) go to 690 IDID = -6 go to 675 ! ! ON THIRD AND SUBSEQUENT ERROR TEST FAILURES, SET THE ORDER TO ! ONE AND REDUCE THE STEPSIZE BY A FACTOR OF FOUR. 670 K = 1 H = 0.25E0*H if (ABS(H) >= HMIN) go to 690 IDID = -6 go to 675 ! ! ! ! ! FOR ALL CRASHES, RESTORE Y TO ITS LAST VALUE, ! INTERPOLATE TO FIND YPRIME AT LAST X, AND RETURN 675 CONTINUE call SDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) return ! ! ! GO BACK AND TRY THIS STEP AGAIN 690 go to 200 ! !------END OF SUBROUTINE SDASTP------ end subroutine SDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI) ! !! SDATRP is the interpolation routine for SDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDATRP-S, DDATRP-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! THE METHODS IN SUBROUTINE SDASTP USE POLYNOMIALS ! TO APPROXIMATE THE SOLUTION. SDATRP APPROXIMATES THE ! SOLUTION AND ITS DERIVATIVE AT TIME XOUT BY EVALUATING ! ONE OF THESE POLYNOMIALS, AND ITS DERIVATIVE,THERE. ! INFORMATION DEFINING THIS POLYNOMIAL IS PASSED FROM ! SDASTP, SO SDATRP CANNOT BE USED ALONE. ! ! THE PARAMETERS ARE: ! X THE CURRENT TIME IN THE INTEGRATION. ! XOUT THE TIME AT WHICH THE SOLUTION IS DESIRED ! YOUT THE INTERPOLATED APPROXIMATION TO Y AT XOUT ! (THIS IS OUTPUT) ! YPOUT THE INTERPOLATED APPROXIMATION TO YPRIME AT XOUT ! (THIS IS OUTPUT) ! NEQ NUMBER OF EQUATIONS ! KOLD ORDER USED ON LAST SUCCESSFUL STEP ! PHI ARRAY OF SCALED DIVIDED DIFFERENCES OF Y ! PSI ARRAY OF PAST STEPSIZE HISTORY !----------------------------------------------------------------------- !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) !***END PROLOGUE SDATRP ! INTEGER NEQ, KOLD REAL X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*) ! INTEGER I, J, KOLDP1 REAL C, D, GAMMA, TEMP1 ! !***FIRST EXECUTABLE STATEMENT SDATRP KOLDP1=KOLD+1 TEMP1=XOUT-X DO 10 I=1,NEQ YOUT(I)=PHI(I,1) 10 YPOUT(I)=0.0E0 C=1.0E0 D=0.0E0 GAMMA=TEMP1/PSI(1) DO 30 J=2,KOLDP1 D=D*GAMMA+C/PSI(J-1) C=C*GAMMA GAMMA=(TEMP1+PSI(J-1))/PSI(J) DO 20 I=1,NEQ YOUT(I)=YOUT(I)+C*PHI(I,J) 20 YPOUT(I)=YPOUT(I)+D*PHI(I,J) 30 CONTINUE return ! !------END OF SUBROUTINE SDATRP------ end subroutine SDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR) ! !! SDAWTS sets the Gerror weight vector for SDASSL. ! !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDAWTS-S, DDAWTS-D) !***AUTHOR Petzold, Linda R., (LLNL) !***DESCRIPTION !----------------------------------------------------------------------- ! THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR ! WT ACCORDING TO WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), ! I=1,-,N. ! RTOL AND ATOL ARE SCALARS if IWT = 0, ! AND VECTORS if IWT = 1. !----------------------------------------------------------------------- !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830315 DATE WRITTEN ! 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) ! 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. ! 901026 Added explicit declarations for all variables and minor ! cosmetic changes to prologue. (FNF) !***END PROLOGUE SDAWTS ! INTEGER NEQ, IWT, IPAR(*) REAL RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*) ! INTEGER I REAL ATOLI, RTOLI ! !***FIRST EXECUTABLE STATEMENT SDAWTS RTOLI=RTOL(1) ATOLI=ATOL(1) DO 20 I=1,NEQ if (IWT == 0) go to 10 RTOLI=RTOL(I) ATOLI=ATOL(I) 10 WT(I)=RTOLI*ABS(Y(I))+ATOLI 20 CONTINUE return !-----------END OF SUBROUTINE SDAWTS------------------------------------ end subroutine SDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, & MITER, ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, SAVE1, & SAVE2, A, D, JSTATE) ! !! SDCOR computes corrections to the Y array for SDRIVE. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE SINGLE PRECISION (SDCOR-S, DDCOR-D, CDCOR-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! In the case of functional iteration, update Y directly from the ! result of the last call to F. ! In the case of the chord method, compute the corrector error and ! solve the linear system with that as right hand side and DFDY as ! coefficient matrix, using the LU decomposition if MITER is 1, 2, 4, ! or 5. !***ROUTINES CALLED SGBSL, SGESL, SNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDCOR INTEGER I, IERROR, IFLAG, IMPL, J, JSTATE, MATDIM, MITER, ML, MU, & MW, N, NDE, NQ REAL A(MATDIM,*), D, DFDY(MATDIM,*), EL(13,12), H, & SAVE1(*), SAVE2(*), SNRM2, T, Y(*), YH(N,*), YWT(*) INTEGER IPVT(*) LOGICAL EVALFA !***FIRST EXECUTABLE STATEMENT SDCOR if (MITER == 0) THEN if (IERROR == 1 .OR. IERROR == 5) THEN DO 100 I = 1,N 100 SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/YWT(I) ELSE DO 102 I = 1,N SAVE1(I) = (H*SAVE2(I) - YH(I,2) - SAVE1(I))/ & MAX(ABS(Y(I)), YWT(I)) 102 CONTINUE end if D = SNRM2(N, SAVE1, 1)/SQRT(REAL(N)) DO 105 I = 1,N 105 SAVE1(I) = H*SAVE2(I) - YH(I,2) ELSE if (MITER == 1 .OR. MITER == 2) THEN if (IMPL == 0) THEN DO 130 I = 1,N 130 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) ELSE if (IMPL == 1) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 150 I = 1,N 150 SAVE2(I) = H*SAVE2(I) DO 160 J = 1,N DO 160 I = 1,N 160 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) ELSE if (IMPL == 2) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 180 I = 1,N 180 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) ELSE if (IMPL == 3) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 140 I = 1,N 140 SAVE2(I) = H*SAVE2(I) DO 170 J = 1,NDE DO 170 I = 1,NDE 170 SAVE2(I) = SAVE2(I) - A(I,J)*(YH(J,2) + SAVE1(J)) end if call SGESL (DFDY, MATDIM, N, IPVT, SAVE2, 0) if (IERROR == 1 .OR. IERROR == 5) THEN DO 200 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 200 SAVE2(I) = SAVE2(I)/YWT(I) ELSE DO 205 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 205 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) end if D = SNRM2(N, SAVE2, 1)/SQRT(REAL(N)) ELSE if (MITER == 4 .OR. MITER == 5) THEN if (IMPL == 0) THEN DO 230 I = 1,N 230 SAVE2(I) = H*SAVE2(I) - YH(I,2) - SAVE1(I) ELSE if (IMPL == 1) THEN if (EVALFA) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 250 I = 1,N 250 SAVE2(I) = H*SAVE2(I) MW = ML + 1 + MU DO 260 J = 1,N DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) SAVE2(I+J-MW) = SAVE2(I+J-MW) & - A(I,J)*(YH(J,2) + SAVE1(J)) 260 CONTINUE ELSE if (IMPL == 2) THEN if (EVALFA) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 280 I = 1,N 280 SAVE2(I) = H*SAVE2(I) - A(I,1)*(YH(I,2) + SAVE1(I)) ELSE if (IMPL == 3) THEN if (EVALFA) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if ELSE EVALFA = .TRUE. end if DO 270 I = 1,N 270 SAVE2(I) = H*SAVE2(I) MW = ML + 1 + MU DO 290 J = 1,NDE DO 290 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) SAVE2(I+J-MW) = SAVE2(I+J-MW) & - A(I,J)*(YH(J,2) + SAVE1(J)) 290 CONTINUE end if call SGBSL (DFDY, MATDIM, N, ML, MU, IPVT, SAVE2, 0) if (IERROR == 1 .OR. IERROR == 5) THEN DO 300 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 300 SAVE2(I) = SAVE2(I)/YWT(I) ELSE DO 305 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 305 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) end if D = SNRM2(N, SAVE2, 1)/SQRT(REAL(N)) ELSE if (MITER == 3) THEN IFLAG = 2 call USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, & N, NDE, IFLAG) if (N == 0) THEN JSTATE = 10 return end if if (IERROR == 1 .OR. IERROR == 5) THEN DO 320 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 320 SAVE2(I) = SAVE2(I)/YWT(I) ELSE DO 325 I = 1,N SAVE1(I) = SAVE1(I) + SAVE2(I) 325 SAVE2(I) = SAVE2(I)/MAX(ABS(Y(I)), YWT(I)) end if D = SNRM2(N, SAVE2, 1)/SQRT(REAL(N)) end if return end subroutine SDCST (MAXORD, MINT, ISWFLG, EL, TQ) ! !! SDCST sets coefficients used by the core integrator SDSTP. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE SINGLE PRECISION (SDCST-S, DDCST-D, CDCST-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! SDCST is called by SDNTL. The array EL determines the basic method. ! The array TQ is involved in adjusting the step size in relation ! to truncation error. EL and TQ depend upon MINT, and are calculated ! for orders 1 to MAXORD( <= 12). For each order NQ, the coefficients ! EL are calculated from the generating polynomial: ! L(T) = EL(1,NQ) + EL(2,NQ)*T + ... + EL(NQ+1,NQ)*T**NQ. ! For the implicit Adams methods, L(T) is given by ! dL/dT = (1+T)*(2+T)* ... *(NQ-1+T)/K, L(-1) = 0, ! where K = factorial(NQ-1). ! For the Gear methods, ! L(T) = (1+T)*(2+T)* ... *(NQ+T)/K, ! where K = factorial(NQ)*(1 + 1/2 + ... + 1/NQ). ! For each order NQ, there are three components of TQ. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDCST REAL EL(13,12), FACTRL(12), GAMMA(14), SUM, TQ(3,12) INTEGER I, ISWFLG, J, MAXORD, MINT, MXRD !***FIRST EXECUTABLE STATEMENT SDCST FACTRL(1) = 1.E0 DO 10 I = 2,MAXORD 10 FACTRL(I) = I*FACTRL(I-1) ! Compute Adams coefficients if (MINT == 1) THEN GAMMA(1) = 1.E0 DO 40 I = 1,MAXORD+1 SUM = 0.E0 DO 30 J = 1,I 30 SUM = SUM - GAMMA(J)/(I-J+2) 40 GAMMA(I+1) = SUM EL(1,1) = 1.E0 EL(2,1) = 1.E0 EL(2,2) = 1.E0 EL(3,2) = 1.E0 DO 60 J = 3,MAXORD EL(2,J) = FACTRL(J-1) DO 50 I = 3,J 50 EL(I,J) = (J-1)*EL(I,J-1) + EL(I-1,J-1) 60 EL(J+1,J) = 1.E0 DO 80 J = 2,MAXORD EL(1,J) = EL(1,J-1) + GAMMA(J) EL(2,J) = 1.E0 DO 80 I = 3,J+1 80 EL(I,J) = EL(I,J)/((I-1)*FACTRL(J-1)) DO 100 J = 1,MAXORD TQ(1,J) = -1.E0/(FACTRL(J)*GAMMA(J)) TQ(2,J) = -1.E0/GAMMA(J+1) 100 TQ(3,J) = -1.E0/GAMMA(J+2) ! Compute Gear coefficients ELSE if (MINT == 2) THEN EL(1,1) = 1.E0 EL(2,1) = 1.E0 DO 130 J = 2,MAXORD EL(1,J) = FACTRL(J) DO 120 I = 2,J 120 EL(I,J) = J*EL(I,J-1) + EL(I-1,J-1) 130 EL(J+1,J) = 1.E0 SUM = 1.E0 DO 150 J = 2,MAXORD SUM = SUM + 1.E0/J DO 150 I = 1,J+1 150 EL(I,J) = EL(I,J)/(FACTRL(J)*SUM) DO 170 J = 1,MAXORD if (J > 1) TQ(1,J) = 1.E0/FACTRL(J-1) TQ(2,J) = (J+1)/EL(1,J) 170 TQ(3,J) = (J+2)/EL(1,J) end if ! Compute constants used in the stiffness test. ! These are the ratio of TQ(2,NQ) for the Gear ! methods to those for the Adams methods. if (ISWFLG == 3) THEN MXRD = MIN(MAXORD, 5) if (MINT == 2) THEN GAMMA(1) = 1.E0 DO 190 I = 1,MXRD SUM = 0.E0 DO 180 J = 1,I 180 SUM = SUM - GAMMA(J)/(I-J+2) 190 GAMMA(I+1) = SUM end if SUM = 1.E0 DO 200 I = 2,MXRD SUM = SUM + 1.E0/I 200 EL(1+I,1) = -(I+1)*SUM*GAMMA(I+1) end if return end subroutine SDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, UROUND, USERS, & Y, YWT, H, MNTOLD, MTROLD, NFE, RC, YH, A, CONVRG, EL, FAC, & IER, IPVT, NQ, NWAIT, RH, RMAX, SAVE2, TQ, TREND, ISWFLG, & JSTATE) ! !! SDNTL sets parameters on the first call to SDSTP, on an internal restart, ... ! or when the user has ! altered MINT, MITER, and/or H. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE SINGLE PRECISION (SDNTL-S, DDNTL-D, CDNTL-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! On the first call, the order is set to 1 and the initial derivatives ! are calculated. RMAX is the maximum ratio by which H can be ! increased in one step. It is initially RMINIT to compensate ! for the small initial H, but then is normally equal to RMNORM. ! If a failure occurs (in corrector convergence or error test), RMAX ! is set at RMFAIL for the next increase. ! If the caller has changed MINT, or if JTASK = 0, SDCST is called ! to set the coefficients of the method. If the caller has changed H, ! YH must be rescaled. If H or MINT has been changed, NWAIT is ! reset to NQ + 2 to prevent further increases in H for that many ! steps. Also, RC is reset. RC is the ratio of new to old values of ! the coefficient L(0)*H. If the caller has changed MITER, RC is ! set to 0 to force the partials to be updated, if partials are used. !***ROUTINES CALLED SDCST, SDSCL, SGBFA, SGBSL, SGEFA, SGESL, SNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDNTL INTEGER I, IFLAG, IMPL, INFO, ISWFLG, JSTATE, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, MU, N, NDE, NFE, & NQ, NWAIT REAL A(MATDIM,*), EL(13,12), EPS, FAC(*), H, HMAX, & HOLD, OLDL0, RC, RH, RMAX, RMINIT, SAVE1(*), SAVE2(*), SNRM2, & SUM, T, TQ(3,12), TREND, UROUND, Y(*), YH(N,*), YWT(*) INTEGER IPVT(*) LOGICAL CONVRG, IER PARAMETER(RMINIT = 10000.E0) !***FIRST EXECUTABLE STATEMENT SDNTL IER = .FALSE. if (JTASK >= 0) THEN if (JTASK == 0) THEN call SDCST (MAXORD, MINT, ISWFLG, EL, TQ) RMAX = RMINIT end if RC = 0.E0 CONVRG = .FALSE. TREND = 1.E0 NQ = 1 NWAIT = 3 call F (N, T, Y, SAVE2) if (N == 0) THEN JSTATE = 6 return end if NFE = NFE + 1 if (IMPL /= 0) THEN if (MITER == 3) THEN IFLAG = 0 call USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, IMPL, N, & NDE, IFLAG) if (IFLAG == -1) THEN IER = .TRUE. return end if if (N == 0) THEN JSTATE = 10 return end if ELSE if (IMPL == 1) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call SGEFA (A, MATDIM, N, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call SGESL (A, MATDIM, N, IPVT, SAVE2, 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call SGBFA (A, MATDIM, N, ML, MU, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call SGBSL (A, MATDIM, N, ML, MU, IPVT, SAVE2, 0) end if ELSE if (IMPL == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 150 I = 1,NDE if (A(I,1) == 0.E0) THEN IER = .TRUE. return ELSE SAVE2(I) = SAVE2(I)/A(I,1) end if 150 CONTINUE DO 155 I = NDE+1,N 155 A(I,1) = 0.E0 ELSE if (IMPL == 3) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call SGEFA (A, MATDIM, NDE, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call SGESL (A, MATDIM, NDE, IPVT, SAVE2, 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if call SGBFA (A, MATDIM, NDE, ML, MU, IPVT, INFO) if (INFO /= 0) THEN IER = .TRUE. return end if call SGBSL (A, MATDIM, NDE, ML, MU, IPVT, SAVE2, 0) end if end if end if DO 170 I = 1,NDE 170 SAVE1(I) = SAVE2(I)/MAX(1.E0, YWT(I)) SUM = SNRM2(NDE, SAVE1, 1)/SQRT(REAL(NDE)) if (SUM > EPS/ABS(H)) H = SIGN(EPS/SUM, H) DO 180 I = 1,N 180 YH(I,2) = H*SAVE2(I) if (MITER == 2 .OR. MITER == 5 .OR. ISWFLG == 3) THEN DO 20 I = 1,N 20 FAC(I) = SQRT(UROUND) end if ELSE if (MITER /= MTROLD) THEN MTROLD = MITER RC = 0.E0 CONVRG = .FALSE. end if if (MINT /= MNTOLD) THEN MNTOLD = MINT OLDL0 = EL(1,NQ) call SDCST (MAXORD, MINT, ISWFLG, EL, TQ) RC = RC*EL(1,NQ)/OLDL0 NWAIT = NQ + 2 end if if (H /= HOLD) THEN NWAIT = NQ + 2 RH = H/HOLD call SDSCL (HMAX, N, NQ, RMAX, HOLD, RC, RH, YH) end if end if return end subroutine SDNTP (H, K, N, NQ, T, TOUT, YH, Y) ! !! SDNTP interpolates the K-th derivative of Y at TOUT, using the data ... ! in the YH array. If K has a value ! greater than NQ, the NQ-th derivative is calculated. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE SINGLE PRECISION (SDNTP-S, DDNTP-D, CDNTP-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDNTP INTEGER I, J, JJ, K, KK, KUSED, N, NQ REAL FACTOR, H, R, T, TOUT, Y(*), YH(N,*) !***FIRST EXECUTABLE STATEMENT SDNTP if (K == 0) THEN DO 10 I = 1,N 10 Y(I) = YH(I,NQ+1) R = ((TOUT - T)/H) DO 20 JJ = 1,NQ J = NQ + 1 - JJ DO 20 I = 1,N 20 Y(I) = YH(I,J) + R*Y(I) ELSE KUSED = MIN(K, NQ) FACTOR = 1.E0 DO 40 KK = 1,KUSED 40 FACTOR = FACTOR*(NQ+1-KK) DO 50 I = 1,N 50 Y(I) = FACTOR*YH(I,NQ+1) R = ((TOUT - T)/H) DO 80 JJ = KUSED+1,NQ J = KUSED + 1 + NQ - JJ FACTOR = 1.E0 DO 60 KK = 1,KUSED 60 FACTOR = FACTOR*(J-KK) DO 70 I = 1,N 70 Y(I) = FACTOR*YH(I,J) + R*Y(I) 80 CONTINUE DO 100 I = 1,N 100 Y(I) = Y(I)*H**(-KUSED) end if return end FUNCTION SDOT (N, SX, INCX, SY, INCY) ! !! SDOT computes the inner product of two vectors. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A4 !***TYPE SINGLE PRECISION (SDOT-S, DDOT-D, CDOTU-C) !***KEYWORDS BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! SY single precision vector with N elements ! INCY storage spacing between elements of SY ! ! --Output-- ! SDOT single precision dot product (zero if N <= 0) ! ! Returns the dot product of single precision SX and SY. ! SDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SDOT real SDOT REAL SX(*), SY(*) !***FIRST EXECUTABLE STATEMENT SDOT SDOT = 0.0E0 if (N <= 0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IX = 1 IY = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N SDOT = SDOT + SX(IX)*SY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE return ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 5. ! 20 M = MOD(N,5) if (M == 0) go to 40 DO 30 I = 1,M SDOT = SDOT + SX(I)*SY(I) 30 CONTINUE if (N < 5) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SDOT = SDOT + 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 return ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX SDOT = SDOT + SX(I)*SY(I) 70 CONTINUE return end subroutine SDPSC (KSGN, N, NQ, YH) ! !! SDPSC computes the predicted YH values by effectively multiplying ... ! the YH array by the Pascal triangle ! matrix when KSGN is +1, and performs the inverse function ! when KSGN is -1. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE SINGLE PRECISION (SDPSC-S, DDPSC-D, CDPSC-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDPSC INTEGER I, J, J1, J2, KSGN, N, NQ REAL YH(N,*) !***FIRST EXECUTABLE STATEMENT SDPSC if (KSGN > 0) THEN DO 10 J1 = 1,NQ DO 10 J2 = J1,NQ J = NQ - J2 + J1 DO 10 I = 1,N 10 YH(I,J) = YH(I,J) + YH(I,J+1) ELSE DO 30 J1 = 1,NQ DO 30 J2 = J1,NQ J = NQ - J2 + J1 DO 30 I = 1,N 30 YH(I,J) = YH(I,J) - YH(I,J+1) end if return end subroutine SDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, & MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, NFE, NJE, & A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, BND, JSTATE) ! !! SDPST evaluates the Jacobian matrix of the right hand side of the ... ! differential equations. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE SINGLE PRECISION (SDPST-S, DDPST-D, CDPST-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! If MITER is 1, 2, 4, or 5, the matrix ! P = I - L(0)*H*Jacobian is stored in DFDY and subjected to LU ! decomposition, with the results also stored in DFDY. !***ROUTINES CALLED SGBFA, SGEFA, SNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDPST INTEGER I, IFLAG, IMAX, IMPL, INFO, ISWFLG, J, J2, JSTATE, K, & MATDIM, MITER, ML, MU, MW, N, NDE, NFE, NJE, NQ REAL A(MATDIM,*), BL, BND, BP, BR, BU, DFDY(MATDIM,*), & DFDYMX, DIFF, DY, EL(13,12), FAC(*), FACMAX, FACMIN, FACTOR, & H, SAVE1(*), SAVE2(*), SCALE, SNRM2, T, UROUND, Y(*), & YH(N,*), YJ, YS, YWT(*) INTEGER IPVT(*) LOGICAL IER PARAMETER(FACMAX = .5E0, BU = 0.5E0) !***FIRST EXECUTABLE STATEMENT SDPST NJE = NJE + 1 IER = .FALSE. if (MITER == 1 .OR. MITER == 2) THEN if (MITER == 1) THEN call JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) if (N == 0) THEN JSTATE = 8 return end if if (ISWFLG == 3) BND = SNRM2(N*N, DFDY, 1) FACTOR = -EL(1,NQ)*H DO 110 J = 1,N DO 110 I = 1,N 110 DFDY(I,J) = FACTOR*DFDY(I,J) ELSE if (MITER == 2) THEN BR = UROUND**(.875E0) BL = UROUND**(.75E0) BP = UROUND**(-.15E0) FACMIN = UROUND**(.78E0) DO 170 J = 1,N YS = MAX(ABS(YWT(J)), ABS(Y(J))) 120 DY = FAC(J)*YS if (DY == 0.E0) THEN if (FAC(J) < FACMAX) THEN FAC(J) = MIN(100.E0*FAC(J), FACMAX) go to 120 ELSE DY = YS end if end if if (NQ == 1) THEN DY = SIGN(DY, SAVE2(J)) ELSE DY = SIGN(DY, YH(J,3)) end if DY = (Y(J) + DY) - Y(J) YJ = Y(J) Y(J) = Y(J) + DY call F (N, T, Y, SAVE1) if (N == 0) THEN JSTATE = 6 return end if Y(J) = YJ FACTOR = -EL(1,NQ)*H/DY DO 140 I = 1,N 140 DFDY(I,J) = (SAVE1(I) - SAVE2(I))*FACTOR ! Step 1 DIFF = ABS(SAVE2(1) - SAVE1(1)) IMAX = 1 DO 150 I = 2,N if (ABS(SAVE2(I) - SAVE1(I)) > DIFF) THEN IMAX = I DIFF = ABS(SAVE2(I) - SAVE1(I)) end if 150 CONTINUE ! Step 2 if (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) > 0.E0) THEN SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) ! Step 3 if (DIFF > BU*SCALE) THEN FAC(J) = MAX(FACMIN, FAC(J)*.5E0) ELSE if (BR*SCALE <= DIFF .AND. DIFF <= BL*SCALE) THEN FAC(J) = MIN(FAC(J)*2.E0, FACMAX) ! Step 4 ELSE if (DIFF < BR*SCALE) THEN FAC(J) = MIN(BP*FAC(J), FACMAX) end if end if 170 CONTINUE if (ISWFLG == 3) BND = SNRM2(N*N, DFDY, 1)/(-EL(1,NQ)*H) NFE = NFE + N end if if (IMPL == 0) THEN DO 190 I = 1,N 190 DFDY(I,I) = DFDY(I,I) + 1.E0 ELSE if (IMPL == 1) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 210 J = 1,N DO 210 I = 1,N 210 DFDY(I,J) = DFDY(I,J) + A(I,J) ELSE if (IMPL == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 230 I = 1,NDE 230 DFDY(I,I) = DFDY(I,I) + A(I,1) ELSE if (IMPL == 3) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 220 J = 1,NDE DO 220 I = 1,NDE 220 DFDY(I,J) = DFDY(I,J) + A(I,J) end if call SGEFA (DFDY, MATDIM, N, IPVT, INFO) if (INFO /= 0) IER = .TRUE. ELSE if (MITER == 4 .OR. MITER == 5) THEN if (MITER == 4) THEN call JACOBN (N, T, Y, DFDY(ML+1,1), MATDIM, ML, MU) if (N == 0) THEN JSTATE = 8 return end if FACTOR = -EL(1,NQ)*H MW = ML + MU + 1 DO 260 J = 1,N DO 260 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) 260 DFDY(I,J) = FACTOR*DFDY(I,J) ELSE if (MITER == 5) THEN BR = UROUND**(.875E0) BL = UROUND**(.75E0) BP = UROUND**(-.15E0) FACMIN = UROUND**(.78E0) MW = ML + MU + 1 J2 = MIN(MW, N) DO 340 J = 1,J2 DO 290 K = J,N,MW YS = MAX(ABS(YWT(K)), ABS(Y(K))) 280 DY = FAC(K)*YS if (DY == 0.E0) THEN if (FAC(K) < FACMAX) THEN FAC(K) = MIN(100.E0*FAC(K), FACMAX) go to 280 ELSE DY = YS end if end if if (NQ == 1) THEN DY = SIGN(DY, SAVE2(K)) ELSE DY = SIGN(DY, YH(K,3)) end if DY = (Y(K) + DY) - Y(K) DFDY(MW,K) = Y(K) 290 Y(K) = Y(K) + DY call F (N, T, Y, SAVE1) if (N == 0) THEN JSTATE = 6 return end if DO 330 K = J,N,MW Y(K) = DFDY(MW,K) YS = MAX(ABS(YWT(K)), ABS(Y(K))) DY = FAC(K)*YS if (DY == 0.E0) DY = YS if (NQ == 1) THEN DY = SIGN(DY, SAVE2(K)) ELSE DY = SIGN(DY, YH(K,3)) end if DY = (Y(K) + DY) - Y(K) FACTOR = -EL(1,NQ)*H/DY DO 300 I = MAX(ML+1, MW+1-K), MIN(MW+N-K, MW+ML) 300 DFDY(I,K) = FACTOR*(SAVE1(I+K-MW) - SAVE2(I+K-MW)) ! Step 1 IMAX = MAX(1, K - MU) DIFF = ABS(SAVE2(IMAX) - SAVE1(IMAX)) DO 310 I = MAX(1, K - MU)+1, MIN(K + ML, N) if (ABS(SAVE2(I) - SAVE1(I)) > DIFF) THEN IMAX = I DIFF = ABS(SAVE2(I) - SAVE1(I)) end if 310 CONTINUE ! Step 2 if (MIN(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) > 0.E0) THEN SCALE = MAX(ABS(SAVE2(IMAX)), ABS(SAVE1(IMAX))) ! Step 3 if (DIFF > BU*SCALE) THEN FAC(J) = MAX(FACMIN, FAC(J)*.5E0) ELSE if (BR*SCALE <= DIFF .AND. DIFF <= BL*SCALE) THEN FAC(J) = MIN(FAC(J)*2.E0, FACMAX) ! Step 4 ELSE if (DIFF < BR*SCALE) THEN FAC(K) = MIN(BP*FAC(K), FACMAX) end if end if 330 CONTINUE 340 CONTINUE NFE = NFE + J2 end if if (ISWFLG == 3) THEN DFDYMX = 0.E0 DO 345 J = 1,N DO 345 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) 345 DFDYMX = MAX(DFDYMX, ABS(DFDY(I,J))) BND = 0.E0 if (DFDYMX /= 0.E0) THEN DO 350 J = 1,N DO 350 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) 350 BND = BND + (DFDY(I,J)/DFDYMX)**2 BND = DFDYMX*SQRT(BND)/(-EL(1,NQ)*H) end if end if if (IMPL == 0) THEN DO 360 J = 1,N 360 DFDY(MW,J) = DFDY(MW,J) + 1.E0 ELSE if (IMPL == 1) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 380 J = 1,N DO 380 I = MAX(ML+1, MW+1-J), MIN(MW+N-J, MW+ML) 380 DFDY(I,J) = DFDY(I,J) + A(I,J) ELSE if (IMPL == 2) THEN call FA (N, T, Y, A, MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 400 J = 1,NDE 400 DFDY(MW,J) = DFDY(MW,J) + A(J,1) ELSE if (IMPL == 3) THEN call FA (N, T, Y, A(ML+1,1), MATDIM, ML, MU, NDE) if (N == 0) THEN JSTATE = 9 return end if DO 390 J = 1,NDE DO 390 I = MAX(ML+1, MW+1-J), MIN(MW+NDE-J, MW+ML) 390 DFDY(I,J) = DFDY(I,J) + A(I,J) end if call SGBFA (DFDY, MATDIM, N, ML, MU, IPVT, INFO) if (INFO /= 0) IER = .TRUE. ELSE if (MITER == 3) THEN IFLAG = 1 call USERS (Y, YH(1,2), YWT, SAVE1, SAVE2, T, H, EL(1,NQ), IMPL, & N, NDE, IFLAG) if (IFLAG == -1) THEN IER = .TRUE. return end if if (N == 0) THEN JSTATE = 10 return end if end if return end subroutine SDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, & IERFLG) ! !! SDRIV1 solves N ordinary differential equations of the form ... ! dY(I)/dT = F(Y(I),T), given the initial conditions ! Y(I) = YI. SDRIV1 uses single precision arithmetic. ! !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE SINGLE PRECISION (SDRIV1-S, DDRIV1-D, CDRIV1-C) !***KEYWORDS GEAR'S METHOD, INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, SINGLE PRECISION, ! STIFF !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! Version 92.1 ! ! I. CHOOSING THE CORRECT ROUTINE ................................... ! ! SDRIV ! DDRIV ! CDRIV ! These are the generic names for three packages for solving ! initial value problems for ordinary differential equations. ! SDRIV uses single precision arithmetic. DDRIV uses double ! precision arithmetic. CDRIV allows complex-valued ! differential equations, integrated with respect to a single, ! real, independent variable. ! ! As an aid in selecting the proper program, the following is a ! discussion of the important options or restrictions associated with ! each program: ! ! A. SDRIV1 should be tried first for those routine problems with ! no more than 200 differential equations (SDRIV2 and SDRIV3 ! have no such restriction.) Internally this routine has two ! important technical defaults: ! 1. Numerical approximation of the Jacobian matrix of the ! right hand side is used. ! 2. The stiff solver option is used. ! Most users of SDRIV1 should not have to concern themselves ! with these details. ! ! B. SDRIV2 should be considered for those problems for which ! SDRIV1 is inadequate. For example, SDRIV1 may have difficulty ! with problems having zero initial conditions and zero ! derivatives. In this case SDRIV2, with an appropriate value ! of the parameter EWT, should perform more efficiently. SDRIV2 ! provides three important additional options: ! 1. The nonstiff equation solver (as well as the stiff ! solver) is available. ! 2. The root-finding option is available. ! 3. The program can dynamically select either the non-stiff ! or the stiff methods. ! Internally this routine also defaults to the numerical ! approximation of the Jacobian matrix of the right hand side. ! ! C. SDRIV3 is the most flexible, and hence the most complex, of ! the programs. Its important additional features include: ! 1. The ability to exploit band structure in the Jacobian ! matrix. ! 2. The ability to solve some implicit differential ! equations, i.e., those having the form: ! A(Y,T)*dY/dT = F(Y,T). ! 3. The option of integrating in the one step mode. ! 4. The option of allowing the user to provide a routine ! which computes the analytic Jacobian matrix of the right ! hand side. ! 5. The option of allowing the user to provide a routine ! which does all the matrix algebra associated with ! corrections to the solution components. ! ! II. PARAMETERS .................................................... ! ! The user should use parameter names in the call sequence of SDRIV1 ! for those quantities whose value may be altered by SDRIV1. The ! parameters in the call sequence are: ! ! N = (Input) The number of differential equations, N <= 200 ! ! T = The independent variable. On input for the first call, T ! is the initial point. On output, T is the point at which ! the solution is given. ! ! Y = The vector of dependent variables. Y is used as input on ! the first call, to set the initial values. On output, Y ! is the computed solution vector. This array Y is passed ! in the call sequence of the user-provided routine F. Thus ! parameters required by F can be stored in this array in ! components N+1 and above. (Note: Changes by the user to ! the first N components of this array will take effect only ! after a restart, i.e., after setting MSTATE to +1(-1).) ! ! F = A subroutine supplied by the user. The name must be ! declared EXTERNAL in the user's calling program. This ! subroutine is of the form: ! SUBROUTINE F (N, T, Y, YDOT) ! REAL Y(*), YDOT(*) ! . ! . ! YDOT(1) = ... ! . ! . ! YDOT(N) = ... ! END (Sample) ! This computes YDOT = F(Y,T), the right hand side of the ! differential equations. Here Y is a vector of length at ! least N. The actual length of Y is determined by the ! user's declaration in the program which calls SDRIV1. ! Thus the dimensioning of Y in F, while required by FORTRAN ! convention, does not actually allocate any storage. When ! this subroutine is called, the first N components of Y are ! intermediate approximations to the solution components. ! The user should not alter these values. Here YDOT is a ! vector of length N. The user should only compute YDOT(I) ! for I from 1 to N. Normally a return from F passes ! control back to SDRIV1. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls SDRIV1, he should set N to zero. ! SDRIV1 will signal this by returning a value of MSTATE ! equal to +5(-5). Altering the value of N in F has no ! effect on the value of N in the call sequence of SDRIV1. ! ! TOUT = (Input) The point at which the solution is desired. ! ! MSTATE = An integer describing the status of integration. The user ! must initialize MSTATE to +1 or -1. If MSTATE is ! positive, the routine will integrate past TOUT and ! interpolate the solution. This is the most efficient ! mode. If MSTATE is negative, the routine will adjust its ! internal step to reach TOUT exactly (useful if a ! singularity exists beyond TOUT.) The meaning of the ! magnitude of MSTATE: ! 1 (Input) Means the first call to the routine. This ! value must be set by the user. On all subsequent ! calls the value of MSTATE should be tested by the ! user. Unless SDRIV1 is to be reinitialized, only the ! sign of MSTATE may be changed by the user. (As a ! convenience to the user who may wish to put out the ! initial conditions, SDRIV1 can be called with ! MSTATE=+1(-1), and TOUT=T. In this case the program ! will return with MSTATE unchanged, i.e., ! MSTATE=+1(-1).) ! 2 (Output) Means a successful integration. If a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance TOUT and call ! again. All other parameters are automatically set. ! 3 (Output)(Unsuccessful) Means the integrator has taken ! 1000 steps without reaching TOUT. The user can ! continue the integration by simply calling SDRIV1 ! again. ! 4 (Output)(Unsuccessful) Means too much accuracy has ! been requested. EPS has been increased to a value ! the program estimates is appropriate. The user can ! continue the integration by simply calling SDRIV1 ! again. ! 5 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE F. ! 6 (Output)(Successful) For MSTATE negative, T is beyond ! TOUT. The solution was obtained by interpolation. ! The user can continue the integration by simply ! advancing TOUT and calling SDRIV1 again. ! 7 (Output)(Unsuccessful) The solution could not be ! obtained. The value of IERFLG (see description ! below) for a "Recoverable" situation indicates the ! type of difficulty encountered: either an illegal ! value for a parameter or an inability to continue the ! solution. For this condition the user should take ! corrective action and reset MSTATE to +1(-1) before ! calling SDRIV1 again. Otherwise the program will ! terminate the run. ! ! EPS = On input, the requested relative accuracy in all solution ! components. On output, the adjusted relative accuracy if ! the input value was too small. The value of EPS should be ! set as large as is reasonable, because the amount of work ! done by SDRIV1 increases as EPS decreases. ! ! WORK ! LENW = (Input) ! WORK is an array of LENW real words used ! internally for temporary storage. The user must allocate ! space for this array in the calling program by a statement ! such as ! REAL WORK(...) ! The length of WORK should be at least N*N + 11*N + 300 ! and LENW should be set to the value used. The contents of ! WORK should not be disturbed between calls to SDRIV1. ! ! IERFLG = An error flag. The error number associated with a ! diagnostic message (see Section IV-A below) is the same as ! the corresponding value of IERFLG. The meaning of IERFLG: ! 0 The routine completed successfully. (No message is ! issued.) ! 3 (Warning) The number of steps required to reach TOUT ! exceeds 1000 . ! 4 (Warning) The value of EPS is too small. ! 11 (Warning) For MSTATE negative, T is beyond TOUT. ! The solution was obtained by interpolation. ! 15 (Warning) The integration step size is below the ! roundoff level of T. (The program issues this ! message as a warning but does not return control to ! the user.) ! 21 (Recoverable) N is greater than 200 . ! 22 (Recoverable) N is not positive. ! 26 (Recoverable) The magnitude of MSTATE is either 0 or ! greater than 7 . ! 27 (Recoverable) EPS is less than zero. ! 32 (Recoverable) Insufficient storage has been allocated ! for the WORK array. ! 41 (Recoverable) The integration step size has gone ! to zero. ! 42 (Recoverable) The integration step size has been ! reduced about 50 times without advancing the ! solution. The problem setup may not be correct. ! 999 (Fatal) The magnitude of MSTATE is 7 . ! ! III. USAGE ........................................................ ! ! PROGRAM SAMPLE ! EXTERNAL F ! REAL ALFA, EPS, T, TOUT ! C N is the number of equations ! PARAMETER(ALFA = 1.E0, N = 3, LENW = N*N + 11*N + 300) ! REAL WORK(LENW), Y(N+1) ! C Initial point ! T = 0.00001E0 ! C Set initial conditions ! Y(1) = 10.E0 ! Y(2) = 0.E0 ! Y(3) = 10.E0 ! C Pass parameter ! Y(4) = ALFA ! TOUT = T ! MSTATE = 1 ! EPS = .001E0 ! 10 call SDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, ! 8 IERFLG) ! if (MSTATE > 2) STOP ! WRITE(*, '(4E12.3)') TOUT, (Y(I), I=1,3) ! TOUT = 10.E0*TOUT ! if (TOUT < 50.E0) go to 10 ! END ! ! SUBROUTINE F (N, T, Y, YDOT) ! REAL ALFA, T, Y(*), YDOT(*) ! ALFA = Y(N+1) ! YDOT(1) = 1.E0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) ! YDOT(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) ! YDOT(3) = 1.E0 - Y(3)*(Y(1) + Y(2)) ! END ! ! IV. OTHER COMMUNICATION TO THE USER ............................... ! ! A. The solver communicates to the user through the parameters ! above. In addition it writes diagnostic messages through the ! standard error handling program XERMSG. A complete description ! of XERMSG is given in "Guide to the SLATEC Common Mathematical ! Library" by Kirby W. Fong et al.. At installations which do not ! have this error handling package the short but serviceable ! routine, XERMSG, available with this package, can be used. That ! program uses the file named OUTPUT to transmit messages. ! ! B. The number of evaluations of the right hand side can be found ! in the WORK array in the location determined by: ! LENW - (N + 50) + 4 ! ! V. REMARKS ........................................................ ! ! For other information, see Section IV of the writeup for SDRIV3. ! !***REFERENCES C. W. Gear, Numerical Initial Value Problems in ! Ordinary Differential Equations, Prentice-Hall, 1971. !***ROUTINES CALLED SDRIV3, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDRIV1 EXTERNAL F REAL EPS, EWTCOM(1), HMAX, T, TOUT, WORK(*), Y(*) INTEGER I, IDLIW, IERFLG, IERROR, IMPL, LENIW, LENW, LENWCM, & LNWCHK, MINT, MITER, ML, MSTATE, MU, MXN, MXORD, MXSTEP, & N, NDE, NROOT, NSTATE, NTASK PARAMETER(MXN = 200, IDLIW = 50) INTEGER IWORK(IDLIW+MXN) CHARACTER INTGR1*8 PARAMETER(NROOT = 0, IERROR = 2, MINT = 2, MITER = 2, IMPL = 0, & MXORD = 5, MXSTEP = 1000) DATA EWTCOM(1) /1.E0/ !***FIRST EXECUTABLE STATEMENT SDRIV1 if (ABS(MSTATE) == 0 .OR. ABS(MSTATE) > 7) THEN WRITE(INTGR1, '(I8)') MSTATE IERFLG = 26 call XERMSG('SLATEC', 'SDRIV1', & 'Illegal input. The magnitude of MSTATE, '//INTGR1// & ', is not in the range 1 to 6 .', IERFLG, 1) MSTATE = SIGN(7, MSTATE) return ELSE if (ABS(MSTATE) == 7) THEN IERFLG = 999 call XERMSG('SLATEC', 'SDRIV1', & 'Illegal input. The magnitude of MSTATE is 7 .', IERFLG, 2) return end if if (N > MXN) THEN WRITE(INTGR1, '(I8)') N IERFLG = 21 call XERMSG('SLATEC', 'SDRIV1', & 'Illegal input. The number of equations, '//INTGR1// & ', is greater than the maximum allowed: 200 .', IERFLG, 1) MSTATE = SIGN(7, MSTATE) return end if if (MSTATE > 0) THEN NSTATE = MSTATE NTASK = 1 ELSE NSTATE = - MSTATE NTASK = 3 end if HMAX = 2.E0*ABS(TOUT - T) LENIW = N + IDLIW LENWCM = LENW - LENIW if (LENWCM < (N*N + 10*N + 250)) THEN LNWCHK = N*N + 10*N + 250 + LENIW WRITE(INTGR1, '(I8)') LNWCHK IERFLG = 32 call XERMSG('SLATEC', 'SDRIV1', & 'Insufficient storage allocated for the work array. '// & 'The required storage is at least '//INTGR1//' .', IERFLG, 1) MSTATE = SIGN(7, MSTATE) return end if if (NSTATE /= 1) THEN DO 20 I = 1,LENIW 20 IWORK(I) = WORK(I+LENWCM) end if call SDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, & IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, & LENWCM, IWORK, LENIW, F, F, NDE, MXSTEP, F, F, & IERFLG) DO 40 I = 1,LENIW 40 WORK(I+LENWCM) = IWORK(I) if (NSTATE <= 4) THEN MSTATE = SIGN(NSTATE, MSTATE) ELSE if (NSTATE == 6) THEN MSTATE = SIGN(5, MSTATE) ELSE if (IERFLG == 11) THEN MSTATE = SIGN(6, MSTATE) ELSE if (IERFLG > 11) THEN MSTATE = SIGN(7, MSTATE) end if return end subroutine SDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, & MINT, WORK, LENW, IWORK, LENIW, G, IERFLG) ! !! SDRIV2 solves N ordinary differential equations of the form ... ! dY(I)/dT = F(Y(I),T), given the ! initial conditions Y(I) = YI. The program has options to ! allow the solution of both stiff and non-stiff differential ! equations. SDRIV2 uses single precision arithmetic. ! !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE SINGLE PRECISION (SDRIV2-S, DDRIV2-D, CDRIV2-C) !***KEYWORDS GEAR'S METHOD, INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, SINGLE PRECISION, ! STIFF !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! I. PARAMETERS ..................................................... ! ! The user should use parameter names in the call sequence of SDRIV2 ! for those quantities whose value may be altered by SDRIV2. The ! parameters in the call sequence are: ! ! N = (Input) The number of differential equations. ! ! T = The independent variable. On input for the first call, T ! is the initial point. On output, T is the point at which ! the solution is given. ! ! Y = The vector of dependent variables. Y is used as input on ! the first call, to set the initial values. On output, Y ! is the computed solution vector. This array Y is passed ! in the call sequence of the user-provided routines F and ! G. Thus parameters required by F and G can be stored in ! this array in components N+1 and above. (Note: Changes ! by the user to the first N components of this array will ! take effect only after a restart, i.e., after setting ! MSTATE to +1(-1).) ! ! F = A subroutine supplied by the user. The name must be ! declared EXTERNAL in the user's calling program. This ! subroutine is of the form: ! SUBROUTINE F (N, T, Y, YDOT) ! REAL Y(*), YDOT(*) ! . ! . ! YDOT(1) = ... ! . ! . ! YDOT(N) = ... ! END (Sample) ! This computes YDOT = F(Y,T), the right hand side of the ! differential equations. Here Y is a vector of length at ! least N. The actual length of Y is determined by the ! user's declaration in the program which calls SDRIV2. ! Thus the dimensioning of Y in F, while required by FORTRAN ! convention, does not actually allocate any storage. When ! this subroutine is called, the first N components of Y are ! intermediate approximations to the solution components. ! The user should not alter these values. Here YDOT is a ! vector of length N. The user should only compute YDOT(I) ! for I from 1 to N. Normally a return from F passes ! control back to SDRIV2. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls SDRIV2, he should set N to zero. ! SDRIV2 will signal this by returning a value of MSTATE ! equal to +6(-6). Altering the value of N in F has no ! effect on the value of N in the call sequence of SDRIV2. ! ! TOUT = (Input) The point at which the solution is desired. ! ! MSTATE = An integer describing the status of integration. The user ! must initialize MSTATE to +1 or -1. If MSTATE is ! positive, the routine will integrate past TOUT and ! interpolate the solution. This is the most efficient ! mode. If MSTATE is negative, the routine will adjust its ! internal step to reach TOUT exactly (useful if a ! singularity exists beyond TOUT.) The meaning of the ! magnitude of MSTATE: ! 1 (Input) Means the first call to the routine. This ! value must be set by the user. On all subsequent ! calls the value of MSTATE should be tested by the ! user. Unless SDRIV2 is to be reinitialized, only the ! sign of MSTATE may be changed by the user. (As a ! convenience to the user who may wish to put out the ! initial conditions, SDRIV2 can be called with ! MSTATE=+1(-1), and TOUT=T. In this case the program ! will return with MSTATE unchanged, i.e., ! MSTATE=+1(-1).) ! 2 (Output) Means a successful integration. If a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance TOUT and call ! again. All other parameters are automatically set. ! 3 (Output)(Unsuccessful) Means the integrator has taken ! 1000 steps without reaching TOUT. The user can ! continue the integration by simply calling SDRIV2 ! again. Other than an error in problem setup, the ! most likely cause for this condition is trying to ! integrate a stiff set of equations with the non-stiff ! integrator option. (See description of MINT below.) ! 4 (Output)(Unsuccessful) Means too much accuracy has ! been requested. EPS has been increased to a value ! the program estimates is appropriate. The user can ! continue the integration by simply calling SDRIV2 ! again. ! 5 (Output) A root was found at a point less than TOUT. ! The user can continue the integration toward TOUT by ! simply calling SDRIV2 again. ! 6 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE F. ! 7 (Output)(Unsuccessful) N has been set to zero in ! FUNCTION G. See description of G below. ! 8 (Output)(Successful) For MSTATE negative, T is beyond ! TOUT. The solution was obtained by interpolation. ! The user can continue the integration by simply ! advancing TOUT and calling SDRIV2 again. ! 9 (Output)(Unsuccessful) The solution could not be ! obtained. The value of IERFLG (see description ! below) for a "Recoverable" situation indicates the ! type of difficulty encountered: either an illegal ! value for a parameter or an inability to continue the ! solution. For this condition the user should take ! corrective action and reset MSTATE to +1(-1) before ! calling SDRIV2 again. Otherwise the program will ! terminate the run. ! ! NROOT = (Input) The number of equations whose roots are desired. ! If NROOT is zero, the root search is not active. This ! option is useful for obtaining output at points which are ! not known in advance, but depend upon the solution, e.g., ! when some solution component takes on a specified value. ! The root search is carried out using the user-written ! function G (see description of G below.) SDRIV2 attempts ! to find the value of T at which one of the equations ! changes sign. SDRIV2 can find at most one root per ! equation per internal integration step, and will then ! return the solution either at TOUT or at a root, whichever ! occurs first in the direction of integration. The initial ! point is never reported as a root. The index of the ! equation whose root is being reported is stored in the ! sixth element of IWORK. ! NOTE: NROOT is never altered by this program. ! ! EPS = On input, the requested relative accuracy in all solution ! components. EPS = 0 is allowed. On output, the adjusted ! relative accuracy if the input value was too small. The ! value of EPS should be set as large as is reasonable, ! because the amount of work done by SDRIV2 increases as ! EPS decreases. ! ! EWT = (Input) Problem zero, i.e., the smallest physically ! meaningful value for the solution. This is used inter- ! nally to compute an array YWT(I) = MAX(ABS(Y(I)), EWT). ! One step error estimates divided by YWT(I) are kept less ! than EPS. Setting EWT to zero provides pure relative ! error control. However, setting EWT smaller than ! necessary can adversely affect the running time. ! ! MINT = (Input) The integration method flag. ! MINT = 1 Means the Adams methods, and is used for ! non-stiff problems. ! MINT = 2 Means the stiff methods of Gear (i.e., the ! backward differentiation formulas), and is ! used for stiff problems. ! MINT = 3 Means the program dynamically selects the ! Adams methods when the problem is non-stiff ! and the Gear methods when the problem is ! stiff. ! MINT may not be changed without restarting, i.e., setting ! the magnitude of MSTATE to 1. ! ! WORK ! LENW = (Input) ! WORK is an array of LENW real words used ! internally for temporary storage. The user must allocate ! space for this array in the calling program by a statement ! such as ! REAL WORK(...) ! The length of WORK should be at least ! 16*N + 2*NROOT + 250 if MINT is 1, or ! N*N + 10*N + 2*NROOT + 250 if MINT is 2, or ! N*N + 17*N + 2*NROOT + 250 if MINT is 3, ! and LENW should be set to the value used. The contents of ! WORK should not be disturbed between calls to SDRIV2. ! ! IWORK ! LENIW = (Input) ! IWORK is an integer array of length LENIW used internally ! for temporary storage. The user must allocate space for ! this array in the calling program by a statement such as ! INTEGER IWORK(...) ! The length of IWORK should be at least ! 50 if MINT is 1, or ! N+50 if MINT is 2 or 3, ! and LENIW should be set to the value used. The contents ! of IWORK should not be disturbed between calls to SDRIV2. ! ! G = A real FORTRAN function supplied by the user ! if NROOT is not 0. In this case, the name must be ! declared EXTERNAL in the user's calling program. G is ! repeatedly called with different values of IROOT to ! obtain the value of each of the NROOT equations for which ! a root is desired. G is of the form: ! REAL FUNCTION G (N, T, Y, IROOT) ! REAL Y(*) ! go to (10, ...), IROOT ! 10 G = ... ! . ! . ! END (Sample) ! Here, Y is a vector of length at least N, whose first N ! components are the solution components at the point T. ! The user should not alter these values. The actual length ! of Y is determined by the user's declaration in the ! program which calls SDRIV2. Thus the dimensioning of Y in ! G, while required by FORTRAN convention, does not actually ! allocate any storage. Normally a return from G passes ! control back to SDRIV2. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls SDRIV2, he should set N to zero. ! SDRIV2 will signal this by returning a value of MSTATE ! equal to +7(-7). In this case, the index of the equation ! being evaluated is stored in the sixth element of IWORK. ! Altering the value of N in G has no effect on the value of ! N in the call sequence of SDRIV2. ! ! IERFLG = An error flag. The error number associated with a ! diagnostic message (see Section II-A below) is the same as ! the corresponding value of IERFLG. The meaning of IERFLG: ! 0 The routine completed successfully. (No message is ! issued.) ! 3 (Warning) The number of steps required to reach TOUT ! exceeds MXSTEP. ! 4 (Warning) The value of EPS is too small. ! 11 (Warning) For MSTATE negative, T is beyond TOUT. ! The solution was obtained by interpolation. ! 15 (Warning) The integration step size is below the ! roundoff level of T. (The program issues this ! message as a warning but does not return control to ! the user.) ! 22 (Recoverable) N is not positive. ! 23 (Recoverable) MINT is less than 1 or greater than 3 . ! 26 (Recoverable) The magnitude of MSTATE is either 0 or ! greater than 9 . ! 27 (Recoverable) EPS is less than zero. ! 32 (Recoverable) Insufficient storage has been allocated ! for the WORK array. ! 33 (Recoverable) Insufficient storage has been allocated ! for the IWORK array. ! 41 (Recoverable) The integration step size has gone ! to zero. ! 42 (Recoverable) The integration step size has been ! reduced about 50 times without advancing the ! solution. The problem setup may not be correct. ! 999 (Fatal) The magnitude of MSTATE is 9 . ! ! II. OTHER COMMUNICATION TO THE USER ............................... ! ! A. The solver communicates to the user through the parameters ! above. In addition it writes diagnostic messages through the ! standard error handling program XERMSG. A complete description ! of XERMSG is given in "Guide to the SLATEC Common Mathematical ! Library" by Kirby W. Fong et al.. At installations which do not ! have this error handling package the short but serviceable ! routine, XERMSG, available with this package, can be used. That ! program uses the file named OUTPUT to transmit messages. ! ! B. The first three elements of WORK and the first five elements of ! IWORK will contain the following statistical data: ! AVGH The average step size used. ! HUSED The step size last used (successfully). ! AVGORD The average order used. ! IMXERR The index of the element of the solution vector that ! contributed most to the last error test. ! NQUSED The order last used (successfully). ! NSTEP The number of steps taken since last initialization. ! NFE The number of evaluations of the right hand side. ! NJE The number of evaluations of the Jacobian matrix. ! ! III. REMARKS ...................................................... ! ! A. On any return from SDRIV2 all information necessary to continue ! the calculation is contained in the call sequence parameters, ! including the work arrays. Thus it is possible to suspend one ! problem, integrate another, and then return to the first. ! ! B. If this package is to be used in an overlay situation, the user ! must declare in the primary overlay the variables in the call ! sequence to SDRIV2. ! ! C. When the routine G is not required, difficulties associated with ! an unsatisfied external can be avoided by using the name of the ! routine which calculates the right hand side of the differential ! equations in place of G in the call sequence of SDRIV2. ! ! IV. USAGE ......................................................... ! ! PROGRAM SAMPLE ! EXTERNAL F ! PARAMETER(MINT = 1, NROOT = 0, N = ..., ! 8 LENW = 16*N + 2*NROOT + 250, LENIW = 50) ! C N is the number of equations ! REAL EPS, EWT, T, TOUT, WORK(LENW), Y(N) ! INTEGER IWORK(LENIW) ! OPEN(FILE='TAPE6', UNIT=6, STATUS='NEW') ! C Initial point ! T = 0. ! C Set initial conditions ! DO 10 I = 1,N ! 10 Y(I) = ... ! TOUT = T ! EWT = ... ! MSTATE = 1 ! EPS = ... ! 20 call SDRIV2 (N, T, Y, F, TOUT, MSTATE, NROOT, EPS, EWT, ! 8 MINT, WORK, LENW, IWORK, LENIW, F, IERFLG) ! C Next to last argument is not ! C F if rootfinding is used. ! if (MSTATE > 2) STOP ! WRITE(6, 100) TOUT, (Y(I), I=1,N) ! TOUT = TOUT + 1. ! if (TOUT <= 10.) go to 20 ! 100 FORMAT(...) ! END (Sample) ! !***REFERENCES C. W. Gear, Numerical Initial Value Problems in ! Ordinary Differential Equations, Prentice-Hall, 1971. !***ROUTINES CALLED SDRIV3, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDRIV2 EXTERNAL F, G REAL EPS, EWT, EWTCOM(1), G, HMAX, T, TOUT, & WORK(*), Y(*) INTEGER IWORK(*) INTEGER IERFLG, IERROR, IMPL, LENIW, LENW, MINT, MITER, ML, & MSTATE, MU, MXORD, MXSTEP, N, NDE, NROOT, NSTATE, NTASK CHARACTER INTGR1*8 PARAMETER(IMPL = 0, MXSTEP = 1000) !***FIRST EXECUTABLE STATEMENT SDRIV2 if (ABS(MSTATE) == 9) THEN IERFLG = 999 call XERMSG('SLATEC', 'SDRIV2', & 'Illegal input. The magnitude of MSTATE IS 9 .', & IERFLG, 2) return ELSE if (ABS(MSTATE) == 0 .OR. ABS(MSTATE) > 9) THEN WRITE(INTGR1, '(I8)') MSTATE IERFLG = 26 call XERMSG('SLATEC', 'SDRIV2', & 'Illegal input. The magnitude of MSTATE, '//INTGR1// & ' is not in the range 1 to 8 .', IERFLG, 1) MSTATE = SIGN(9, MSTATE) return end if if (MINT < 1 .OR. MINT > 3) THEN WRITE(INTGR1, '(I8)') MINT IERFLG = 23 call XERMSG('SLATEC', 'SDRIV2', & 'Illegal input. Improper value for the integration method '// & 'flag, '//INTGR1//' .', IERFLG, 1) MSTATE = SIGN(9, MSTATE) return end if if (MSTATE >= 0) THEN NSTATE = MSTATE NTASK = 1 ELSE NSTATE = - MSTATE NTASK = 3 end if EWTCOM(1) = EWT if (EWT /= 0.E0) THEN IERROR = 3 ELSE IERROR = 2 end if if (MINT == 1) THEN MITER = 0 MXORD = 12 ELSE if (MINT == 2) THEN MITER = 2 MXORD = 5 ELSE if (MINT == 3) THEN MITER = 2 MXORD = 12 end if HMAX = 2.E0*ABS(TOUT - T) call SDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, EWTCOM, & IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, & LENW, IWORK, LENIW, F, F, NDE, MXSTEP, G, F, IERFLG) if (NSTATE <= 7) THEN MSTATE = SIGN(NSTATE, MSTATE) ELSE if (NSTATE == 11) THEN MSTATE = SIGN(8, MSTATE) ELSE if (NSTATE > 11) THEN MSTATE = SIGN(9, MSTATE) end if return end subroutine SDRIV3 (N, T, Y, F, NSTATE, TOUT, NTASK, NROOT, EPS, & EWT, IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, WORK, & LENW, IWORK, LENIW, JACOBN, FA, NDE, MXSTEP, G, USERS, IERFLG) ! !! SDRIV3 solves N ordinary differential equations of the form ... ! dY(I)/dT = F(Y(I),T), given the ! initial conditions Y(I) = YI. The program has options to ! allow the solution of both stiff and non-stiff differential ! equations. Other important options are available. SDRIV3 ! uses single precision arithmetic. ! !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE SINGLE PRECISION (SDRIV3-S, DDRIV3-D, CDRIV3-C) !***KEYWORDS GEAR'S METHOD, INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, SINGLE PRECISION, ! STIFF !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! I. ABSTRACT ....................................................... ! ! The primary function of SDRIV3 is to solve N ordinary differential ! equations of the form dY(I)/dT = F(Y(I),T), given the initial ! conditions Y(I) = YI. The program has options to allow the ! solution of both stiff and non-stiff differential equations. In ! addition, SDRIV3 may be used to solve: ! 1. The initial value problem, A*dY(I)/dT = F(Y(I),T), where A is ! a non-singular matrix depending on Y and T. ! 2. The hybrid differential/algebraic initial value problem, ! A*dY(I)/dT = F(Y(I),T), where A is a vector (whose values may ! depend upon Y and T) some of whose components will be zero ! corresponding to those equations which are algebraic rather ! than differential. ! SDRIV3 is to be called once for each output point of T. ! ! II. PARAMETERS .................................................... ! ! The user should use parameter names in the call sequence of SDRIV3 ! for those quantities whose value may be altered by SDRIV3. The ! parameters in the call sequence are: ! ! N = (Input) The number of dependent functions whose solution ! is desired. N must not be altered during a problem. ! ! T = The independent variable. On input for the first call, T ! is the initial point. On output, T is the point at which ! the solution is given. ! ! Y = The vector of dependent variables. Y is used as input on ! the first call, to set the initial values. On output, Y ! is the computed solution vector. This array Y is passed ! in the call sequence of the user-provided routines F, ! JACOBN, FA, USERS, and G. Thus parameters required by ! those routines can be stored in this array in components ! N+1 and above. (Note: Changes by the user to the first ! N components of this array will take effect only after a ! restart, i.e., after setting NSTATE to 1 .) ! ! F = A subroutine supplied by the user. The name must be ! declared EXTERNAL in the user's calling program. This ! subroutine is of the form: ! SUBROUTINE F (N, T, Y, YDOT) ! REAL Y(*), YDOT(*) ! . ! . ! YDOT(1) = ... ! . ! . ! YDOT(N) = ... ! END (Sample) ! This computes YDOT = F(Y,T), the right hand side of the ! differential equations. Here Y is a vector of length at ! least N. The actual length of Y is determined by the ! user's declaration in the program which calls SDRIV3. ! Thus the dimensioning of Y in F, while required by FORTRAN ! convention, does not actually allocate any storage. When ! this subroutine is called, the first N components of Y are ! intermediate approximations to the solution components. ! The user should not alter these values. Here YDOT is a ! vector of length N. The user should only compute YDOT(I) ! for I from 1 to N. Normally a return from F passes ! control back to SDRIV3. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls SDRIV3, he should set N to zero. ! SDRIV3 will signal this by returning a value of NSTATE ! equal to 6 . Altering the value of N in F has no effect ! on the value of N in the call sequence of SDRIV3. ! ! NSTATE = An integer describing the status of integration. The ! meaning of NSTATE is as follows: ! 1 (Input) Means the first call to the routine. This ! value must be set by the user. On all subsequent ! calls the value of NSTATE should be tested by the ! user, but must not be altered. (As a convenience to ! the user who may wish to put out the initial ! conditions, SDRIV3 can be called with NSTATE=1, and ! TOUT=T. In this case the program will return with ! NSTATE unchanged, i.e., NSTATE=1.) ! 2 (Output) Means a successful integration. If a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance TOUT and call ! again. All other parameters are automatically set. ! 3 (Output)(Unsuccessful) Means the integrator has taken ! MXSTEP steps without reaching TOUT. The user can ! continue the integration by simply calling SDRIV3 ! again. ! 4 (Output)(Unsuccessful) Means too much accuracy has ! been requested. EPS has been increased to a value ! the program estimates is appropriate. The user can ! continue the integration by simply calling SDRIV3 ! again. ! 5 (Output) A root was found at a point less than TOUT. ! The user can continue the integration toward TOUT by ! simply calling SDRIV3 again. ! 6 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE F. ! 7 (Output)(Unsuccessful) N has been set to zero in ! FUNCTION G. See description of G below. ! 8 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE JACOBN. See description of JACOBN below. ! 9 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE FA. See description of FA below. ! 10 (Output)(Unsuccessful) N has been set to zero in ! SUBROUTINE USERS. See description of USERS below. ! 11 (Output)(Successful) For NTASK = 2 or 3, T is beyond ! TOUT. The solution was obtained by interpolation. ! The user can continue the integration by simply ! advancing TOUT and calling SDRIV3 again. ! 12 (Output)(Unsuccessful) The solution could not be ! obtained. The value of IERFLG (see description ! below) for a "Recoverable" situation indicates the ! type of difficulty encountered: either an illegal ! value for a parameter or an inability to continue the ! solution. For this condition the user should take ! corrective action and reset NSTATE to 1 before ! calling SDRIV3 again. Otherwise the program will ! terminate the run. ! ! TOUT = (Input) The point at which the solution is desired. The ! position of TOUT relative to T on the first call ! determines the direction of integration. ! ! NTASK = (Input) An index specifying the manner of returning the ! solution, according to the following: ! NTASK = 1 Means SDRIV3 will integrate past TOUT and ! interpolate the solution. This is the most ! efficient mode. ! NTASK = 2 Means SDRIV3 will return the solution after ! each internal integration step, or at TOUT, ! whichever comes first. In the latter case, ! the program integrates exactly to TOUT. ! NTASK = 3 Means SDRIV3 will adjust its internal step to ! reach TOUT exactly (useful if a singularity ! exists beyond TOUT.) ! ! NROOT = (Input) The number of equations whose roots are desired. ! If NROOT is zero, the root search is not active. This ! option is useful for obtaining output at points which are ! not known in advance, but depend upon the solution, e.g., ! when some solution component takes on a specified value. ! The root search is carried out using the user-written ! function G (see description of G below.) SDRIV3 attempts ! to find the value of T at which one of the equations ! changes sign. SDRIV3 can find at most one root per ! equation per internal integration step, and will then ! return the solution either at TOUT or at a root, whichever ! occurs first in the direction of integration. The initial ! point is never reported as a root. The index of the ! equation whose root is being reported is stored in the ! sixth element of IWORK. ! NOTE: NROOT is never altered by this program. ! ! EPS = On input, the requested relative accuracy in all solution ! components. EPS = 0 is allowed. On output, the adjusted ! relative accuracy if the input value was too small. The ! value of EPS should be set as large as is reasonable, ! because the amount of work done by SDRIV3 increases as EPS ! decreases. ! ! EWT = (Input) Problem zero, i.e., the smallest, nonzero, ! physically meaningful value for the solution. (Array, ! possibly of length one. See following description of ! IERROR.) Setting EWT smaller than necessary can adversely ! affect the running time. ! ! IERROR = (Input) Error control indicator. A value of 3 is ! suggested for most problems. Other choices and detailed ! explanations of EWT and IERROR are given below for those ! who may need extra flexibility. ! ! These last three input quantities EPS, EWT and IERROR ! control the accuracy of the computed solution. EWT and ! IERROR are used internally to compute an array YWT. One ! step error estimates divided by YWT(I) are kept less than ! EPS in root mean square norm. ! IERROR (Set by the user) = ! 1 Means YWT(I) = 1. (Absolute error control) ! EWT is ignored. ! 2 Means YWT(I) = ABS(Y(I)), (Relative error control) ! EWT is ignored. ! 3 Means YWT(I) = MAX(ABS(Y(I)), EWT(1)). ! 4 Means YWT(I) = MAX(ABS(Y(I)), EWT(I)). ! This choice is useful when the solution components ! have differing scales. ! 5 Means YWT(I) = EWT(I). ! If IERROR is 3, EWT need only be dimensioned one. ! If IERROR is 4 or 5, the user must dimension EWT at least ! N, and set its values. ! ! MINT = (Input) The integration method indicator. ! MINT = 1 Means the Adams methods, and is used for ! non-stiff problems. ! MINT = 2 Means the stiff methods of Gear (i.e., the ! backward differentiation formulas), and is ! used for stiff problems. ! MINT = 3 Means the program dynamically selects the ! Adams methods when the problem is non-stiff ! and the Gear methods when the problem is ! stiff. When using the Adams methods, the ! program uses a value of MITER=0; when using ! the Gear methods, the program uses the value ! of MITER provided by the user. Only a value ! of IMPL = 0 and a value of MITER = 1, 2, 4, or ! 5 is allowed for this option. The user may ! not alter the value of MINT or MITER without ! restarting, i.e., setting NSTATE to 1. ! ! MITER = (Input) The iteration method indicator. ! MITER = 0 Means functional iteration. This value is ! suggested for non-stiff problems. ! MITER = 1 Means chord method with analytic Jacobian. ! In this case, the user supplies subroutine ! JACOBN (see description below). ! MITER = 2 Means chord method with Jacobian calculated ! internally by finite differences. ! MITER = 3 Means chord method with corrections computed ! by the user-written routine USERS (see ! description of USERS below.) This option ! allows all matrix algebra and storage ! decisions to be made by the user. When using ! a value of MITER = 3, the subroutine FA is ! not required, even if IMPL is not 0. For ! further information on using this option, see ! Section IV-E below. ! MITER = 4 Means the same as MITER = 1 but the A and ! Jacobian matrices are assumed to be banded. ! MITER = 5 Means the same as MITER = 2 but the A and ! Jacobian matrices are assumed to be banded. ! ! IMPL = (Input) The implicit method indicator. ! IMPL = 0 Means solving dY(I)/dT = F(Y(I),T). ! IMPL = 1 Means solving A*dY(I)/dT = F(Y(I),T), non- ! singular A (see description of FA below.) ! Only MINT = 1 or 2, and MITER = 1, 2, 3, 4, ! or 5 are allowed for this option. ! IMPL = 2,3 Means solving certain systems of hybrid ! differential/algebraic equations (see ! description of FA below.) Only MINT = 2 and ! MITER = 1, 2, 3, 4, or 5, are allowed for ! this option. ! The value of IMPL must not be changed during a problem. ! ! ML = (Input) The lower half-bandwidth in the case of a banded ! A or Jacobian matrix. (I.e., maximum(R-C) for nonzero ! A(R,C).) ! ! MU = (Input) The upper half-bandwidth in the case of a banded ! A or Jacobian matrix. (I.e., maximum(C-R).) ! ! MXORD = (Input) The maximum order desired. This is <= 12 for ! the Adams methods and <= 5 for the Gear methods. Normal ! value is 12 and 5, respectively. If MINT is 3, the ! maximum order used will be MIN(MXORD, 12) when using the ! Adams methods, and MIN(MXORD, 5) when using the Gear ! methods. MXORD must not be altered during a problem. ! ! HMAX = (Input) The maximum magnitude of the step size that will ! be used for the problem. This is useful for ensuring that ! important details are not missed. If this is not the ! case, a large value, such as the interval length, is ! suggested. ! ! WORK ! LENW = (Input) ! WORK is an array of LENW real words used ! internally for temporary storage. The user must allocate ! space for this array in the calling program by a statement ! such as ! REAL WORK(...) ! The following table gives the required minimum value for ! the length of WORK, depending on the value of IMPL and ! MITER. LENW should be set to the value used. The ! contents of WORK should not be disturbed between calls to ! SDRIV3. ! ! IMPL = 0 1 2 3 ! --------------------------------------------------------- ! MITER = 0 (MXORD+4)*N Not allowed Not allowed Not allowed ! + 2*NROOT ! + 250 ! ! 1,2 N*N + 2*N*N + N*N + N*(N + NDE) ! (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N ! + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT ! + 250 + 250 + 250 + 250 ! ! 3 (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N (MXORD+4)*N ! + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT ! + 250 + 250 + 250 + 250 ! ! 4,5 (2*ML+MU+1) 2*(2*ML+MU+1) (2*ML+MU+1) (2*ML+MU+1)* ! *N + *N + *N + (N+NDE) + ! (MXORD+5)*N (MXORD+5)*N (MXORD+6)*N + (MXORD+5)*N ! + 2*NROOT + 2*NROOT + 2*NROOT + 2*NROOT ! + 250 + 250 + 250 + 250 ! --------------------------------------------------------- ! ! IWORK ! LENIW = (Input) ! IWORK is an integer array of length LENIW used internally ! for temporary storage. The user must allocate space for ! this array in the calling program by a statement such as ! INTEGER IWORK(...) ! The length of IWORK should be at least ! 50 if MITER is 0 or 3, or ! N+50 if MITER is 1, 2, 4, or 5, or MINT is 3, ! and LENIW should be set to the value used. The contents ! of IWORK should not be disturbed between calls to SDRIV3. ! ! JACOBN = A subroutine supplied by the user, if MITER is 1 or 4. ! If this is the case, the name must be declared EXTERNAL in ! the user's calling program. Given a system of N ! differential equations, it is meaningful to speak about ! the partial derivative of the I-th right hand side with ! respect to the J-th dependent variable. In general there ! are N*N such quantities. Often however the equations can ! be ordered so that the I-th differential equation only ! involves dependent variables with index near I, e.g., I+1, ! I-2. Such a system is called banded. If, for all I, the ! I-th equation depends on at most the variables ! Y(I-ML), Y(I-ML+1), ... , Y(I), Y(I+1), ... , Y(I+MU) ! then we call ML+MU+1 the bandwidth of the system. In a ! banded system many of the partial derivatives above are ! automatically zero. For the cases MITER = 1, 2, 4, and 5, ! some of these partials are needed. For the cases ! MITER = 2 and 5 the necessary derivatives are ! approximated numerically by SDRIV3, and we only ask the ! user to tell SDRIV3 the value of ML and MU if the system ! is banded. For the cases MITER = 1 and 4 the user must ! derive these partials algebraically and encode them in ! subroutine JACOBN. By computing these derivatives the ! user can often save 20-30 per cent of the computing time. ! Usually, however, the accuracy is not much affected and ! most users will probably forego this option. The optional ! user-written subroutine JACOBN has the form: ! SUBROUTINE JACOBN (N, T, Y, DFDY, MATDIM, ML, MU) ! REAL Y(*), DFDY(MATDIM,*) ! . ! . ! Calculate values of DFDY ! . ! . ! END (Sample) ! Here Y is a vector of length at least N. The actual ! length of Y is determined by the user's declaration in the ! program which calls SDRIV3. Thus the dimensioning of Y in ! JACOBN, while required by FORTRAN convention, does not ! actually allocate any storage. When this subroutine is ! called, the first N components of Y are intermediate ! approximations to the solution components. The user ! should not alter these values. If the system is not ! banded (MITER=1), the partials of the I-th equation with ! respect to the J-th dependent function are to be stored in ! DFDY(I,J). Thus partials of the I-th equation are stored ! in the I-th row of DFDY. If the system is banded ! (MITER=4), then the partials of the I-th equation with ! respect to Y(J) are to be stored in DFDY(K,J), where ! K=I-J+MU+1 . Normally a return from JACOBN passes control ! back to SDRIV3. However, if the user would like to abort ! the calculation, i.e., return control to the program which ! calls SDRIV3, he should set N to zero. SDRIV3 will signal ! this by returning a value of NSTATE equal to +8(-8). ! Altering the value of N in JACOBN has no effect on the ! value of N in the call sequence of SDRIV3. ! ! FA = A subroutine supplied by the user if IMPL is not zero, and ! MITER is not 3. If so, the name must be declared EXTERNAL ! in the user's calling program. This subroutine computes ! the array A, where A*dY(I)/dT = F(Y(I),T). ! There are three cases: ! ! IMPL=1. ! Subroutine FA is of the form: ! SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) ! REAL Y(*), A(MATDIM,*) ! . ! . ! Calculate ALL values of A ! . ! . ! END (Sample) ! In this case A is assumed to be a nonsingular matrix, ! with the same structure as DFDY (see JACOBN description ! above). Programming considerations prevent complete ! generality. If MITER is 1 or 2, A is assumed to be full ! and the user must compute and store all values of ! A(I,J), I,J=1, ... ,N. If MITER is 4 or 5, A is assumed ! to be banded with lower and upper half bandwidth ML and ! MU. The left hand side of the I-th equation is a linear ! combination of dY(I-ML)/dT, dY(I-ML+1)/dT, ... , ! dY(I)/dT, ... , dY(I+MU-1)/dT, dY(I+MU)/dT. Thus in the ! I-th equation, the coefficient of dY(J)/dT is to be ! stored in A(K,J), where K=I-J+MU+1. ! NOTE: The array A will be altered between calls to FA. ! ! IMPL=2. ! Subroutine FA is of the form: ! SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) ! REAL Y(*), A(*) ! . ! . ! Calculate non-zero values of A(1),...,A(NDE) ! . ! . ! END (Sample) ! In this case it is assumed that the system is ordered by ! the user so that the differential equations appear ! first, and the algebraic equations appear last. The ! algebraic equations must be written in the form: ! 0 = F(Y(I),T). When using this option it is up to the ! user to provide initial values for the Y(I) that satisfy ! the algebraic equations as well as possible. It is ! further assumed that A is a vector of length NDE. All ! of the components of A, which may depend on T, Y(I), ! etc., must be set by the user to non-zero values. ! ! IMPL=3. ! Subroutine FA is of the form: ! SUBROUTINE FA (N, T, Y, A, MATDIM, ML, MU, NDE) ! REAL Y(*), A(MATDIM,*) ! . ! . ! Calculate ALL values of A ! . ! . ! END (Sample) ! In this case A is assumed to be a nonsingular NDE by NDE ! matrix with the same structure as DFDY (see JACOBN ! description above). Programming considerations prevent ! complete generality. If MITER is 1 or 2, A is assumed ! to be full and the user must compute and store all ! values of A(I,J), I,J=1, ... ,NDE. If MITER is 4 or 5, ! A is assumed to be banded with lower and upper half ! bandwidths ML and MU. The left hand side of the I-th ! equation is a linear combination of dY(I-ML)/dT, ! dY(I-ML+1)/dT, ... , dY(I)/dT, ... , dY(I+MU-1)/dT, ! dY(I+MU)/dT. Thus in the I-th equation, the coefficient ! of dY(J)/dT is to be stored in A(K,J), where K=I-J+MU+1. ! It is assumed that the system is ordered by the user so ! that the differential equations appear first, and the ! algebraic equations appear last. The algebraic ! equations must be written in the form 0 = F(Y(I),T). ! When using this option it is up to the user to provide ! initial values for the Y(I) that satisfy the algebraic ! equations as well as possible. ! NOTE: For IMPL = 3, the array A will be altered between ! calls to FA. ! Here Y is a vector of length at least N. The actual ! length of Y is determined by the user's declaration in the ! program which calls SDRIV3. Thus the dimensioning of Y in ! FA, while required by FORTRAN convention, does not ! actually allocate any storage. When this subroutine is ! called, the first N components of Y are intermediate ! approximations to the solution components. The user ! should not alter these values. FA is always called ! immediately after calling F, with the same values of T ! and Y. Normally a return from FA passes control back to ! SDRIV3. However, if the user would like to abort the ! calculation, i.e., return control to the program which ! calls SDRIV3, he should set N to zero. SDRIV3 will signal ! this by returning a value of NSTATE equal to +9(-9). ! Altering the value of N in FA has no effect on the value ! of N in the call sequence of SDRIV3. ! ! NDE = (Input) The number of differential equations. This is ! required only for IMPL = 2 or 3, with NDE < N. ! ! MXSTEP = (Input) The maximum number of internal steps allowed on ! one call to SDRIV3. ! ! G = A real FORTRAN function supplied by the user ! if NROOT is not 0. In this case, the name must be ! declared EXTERNAL in the user's calling program. G is ! repeatedly called with different values of IROOT to obtain ! the value of each of the NROOT equations for which a root ! is desired. G is of the form: ! REAL FUNCTION G (N, T, Y, IROOT) ! REAL Y(*) ! go to (10, ...), IROOT ! 10 G = ... ! . ! . ! END (Sample) ! Here, Y is a vector of length at least N, whose first N ! components are the solution components at the point T. ! The user should not alter these values. The actual length ! of Y is determined by the user's declaration in the ! program which calls SDRIV3. Thus the dimensioning of Y in ! G, while required by FORTRAN convention, does not actually ! allocate any storage. Normally a return from G passes ! control back to SDRIV3. However, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls SDRIV3, he should set N to zero. ! SDRIV3 will signal this by returning a value of NSTATE ! equal to +7(-7). In this case, the index of the equation ! being evaluated is stored in the sixth element of IWORK. ! Altering the value of N in G has no effect on the value of ! N in the call sequence of SDRIV3. ! ! USERS = A subroutine supplied by the user, if MITER is 3. ! If this is the case, the name must be declared EXTERNAL in ! the user's calling program. The routine USERS is called ! by SDRIV3 when certain linear systems must be solved. The ! user may choose any method to form, store and solve these ! systems in order to obtain the solution result that is ! returned to SDRIV3. In particular, this allows sparse ! matrix methods to be used. The call sequence for this ! routine is: ! ! SUBROUTINE USERS (Y, YH, YWT, SAVE1, SAVE2, T, H, EL, ! 8 IMPL, N, NDE, IFLAG) ! REAL Y(*), YH(*), YWT(*), SAVE1(*), ! 8 SAVE2(*), T, H, EL ! ! The input variable IFLAG indicates what action is to be ! taken. Subroutine USERS should perform the following ! operations, depending on the value of IFLAG and IMPL. ! ! IFLAG = 0 ! IMPL = 0. USERS is not called. ! IMPL = 1, 2 or 3. Solve the system A*X = SAVE2, ! returning the result in SAVE2. The array SAVE1 can ! be used as a work array. For IMPL = 1, there are N ! components to the system, and for IMPL = 2 or 3, ! there are NDE components to the system. ! ! IFLAG = 1 ! IMPL = 0. Compute, decompose and store the matrix ! (I - H*EL*J), where I is the identity matrix and J ! is the Jacobian matrix of the right hand side. The ! array SAVE1 can be used as a work array. ! IMPL = 1, 2 or 3. Compute, decompose and store the ! matrix (A - H*EL*J). The array SAVE1 can be used as ! a work array. ! ! IFLAG = 2 ! IMPL = 0. Solve the system ! (I - H*EL*J)*X = H*SAVE2 - YH - SAVE1, ! returning the result in SAVE2. ! IMPL = 1, 2 or 3. Solve the system ! (A - H*EL*J)*X = H*SAVE2 - A*(YH + SAVE1) ! returning the result in SAVE2. ! The array SAVE1 should not be altered. ! If IFLAG is 0 and IMPL is 1 or 2 and the matrix A is ! singular, or if IFLAG is 1 and one of the matrices ! (I - H*EL*J), (A - H*EL*J) is singular, the INTEGER ! variable IFLAG is to be set to -1 before RETURNing. ! Normally a return from USERS passes control back to ! SDRIV3. However, if the user would like to abort the ! calculation, i.e., return control to the program which ! calls SDRIV3, he should set N to zero. SDRIV3 will signal ! this by returning a value of NSTATE equal to +10(-10). ! Altering the value of N in USERS has no effect on the ! value of N in the call sequence of SDRIV3. ! ! IERFLG = An error flag. The error number associated with a ! diagnostic message (see Section III-A below) is the same ! as the corresponding value of IERFLG. The meaning of ! IERFLG: ! 0 The routine completed successfully. (No message is ! issued.) ! 3 (Warning) The number of steps required to reach TOUT ! exceeds MXSTEP. ! 4 (Warning) The value of EPS is too small. ! 11 (Warning) For NTASK = 2 or 3, T is beyond TOUT. ! The solution was obtained by interpolation. ! 15 (Warning) The integration step size is below the ! roundoff level of T. (The program issues this ! message as a warning but does not return control to ! the user.) ! 22 (Recoverable) N is not positive. ! 23 (Recoverable) MINT is less than 1 or greater than 3 . ! 24 (Recoverable) MITER is less than 0 or greater than ! 5 . ! 25 (Recoverable) IMPL is less than 0 or greater than 3 . ! 26 (Recoverable) The value of NSTATE is less than 1 or ! greater than 12 . ! 27 (Recoverable) EPS is less than zero. ! 28 (Recoverable) MXORD is not positive. ! 29 (Recoverable) For MINT = 3, either MITER = 0 or 3, or ! IMPL = 0 . ! 30 (Recoverable) For MITER = 0, IMPL is not 0 . ! 31 (Recoverable) For MINT = 1, IMPL is 2 or 3 . ! 32 (Recoverable) Insufficient storage has been allocated ! for the WORK array. ! 33 (Recoverable) Insufficient storage has been allocated ! for the IWORK array. ! 41 (Recoverable) The integration step size has gone ! to zero. ! 42 (Recoverable) The integration step size has been ! reduced about 50 times without advancing the ! solution. The problem setup may not be correct. ! 43 (Recoverable) For IMPL greater than 0, the matrix A ! is singular. ! 999 (Fatal) The value of NSTATE is 12 . ! ! III. OTHER COMMUNICATION TO THE USER .............................. ! ! A. The solver communicates to the user through the parameters ! above. In addition it writes diagnostic messages through the ! standard error handling program XERMSG. A complete description ! of XERMSG is given in "Guide to the SLATEC Common Mathematical ! Library" by Kirby W. Fong et al.. At installations which do not ! have this error handling package the short but serviceable ! routine, XERMSG, available with this package, can be used. That ! program uses the file named OUTPUT to transmit messages. ! ! B. The first three elements of WORK and the first five elements of ! IWORK will contain the following statistical data: ! AVGH The average step size used. ! HUSED The step size last used (successfully). ! AVGORD The average order used. ! IMXERR The index of the element of the solution vector that ! contributed most to the last error test. ! NQUSED The order last used (successfully). ! NSTEP The number of steps taken since last initialization. ! NFE The number of evaluations of the right hand side. ! NJE The number of evaluations of the Jacobian matrix. ! ! IV. REMARKS ....................................................... ! ! A. Other routines used: ! SDNTP, SDZRO, SDSTP, SDNTL, SDPST, SDCOR, SDCST, ! SDPSC, and SDSCL; ! SGEFA, SGESL, SGBFA, SGBSL, and SNRM2 (from LINPACK) ! R1MACH (from the Bell Laboratories Machine Constants Package) ! XERMSG (from the SLATEC Common Math Library) ! The last seven routines above, not having been written by the ! present authors, are not explicitly part of this package. ! ! B. On any return from SDRIV3 all information necessary to continue ! the calculation is contained in the call sequence parameters, ! including the work arrays. Thus it is possible to suspend one ! problem, integrate another, and then return to the first. ! ! C. If this package is to be used in an overlay situation, the user ! must declare in the primary overlay the variables in the call ! sequence to SDRIV3. ! ! D. Changing parameters during an integration. ! The value of NROOT, EPS, EWT, IERROR, MINT, MITER, or HMAX may ! be altered by the user between calls to SDRIV3. For example, if ! too much accuracy has been requested (the program returns with ! NSTATE = 4 and an increased value of EPS) the user may wish to ! increase EPS further. In general, prudence is necessary when ! making changes in parameters since such changes are not ! implemented until the next integration step, which is not ! necessarily the next call to SDRIV3. This can happen if the ! program has already integrated to a point which is beyond the ! new point TOUT. ! ! E. As the price for complete control of matrix algebra, the SDRIV3 ! USERS option puts all responsibility for Jacobian matrix ! evaluation on the user. It is often useful to approximate ! numerically all or part of the Jacobian matrix. However this ! must be done carefully. The FORTRAN sequence below illustrates ! the method we recommend. It can be inserted directly into ! subroutine USERS to approximate Jacobian elements in rows I1 ! to I2 and columns J1 to J2. ! REAL DFDY(N,N), EPSJ, H, R, R1MACH, ! 8 SAVE1(N), SAVE2(N), T, UROUND, Y(N), YJ, YWT(N) ! UROUND = R1MACH(4) ! EPSJ = SQRT(UROUND) ! DO 30 J = J1,J2 ! R = EPSJ*MAX(ABS(YWT(J)), ABS(Y(J))) ! if (R == 0.E0) R = YWT(J) ! YJ = Y(J) ! Y(J) = Y(J) + R ! call F (N, T, Y, SAVE1) ! if (N == 0) RETURN ! Y(J) = YJ ! DO 20 I = I1,I2 ! 20 DFDY(I,J) = (SAVE1(I) - SAVE2(I))/R ! 30 CONTINUE ! Many problems give rise to structured sparse Jacobians, e.g., ! block banded. It is possible to approximate them with fewer ! function evaluations than the above procedure uses; see Curtis, ! Powell and Reid, J. Inst. Maths Applics, (1974), Vol. 13, ! pp. 117-119. ! ! F. When any of the routines JACOBN, FA, G, or USERS, is not ! required, difficulties associated with unsatisfied externals can ! be avoided by using the name of the routine which calculates the ! right hand side of the differential equations in place of the ! corresponding name in the call sequence of SDRIV3. ! !***REFERENCES C. W. Gear, Numerical Initial Value Problems in ! Ordinary Differential Equations, Prentice-Hall, 1971. !***ROUTINES CALLED R1MACH, SDNTP, SDSTP, SDZRO, SGBFA, SGBSL, SGEFA, ! SGESL, SNRM2, XERMSG !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDRIV3 EXTERNAL F, JACOBN, FA, G, USERS REAL AE, BIG, EPS, EWT(*), G, GLAST, GNOW, H, HMAX, & HSIGN, HUSED, NROUND, RE, R1MACH, SIZE, SNRM2, SUM, T, TLAST, & TOUT, TROOT, UROUND, WORK(*), Y(*) INTEGER I, IA, IAVGH, IAVGRD, ICNVRG, IDFDY, IEL, IERFLG, IERROR, & IFAC, IFLAG, IGNOW, IH, IHMAX, IHOLD, IHSIGN, IHUSED, & IJROOT, IJSTPL, IJTASK, IMNT, IMNTLD, IMPL, IMTR, IMTRLD, & IMTRSV, IMXERR, IMXORD, IMXRDS, INDMXR, INDPRT, INDPVT, & INDTRT, INFE, INFO, INJE, INQ, INQUSE, INROOT, INRTLD, & INSTEP, INWAIT, IRC, IRMAX, IROOT, IMACH1, IMACH4, ISAVE1, & ISAVE2, IT, ITOUT, ITQ, ITREND, ITROOT, IWORK(*), IYH, & IYWT, J, JSTATE, JTROOT, LENCHK, LENIW, LENW, LIWCHK, & MATDIM, MAXORD, MINT, MITER, ML, MU, MXORD, MXSTEP, N, & NDE, NDECOM, NPAR, NROOT, NSTATE, NSTEPL, NTASK LOGICAL CONVRG CHARACTER INTGR1*8, INTGR2*8, RL1*16, RL2*16 PARAMETER(NROUND = 20.E0) PARAMETER(IAVGH = 1, IHUSED = 2, IAVGRD = 3, & IEL = 4, IH = 160, IHMAX = 161, IHOLD = 162, & IHSIGN = 163, IRC = 164, IRMAX = 165, IT = 166, & ITOUT = 167, ITQ = 168, ITREND = 204, IMACH1 = 205, & IMACH4 = 206, IYH = 251, & INDMXR = 1, INQUSE = 2, INSTEP = 3, INFE = 4, INJE = 5, & INROOT = 6, ICNVRG = 7, IJROOT = 8, IJTASK = 9, & IMNTLD = 10, IMTRLD = 11, INQ = 12, INRTLD = 13, & INDTRT = 14, INWAIT = 15, IMNT = 16, IMTRSV = 17, & IMTR = 18, IMXRDS = 19, IMXORD = 20, INDPRT = 21, & IJSTPL = 22, INDPVT = 51) !***FIRST EXECUTABLE STATEMENT SDRIV3 if (NSTATE == 12) THEN IERFLG = 999 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. The value of NSTATE is 12 .', IERFLG, 2) return ELSE if (NSTATE < 1 .OR. NSTATE > 12) THEN WRITE(INTGR1, '(I8)') NSTATE IERFLG = 26 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. Improper value for NSTATE(= '//INTGR1//').', & IERFLG, 1) NSTATE = 12 return end if NPAR = N if (EPS < 0.E0) THEN WRITE(RL1, '(E16.8)') EPS IERFLG = 27 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. EPS, '//RL1//', is negative.', IERFLG, 1) NSTATE = 12 return end if if (N <= 0) THEN WRITE(INTGR1, '(I8)') N IERFLG = 22 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. Number of equations, '//INTGR1// & ', is not positive.', IERFLG, 1) NSTATE = 12 return end if if (MXORD <= 0) THEN WRITE(INTGR1, '(I8)') MXORD IERFLG = 28 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. Maximum order, '//INTGR1// & ', is not positive.', IERFLG, 1) NSTATE = 12 return end if if (MINT < 1 .OR. MINT > 3) THEN WRITE(INTGR1, '(I8)') MINT IERFLG = 23 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. Improper value for the integration method '// & 'flag, '//INTGR1//' .', IERFLG, 1) NSTATE = 12 return ELSE if (MITER < 0 .OR. MITER > 5) THEN WRITE(INTGR1, '(I8)') MITER IERFLG = 24 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. Improper value for MITER(= '//INTGR1//').', & IERFLG, 1) NSTATE = 12 return ELSE if (IMPL < 0 .OR. IMPL > 3) THEN WRITE(INTGR1, '(I8)') IMPL IERFLG = 25 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. Improper value for IMPL(= '//INTGR1//').', & IERFLG, 1) NSTATE = 12 return ELSE if (MINT == 3 .AND. & (MITER == 0 .OR. MITER == 3 .OR. IMPL /= 0)) THEN WRITE(INTGR1, '(I8)') MITER WRITE(INTGR2, '(I8)') IMPL IERFLG = 29 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. For MINT = 3, the value of MITER, '//INTGR1// & ', and/or IMPL, '//INTGR2//', is not allowed.', IERFLG, 1) NSTATE = 12 return ELSE if ((IMPL >= 1 .AND. IMPL <= 3) .AND. MITER == 0) THEN WRITE(INTGR1, '(I8)') IMPL IERFLG = 30 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. For MITER = 0, the value of IMPL, '//INTGR1// & ', is not allowed.', IERFLG, 1) NSTATE = 12 return ELSE if ((IMPL == 2 .OR. IMPL == 3) .AND. MINT == 1) THEN WRITE(INTGR1, '(I8)') IMPL IERFLG = 31 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. For MINT = 1, the value of IMPL, '//INTGR1// & ', is not allowed.', IERFLG, 1) NSTATE = 12 return end if if (MITER == 0 .OR. MITER == 3) THEN LIWCHK = INDPVT - 1 ELSE if (MITER == 1 .OR. MITER == 2 .OR. MITER == 4 .OR. & MITER == 5) THEN LIWCHK = INDPVT + N - 1 end if if (LENIW < LIWCHK) THEN WRITE(INTGR1, '(I8)') LIWCHK IERFLG = 33 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. Insufficient storage allocated for the '// & 'IWORK array. Based on the value of the input parameters '// & 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) NSTATE = 12 return end if ! Allocate the WORK array ! IYH is the index of YH in WORK if (MINT == 1 .OR. MINT == 3) THEN MAXORD = MIN(MXORD, 12) ELSE if (MINT == 2) THEN MAXORD = MIN(MXORD, 5) end if IDFDY = IYH + (MAXORD + 1)*N ! IDFDY is the index of DFDY ! if (MITER == 0 .OR. MITER == 3) THEN IYWT = IDFDY ELSE if (MITER == 1 .OR. MITER == 2) THEN IYWT = IDFDY + N*N ELSE if (MITER == 4 .OR. MITER == 5) THEN IYWT = IDFDY + (2*ML + MU + 1)*N end if ! IYWT is the index of YWT ISAVE1 = IYWT + N ! ISAVE1 is the index of SAVE1 ISAVE2 = ISAVE1 + N ! ISAVE2 is the index of SAVE2 IGNOW = ISAVE2 + N ! IGNOW is the index of GNOW ITROOT = IGNOW + NROOT ! ITROOT is the index of TROOT IFAC = ITROOT + NROOT ! IFAC is the index of FAC if (MITER == 2 .OR. MITER == 5 .OR. MINT == 3) THEN IA = IFAC + N ELSE IA = IFAC end if ! IA is the index of A if (IMPL == 0 .OR. MITER == 3) THEN LENCHK = IA - 1 ELSE if (IMPL == 1 .AND. (MITER == 1 .OR. MITER == 2)) THEN LENCHK = IA - 1 + N*N ELSE if (IMPL == 1 .AND. (MITER == 4 .OR. MITER == 5)) THEN LENCHK = IA - 1 + (2*ML + MU + 1)*N ELSE if (IMPL == 2 .AND. MITER /= 3) THEN LENCHK = IA - 1 + N ELSE if (IMPL == 3 .AND. (MITER == 1 .OR. MITER == 2)) THEN LENCHK = IA - 1 + N*NDE ELSE if (IMPL == 3 .AND. (MITER == 4 .OR. MITER == 5)) THEN LENCHK = IA - 1 + (2*ML + MU + 1)*NDE end if if (LENW < LENCHK) THEN WRITE(INTGR1, '(I8)') LENCHK IERFLG = 32 call XERMSG('SLATEC', 'SDRIV3', & 'Illegal input. Insufficient storage allocated for the '// & 'WORK array. Based on the value of the input parameters '// & 'involved, the required storage is '//INTGR1//' .', IERFLG, 1) NSTATE = 12 return end if if (MITER == 0 .OR. MITER == 3) THEN MATDIM = 1 ELSE if (MITER == 1 .OR. MITER == 2) THEN MATDIM = N ELSE if (MITER == 4 .OR. MITER == 5) THEN MATDIM = 2*ML + MU + 1 end if if (IMPL == 0 .OR. IMPL == 1) THEN NDECOM = N ELSE if (IMPL == 2 .OR. IMPL == 3) THEN NDECOM = NDE end if if (NSTATE == 1) THEN ! Initialize parameters if (MINT == 1 .OR. MINT == 3) THEN IWORK(IMXORD) = MIN(MXORD, 12) ELSE if (MINT == 2) THEN IWORK(IMXORD) = MIN(MXORD, 5) end if IWORK(IMXRDS) = MXORD if (MINT == 1 .OR. MINT == 2) THEN IWORK(IMNT) = MINT IWORK(IMTR) = MITER IWORK(IMNTLD) = MINT IWORK(IMTRLD) = MITER ELSE if (MINT == 3) THEN IWORK(IMNT) = 1 IWORK(IMTR) = 0 IWORK(IMNTLD) = IWORK(IMNT) IWORK(IMTRLD) = IWORK(IMTR) IWORK(IMTRSV) = MITER end if WORK(IHMAX) = HMAX UROUND = R1MACH (4) WORK(IMACH4) = UROUND WORK(IMACH1) = R1MACH (1) if (NROOT /= 0) THEN RE = UROUND AE = WORK(IMACH1) end if H = (TOUT - T)*(1.E0 - 4.E0*UROUND) H = SIGN(MIN(ABS(H), HMAX), H) WORK(IH) = H HSIGN = SIGN(1.E0, H) WORK(IHSIGN) = HSIGN IWORK(IJTASK) = 0 WORK(IAVGH) = 0.E0 WORK(IHUSED) = 0.E0 WORK(IAVGRD) = 0.E0 IWORK(INDMXR) = 0 IWORK(INQUSE) = 0 IWORK(INSTEP) = 0 IWORK(IJSTPL) = 0 IWORK(INFE) = 0 IWORK(INJE) = 0 IWORK(INROOT) = 0 WORK(IT) = T IWORK(ICNVRG) = 0 IWORK(INDPRT) = 0 ! Set initial conditions DO 30 I = 1,N 30 WORK(I+IYH-1) = Y(I) if (T == TOUT) RETURN go to 180 ELSE UROUND = WORK(IMACH4) if (NROOT /= 0) THEN RE = UROUND AE = WORK(IMACH1) end if end if ! On a continuation, check ! that output points have ! been or will be overtaken. if (IWORK(ICNVRG) == 1) THEN CONVRG = .TRUE. ELSE CONVRG = .FALSE. end if T = WORK(IT) H = WORK(IH) HSIGN = WORK(IHSIGN) if (IWORK(IJTASK) == 0) go to 180 ! ! IWORK(IJROOT) flags unreported ! roots, and is set to the value of ! NTASK when a root was last selected. ! It is set to zero when all roots ! have been reported. IWORK(INROOT) ! contains the index and WORK(ITOUT) ! contains the value of the root last ! selected to be reported. ! IWORK(INRTLD) contains the value of ! NROOT and IWORK(INDTRT) contains ! the value of ITROOT when the array ! of roots was last calculated. if (NROOT /= 0) THEN if (IWORK(IJROOT) > 0) THEN ! TOUT has just been reported. ! If TROOT <= TOUT, report TROOT. if (NSTATE /= 5) THEN if (TOUT*HSIGN >= WORK(ITOUT)*HSIGN) THEN TROOT = WORK(ITOUT) call SDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) T = TROOT NSTATE = 5 IERFLG = 0 go to 580 end if ! A root has just been reported. ! Select the next root. ELSE TROOT = T IROOT = 0 DO 50 I = 1,IWORK(INRTLD) JTROOT = I + IWORK(INDTRT) - 1 if (WORK(JTROOT)*HSIGN <= TROOT*HSIGN) THEN ! ! Check for multiple roots. ! if (WORK(JTROOT) == WORK(ITOUT) .AND. & I > IWORK(INROOT)) THEN IROOT = I TROOT = WORK(JTROOT) go to 60 end if if (WORK(JTROOT)*HSIGN > WORK(ITOUT)*HSIGN) THEN IROOT = I TROOT = WORK(JTROOT) end if end if 50 CONTINUE 60 IWORK(INROOT) = IROOT WORK(ITOUT) = TROOT IWORK(IJROOT) = NTASK if (NTASK == 1) THEN if (IROOT == 0) THEN IWORK(IJROOT) = 0 ELSE if (TOUT*HSIGN >= TROOT*HSIGN) THEN call SDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), & Y) NSTATE = 5 T = TROOT IERFLG = 0 go to 580 end if end if ELSE if (NTASK == 2 .OR. NTASK == 3) THEN ! ! If there are no more roots, or the ! user has altered TOUT to be less ! than a root, set IJROOT to zero. ! if (IROOT == 0 .OR. (TOUT*HSIGN < TROOT*HSIGN)) THEN IWORK(IJROOT) = 0 ELSE call SDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), & Y) NSTATE = 5 IERFLG = 0 T = TROOT go to 580 end if end if end if end if end if ! if (NTASK == 1) THEN NSTATE = 2 if (T*HSIGN >= TOUT*HSIGN) THEN call SDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT IERFLG = 0 go to 580 end if ELSE if (NTASK == 2) THEN ! Check if TOUT has ! been reset < T if (T*HSIGN > TOUT*HSIGN) THEN WRITE(RL1, '(E16.8)') T WRITE(RL2, '(E16.8)') TOUT IERFLG = 11 call XERMSG('SLATEC', 'SDRIV3', & 'While integrating exactly to TOUT, T, '//RL1// & ', was beyond TOUT, '//RL2//' . Solution obtained by '// & 'interpolation.', IERFLG, 0) NSTATE = 11 call SDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT go to 580 end if ! Determine if TOUT has been overtaken ! if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT NSTATE = 2 IERFLG = 0 go to 560 end if ! If there are no more roots ! to report, report T. if (NSTATE == 5) THEN NSTATE = 2 IERFLG = 0 go to 560 end if NSTATE = 2 ! See if TOUT will ! be overtaken. if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) WORK(IH) = H if (H == 0.E0) go to 670 IWORK(IJTASK) = -1 end if ELSE if (NTASK == 3) THEN NSTATE = 2 if (T*HSIGN > TOUT*HSIGN) THEN WRITE(RL1, '(E16.8)') T WRITE(RL2, '(E16.8)') TOUT IERFLG = 11 call XERMSG('SLATEC', 'SDRIV3', & 'While integrating exactly to TOUT, T, '//RL1// & ', was beyond TOUT, '//RL2//' . Solution obtained by '// & 'interpolation.', IERFLG, 0) NSTATE = 11 call SDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT go to 580 end if if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT IERFLG = 0 go to 560 end if if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) WORK(IH) = H if (H == 0.E0) go to 670 IWORK(IJTASK) = -1 end if end if ! Implement changes in MINT, MITER, and/or HMAX. ! if ((MINT /= IWORK(IMNTLD) .OR. MITER /= IWORK(IMTRLD)) .AND. & MINT /= 3 .AND. IWORK(IMNTLD) /= 3) IWORK(IJTASK) = -1 if (HMAX /= WORK(IHMAX)) THEN H = SIGN(MIN(ABS(H), HMAX), H) if (H /= WORK(IH)) THEN IWORK(IJTASK) = -1 WORK(IH) = H end if WORK(IHMAX) = HMAX end if ! 180 NSTEPL = IWORK(INSTEP) DO 190 I = 1,N 190 Y(I) = WORK(I+IYH-1) if (NROOT /= 0) THEN DO 200 I = 1,NROOT WORK(I+IGNOW-1) = G (NPAR, T, Y, I) if (NPAR == 0) THEN IWORK(INROOT) = I NSTATE = 7 return end if 200 CONTINUE end if if (IERROR == 1) THEN DO 230 I = 1,N 230 WORK(I+IYWT-1) = 1.E0 go to 410 ELSE if (IERROR == 5) THEN DO 250 I = 1,N 250 WORK(I+IYWT-1) = EWT(I) go to 410 end if ! Reset YWT array. Looping point. 260 if (IERROR == 2) THEN DO 280 I = 1,N if (Y(I) == 0.E0) go to 290 280 WORK(I+IYWT-1) = ABS(Y(I)) go to 410 290 if (IWORK(IJTASK) == 0) THEN call F (NPAR, T, Y, WORK(ISAVE2)) if (NPAR == 0) THEN NSTATE = 6 return end if IWORK(INFE) = IWORK(INFE) + 1 if (MITER == 3 .AND. IMPL /= 0) THEN IFLAG = 0 call USERS (Y, WORK(IYH), WORK(IYWT), WORK(ISAVE1), & WORK(ISAVE2), T, H, WORK(IEL), IMPL, NPAR, & NDECOM, IFLAG) if (IFLAG == -1) go to 690 if (NPAR == 0) THEN NSTATE = 10 return end if ELSE if (IMPL == 1) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call SGEFA (WORK(IA), MATDIM, N, IWORK(INDPVT), INFO) if (INFO /= 0) go to 690 call SGESL (WORK(IA), MATDIM, N, IWORK(INDPVT), & WORK(ISAVE2), 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call SGBFA (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), & INFO) if (INFO /= 0) go to 690 call SGBSL (WORK(IA), MATDIM, N, ML, MU, IWORK(INDPVT), & WORK(ISAVE2), 0) end if ELSE if (IMPL == 2) THEN call FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if DO 340 I = 1,NDECOM if (WORK(I+IA-1) == 0.E0) go to 690 340 WORK(I+ISAVE2-1) = WORK(I+ISAVE2-1)/WORK(I+IA-1) ELSE if (IMPL == 3) THEN if (MITER == 1 .OR. MITER == 2) THEN call FA (NPAR, T, Y, WORK(IA), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call SGEFA (WORK(IA), MATDIM, NDE, IWORK(INDPVT), INFO) if (INFO /= 0) go to 690 call SGESL (WORK(IA), MATDIM, NDE, IWORK(INDPVT), & WORK(ISAVE2), 0) ELSE if (MITER == 4 .OR. MITER == 5) THEN call FA (NPAR, T, Y, WORK(IA+ML), MATDIM, ML, MU, NDECOM) if (NPAR == 0) THEN NSTATE = 9 return end if call SGBFA (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), & INFO) if (INFO /= 0) go to 690 call SGBSL (WORK(IA), MATDIM, NDE, ML, MU, IWORK(INDPVT), & WORK(ISAVE2), 0) end if end if end if DO 360 J = I,N if (Y(J) /= 0.E0) THEN WORK(J+IYWT-1) = ABS(Y(J)) ELSE if (IWORK(IJTASK) == 0) THEN WORK(J+IYWT-1) = ABS(H*WORK(J+ISAVE2-1)) ELSE WORK(J+IYWT-1) = ABS(WORK(J+IYH+N-1)) end if end if if (WORK(J+IYWT-1) == 0.E0) WORK(J+IYWT-1) = UROUND 360 CONTINUE ELSE if (IERROR == 3) THEN DO 380 I = 1,N 380 WORK(I+IYWT-1) = MAX(EWT(1), ABS(Y(I))) ELSE if (IERROR == 4) THEN DO 400 I = 1,N 400 WORK(I+IYWT-1) = MAX(EWT(I), ABS(Y(I))) end if ! 410 DO 420 I = 1,N 420 WORK(I+ISAVE2-1) = Y(I)/WORK(I+IYWT-1) SUM = SNRM2(N, WORK(ISAVE2), 1)/SQRT(REAL(N)) SUM = MAX(1.E0, SUM) if (EPS < SUM*UROUND) THEN EPS = SUM*UROUND*(1.E0 + 10.E0*UROUND) WRITE(RL1, '(E16.8)') T WRITE(RL2, '(E16.8)') EPS IERFLG = 4 call XERMSG('SLATEC', 'SDRIV3', & 'At T, '//RL1//', the requested accuracy, EPS, was not '// & 'obtainable with the machine precision. EPS has been '// & 'increased to '//RL2//' .', IERFLG, 0) NSTATE = 4 go to 560 end if if (ABS(H) >= UROUND*ABS(T)) THEN IWORK(INDPRT) = 0 ELSE if (IWORK(INDPRT) == 0) THEN WRITE(RL1, '(E16.8)') T WRITE(RL2, '(E16.8)') H IERFLG = 15 call XERMSG('SLATEC', 'SDRIV3', & 'At T, '//RL1//', the step size, '//RL2//', is smaller '// & 'than the roundoff level of T. This may occur if there is '// & 'an abrupt change in the right hand side of the '// & 'differential equations.', IERFLG, 0) IWORK(INDPRT) = 1 end if if (NTASK /= 2) THEN if ((IWORK(INSTEP)-NSTEPL) == MXSTEP) THEN WRITE(RL1, '(E16.8)') T WRITE(INTGR1, '(I8)') MXSTEP WRITE(RL2, '(E16.8)') TOUT IERFLG = 3 call XERMSG('SLATEC', 'SDRIV3', & 'At T, '//RL1//', '//INTGR1//' steps have been taken '// & 'without reaching TOUT, '//RL2//' .', IERFLG, 0) NSTATE = 3 go to 560 end if end if ! ! call SDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, ! 8 MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, ! 8 USERS, AVGH, AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, ! 8 NFE, NJE, NQUSED, NSTEP, T, Y, YH, A, CONVRG, ! 8 DFDY, EL, FAC, HOLD, IPVT, JSTATE, JSTEPL, NQ, NWAIT, ! 8 RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, MTRSV, ! 8 MXRDSV) ! call SDSTP (EPS, F, FA, WORK(IHMAX), IMPL, IERROR, JACOBN, & MATDIM, IWORK(IMXORD), IWORK(IMNT), IWORK(IMTR), ML, & MU, NPAR, NDECOM, WORK(IYWT), UROUND, USERS, & WORK(IAVGH), WORK(IAVGRD), WORK(IH), HUSED, & IWORK(IJTASK), IWORK(IMNTLD), IWORK(IMTRLD), & IWORK(INFE), IWORK(INJE), IWORK(INQUSE), & IWORK(INSTEP), WORK(IT), Y, WORK(IYH), WORK(IA), & CONVRG, WORK(IDFDY), WORK(IEL), WORK(IFAC), & WORK(IHOLD), IWORK(INDPVT), JSTATE, IWORK(IJSTPL), & IWORK(INQ), IWORK(INWAIT), WORK(IRC), WORK(IRMAX), & WORK(ISAVE1), WORK(ISAVE2), WORK(ITQ), WORK(ITREND), & MINT, IWORK(IMTRSV), IWORK(IMXRDS)) T = WORK(IT) H = WORK(IH) if (CONVRG) THEN IWORK(ICNVRG) = 1 ELSE IWORK(ICNVRG) = 0 end if go to (470, 670, 680, 690, 690, 660, 660, 660, 660, 660), JSTATE 470 IWORK(IJTASK) = 1 ! Determine if a root has been overtaken if (NROOT /= 0) THEN IROOT = 0 DO 500 I = 1,NROOT GLAST = WORK(I+IGNOW-1) GNOW = G (NPAR, T, Y, I) if (NPAR == 0) THEN IWORK(INROOT) = I NSTATE = 7 return end if WORK(I+IGNOW-1) = GNOW if (GLAST*GNOW > 0.E0) THEN WORK(I+ITROOT-1) = T + H ELSE if (GNOW == 0.E0) THEN WORK(I+ITROOT-1) = T IROOT = I ELSE if (GLAST == 0.E0) THEN WORK(I+ITROOT-1) = T + H ELSE if (ABS(HUSED) >= UROUND*ABS(T)) THEN TLAST = T - HUSED IROOT = I TROOT = T call SDZRO (AE, G, H, NPAR, IWORK(INQ), IROOT, RE, T, & WORK(IYH), UROUND, TROOT, TLAST, & GNOW, GLAST, Y) DO 480 J = 1,N 480 Y(J) = WORK(IYH+J-1) if (NPAR == 0) THEN IWORK(INROOT) = I NSTATE = 7 return end if WORK(I+ITROOT-1) = TROOT ELSE WORK(I+ITROOT-1) = T IROOT = I end if end if end if end if 500 CONTINUE if (IROOT == 0) THEN IWORK(IJROOT) = 0 ! Select the first root ELSE IWORK(IJROOT) = NTASK IWORK(INRTLD) = NROOT IWORK(INDTRT) = ITROOT TROOT = T + H DO 510 I = 1,NROOT if (WORK(I+ITROOT-1)*HSIGN < TROOT*HSIGN) THEN TROOT = WORK(I+ITROOT-1) IROOT = I end if 510 CONTINUE IWORK(INROOT) = IROOT WORK(ITOUT) = TROOT if (TROOT*HSIGN <= TOUT*HSIGN) THEN call SDNTP (H, 0, N, IWORK(INQ), T, TROOT, WORK(IYH), Y) NSTATE = 5 T = TROOT IERFLG = 0 go to 580 end if end if end if ! Test for NTASK condition to be satisfied NSTATE = 2 if (NTASK == 1) THEN if (T*HSIGN < TOUT*HSIGN) go to 260 call SDNTP (H, 0, N, IWORK(INQ), T, TOUT, WORK(IYH), Y) T = TOUT IERFLG = 0 go to 580 ! TOUT is assumed to have been attained ! exactly if T is within twenty roundoff ! units of TOUT, relative to MAX(TOUT, T). ! ELSE if (NTASK == 2) THEN if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT ELSE if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) WORK(IH) = H if (H == 0.E0) go to 670 IWORK(IJTASK) = -1 end if end if ELSE if (NTASK == 3) THEN if (ABS(TOUT - T) <= NROUND*UROUND*MAX(ABS(T), ABS(TOUT))) THEN T = TOUT ELSE if ((T + H)*HSIGN > TOUT*HSIGN) THEN H = TOUT - T if ((T + H)*HSIGN > TOUT*HSIGN) H = H*(1.E0 - 4.E0*UROUND) WORK(IH) = H if (H == 0.E0) go to 670 IWORK(IJTASK) = -1 end if go to 260 end if end if IERFLG = 0 ! All returns are made through this ! section. IMXERR is determined. 560 DO 570 I = 1,N 570 Y(I) = WORK(I+IYH-1) 580 if (IWORK(IJTASK) == 0) RETURN BIG = 0.E0 IMXERR = 1 DO 590 I = 1,N ! SIZE = ABS(ERROR(I)/YWT(I)) SIZE = ABS(WORK(I+ISAVE1-1)/WORK(I+IYWT-1)) if (BIG < SIZE) THEN BIG = SIZE IMXERR = I end if 590 CONTINUE IWORK(INDMXR) = IMXERR WORK(IHUSED) = HUSED return ! 660 NSTATE = JSTATE return ! Fatal errors are processed here ! 670 WRITE(RL1, '(E16.8)') T IERFLG = 41 call XERMSG('SLATEC', 'SDRIV3', & 'At T, '//RL1//', the attempted step size has gone to '// & 'zero. Often this occurs if the problem setup is incorrect.', & IERFLG, 1) NSTATE = 12 return ! 680 WRITE(RL1, '(E16.8)') T IERFLG = 42 call XERMSG('SLATEC', 'SDRIV3', & 'At T, '//RL1//', the step size has been reduced about 50 '// & 'times without advancing the solution. Often this occurs '// & 'if the problem setup is incorrect.', IERFLG, 1) NSTATE = 12 return ! 690 WRITE(RL1, '(E16.8)') T IERFLG = 43 call XERMSG('SLATEC', 'SDRIV3', & 'At T, '//RL1//', while solving A*YDOT = F, A is singular.', & IERFLG, 1) NSTATE = 12 return end subroutine SDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) ! !! SDSCL rescales the YH array whenever the step size is changed. !! !***LIBRARY SLATEC (SDRIVE) !***TYPE SINGLE PRECISION (SDSCL-S, DDSCL-D, CDSCL-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDSCL INTEGER I, J, N, NQ REAL H, HMAX, RC, RH, RMAX, R1, YH(N,*) !***FIRST EXECUTABLE STATEMENT SDSCL if (H < 1.E0) THEN RH = MIN(ABS(H)*RH, ABS(H)*RMAX, HMAX)/ABS(H) ELSE RH = MIN(RH, RMAX, HMAX/ABS(H)) end if R1 = 1.E0 DO 10 J = 1,NQ R1 = R1*RH DO 10 I = 1,N 10 YH(I,J+1) = YH(I,J+1)*R1 H = H*RH RC = RC*RH return end FUNCTION SDSDOT (N, SB, SX, INCX, SY, INCY) ! !! SDSDOT computes the inner product of two vectors with extended precision. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A4 !***TYPE SINGLE PRECISION (SDSDOT-S, CDCDOT-C) !***KEYWORDS BLAS, DOT PRODUCT, INNER PRODUCT, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SB single precision scalar to be added to inner product ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! SY single precision vector with N elements ! INCY storage spacing between elements of SY ! ! --Output-- ! SDSDOT single precision dot product (SB if N <= 0) ! ! Returns S.P. result with dot product accumulated in D.P. ! SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SDSDOT real SDSDOT REAL SX(*), SY(*), SB DOUBLE PRECISION DSDOT !***FIRST EXECUTABLE STATEMENT SDSDOT DSDOT = SB if (N <= 0) go to 30 if (INCX == INCY .AND. INCX > 0) go to 40 ! ! Code for unequal or nonpositive increments. ! KX = 1 KY = 1 if (INCX < 0) KX = 1+(1-N)*INCX if (INCY < 0) KY = 1+(1-N)*INCY DO 10 I = 1,N DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) KX = KX + INCX KY = KY + INCY 10 CONTINUE 30 SDSDOT = DSDOT return ! ! Code for equal and positive increments. ! 40 NS = N*INCX DO 50 I = 1,NS,INCX DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) 50 CONTINUE SDSDOT = DSDOT return end subroutine SDSTP (EPS, F, FA, HMAX, IMPL, IERROR, JACOBN, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, YWT, UROUND, USERS, AVGH, & AVGORD, H, HUSED, JTASK, MNTOLD, MTROLD, NFE, NJE, NQUSED, & NSTEP, T, Y, YH, A, CONVRG, DFDY, EL, FAC, HOLD, IPVT, JSTATE, & JSTEPL, NQ, NWAIT, RC, RMAX, SAVE1, SAVE2, TQ, TREND, ISWFLG, & MTRSV, MXRDSV) ! !! SDSTP performs one step of the integration of an initial value problem ... ! for a system of ordinary differential equations. ! !***LIBRARY SLATEC (SDRIVE) !***TYPE SINGLE PRECISION (SDSTP-S, DDSTP-D, CDSTP-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! Communication with SDSTP is done with the following variables: ! ! YH An N by MAXORD+1 array containing the dependent variables ! and their scaled derivatives. MAXORD, the maximum order ! used, is currently 12 for the Adams methods and 5 for the ! Gear methods. YH(I,J+1) contains the J-th derivative of ! Y(I), scaled by H**J/factorial(J). Only Y(I), ! 1 <= I <= N, need be set by the calling program on ! the first entry. The YH array should not be altered by ! the calling program. When referencing YH as a ! 2-dimensional array, use a column length of N, as this is ! the value used in SDSTP. ! DFDY A block of locations used for partial derivatives if MITER ! is not 0. If MITER is 1 or 2 its length must be at least ! N*N. If MITER is 4 or 5 its length must be at least ! (2*ML+MU+1)*N. ! YWT An array of N locations used in convergence and error tests ! SAVE1 ! SAVE2 Arrays of length N used for temporary storage. ! IPVT An integer array of length N used by the linear system ! solvers for the storage of row interchange information. ! A A block of locations used to store the matrix A, when using ! the implicit method. If IMPL is 1, A is a MATDIM by N ! array. If MITER is 1 or 2 MATDIM is N, and if MITER is 4 ! or 5 MATDIM is 2*ML+MU+1. If IMPL is 2 its length is N. ! If IMPL is 3, A is a MATDIM by NDE array. ! JTASK An integer used on input. ! It has the following values and meanings: ! == 0 Perform the first step. This value enables ! the subroutine to initialize itself. ! > 0 Take a new step continuing from the last. ! Assumes the last step was successful and ! user has not changed any parameters. ! < 0 Take a new step with a new value of H and/or ! MINT and/or MITER. ! JSTATE A completion code with the following meanings: ! 1 The step was successful. ! 2 A solution could not be obtained with H /= 0. ! 3 A solution was not obtained in MXTRY attempts. ! 4 For IMPL /= 0, the matrix A is singular. ! On a return with JSTATE > 1, the values of T and ! the YH array are as of the beginning of the last ! step, and H is the last step size attempted. !***ROUTINES CALLED SDCOR, SDCST, SDNTL, SDPSC, SDPST, SDSCL, SNRM2 !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDSTP EXTERNAL F, JACOBN, FA, USERS INTEGER I, IERROR, IMPL, IPVT(*), ISWFLG, ITER, J, JSTATE, JSTEPL, & JTASK, MATDIM, MAXORD, MINT, MITER, ML, MNTOLD, MTROLD, & MTRSV, MU, MXFAIL, MXITER, MXRDSV, MXTRY, N, NDE, NDJSTP, & NFAIL, NFE, NJE, NQ, NQUSED, NSTEP, NSV, NTRY, NWAIT REAL A(MATDIM,*), AVGH, AVGORD, BIAS1, BIAS2, BIAS3, & BND, CTEST, D, DENOM, DFDY(MATDIM,*), D1, EL(13,12), EPS, & ERDN, ERUP, ETEST, FAC(*), H, HMAX, HN, HOLD, HS, HUSED, & NUMER, RC, RCTEST, RH, RH1, RH2, RH3, RMAX, RMFAIL, RMNORM, & SAVE1(*), SAVE2(*), SNRM2, T, TOLD, TQ(3,12), TREND, TRSHLD, & UROUND, Y(*), YH(N,*), YWT(*), Y0NRM LOGICAL CONVRG, EVALFA, EVALJC, IER, SWITCH PARAMETER(BIAS1 = 1.3E0, BIAS2 = 1.2E0, BIAS3 = 1.4E0, MXFAIL = 3, & MXITER = 3, MXTRY = 50, RCTEST = .3E0, RMFAIL = 2.E0, & RMNORM = 10.E0, TRSHLD = 1.E0) PARAMETER (NDJSTP = 10) DATA IER /.FALSE./ !***FIRST EXECUTABLE STATEMENT SDSTP NSV = N BND = 0.E0 SWITCH = .FALSE. NTRY = 0 TOLD = T NFAIL = 0 if (JTASK <= 0) THEN call SDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, & UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, & YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, & RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) if (N == 0) go to 440 if (H == 0.E0) go to 400 if (IER) go to 420 end if 100 NTRY = NTRY + 1 if (NTRY > MXTRY) go to 410 T = T + H call SDPSC (1, N, NQ, YH) EVALJC = (((ABS(RC - 1.E0) > RCTEST) .OR. & (NSTEP >= JSTEPL + NDJSTP)) .AND. (MITER /= 0)) EVALFA = .NOT. EVALJC ! 110 ITER = 0 DO 115 I = 1,N 115 Y(I) = YH(I,1) call F (N, T, Y, SAVE2) if (N == 0) THEN JSTATE = 6 go to 430 end if NFE = NFE + 1 if (EVALJC .OR. IER) THEN call SDPST (EL, F, FA, H, IMPL, JACOBN, MATDIM, MITER, ML, & MU, N, NDE, NQ, SAVE2, T, USERS, Y, YH, YWT, UROUND, & NFE, NJE, A, DFDY, FAC, IER, IPVT, SAVE1, ISWFLG, & BND, JSTATE) if (N == 0) go to 430 if (IER) go to 160 CONVRG = .FALSE. RC = 1.E0 JSTEPL = NSTEP end if DO 125 I = 1,N 125 SAVE1(I) = 0.E0 ! Up to MXITER corrector iterations are taken. ! Convergence is tested by requiring the r.m.s. ! norm of changes to be less than EPS. The sum of ! the corrections is accumulated in the vector ! SAVE1(I). It is approximately equal to the L-th ! derivative of Y multiplied by ! H**L/(factorial(L-1)*EL(L,NQ)), and is thus ! proportional to the actual errors to the lowest ! power of H present (H**L). The YH array is not ! altered in the correction loop. The norm of the ! iterate difference is stored in D. If ! ITER > 0, an estimate of the convergence rate ! constant is stored in TREND, and this is used in ! the convergence test. ! 130 call SDCOR (DFDY, EL, FA, H, IERROR, IMPL, IPVT, MATDIM, MITER, & ML, MU, N, NDE, NQ, T, USERS, Y, YH, YWT, EVALFA, & SAVE1, SAVE2, A, D, JSTATE) if (N == 0) go to 430 if (ISWFLG == 3 .AND. MINT == 1) THEN if (ITER == 0) THEN NUMER = SNRM2(N, SAVE1, 1) DO 132 I = 1,N 132 DFDY(1,I) = SAVE1(I) Y0NRM = SNRM2(N, YH, 1) ELSE DENOM = NUMER DO 134 I = 1,N 134 DFDY(1,I) = SAVE1(I) - DFDY(1,I) NUMER = SNRM2(N, DFDY, MATDIM) if (EL(1,NQ)*NUMER <= 100.E0*UROUND*Y0NRM) THEN if (RMAX == RMFAIL) THEN SWITCH = .TRUE. go to 170 end if end if DO 136 I = 1,N 136 DFDY(1,I) = SAVE1(I) if (DENOM /= 0.E0) & BND = MAX(BND, NUMER/(DENOM*ABS(H)*EL(1,NQ))) end if end if if (ITER > 0) TREND = MAX(.9E0*TREND, D/D1) D1 = D CTEST = MIN(2.E0*TREND, 1.E0)*D if (CTEST <= EPS) go to 170 ITER = ITER + 1 if (ITER < MXITER) THEN DO 140 I = 1,N 140 Y(I) = YH(I,1) + EL(1,NQ)*SAVE1(I) call F (N, T, Y, SAVE2) if (N == 0) THEN JSTATE = 6 go to 430 end if NFE = NFE + 1 go to 130 end if ! The corrector iteration failed to converge in ! MXITER tries. If partials are involved but are ! not up to date, they are reevaluated for the next ! try. Otherwise the YH array is retracted to its ! values before prediction, and H is reduced, if ! possible. If not, a no-convergence exit is taken. if (CONVRG) THEN EVALJC = .TRUE. EVALFA = .FALSE. go to 110 end if 160 T = TOLD call SDPSC (-1, N, NQ, YH) NWAIT = NQ + 2 if (JTASK /= 0 .AND. JTASK /= 2) RMAX = RMFAIL if (ITER == 0) THEN RH = .3E0 ELSE RH = .9E0*(EPS/CTEST)**(.2E0) end if if (RH*H == 0.E0) go to 400 call SDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) go to 100 ! The corrector has converged. CONVRG is set ! to .TRUE. if partial derivatives were used, ! to indicate that they may need updating on ! subsequent steps. The error test is made. 170 CONVRG = (MITER /= 0) if (IERROR == 1 .OR. IERROR == 5) THEN DO 180 I = 1,NDE 180 SAVE2(I) = SAVE1(I)/YWT(I) ELSE DO 185 I = 1,NDE 185 SAVE2(I) = SAVE1(I)/MAX(ABS(Y(I)), YWT(I)) end if ETEST = SNRM2(NDE, SAVE2, 1)/(TQ(2,NQ)*SQRT(REAL(NDE))) ! ! The error test failed. NFAIL keeps track of ! multiple failures. Restore T and the YH ! array to their previous values, and prepare ! to try the step again. Compute the optimum ! step size for this or one lower order. if (ETEST > EPS) THEN T = TOLD call SDPSC (-1, N, NQ, YH) NFAIL = NFAIL + 1 if (NFAIL < MXFAIL .OR. NQ == 1) THEN if (JTASK /= 0 .AND. JTASK /= 2) RMAX = RMFAIL RH2 = 1.E0/(BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) if (NQ > 1) THEN if (IERROR == 1 .OR. IERROR == 5) THEN DO 190 I = 1,NDE 190 SAVE2(I) = YH(I,NQ+1)/YWT(I) ELSE DO 195 I = 1,NDE 195 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), YWT(I)) end if ERDN = SNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(REAL(NDE))) RH1 = 1.E0/MAX(1.E0, BIAS1*(ERDN/EPS)**(1.E0/NQ)) if (RH2 < RH1) THEN NQ = NQ - 1 RC = RC*EL(1,NQ)/EL(1,NQ+1) RH = RH1 ELSE RH = RH2 end if ELSE RH = RH2 end if NWAIT = NQ + 2 if (RH*H == 0.E0) go to 400 call SDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) go to 100 end if ! Control reaches this section if the error test has ! failed MXFAIL or more times. It is assumed that the ! derivatives that have accumulated in the YH array have ! errors of the wrong order. Hence the first derivative ! is recomputed, the order is set to 1, and the step is ! retried. NFAIL = 0 JTASK = 2 DO 215 I = 1,N 215 Y(I) = YH(I,1) call SDNTL (EPS, F, FA, HMAX, HOLD, IMPL, JTASK, MATDIM, & MAXORD, MINT, MITER, ML, MU, N, NDE, SAVE1, T, & UROUND, USERS, Y, YWT, H, MNTOLD, MTROLD, NFE, RC, & YH, A, CONVRG, EL, FAC, IER, IPVT, NQ, NWAIT, RH, & RMAX, SAVE2, TQ, TREND, ISWFLG, JSTATE) RMAX = RMNORM if (N == 0) go to 440 if (H == 0.E0) go to 400 if (IER) go to 420 go to 100 end if ! After a successful step, update the YH array. NSTEP = NSTEP + 1 HUSED = H NQUSED = NQ AVGH = ((NSTEP-1)*AVGH + H)/NSTEP AVGORD = ((NSTEP-1)*AVGORD + NQ)/NSTEP DO 230 J = 1,NQ+1 DO 230 I = 1,N 230 YH(I,J) = YH(I,J) + EL(J,NQ)*SAVE1(I) DO 235 I = 1,N 235 Y(I) = YH(I,1) ! If ISWFLG is 3, consider ! changing integration methods. if (ISWFLG == 3) THEN if (BND /= 0.E0) THEN if (MINT == 1 .AND. NQ <= 5) THEN HN = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.E0/(NQ+1))) HN = MIN(HN, 1.E0/(2.E0*EL(1,NQ)*BND)) HS = ABS(H)/MAX(UROUND, & (ETEST/(EPS*EL(NQ+1,1)))**(1.E0/(NQ+1))) if (HS > 1.2E0*HN) THEN MINT = 2 MNTOLD = MINT MITER = MTRSV MTROLD = MITER MAXORD = MIN(MXRDSV, 5) RC = 0.E0 RMAX = RMNORM TREND = 1.E0 call SDCST (MAXORD, MINT, ISWFLG, EL, TQ) NWAIT = NQ + 2 end if ELSE if (MINT == 2) THEN HS = ABS(H)/MAX(UROUND, (ETEST/EPS)**(1.E0/(NQ+1))) HN = ABS(H)/MAX(UROUND, & (ETEST*EL(NQ+1,1)/EPS)**(1.E0/(NQ+1))) HN = MIN(HN, 1.E0/(2.E0*EL(1,NQ)*BND)) if (HN >= HS) THEN MINT = 1 MNTOLD = MINT MITER = 0 MTROLD = MITER MAXORD = MIN(MXRDSV, 12) RMAX = RMNORM TREND = 1.E0 CONVRG = .FALSE. call SDCST (MAXORD, MINT, ISWFLG, EL, TQ) NWAIT = NQ + 2 end if end if end if end if if (SWITCH) THEN MINT = 2 MNTOLD = MINT MITER = MTRSV MTROLD = MITER MAXORD = MIN(MXRDSV, 5) NQ = MIN(NQ, MAXORD) RC = 0.E0 RMAX = RMNORM TREND = 1.E0 call SDCST (MAXORD, MINT, ISWFLG, EL, TQ) NWAIT = NQ + 2 end if ! Consider changing H if NWAIT = 1. Otherwise ! decrease NWAIT by 1. If NWAIT is then 1 and ! NQ < MAXORD, then SAVE1 is saved for use in ! a possible order increase on the next step. ! if (JTASK == 0 .OR. JTASK == 2) THEN RH = 1.E0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) if (RH > TRSHLD) call SDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) ELSE if (NWAIT > 1) THEN NWAIT = NWAIT - 1 if (NWAIT == 1 .AND. NQ < MAXORD) THEN DO 250 I = 1,NDE 250 YH(I,MAXORD+1) = SAVE1(I) end if ! If a change in H is considered, an increase or decrease in ! order by one is considered also. A change in H is made ! only if it is by a factor of at least TRSHLD. Factors ! RH1, RH2, and RH3 are computed, by which H could be ! multiplied at order NQ - 1, order NQ, or order NQ + 1, ! respectively. The largest of these is determined and the ! new order chosen accordingly. If the order is to be ! increased, we compute one additional scaled derivative. ! If there is a change of order, reset NQ and the ! coefficients. In any case H is reset according to RH and ! the YH array is rescaled. ELSE if (NQ == 1) THEN RH1 = 0.E0 ELSE if (IERROR == 1 .OR. IERROR == 5) THEN DO 270 I = 1,NDE 270 SAVE2(I) = YH(I,NQ+1)/YWT(I) ELSE DO 275 I = 1,NDE 275 SAVE2(I) = YH(I,NQ+1)/MAX(ABS(Y(I)), YWT(I)) end if ERDN = SNRM2(NDE, SAVE2, 1)/(TQ(1,NQ)*SQRT(REAL(NDE))) RH1 = 1.E0/MAX(UROUND, BIAS1*(ERDN/EPS)**(1.E0/NQ)) end if RH2 = 1.E0/MAX(UROUND, BIAS2*(ETEST/EPS)**(1.E0/(NQ+1))) if (NQ == MAXORD) THEN RH3 = 0.E0 ELSE if (IERROR == 1 .OR. IERROR == 5) THEN DO 290 I = 1,NDE 290 SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/YWT(I) ELSE DO 295 I = 1,NDE SAVE2(I) = (SAVE1(I) - YH(I,MAXORD+1))/ & MAX(ABS(Y(I)), YWT(I)) 295 CONTINUE end if ERUP = SNRM2(NDE, SAVE2, 1)/(TQ(3,NQ)*SQRT(REAL(NDE))) RH3 = 1.E0/MAX(UROUND, BIAS3*(ERUP/EPS)**(1.E0/(NQ+2))) end if if (RH1 > RH2 .AND. RH1 >= RH3) THEN RH = RH1 if (RH <= TRSHLD) go to 380 NQ = NQ - 1 RC = RC*EL(1,NQ)/EL(1,NQ+1) ELSE if (RH2 >= RH1 .AND. RH2 >= RH3) THEN RH = RH2 if (RH <= TRSHLD) go to 380 ELSE RH = RH3 if (RH <= TRSHLD) go to 380 DO 360 I = 1,N 360 YH(I,NQ+2) = SAVE1(I)*EL(NQ+1,NQ)/(NQ+1) NQ = NQ + 1 RC = RC*EL(1,NQ)/EL(1,NQ-1) end if if (ISWFLG == 3 .AND. MINT == 1) THEN if (BND /= 0.E0) RH = MIN(RH, 1.E0/(2.E0*EL(1,NQ)*BND*ABS(H))) end if call SDSCL (HMAX, N, NQ, RMAX, H, RC, RH, YH) RMAX = RMNORM 380 NWAIT = NQ + 2 end if ! All returns are made through this section. H is saved ! in HOLD to allow the caller to change H on the next step JSTATE = 1 HOLD = H return ! 400 JSTATE = 2 HOLD = H DO 405 I = 1,N 405 Y(I) = YH(I,1) return ! 410 JSTATE = 3 HOLD = H return ! 420 JSTATE = 4 HOLD = H return ! 430 T = TOLD call SDPSC (-1, NSV, NQ, YH) DO 435 I = 1,NSV 435 Y(I) = YH(I,1) 440 HOLD = H return end subroutine SDZRO (AE, F, H, N, NQ, IROOT, RE, T, YH, UROUND, B, C, & FB, FC, Y) ! !! SDZRO searches for a zero of a function F(N, T, Y, IROOT) ... ! between the given values B and C until the width of the ! interval (B, C) has collapsed to within a tolerance ! specified by the stopping criterion, ! ABS(B - C) <= 2.*(RW*ABS(B) + AE). ! !***LIBRARY SLATEC (SDRIVE) !***TYPE SINGLE PRECISION (SDZRO-S, DDZRO-D, CDZRO-C) !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! This is a special purpose version of ZEROIN, modified for use with ! the SDRIV package. ! ! Sandia Mathematical Program Library ! Mathematical Computing Services Division 5422 ! Sandia Laboratories ! P. O. Box 5800 ! Albuquerque, New Mexico 87115 ! Control Data 6600 Version 4.5, 1 November 1971 ! ! PARAMETERS ! F - Name of the external function, which returns a ! real result. This name must be in an ! EXTERNAL statement in the calling program. ! B - One end of the interval (B, C). The value returned for ! B usually is the better approximation to a zero of F. ! C - The other end of the interval (B, C). ! RE - Relative error used for RW in the stopping criterion. ! If the requested RE is less than machine precision, ! then RW is set to approximately machine precision. ! AE - Absolute error used in the stopping criterion. If the ! given interval (B, C) contains the origin, then a ! nonzero value should be chosen for AE. ! !***REFERENCES L. F. Shampine and H. A. Watts, ZEROIN, a root-solving ! routine, SC-TM-70-631, Sept 1970. ! T. J. Dekker, Finding a zero by means of successive ! linear interpolation, Constructive Aspects of the ! Fundamental Theorem of Algebra, edited by B. Dejon ! and P. Henrici, 1969. !***ROUTINES CALLED SDNTP !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 900329 Initial submission to SLATEC. !***END PROLOGUE SDZRO INTEGER IC, IROOT, KOUNT, N, NQ REAL A, ACBS, ACMB, AE, B, C, CMB, ER, F, FA, FB, FC, & H, P, Q, RE, RW, T, TOL, UROUND, Y(*), YH(N,*) !***FIRST EXECUTABLE STATEMENT SDZRO ER = 4.E0*UROUND RW = MAX(RE, ER) IC = 0 ACBS = ABS(B - C) A = C FA = FC KOUNT = 0 ! Perform interchange 10 if (ABS(FC) < ABS(FB)) THEN A = B FA = FB B = C FB = FC C = A FC = FA end if CMB = 0.5E0*(C - B) ACMB = ABS(CMB) TOL = RW*ABS(B) + AE ! Test stopping criterion if (ACMB <= TOL) RETURN if (KOUNT > 50) RETURN ! Calculate new iterate implicitly as ! B + P/Q, where we arrange P >= 0. ! The implicit form is used to prevent overflow. P = (B - A)*FB Q = FA - FB if (P < 0.E0) THEN P = -P Q = -Q end if ! Update A and check for satisfactory reduction ! in the size of our bounding interval. A = B FA = FB IC = IC + 1 if (IC >= 4) THEN if (8.E0*ACMB >= ACBS) THEN ! Bisect B = 0.5E0*(C + B) go to 20 end if IC = 0 end if ACBS = ACMB ! Test for too small a change if (P <= ABS(Q)*TOL) THEN ! Increment by tolerance B = B + SIGN(TOL, CMB) ! Root ought to be between ! B and (C + B)/2. ELSE if (P < CMB*Q) THEN ! Interpolate B = B + P/Q ELSE ! Bisect B = 0.5E0*(C + B) end if ! Have completed computation ! for new iterate B. 20 call SDNTP (H, 0, N, NQ, T, B, YH, Y) FB = F(N, B, Y, IROOT) if (N == 0) RETURN if (FB == 0.E0) RETURN KOUNT = KOUNT + 1 ! ! Decide whether next step is interpolation or extrapolation ! if (SIGN(1.0E0, FB) == SIGN(1.0E0, FC)) THEN C = A FC = FA end if go to 10 end subroutine SEPELI (INTL, IORDER, A, B, M, MBDCND, BDA, ALPHA, BDB, & BETA, C, D, N, NBDCND, BDC, GAMA, BDD, XNU, COFX, COFY, GRHS, & USOL, IDMN, W, PERTRB, IERROR) ! !! SEPELI discretizes and solves a second and, optionally, a fourth order ... ! finite difference approximation on a uniform grid to ! the general separable elliptic partial differential ! equation on a rectangle with any combination of periodic or ! mixed boundary conditions. ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A2 !***TYPE SINGLE PRECISION (SEPELI-S) !***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SEPARABLE !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Dimension of BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1), ! Arguments USOL(IDMN,N+1), GRHS(IDMN,N+1), ! W (see argument list) ! ! Latest Revision March 1977 ! ! Purpose SEPELI solves for either the second-order ! finite difference approximation or a ! fourth-order approximation to a separable ! elliptic equation. ! ! 2 2 ! AF(X)*d U/dX + BF(X)*dU/dX + CF(X)*U + ! 2 2 ! DF(Y)*d U/dY + EF(Y)*dU/dY + FF(Y)*U ! ! = G(X,Y) ! ! on a rectangle (X greater than or equal to A ! and less than or equal to B; Y greater than ! or equal to C and less than or equal to D). ! Any combination of periodic or mixed boundary ! conditions is allowed. ! ! Purpose The possible boundary conditions are: ! in the X-direction: ! (0) Periodic, U(X+B-A,Y)=U(X,Y) for all Y,X ! (1) U(A,Y), U(B,Y) are specified for all Y ! (2) U(A,Y), dU(B,Y)/dX+BETA*U(B,Y) are ! specified for all Y ! (3) dU(A,Y)/dX+ALPHA*U(A,Y),dU(B,Y)/dX+ ! BETA*U(B,Y) are specified for all Y ! (4) dU(A,Y)/dX+ALPHA*U(A,Y),U(B,Y) are ! specified for all Y ! ! in the Y-direction: ! (0) Periodic, U(X,Y+D-C)=U(X,Y) for all X,Y ! (1) U(X,C),U(X,D) are specified for all X ! (2) U(X,C),dU(X,D)/dY+XNU*U(X,D) are specified ! for all X ! (3) dU(X,C)/dY+GAMA*U(X,C),dU(X,D)/dY+ ! XNU*U(X,D) are specified for all X ! (4) dU(X,C)/dY+GAMA*U(X,C),U(X,D) are ! specified for all X ! ! Arguments ! ! On Input INTL ! = 0 On initial entry to SEPELI or if any of ! the arguments C, D, N, NBDCND, COFY are ! changed from a previous call ! = 1 If C, D, N, NBDCND, COFY are unchanged ! from the previous call. ! ! IORDER ! = 2 If a second-order approximation is sought ! = 4 If a fourth-order approximation is sought ! ! A,B ! The range of the X-independent variable; ! i.e., X is greater than or equal to A and ! less than or equal to B. A must be less than ! B. ! ! M ! The number of panels into which the interval ! [A,B] is subdivided. Hence, there will be ! M+1 grid points in the X-direction given by ! XI=A+(I-1)*DLX for I=1,2,...,M+1 where ! DLX=(B-A)/M is the panel width. M must be ! less than IDMN and greater than 5. ! ! MBDCND ! Indicates the type of boundary condition at ! X=A and X=B ! = 0 If the solution is periodic in X; i.e., ! U(X+B-A,Y)=U(X,Y) for all Y,X ! = 1 If the solution is specified at X=A and ! X=B; i.e., U(A,Y) and U(B,Y) are ! specified for all Y ! = 2 If the solution is specified at X=A and ! the boundary condition is mixed at X=B; ! i.e., U(A,Y) and dU(B,Y)/dX+BETA*U(B,Y) ! are specified for all Y ! = 3 If the boundary conditions at X=A and X=B ! are mixed; i.e., dU(A,Y)/dX+ALPHA*U(A,Y) ! and dU(B,Y)/dX+BETA*U(B,Y) are specified ! for all Y ! = 4 If the boundary condition at X=A is mixed ! and the solution is specified at X=B; ! i.e., dU(A,Y)/dX+ALPHA*U(A,Y) and U(B,Y) ! are specified for all Y ! ! BDA ! A one-dimensional array of length N+1 that ! specifies the values of dU(A,Y)/dX+ ! ALPHA*U(A,Y) at X=A, when MBDCND=3 or 4. ! BDA(J) = dU(A,YJ)/dX+ALPHA*U(A,YJ); ! J=1,2,...,N+1 ! when MBDCND has any other value, BDA is a ! dummy parameter. ! ! On Input ALPHA ! The scalar multiplying the solution in case ! of a mixed boundary condition at X=A (see ! argument BDA). If MBDCND = 3,4 then ALPHA is ! a dummy parameter. ! ! BDB ! A one-dimensional array of length N+1 that ! specifies the values of dU(B,Y)/dX+ ! BETA*U(B,Y) at X=B. When MBDCND=2 or 3 ! BDB(J) = dU(B,YJ)/dX+BETA*U(B,YJ); ! J=1,2,...,N+1 ! When MBDCND has any other value, BDB is a ! dummy parameter. ! ! BETA ! The scalar multiplying the solution in case ! of a mixed boundary condition at X=B (see ! argument BDB). If MBDCND=2,3 then BETA is a ! dummy parameter. ! ! C,D ! The range of the Y-independent variable; ! i.e., Y is greater than or equal to C and ! less than or equal to D. C must be less than ! D. ! ! N ! The number of panels into which the interval ! [C,D] is subdivided. Hence, there will be ! N+1 grid points in the Y-direction given by ! YJ=C+(J-1)*DLY for J=1,2,...,N+1 where ! DLY=(D-C)/N is the panel width. In addition, ! N must be greater than 4. ! ! NBDCND ! Indicates the types of boundary conditions at ! Y=C and Y=D ! = 0 If the solution is periodic in Y; i.e., ! U(X,Y+D-C)=U(X,Y) for all X,Y ! = 1 If the solution is specified at Y=C and ! Y = D, i.e., U(X,C) and U(X,D) are ! specified for all X ! = 2 If the solution is specified at Y=C and ! the boundary condition is mixed at Y=D; ! i.e., U(X,C) and dU(X,D)/dY+XNU*U(X,D) ! are specified for all X ! = 3 If the boundary conditions are mixed at ! Y=C and Y=D; i.e., dU(X,D)/dY+GAMA*U(X,C) ! and dU(X,D)/dY+XNU*U(X,D) are specified ! for all X ! = 4 If the boundary condition is mixed at Y=C ! and the solution is specified at Y=D; ! i.e. dU(X,C)/dY+GAMA*U(X,C) and U(X,D) ! are specified for all X ! ! BDC ! A one-dimensional array of length M+1 that ! specifies the value of dU(X,C)/dY+GAMA*U(X,C) ! at Y=C. When NBDCND=3 or 4 ! BDC(I) = dU(XI,C)/dY + GAMA*U(XI,C); ! I=1,2,...,M+1. ! When NBDCND has any other value, BDC is a ! dummy parameter. ! ! GAMA ! The scalar multiplying the solution in case ! of a mixed boundary condition at Y=C (see ! argument BDC). If NBDCND=3,4 then GAMA is a ! dummy parameter. ! ! BDD ! A one-dimensional array of length M+1 that ! specifies the value of dU(X,D)/dY + ! XNU*U(X,D) at Y=C. When NBDCND=2 or 3 ! BDD(I) = dU(XI,D)/dY + XNU*U(XI,D); ! I=1,2,...,M+1. ! When NBDCND has any other value, BDD is a ! dummy parameter. ! ! XNU ! The scalar multiplying the solution in case ! of a mixed boundary condition at Y=D (see ! argument BDD). If NBDCND=2 or 3 then XNU is ! a dummy parameter. ! ! COFX ! A user-supplied subprogram with ! parameters X, AFUN, BFUN, CFUN which ! returns the values of the X-dependent ! coefficients AF(X), BF(X), CF(X) in ! the elliptic equation at X. ! ! COFY ! A user-supplied subprogram with ! parameters Y, DFUN, EFUN, FFUN which ! returns the values of the Y-dependent ! coefficients DF(Y), EF(Y), FF(Y) in ! the elliptic equation at Y. ! ! NOTE: COFX and COFY must be declared external ! in the calling routine. The values returned in ! AFUN and DFUN must satisfy AFUN*DFUN greater ! than 0 for A less than X less than B, ! C less than Y less than D (see IERROR=10). ! The coefficients provided may lead to a matrix ! equation which is not diagonally dominant in ! which case solution may fail (see IERROR=4). ! ! GRHS ! A two-dimensional array that specifies the ! values of the right-hand side of the elliptic ! equation; i.e., GRHS(I,J)=G(XI,YI), for ! I=2,...,M; J=2,...,N. At the boundaries, ! GRHS is defined by ! ! MBDCND GRHS(1,J) GRHS(M+1,J) ! ------ --------- ----------- ! 0 G(A,YJ) G(B,YJ) ! 1 * * ! 2 * G(B,YJ) J=1,2,...,N+1 ! 3 G(A,YJ) G(B,YJ) ! 4 G(A,YJ) * ! ! NBDCND GRHS(I,1) GRHS(I,N+1) ! ------ --------- ----------- ! 0 G(XI,C) G(XI,D) ! 1 * * ! 2 * G(XI,D) I=1,2,...,M+1 ! 3 G(XI,C) G(XI,D) ! 4 G(XI,C) * ! ! where * means these quantities are not used. ! GRHS should be dimensioned IDMN by at least ! N+1 in the calling routine. ! ! USOL ! A two-dimensional array that specifies the ! values of the solution along the boundaries. ! At the boundaries, USOL is defined by ! ! MBDCND USOL(1,J) USOL(M+1,J) ! ------ --------- ----------- ! 0 * * ! 1 U(A,YJ) U(B,YJ) ! 2 U(A,YJ) * J=1,2,...,N+1 ! 3 * * ! 4 * U(B,YJ) ! ! NBDCND USOL(I,1) USOL(I,N+1) ! ------ --------- ----------- ! 0 * * ! 1 U(XI,C) U(XI,D) ! 2 U(XI,C) * I=1,2,...,M+1 ! 3 * * ! 4 * U(XI,D) ! ! where * means the quantities are not used in ! the solution. ! ! If IORDER=2, the user may equivalence GRHS ! and USOL to save space. Note that in this ! case the tables specifying the boundaries of ! the GRHS and USOL arrays determine the ! boundaries uniquely except at the corners. ! If the tables call for both G(X,Y) and ! U(X,Y) at a corner then the solution must be ! chosen. For example, if MBDCND=2 and ! NBDCND=4, then U(A,C), U(A,D), U(B,D) must be ! chosen at the corners in addition to G(B,C). ! ! If IORDER=4, then the two arrays, USOL and ! GRHS, must be distinct. ! ! USOL should be dimensioned IDMN by at least ! N+1 in the calling routine. ! ! IDMN ! The row (or first) dimension of the arrays ! GRHS and USOL as it appears in the program ! calling SEPELI. This parameter is used to ! specify the variable dimension of GRHS and ! USOL. IDMN must be at least 7 and greater ! than or equal to M+1. ! ! W ! A one-dimensional array that must be provided ! by the user for work space. Let ! K=INT(log2(N+1))+1 and set L=2**(K+1). ! then (K-2)*L+K+10*N+12*M+27 will suffice ! as a length of W. THE actual length of W in ! the calling routine must be set in W(1) (see ! IERROR=11). ! ! On Output USOL ! Contains the approximate solution to the ! elliptic equation. USOL(I,J) is the ! approximation to U(XI,YJ) for I=1,2...,M+1 ! and J=1,2,...,N+1. The approximation has ! error O(DLX**2+DLY**2) if called with ! IORDER=2 and O(DLX**4+DLY**4) if called with ! IORDER=4. ! ! W ! Contains intermediate values that must not be ! destroyed if SEPELI is called again with ! INTL=1. In addition W(1) contains the exact ! minimal length (in floating point) required ! for the work space (see IERROR=11). ! ! PERTRB ! If a combination of periodic or derivative ! boundary conditions (i.e., ALPHA=BETA=0 if ! MBDCND=3; GAMA=XNU=0 if NBDCND=3) is ! specified and if the coefficients of U(X,Y) ! in the separable elliptic equation are zero ! (i.e., CF(X)=0 for X greater than or equal to ! A and less than or equal to B; FF(Y)=0 for ! Y greater than or equal to C and less than ! or equal to D) then a solution may not exist. ! PERTRB is a constant calculated and ! subtracted from the right-hand side of the ! matrix equations generated by SEPELI which ! insures that a solution exists. SEPELI then ! computes this solution which is a weighted ! minimal least squares solution to the ! original problem. ! ! IERROR ! An error flag that indicates invalid input ! parameters or failure to find a solution ! = 0 No error ! = 1 If A greater than B or C greater than D ! = 2 If MBDCND less than 0 or MBDCND greater ! than 4 ! = 3 If NBDCND less than 0 or NBDCND greater ! than 4 ! = 4 If attempt to find a solution fails. ! (the linear system generated is not ! diagonally dominant.) ! = 5 If IDMN is too small (see discussion of ! IDMN) ! = 6 If M is too small or too large (see ! discussion of M) ! = 7 If N is too small (see discussion of N) ! = 8 If IORDER is not 2 or 4 ! = 9 If INTL is not 0 or 1 ! = 10 If AFUN*DFUN less than or equal to 0 for ! some interior mesh point (XI,YJ) ! = 11 If the work space length input in W(1) ! is less than the exact minimal work ! space length required output in W(1). ! ! NOTE (concerning IERROR=4): for the ! coefficients input through COFX, COFY, the ! discretization may lead to a block ! tridiagonal linear system which is not ! diagonally dominant (for example, this ! happens if CFUN=0 and BFUN/(2.*DLX) greater ! than AFUN/DLX**2). In this case solution may ! fail. This cannot happen in the limit as ! DLX, DLY approach zero. Hence, the condition ! may be remedied by taking larger values for M ! or N. ! ! Entry Points SEPELI, SPELIP, CHKPRM, CHKSNG, ORTHOG, MINSOL, ! TRISP, DEFER, DX, DY, BLKTRI, BLKTR1, INDXB, ! INDXA, INDXC, PROD, PRODP, CPROD, CPRODP, ! PPADD, PSGF, BSRH, PPSGF, PPSPF, COMPB, ! TRUN1, STOR1, TQLRAT ! ! Special Conditions NONE ! ! Common Blocks SPLP, CBLKT ! ! I/O NONE ! ! Precision Single ! ! Specialist John C. Adams, NCAR, Boulder, Colorado 80307 ! ! Language FORTRAN ! ! History Developed at NCAR during 1975-76. ! ! Algorithm SEPELI automatically discretizes the separable ! elliptic equation which is then solved by a ! generalized cyclic reduction algorithm in the ! subroutine, BLKTRI. The fourth-order solution ! is obtained using 'Deferred Corrections' which ! is described and referenced in sections, ! references and method. ! ! Space Required 14654 (octal) = 6572 (decimal) ! ! Accuracy and Timing The following computational results were ! obtained by solving the sample problem at the ! end of this write-up on the Control Data 7600. ! The op count is proportional to M*N*log2(N). ! In contrast to the other routines in this ! chapter, accuracy is tested by computing and ! tabulating second- and fourth-order ! discretization errors. Below is a table ! containing computational results. The times ! given do not include initialization (i.e., ! times are for INTL=1). Note that the ! fourth-order accuracy is not realized until the ! mesh is sufficiently refined. ! ! Second-order Fourth-order Second-order Fourth-order ! M N Execution Time Execution Time Error Error ! (M SEC) (M SEC) ! 6 6 6 14 6.8E-1 1.2E0 ! 14 14 23 58 1.4E-1 1.8E-1 ! 30 30 100 247 3.2E-2 9.7E-3 ! 62 62 445 1,091 7.5E-3 3.0E-4 ! 126 126 2,002 4,772 1.8E-3 3.5E-6 ! ! Portability There are no machine-dependent constants. ! ! Required Resident SQRT, ABS, LOG ! Routines ! ! References Keller, H.B., 'Numerical Methods for Two-point ! Boundary-value Problems', Blaisdel (1968), ! Waltham, Mass. ! ! Swarztrauber, P., and R. Sweet (1975): ! 'Efficient FORTRAN Subprograms for The ! Solution of Elliptic Partial Differential ! Equations'. NCAR Technical Note ! NCAR-TN/IA-109, pp. 135-137. ! !***REFERENCES H. B. Keller, Numerical Methods for Two-point ! Boundary-value Problems, Blaisdel, Waltham, Mass., ! 1968. ! P. N. Swarztrauber and R. Sweet, Efficient Fortran ! subprograms for the solution of elliptic equations, ! NCAR TN/IA-109, July 1975, 138 pp. !***ROUTINES CALLED CHKPRM, SPELIP !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SEPELI ! DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , & W(*) EXTERNAL COFX ,COFY !***FIRST EXECUTABLE STATEMENT SEPELI call CHKPRM (INTL,IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,COFY, & IDMN,IERROR) if (IERROR /= 0) RETURN ! ! COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT ! L = N+1 if (NBDCND == 0) L = N LOGB2N = INT(LOG(L+0.5)/LOG(2.0))+1 LL = 2**(LOGB2N+1) K = M+1 L = N+1 LENGTH = (LOGB2N-2)*LL+LOGB2N+MAX(2*L,6*K)+5 if (NBDCND == 0) LENGTH = LENGTH+2*L IERROR = 11 LINPUT = INT(W(1)+0.5) LOUTPT = LENGTH+6*(K+L)+1 W(1) = LOUTPT if (LOUTPT > LINPUT) RETURN IERROR = 0 ! ! SET WORK SPACE INDICES ! 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 SPELIP (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N, & NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,W(I1),W(I2),W(I3), & W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11), & W(I12),GRHS,USOL,IDMN,W(I13),PERTRB,IERROR) return end subroutine SEPX4 (IORDER, A, B, M, MBDCND, BDA, ALPHA, BDB, BETA, & C, D, N, NBDCND, BDC, BDD, COFX, GRHS, USOL, IDMN, W, PERTRB, & IERROR) ! !! SEPX4 solves for either the second or fourth order finite difference ... ! approximation to the solution of a separable ! elliptic partial differential equation on a rectangle. ! Any combination of periodic or mixed boundary conditions is ! allowed. ! !***LIBRARY SLATEC (FISHPACK) !***CATEGORY I2B1A2 !***TYPE SINGLE PRECISION (SEPX4-S) !***KEYWORDS ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SEPARABLE !***AUTHOR Adams, J., (NCAR) ! Swarztrauber, P. N., (NCAR) ! Sweet, R., (NCAR) !***DESCRIPTION ! ! Purpose SEPX4 solves for either the second-order ! finite difference approximation or a ! fourth-order approximation to the ! solution of a separable elliptic equation ! AF(X)*UXX+BF(X)*UX+CF(X)*U+UYY = G(X,Y) ! ! on a rectangle (X greater than or equal to A ! and less than or equal to B; Y greater than ! or equal to C and less than or equal to D). ! Any combination of periodic or mixed boundary ! conditions is allowed. ! If boundary conditions in the X direction ! are periodic (see MBDCND=0 below) then the ! coefficients must satisfy ! AF(X)=C1,BF(X)=0,CF(X)=C2 for all X. ! Here C1,C2 are constants, C1 > 0. ! ! The possible boundary conditions are ! in the X-direction: ! (0) Periodic, U(X+B-A,Y)=U(X,Y) for all Y,X ! (1) U(A,Y), U(B,Y) are specified for all Y ! (2) U(A,Y), dU(B,Y)/dX+BETA*U(B,Y) are ! specified for all Y ! (3) dU(A,Y)/dX+ALPHA*U(A,Y),dU(B,Y)/dX+ ! BETA*U(B,Y) are specified for all Y ! (4) dU(A,Y)/dX+ALPHA*U(A,Y),U(B,Y) are ! specified for all Y ! ! In the Y-direction: ! (0) Periodic, U(X,Y+D-C)=U(X,Y) for all X,Y ! (1) U(X,C),U(X,D) are specified for all X ! (2) U(X,C),dU(X,D)/dY are specified for all X ! (3) dU(X,C)/DY,dU(X,D)/dY are specified for ! all X ! (4) dU(X,C)/DY,U(X,D) are specified for all X ! ! Usage Call SEPX4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB, ! BETA,C,D,N,NBDCND,BDC,BDD,COFX, ! GRHS,USOL,IDMN,W,PERTRB,IERROR) ! ! Arguments ! ! IORDER ! = 2 If a second-order approximation is sought ! = 4 If a fourth-order approximation is sought ! ! A,B ! The range of the X-independent variable; ! i.e., X is greater than or equal to A and ! less than or equal to B. A must be less than ! B. ! ! M ! The number of panels into which the interval ! [A,B] is subdivided. Hence, there will be ! M+1 grid points in the X-direction given by ! XI=A+(I-1)*DLX for I=1,2,...,M+1 where ! DLX=(B-A)/M is the panel width. M must be ! less than IDMN and greater than 5. ! ! MBDCND ! Indicates the type of boundary condition at ! X=A and X=B ! = 0 If the solution is periodic in X; i.e., ! U(X+B-A,Y)=U(X,Y) for all Y,X ! = 1 If the solution is specified at X=A and ! X=B; i.e., U(A,Y) and U(B,Y) are ! specified for all Y ! = 2 If the solution is specified at X=A and ! the boundary condition is mixed at X=B; ! i.e., U(A,Y) and dU(B,Y)/dX+BETA*U(B,Y) ! are specified for all Y ! = 3 If the boundary conditions at X=A and X=B ! are mixed; i.e., dU(A,Y)/dX+ALPHA*U(A,Y) ! and dU(B,Y)/dX+BETA*U(B,Y) are specified ! for all Y ! = 4 If the boundary condition at X=A is mixed ! and the solution is specified at X=B; ! i.e., dU(A,Y)/dX+ALPHA*U(A,Y) and U(B,Y) ! are specified for all Y ! ! BDA ! A one-dimensional array of length N+1 that ! specifies the values of dU(A,Y)/dX+ ! ALPHA*U(A,Y) at X=A, when MBDCND=3 or 4. ! BDA(J) = dU(A,YJ)/dX+ALPHA*U(A,YJ); ! J=1,2,...,N+1 ! When MBDCND has any other value, BDA is a ! dummy parameter. ! ! On Input ALPHA ! The scalar multiplying the solution in case ! of a mixed boundary condition AT X=A (see ! argument BDA). If MBDCND = 3,4 then ALPHA is ! a dummy parameter. ! ! BDB ! A one-dimensional array of length N+1 that ! specifies the values of dU(B,Y)/dX+ ! BETA*U(B,Y) at X=B. when MBDCND=2 or 3 ! BDB(J) = dU(B,YJ)/dX+BETA*U(B,YJ); ! J=1,2,...,N+1 ! When MBDCND has any other value, BDB is a ! dummy parameter. ! ! BETA ! The scalar multiplying the solution in case ! of a mixed boundary condition at X=B (see ! argument BDB). If MBDCND=2,3 then BETA is a ! dummy parameter. ! ! C,D ! The range of the Y-independent variable; ! i.e., Y is greater than or equal to C and ! less than or equal to D. C must be less than ! D. ! ! N ! The number of panels into which the interval ! [C,D] is subdivided. Hence, there will be ! N+1 grid points in the Y-direction given by ! YJ=C+(J-1)*DLY for J=1,2,...,N+1 where ! DLY=(D-C)/N is the panel width. In addition, ! N must be greater than 4. ! ! NBDCND ! Indicates the types of boundary conditions at ! Y=C and Y=D ! = 0 If the solution is periodic in Y; i.e., ! U(X,Y+D-C)=U(X,Y) for all X,Y ! = 1 If the solution is specified at Y=C and ! Y = D, i.e., U(X,C) and U(X,D) are ! specified for all X ! = 2 If the solution is specified at Y=C and ! the boundary condition is mixed at Y=D; ! i.e., dU(X,C)/dY and U(X,D) ! are specified for all X ! = 3 If the boundary conditions are mixed at ! Y= C and Y=D i.e., dU(X,D)/DY ! and dU(X,D)/dY are specified ! for all X ! = 4 If the boundary condition is mixed at Y=C ! and the solution is specified at Y=D; ! i.e. dU(X,C)/dY+GAMA*U(X,C) and U(X,D) ! are specified for all X ! ! BDC ! A one-dimensional array of length M+1 that ! specifies the value dU(X,C)/DY ! at Y=C. When NBDCND=3 or 4 ! BDC(I) = dU(XI,C)/DY ! I=1,2,...,M+1. ! When NBDCND has any other value, BDC is a ! dummy parameter. ! ! ! BDD ! A one-dimensional array of length M+1 that ! specifies the value of dU(X,D)/DY ! at Y=D. When NBDCND=2 or 3 ! BDD(I)=dU(XI,D)/DY ! I=1,2,...,M+1. ! When NBDCND has any other value, BDD is a ! dummy parameter. ! ! ! COFX ! A user-supplied subprogram with ! parameters X, AFUN, BFUN, CFUN which ! returns the values of the X-dependent ! coefficients AF(X), BF(X), CF(X) in ! the elliptic equation at X. ! If boundary conditions in the X direction ! are periodic then the coefficients ! must satisfy AF(X)=C1,BF(X)=0,CF(X)=C2 for ! all X. Here C1 > 0 and C2 are constants. ! ! Note that COFX must be declared external ! in the calling routine. ! ! GRHS ! A two-dimensional array that specifies the ! values of the right-hand side of the elliptic ! equation; i.e., GRHS(I,J)=G(XI,YI), for ! I=2,...,M; J=2,...,N. At the boundaries, ! GRHS is defined by ! ! MBDCND GRHS(1,J) GRHS(M+1,J) ! ------ --------- ----------- ! 0 G(A,YJ) G(B,YJ) ! 1 * * ! 2 * G(B,YJ) J=1,2,...,N+1 ! 3 G(A,YJ) G(B,YJ) ! 4 G(A,YJ) * ! ! NBDCND GRHS(I,1) GRHS(I,N+1) ! ------ --------- ----------- ! 0 G(XI,C) G(XI,D) ! 1 * * ! 2 * G(XI,D) I=1,2,...,M+1 ! 3 G(XI,C) G(XI,D) ! 4 G(XI,C) * ! ! where * means these quantities are not used. ! GRHS should be dimensioned IDMN by at least ! N+1 in the calling routine. ! ! USOL ! A two-dimensional array that specifies the ! values of the solution along the boundaries. ! At the boundaries, USOL is defined by ! ! MBDCND USOL(1,J) USOL(M+1,J) ! ------ --------- ----------- ! 0 * * ! 1 U(A,YJ) U(B,YJ) ! 2 U(A,YJ) * J=1,2,...,N+1 ! 3 * * ! 4 * U(B,YJ) ! ! NBDCND USOL(I,1) USOL(I,N+1) ! ------ --------- ----------- ! 0 * * ! 1 U(XI,C) U(XI,D) ! 2 U(XI,C) * I=1,2,...,M+1 ! 3 * * ! 4 * U(XI,D) ! ! where * means the quantities are not used in ! the solution. ! ! If IORDER=2, the user may equivalence GRHS ! and USOL to save space. Note that in this ! case the tables specifying the boundaries of ! the GRHS and USOL arrays determine the ! boundaries uniquely except at the corners. ! If the tables call for both G(X,Y) and ! U(X,Y) at a corner then the solution must be ! chosen. For example, if MBDCND=2 and ! NBDCND=4, then U(A,C), U(A,D), U(B,D) must be ! chosen at the corners in addition to G(B,C). ! ! If IORDER=4, then the two arrays, USOL and ! GRHS, must be distinct. ! ! USOL should be dimensioned IDMN by at least ! N+1 in the calling routine. ! ! IDMN ! The row (or first) dimension of the arrays ! GRHS and USOL as it appears in the program ! calling SEPX4. This parameter is used to ! specify the variable dimension of GRHS and ! USOL. IDMN must be at least 7 and greater ! than or equal to M+1. ! ! W ! A one-dimensional array that must be provided ! by the user for work space. ! 10*N+(16+INT(log2(N)))*(M+1)+23 will suffice ! as a length for W. The actual length of ! W in the calling routine must be set in W(1) ! (see IERROR=11). ! ! On Output USOL ! Contains the approximate solution to the ! elliptic equation. USOL(I,J) is the ! approximation to U(XI,YJ) for I=1,2...,M+1 ! and J=1,2,...,N+1. The approximation has ! error O(DLX**2+DLY**2) if called with ! IORDER=2 and O(DLX**4+DLY**4) if called with ! IORDER=4. ! ! W ! W(1) contains the exact minimal length (in ! floating point) required for the work space ! (see IERROR=11). ! ! PERTRB ! If a combination of periodic or derivative ! boundary conditions (i.e., ALPHA=BETA=0 if ! MBDCND=3) is specified and if CF(X)=0 for all ! X, then a solution to the discretized matrix ! equation may not exist (reflecting the non- ! uniqueness of solutions to the PDE). PERTRB ! is a constant calculated and subtracted from ! the right hand side of the matrix equation ! insuring the existence of a solution. ! SEPX4 computes this solution which is a ! weighted minimal least squares solution to ! the original problem. If singularity is ! not detected PERTRB=0.0 is returned by ! SEPX4. ! ! IERROR ! An error flag that indicates invalid input ! parameters or failure to find a solution ! = 0 No error ! = 1 If A greater than B or C greater than D ! = 2 If MBDCND less than 0 or MBDCND greater ! than 4 ! = 3 If NBDCND less than 0 or NBDCND greater ! than 4 ! = 4 If attempt to find a solution fails. ! (the linear system generated is not ! diagonally dominant.) ! = 5 If IDMN is too small (see discussion of ! IDMN) ! = 6 If M is too small or too large (see ! discussion of M) ! = 7 If N is too small (see discussion of N) ! = 8 If IORDER is not 2 or 4 ! = 10 If AFUN is less than or equal to zero ! for some interior mesh point XI ! = 11 If the work space length input in W(1) ! is less than the exact minimal work ! space length required output in W(1). ! = 12 If MBDCND=0 and AF(X)=CF(X)=constant ! or BF(X)=0 for all X is not true. ! ! *Long Description: ! ! Dimension of BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1), ! Arguments USOL(IDMN,N+1), GRHS(IDMN,N+1), ! W (see argument list) ! ! Latest Revision October 1980 ! ! Special Conditions NONE ! ! Common Blocks SPL4 ! ! I/O NONE ! ! Precision Single ! ! Required Library NONE ! Files ! ! Specialist John C. Adams, NCAR, Boulder, Colorado 80307 ! ! Language FORTRAN ! ! ! Entry Points SEPX4,SPELI4,CHKPR4,CHKSN4,ORTHO4,MINSO4,TRIS4, ! DEFE4,DX4,DY4 ! ! History SEPX4 was developed by modifying the ULIB ! routine SEPELI during October 1978. ! It should be used instead of SEPELI whenever ! possible. The increase in speed is at least ! a factor of three. ! ! Algorithm SEPX4 automatically discretizes the separable ! elliptic equation which is then solved by a ! generalized cyclic reduction algorithm in the ! subroutine POIS. The fourth order solution ! is obtained using the technique of ! deferred corrections referenced below. ! ! ! References Keller, H.B., 'Numerical Methods for Two-point ! Boundary-value Problems', Blaisdel (1968), ! Waltham, Mass. ! ! Swarztrauber, P., and R. Sweet (1975): ! 'Efficient FORTRAN Subprograms For The ! Solution of Elliptic Partial Differential ! Equations'. NCAR Technical Note ! NCAR-TN/IA-109, pp. 135-137. ! !***REFERENCES H. B. Keller, Numerical Methods for Two-point ! Boundary-value Problems, Blaisdel, Waltham, Mass., ! 1968. ! P. N. Swarztrauber and R. Sweet, Efficient Fortran ! subprograms for the solution of elliptic equations, ! NCAR TN/IA-109, July 1975, 138 pp. !***ROUTINES CALLED CHKPR4, SPELI4 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920122 Minor corrections and modifications to prologue. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SEPX4 ! DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , & W(*) EXTERNAL COFX !***FIRST EXECUTABLE STATEMENT SEPX4 call CHKPR4(IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,IDMN,IERROR) if (IERROR /= 0) RETURN ! ! COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT ! L = N+1 if (NBDCND == 0) L = N K = M+1 L = N+1 ! ESTIMATE LOG BASE 2 OF N LOG2N=INT(LOG(REAL(N+1))/LOG(2.0)+0.5) LENGTH=4*(N+1)+(10+LOG2N)*(M+1) IERROR = 11 LINPUT = INT(W(1)+0.5) LOUTPT = LENGTH+6*(K+L)+1 W(1) = LOUTPT if (LOUTPT > LINPUT) RETURN IERROR = 0 ! ! SET WORK SPACE INDICES ! 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 SPELI4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N, & NBDCND,BDC,BDD,COFX,W(I1),W(I2),W(I3), & W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11), & W(I12),GRHS,USOL,IDMN,W(I13),PERTRB,IERROR) return end subroutine SGBCO (ABD, LDA, N, ML, MU, IPVT, RCOND, Z) ! !! SGBCO factors a band matrix by Gaussian elimination and estimates ... ! the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A2 !***TYPE SINGLE PRECISION (SGBCO-S, DGBCO-D, CGBCO-C) !***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SBGCO factors a real band matrix by Gaussian ! elimination and estimates the condition of the matrix. ! ! If RCOND is not needed, SGBFA is slightly faster. ! To solve A*X = B , follow SBGCO by SGBSL. ! To compute INVERSE(A)*C , follow SBGCO by SGBSL. ! To compute DETERMINANT(A) , follow SBGCO by SGBDI. ! ! On Entry ! ! ABD REAL(LDA, N) ! contains the matrix in band storage. The columns ! of the matrix are stored in the columns of ABD and ! the diagonals of the matrix are stored in rows ! ML+1 through 2*ML+MU+1 of ABD . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= 2*ML + MU + 1 . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! ! On Return ! ! ABD an upper triangular matrix in band storage and ! the multipliers which were used to obtain it. ! The factorization can be written A = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z REAL(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! M = ML + MU + 1 ! DO 20 J = 1, N ! I1 = MAX(1, J-MU) ! I2 = MIN(N, J+ML) ! DO 10 I = I1, I2 ! K = I - J + M ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses rows ML+1 through 2*ML+MU+1 of ABD . ! In addition, the first ML rows in ABD are used for ! elements generated during the triangularization. ! The total number of rows needed in ABD is 2*ML+MU+1 . ! The ML+MU by ML+MU upper left triangle and the ! ML by ML lower right triangle are not referenced. ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABD should contain ! ! * * * + + + , * = not used ! * * 13243546 , + = used for pivoting ! * 1223344556 ! 112233445566 ! 2132435465 * ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SASUM, SAXPY, SDOT, SGBFA, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGBCO INTEGER LDA,N,ML,MU,IPVT(*) REAL ABD(LDA,*),Z(*) REAL RCOND ! REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER IS,INFO,J,JU,K,KB,KP1,L,LA,LM,LZ,M,MM ! ! COMPUTE 1-NORM OF A ! !***FIRST EXECUTABLE STATEMENT SGBCO ANORM = 0.0E0 L = ML + 1 IS = L + MU DO 10 J = 1, N ANORM = MAX(ANORM,SASUM(L,ABD(IS,J),1)) if (IS > ML + 1) IS = IS - 1 if (J <= MU) L = L + 1 if (J >= N - ML) L = L - 1 10 CONTINUE ! ! FACTOR ! call SGBFA(ABD,LDA,N,ML,MU,IPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . ! TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE ! CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE ! TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID ! OVERFLOW. ! ! SOLVE TRANS(U)*W = E ! EK = 1.0E0 DO 20 J = 1, N Z(J) = 0.0E0 20 CONTINUE M = ML + MU + 1 JU = 0 DO 100 K = 1, N if (Z(K) /= 0.0E0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= ABS(ABD(M,K))) go to 30 S = ABS(ABD(M,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 (ABD(M,K) == 0.0E0) go to 40 WK = WK/ABD(M,K) WKM = WKM/ABD(M,K) go to 50 40 CONTINUE WK = 1.0E0 WKM = 1.0E0 50 CONTINUE KP1 = K + 1 JU = MIN(MAX(JU,MU+IPVT(K)),N) MM = M if (KP1 > JU) go to 90 DO 60 J = KP1, JU MM = MM - 1 SM = SM + ABS(Z(J)+WKM*ABD(MM,J)) Z(J) = Z(J) + WK*ABD(MM,J) S = S + ABS(Z(J)) 60 CONTINUE if (S >= SM) go to 80 T = WKM - WK WK = WKM MM = M DO 70 J = KP1, JU MM = MM - 1 Z(J) = Z(J) + T*ABD(MM,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) ! ! SOLVE TRANS(L)*Y = W ! DO 120 KB = 1, N K = N + 1 - KB LM = MIN(ML,N-K) if (K < N) Z(K) = Z(K) + SDOT(LM,ABD(M+1,K),1,Z(K+1),1) if (ABS(Z(K)) <= 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) ! YNORM = 1.0E0 ! ! SOLVE L*V = Y ! DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T LM = MIN(ML,N-K) if (K < N) call SAXPY(LM,T,ABD(M+1,K),1,Z(K+1),1) if (ABS(Z(K)) <= 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 ! ! SOLVE U*Z = W ! DO 160 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= ABS(ABD(M,K))) go to 150 S = ABS(ABD(M,K))/ABS(Z(K)) call SSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE if (ABD(M,K) /= 0.0E0) Z(K) = Z(K)/ABD(M,K) if (ABD(M,K) == 0.0E0) Z(K) = 1.0E0 LM = MIN(K,M) - 1 LA = M - LM LZ = K - LM T = -Z(K) call SAXPY(LM,T,ABD(LA,K),1,Z(LZ),1) 160 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine SGBDI (ABD, LDA, N, ML, MU, IPVT, DET) ! !! SGBDI computes the determinant of a band matrix using the factors ... ! computed by SGBCO or SGBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D3A2 !***TYPE SINGLE PRECISION (SGBDI-S, DGBDI-D, CGBDI-C) !***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, ! MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SGBDI computes the determinant of a band matrix ! using the factors computed by SBGCO or SGBFA. ! If the inverse is needed, use SGBSL N times. ! ! On Entry ! ! ABD REAL(LDA, N) ! the output from SBGCO or SGBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from SBGCO or SGBFA. ! ! On Return ! ! DET REAL(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGBDI INTEGER LDA,N,ML,MU,IPVT(*) REAL ABD(LDA,*),DET(2) ! REAL TEN INTEGER I,M !***FIRST EXECUTABLE STATEMENT SGBDI M = ML + MU + 1 DET(1) = 1.0E0 DET(2) = 0.0E0 TEN = 10.0E0 DO 50 I = 1, N if (IPVT(I) /= I) DET(1) = -DET(1) DET(1) = ABD(M,I)*DET(1) if (DET(1) == 0.0E0) go to 60 10 if (ABS(DET(1)) >= 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)) < TEN) go to 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 go to 30 40 CONTINUE 50 CONTINUE 60 CONTINUE return end subroutine SGBFA (ABD, LDA, N, ML, MU, IPVT, INFO) ! !! SGBFA factors a band matrix using Gaussian elimination. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A2 !***TYPE SINGLE PRECISION (SGBFA-S, DGBFA-D, CGBFA-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SGBFA factors a real band matrix by elimination. ! ! SGBFA is usually called by SBGCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! ! On Entry ! ! ABD REAL(LDA, N) ! contains the matrix in band storage. The columns ! of the matrix are stored in the columns of ABD and ! the diagonals of the matrix are stored in rows ! ML+1 through 2*ML+MU+1 of ABD . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= 2*ML + MU + 1 . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! On Return ! ! ABD an upper triangular matrix in band storage and ! the multipliers which were used to obtain it. ! The factorization can be written A = L*U , where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if U(K,K) == 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that SGBSL will divide by zero if ! called. Use RCOND in SBGCO for a reliable ! indication of singularity. ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! M = ML + MU + 1 ! DO 20 J = 1, N ! I1 = MAX(1, J-MU) ! I2 = MIN(N, J+ML) ! DO 10 I = I1, I2 ! K = I - J + M ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses rows ML+1 through 2*ML+MU+1 of ABD . ! In addition, the first ML rows in ABD are used for ! elements generated during the triangularization. ! The total number of rows needed in ABD is 2*ML+MU+1 . ! The ML+MU by ML+MU upper left triangle and the ! ML by ML lower right triangle are not referenced. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED ISAMAX, SAXPY, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGBFA INTEGER LDA,N,ML,MU,IPVT(*),INFO REAL ABD(LDA,*) ! REAL T INTEGER I,ISAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 ! !***FIRST EXECUTABLE STATEMENT SGBFA M = ML + MU + 1 INFO = 0 ! ! ZERO INITIAL FILL-IN COLUMNS ! J0 = MU + 2 J1 = MIN(N,M) - 1 if (J1 < 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 ! ! GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING ! NM1 = N - 1 if (NM1 < 1) go to 130 DO 120 K = 1, NM1 KP1 = K + 1 ! ! ZERO NEXT FILL-IN COLUMN ! JZ = JZ + 1 if (JZ > N) go to 50 if (ML < 1) go to 50 DO 40 I = 1, ML ABD(I,JZ) = 0.0E0 40 CONTINUE 50 CONTINUE ! ! FIND L = PIVOT INDEX ! LM = MIN(ML,N-K) L = ISAMAX(LM+1,ABD(M,K),1) + M - 1 IPVT(K) = L + K - M ! ! ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED ! if (ABD(L,K) == 0.0E0) go to 100 ! ! INTERCHANGE if NECESSARY ! if (L == M) go to 60 T = ABD(L,K) ABD(L,K) = ABD(M,K) ABD(M,K) = T 60 CONTINUE ! ! COMPUTE MULTIPLIERS ! T = -1.0E0/ABD(M,K) call SSCAL(LM,T,ABD(M+1,K),1) ! ! ROW ELIMINATION WITH COLUMN INDEXING ! JU = MIN(MAX(JU,MU+IPVT(K)),N) MM = M if (JU < KP1) go to 90 DO 80 J = KP1, JU L = L - 1 MM = MM - 1 T = ABD(L,J) if (L == 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) == 0.0E0) INFO = N return end subroutine SGBMV (TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, & BETA, Y, INCY) ! !! SGBMV multiplies a real vector by a real general band matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SGBMV-S, DGBMV-D, CGBMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! SGBMV performs one of the matrix-vector operations ! ! y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, ! ! where alpha and beta are scalars, x and y are vectors and A is an ! m by n band matrix, with kl sub-diagonals and ku super-diagonals. ! ! Parameters ! ========== ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' y := alpha*A*x + beta*y. ! ! TRANS = 'T' or 't' y := alpha*A'*x + beta*y. ! ! TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix A. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! KL - INTEGER. ! On entry, KL specifies the number of sub-diagonals of the ! matrix A. KL must satisfy 0 .le. KL. ! Unchanged on exit. ! ! KU - INTEGER. ! On entry, KU specifies the number of super-diagonals of the ! matrix A. KU must satisfy 0 .le. KU. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n ). ! Before entry, the leading ( kl + ku + 1 ) by n part of the ! array A must contain the matrix of coefficients, supplied ! column by column, with the leading diagonal of the matrix in ! row ( ku + 1 ) of the array, the first super-diagonal ! starting at position 2 in row ku, the first sub-diagonal ! starting at position 1 in row ( ku + 2 ), and so on. ! Elements in the array A that do not correspond to elements ! in the band matrix (such as the top left ku by ku triangle) ! are not referenced. ! The following program segment will transfer a band matrix ! from conventional full matrix storage to band storage: ! ! DO 20, J = 1, N ! K = KU + 1 - J ! DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) ! A( K + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( kl + ku + 1 ). ! Unchanged on exit. ! ! X - REAL array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. ! Before entry, the incremented array X must contain the ! vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - REAL array of DIMENSION at least ! ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. ! Before entry, the incremented array Y must contain the ! vector y. On exit, Y is overwritten by the updated vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SGBMV ! .. Scalar Arguments .. REAL ALPHA, BETA INTEGER INCX, INCY, KL, KU, LDA, M, N CHARACTER*1 TRANS ! .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, & LENX, LENY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX, MIN !***FIRST EXECUTABLE STATEMENT SGBMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE if ( M < 0 )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( KL < 0 )THEN INFO = 4 ELSE if ( KU < 0 )THEN INFO = 5 ELSE if ( LDA < ( KL + KU + 1 ) )THEN INFO = 8 ELSE if ( INCX == 0 )THEN INFO = 10 ELSE if ( INCY == 0 )THEN INFO = 13 end if if ( INFO /= 0 )THEN call XERBLA( 'SGBMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if ( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N end if if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the band part of A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return KUP1 = KU + 1 if ( LSAME( TRANS, 'N' ) )THEN ! ! Form y := alpha*A*x + y. ! JX = KX if ( INCY == 1 )THEN DO 60, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) K = KUP1 - J DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) Y( I ) = Y( I ) + TEMP*A( K + I, J ) 50 CONTINUE end if JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY K = KUP1 - J DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) IY = IY + INCY 70 CONTINUE end if JX = JX + INCX if ( J > KU ) & KY = KY + INCY 80 CONTINUE end if ELSE ! ! Form y := alpha*A'*x + y. ! JY = KY if ( INCX == 1 )THEN DO 100, J = 1, N TEMP = ZERO K = KUP1 - J DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + A( K + I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX K = KUP1 - J DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + A( K + I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY if ( J > KU ) & KX = KX + INCX 120 CONTINUE end if end if ! return ! ! End of SGBMV . ! end subroutine SGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB) ! !! SGBSL solves the real band system A*X=B or TRANS(A)*X=B using ... ! the factors computed by SGBCO or SGBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A2 !***TYPE SINGLE PRECISION (SGBSL-S, DGBSL-D, CGBSL-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SGBSL solves the real band system ! A * X = B or TRANS(A) * X = B ! using the factors computed by SBGCO or SGBFA. ! ! On Entry ! ! ABD REAL(LDA, N) ! the output from SBGCO or SGBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from SBGCO or SGBFA. ! ! B REAL(N) ! the right hand side vector. ! ! JOB INTEGER ! = 0 to solve A*X = B , ! = nonzero to solve TRANS(A)*X = B , where ! TRANS(A) is the transpose. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically, this indicates singularity, ! but it is often caused by improper arguments or improper ! setting of LDA . It will not occur if the subroutines are ! called correctly and if SBGCO has set RCOND > 0.0 ! or SGBFA has set INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call SBGCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) ! If (RCOND is too small) go to ... ! DO 10 J = 1, P ! call SGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGBSL INTEGER LDA,N,ML,MU,IPVT(*),JOB REAL ABD(LDA,*),B(*) ! REAL SDOT,T INTEGER K,KB,L,LA,LB,LM,M,NM1 !***FIRST EXECUTABLE STATEMENT SGBSL M = MU + ML + 1 NM1 = N - 1 if (JOB /= 0) go to 50 ! ! JOB = 0 , SOLVE A * X = B ! FIRST SOLVE L*Y = B ! if (ML == 0) go to 30 if (NM1 < 1) go to 30 DO 20 K = 1, NM1 LM = MIN(ML,N-K) L = IPVT(K) T = B(L) if (L == 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 ! ! NOW SOLVE U*X = Y ! DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/ABD(M,K) LM = MIN(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 ! ! JOB = NONZERO, SOLVE TRANS(A) * X = B ! FIRST SOLVE TRANS(U)*Y = B ! DO 60 K = 1, N LM = MIN(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 ! ! NOW SOLVE TRANS(L)*X = Y ! if (ML == 0) go to 90 if (NM1 < 1) go to 90 DO 80 KB = 1, NM1 K = N - KB LM = MIN(ML,N-K) B(K) = B(K) + SDOT(LM,ABD(M+1,K),1,B(K+1),1) L = IPVT(K) if (L == 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 SGECO (A, LDA, N, IPVT, RCOND, Z) ! !! SGECO factors a matrix using Gaussian elimination and estimates ... ! the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A1 !***TYPE SINGLE PRECISION (SGECO-S, DGECO-D, CGECO-C) !***KEYWORDS CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SGECO factors a real matrix by Gaussian elimination ! and estimates the condition of the matrix. ! ! If RCOND is not needed, SGEFA is slightly faster. ! To solve A*X = B , follow SGECO by SGESL. ! To compute INVERSE(A)*C , follow SGECO by SGESL. ! To compute DETERMINANT(A) , follow SGECO by SGEDI. ! To compute INVERSE(A) , follow SGECO by SGEDI. ! ! On Entry ! ! A REAL(LDA, N) ! the matrix to be factored. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix and the multipliers ! which were used to obtain it. ! The factorization can be written A = L*U , where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z REAL(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SASUM, SAXPY, SDOT, SGEFA, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGECO INTEGER LDA,N,IPVT(*) REAL A(LDA,*),Z(*) REAL RCOND ! REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER INFO,J,K,KB,KP1,L ! ! COMPUTE 1-NORM OF A ! !***FIRST EXECUTABLE STATEMENT SGECO ANORM = 0.0E0 DO 10 J = 1, N ANORM = MAX(ANORM,SASUM(N,A(1,J),1)) 10 CONTINUE ! ! FACTOR ! call SGEFA(A,LDA,N,IPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . ! TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE ! CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE ! TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID ! OVERFLOW. ! ! SOLVE TRANS(U)*W = E ! EK = 1.0E0 DO 20 J = 1, N Z(J) = 0.0E0 20 CONTINUE DO 100 K = 1, N if (Z(K) /= 0.0E0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= 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) == 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 > 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 >= 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) ! ! SOLVE TRANS(L)*Y = W ! DO 120 KB = 1, N K = N + 1 - KB if (K < N) Z(K) = Z(K) + SDOT(N-K,A(K+1,K),1,Z(K+1),1) if (ABS(Z(K)) <= 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) ! YNORM = 1.0E0 ! ! SOLVE L*V = Y ! DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T if (K < N) call SAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) if (ABS(Z(K)) <= 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 ! ! SOLVE U*Z = V ! DO 160 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= 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) /= 0.0E0) Z(K) = Z(K)/A(K,K) if (A(K,K) == 0.0E0) Z(K) = 1.0E0 T = -Z(K) call SAXPY(K-1,T,A(1,K),1,Z(1),1) 160 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine SGEDI (A, LDA, N, IPVT, DET, WORK, JOB) ! !! SGEDI computes the determinant and inverse of a matrix using the ... ! factors computed by SGECO or SGEFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A1, D3A1 !***TYPE SINGLE PRECISION (SGEDI-S, DGEDI-D, CGEDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SGEDI computes the determinant and inverse of a matrix ! using the factors computed by SGECO or SGEFA. ! ! On Entry ! ! A REAL(LDA, N) ! the output from SGECO or SGEFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! IPVT INTEGER(N) ! the pivot vector from SGECO or SGEFA. ! ! WORK REAL(N) ! work vector. Contents destroyed. ! ! JOB INTEGER ! = 11 both determinant and inverse. ! = 01 inverse only. ! = 10 determinant only. ! ! On Return ! ! A inverse of original matrix if requested. ! Otherwise unchanged. ! ! DET REAL(2) ! determinant of original matrix if requested. ! Otherwise not referenced. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) == 0.0 . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal and the inverse is requested. ! It will not occur if the subroutines are called correctly ! and if SGECO has set RCOND > 0.0 or SGEFA has set ! INFO == 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SSCAL, SSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGEDI INTEGER LDA,N,IPVT(*),JOB REAL A(LDA,*),DET(2),WORK(*) ! REAL T REAL TEN INTEGER I,J,K,KB,KP1,L,NM1 !***FIRST EXECUTABLE STATEMENT SGEDI ! ! COMPUTE DETERMINANT ! if (JOB/10 == 0) go to 70 DET(1) = 1.0E0 DET(2) = 0.0E0 TEN = 10.0E0 DO 50 I = 1, N if (IPVT(I) /= I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) if (DET(1) == 0.0E0) go to 60 10 if (ABS(DET(1)) >= 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)) < 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 ! ! COMPUTE INVERSE(U) ! if (MOD(JOB,10) == 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 < 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 ! ! FORM INVERSE(U)*INVERSE(L) ! NM1 = N - 1 if (NM1 < 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 /= K) call SSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE return end subroutine SGEEV (A, LDA, N, E, V, LDV, WORK, JOB, INFO) ! !! SGEEV computes the eigenvalues and, optionally, the eigenvectors ... ! of a real general matrix. ! !***LIBRARY SLATEC !***CATEGORY D4A2 !***TYPE SINGLE PRECISION (SGEEV-S, CGEEV-C) !***KEYWORDS EIGENVALUES, EIGENVECTORS, GENERAL MATRIX !***AUTHOR Kahaner, D. K., (NBS) ! Moler, C. B., (U. of New Mexico) ! Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! Abstract ! SGEEV computes the eigenvalues and, optionally, ! the eigenvectors of a general real matrix. ! ! Call Sequence Parameters- ! (The values of parameters marked with * (star) will be changed ! by SGEEV.) ! ! A* REAL(LDA,N) ! real nonsymmetric input matrix. ! ! LDA INTEGER ! set by the user to ! the leading dimension of the real array A. ! ! N INTEGER ! set by the user to ! the order of the matrices A and V, and ! the number of elements in E. ! ! E* COMPLEX(N) ! on return from SGEEV, E contains the eigenvalues of A. ! See also INFO below. ! ! V* COMPLEX(LDV,N) ! on return from SGEEV, if the user has set JOB ! = 0 V is not referenced. ! = nonzero the N eigenvectors of A are stored in the ! first N columns of V. See also INFO below. ! (Note that if the input matrix A is nearly degenerate, ! V may be badly conditioned, i.e., may have nearly ! dependent columns.) ! ! LDV INTEGER ! set by the user to ! the leading dimension of the array V if JOB is also ! set nonzero. In that case, N must be <= LDV. ! If JOB is set to zero, LDV is not referenced. ! ! WORK* REAL(2N) ! temporary storage vector. Contents changed by SGEEV. ! ! JOB INTEGER ! set by the user to ! = 0 eigenvalues only to be calculated by SGEEV. ! Neither V nor LDV is referenced. ! = nonzero eigenvalues and vectors to be calculated. ! In this case, A & V must be distinct arrays. ! Also, if LDA > LDV, SGEEV changes all the ! elements of A thru column N. If LDA < LDV, ! SGEEV changes all the elements of V through ! column N. If LDA = LDV, only A(I,J) and V(I, ! J) for I,J = 1,...,N are changed by SGEEV. ! ! INFO* INTEGER ! on return from SGEEV the value of INFO is ! = 0 normal return, calculation successful. ! = K if the eigenvalue iteration fails to converge, ! eigenvalues K+1 through N are correct, but ! no eigenvectors were computed even if they were ! requested (JOB nonzero). ! ! Error Messages ! No. 1 recoverable N is greater than LDA ! No. 2 recoverable N is less than one. ! No. 3 recoverable JOB is nonzero and N is greater than LDV ! No. 4 warning LDA > LDV, elements of A other than the ! N by N input elements have been changed. ! No. 5 warning LDA < LDV, elements of V other than the ! N x N output elements have been changed. ! !***REFERENCES (NONE) !***ROUTINES CALLED BALANC, BALBAK, HQR, HQR2, ORTHES, ORTRAN, SCOPY, ! SCOPYM, XERMSG !***REVISION HISTORY (YYMMDD) ! 800808 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE SGEEV INTEGER I,IHI,ILO,INFO,J,JB,JOB,K,KM,KP,L,LDA,LDV, & MDIM,N REAL A(*),E(*),WORK(*),V(*) !***FIRST EXECUTABLE STATEMENT SGEEV if (N > LDA) call XERMSG ('SLATEC', 'SGEEV', 'N > LDA.', 1, & 1) if (N > LDA) RETURN if (N < 1) call XERMSG ('SLATEC', 'SGEEV', 'N < 1', 2, 1) if ( N < 1) RETURN if ( N == 1 .AND. JOB == 0) go to 35 MDIM = LDA if ( JOB == 0) go to 5 if (N > LDV) call XERMSG ('SLATEC', 'SGEEV', & 'JOB /= 0 AND N > LDV.', 3, 1) if ( N > LDV) RETURN if ( N == 1) go to 35 ! ! REARRANGE A if NECESSARY WHEN LDA > LDV AND JOB /= 0 ! MDIM = MIN(LDA,LDV) if (LDA < LDV) call XERMSG ('SLATEC', 'SGEEV', & 'LDA < LDV, ELEMENTS OF V OTHER THAN THE N BY N OUTPUT ' // & 'ELEMENTS HAVE BEEN CHANGED.', 5, 0) if ( LDA <= LDV) go to 5 call XERMSG ('SLATEC', 'SGEEV', & 'LDA > LDV, ELEMENTS OF A OTHER THAN THE N BY N INPUT ' // & 'ELEMENTS HAVE BEEN CHANGED.', 4, 0) L = N - 1 DO 4 J=1,L M = 1+J*LDV K = 1+J*LDA call SCOPY(N,A(K),1,A(M),1) 4 CONTINUE 5 CONTINUE ! ! SCALE AND ORTHOGONAL REDUCTION TO HESSENBERG. ! call BALANC(MDIM,N,A,ILO,IHI,WORK(1)) call ORTHES(MDIM,N,ILO,IHI,A,WORK(N+1)) if ( JOB /= 0) go to 10 ! ! EIGENVALUES ONLY ! call HQR(LDA,N,ILO,IHI,A,E(1),E(N+1),INFO) go to 30 ! ! EIGENVALUES AND EIGENVECTORS. ! 10 call ORTRAN(MDIM,N,ILO,IHI,A,WORK(N+1),V) call HQR2(MDIM,N,ILO,IHI,A,E(1),E(N+1),V,INFO) if (INFO /= 0) go to 30 call BALBAK(MDIM,N,ILO,IHI,WORK(1),N,V) ! ! CONVERT EIGENVECTORS TO COMPLEX STORAGE. ! DO 20 JB = 1,N J=N+1-JB I=N+J K=(J-1)*MDIM+1 KP=K+MDIM KM=K-MDIM if ( E(I) >= 0.0E0) call SCOPY(N,V(K),1,WORK(1),2) if ( E(I) < 0.0E0) call SCOPY(N,V(KM),1,WORK(1),2) if ( E(I) == 0.0E0) call sinit ( N,0.0E0,WORK(2),2) if ( E(I) > 0.0E0) call SCOPY(N,V(KP),1,WORK(2),2) if ( E(I) < 0.0E0) call SCOPYM(N,V(K),1,WORK(2),2) L=2*(J-1)*LDV+1 call SCOPY(2*N,WORK(1),1,V(L),1) 20 CONTINUE ! ! CONVERT EIGENVALUES TO COMPLEX STORAGE. ! 30 call SCOPY(N,E(1),1,WORK(1),1) call SCOPY(N,E(N+1),1,E(2),2) call SCOPY(N,WORK(1),1,E(1),2) return ! ! TAKE CARE OF N=1 CASE ! 35 E(1) = A(1) E(2) = 0.E0 INFO = 0 if ( JOB == 0) RETURN V(1) = A(1) V(2) = 0.E0 return end subroutine SGEFA (A, LDA, N, IPVT, INFO) ! !! SGEFA factors a matrix using Gaussian elimination. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A1 !***TYPE SINGLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C) !***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SGEFA factors a real matrix by Gaussian elimination. ! ! SGEFA is usually called by SGECO, but it can be called ! directly with a saving in time if RCOND is not needed. ! (Time for SGECO) = (1 + 9/N)*(Time for SGEFA) . ! ! On Entry ! ! A REAL(LDA, N) ! the matrix to be factored. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix and the multipliers ! which were used to obtain it. ! The factorization can be written A = L*U , where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if U(K,K) == 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that SGESL or SGEDI will divide by zero ! if called. Use RCOND in SGECO for a reliable ! indication of singularity. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED ISAMAX, SAXPY, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGEFA INTEGER LDA,N,IPVT(*),INFO REAL A(LDA,*) ! REAL T INTEGER ISAMAX,J,K,KP1,L,NM1 ! ! GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING ! !***FIRST EXECUTABLE STATEMENT SGEFA INFO = 0 NM1 = N - 1 if (NM1 < 1) go to 70 DO 60 K = 1, NM1 KP1 = K + 1 ! ! FIND L = PIVOT INDEX ! L = ISAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L ! ! ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED ! if (A(L,K) == 0.0E0) go to 40 ! ! INTERCHANGE if NECESSARY ! if (L == K) go to 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE ! ! COMPUTE MULTIPLIERS ! T = -1.0E0/A(K,K) call SSCAL(N-K,T,A(K+1,K),1) ! ! ROW ELIMINATION WITH COLUMN INDEXING ! DO 30 J = KP1, N T = A(L,J) if (L == 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) == 0.0E0) INFO = N return end subroutine SGEFS (A, LDA, N, V, ITASK, IND, WORK, IWORK) ! !! SGEFS solves a general system of linear equations. ! !***LIBRARY SLATEC !***CATEGORY D2A1 !***TYPE SINGLE PRECISION (SGEFS-S, DGEFS-D, CGEFS-C) !***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, ! GENERAL SYSTEM OF LINEAR EQUATIONS !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine SGEFS solves a general NxN system of single ! precision linear equations using LINPACK subroutines SGECO ! and SGESL. That is, if A is an NxN real matrix and if X ! and B are real N-vectors, then SGEFS solves the equation ! ! A*X=B. ! ! The matrix A is first factored into upper and lower tri- ! angular matrices U and L using partial pivoting. These ! factors and the pivoting information are used to find the ! solution vector X. An approximate condition number is ! calculated to provide a rough estimate of the number of ! digits of accuracy in the computed solution. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N and IWORK must not have been altered by the user follow- ! ing factorization (ITASK=1). IND will not be changed by SGEFS ! in this case. ! ! Argument Description *** ! ! A REAL(LDA,N) ! on entry, the doubly subscripted array with dimension ! (LDA,N) which contains the coefficient matrix. ! on return, an upper triangular matrix U and the ! multipliers necessary to construct a matrix L ! so that A=L*U. ! LDA INTEGER ! the leading dimension of the array A. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. The first N elements of ! the array A are the elements of the first column of ! the matrix A. N must be greater than or equal to 1. ! (terminal error message IND=-2) ! V REAL(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! If ITASK=1, the matrix A is factored and then the ! linear equation is solved. ! If ITASK > 1, the equation is solved using the existing ! factored matrix A and IWORK. ! If ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. ! LT. 0 see error message corresponding to IND below. ! WORK REAL(N) ! a singly subscripted array of dimension at least N. ! IWORK INTEGER(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than 1. ! IND=-3 terminal ITASK is less than 1. ! IND=-4 terminal The matrix A is computationally singular. ! A solution has not been computed. ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! Note- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED R1MACH, SGECO, SGESL, XERMSG !***REVISION HISTORY (YYMMDD) ! 800317 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGEFS ! INTEGER LDA,N,ITASK,IND,IWORK(*) REAL A(LDA,*),V(*),WORK(*),R1MACH REAL RCOND CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT SGEFS if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'SGEFS', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'SGEFS', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'SGEFS', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ITASK == 1) THEN ! ! FACTOR MATRIX A INTO LU ! call SGECO(A,LDA,N,IWORK,RCOND,WORK) ! ! CHECK FOR COMPUTATIONALLY SINGULAR MATRIX ! if (RCOND == 0.0) THEN IND = -4 call XERMSG ('SLATEC', 'SGEFS', & 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) return ENDIF ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(R1MACH(4)/RCOND) if (IND <= 0) THEN IND=-10 call XERMSG ('SLATEC', 'SGEFS', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) ENDIF end if ! ! SOLVE AFTER FACTORING ! call SGESL(A,LDA,N,IWORK,V,0) return end subroutine SGEIR (A, LDA, N, V, ITASK, IND, WORK, IWORK) ! !! SGEIR solves a general system of linear equations. Iterative refinement ... ! is used to obtain an error estimate. ! !***LIBRARY SLATEC !***CATEGORY D2A1 !***TYPE SINGLE PRECISION (SGEIR-S, CGEIR-C) !***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, ! GENERAL SYSTEM OF LINEAR EQUATIONS !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine SGEIR solves a general NxN system of single ! precision linear equations using LINPACK subroutines SGEFA and ! SGESL. One pass of iterative refinement is used only to obtain ! an estimate of the accuracy. That is, if A is an NxN real ! matrix and if X and B are real N-vectors, then SGEIR solves ! the equation ! ! A*X=B. ! ! The matrix A is first factored into upper and lower tri- ! angular matrices U and L using partial pivoting. These ! factors and the pivoting information are used to calculate ! the solution, X. Then the residual vector is found and ! used to calculate an estimate of the relative error, IND. ! IND estimates the accuracy of the solution only when the ! input matrix and the right hand side are represented ! exactly in the computer and does not take into account ! any errors in the input data. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to solve only (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N, WORK, and IWORK must not have been altered by the ! user following factorization (ITASK=1). IND will not be ! changed by SGEIR in this case. ! ! Argument Description *** ! ! A REAL(LDA,N) ! the doubly subscripted array with dimension (LDA,N) ! which contains the coefficient matrix. A is not ! altered by the routine. ! LDA INTEGER ! the leading dimension of the array A. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. The first N elements of ! the array A are the elements of the first column of ! matrix A. N must be greater than or equal to 1. ! (terminal error message IND=-2) ! V REAL(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! If ITASK=1, the matrix A is factored and then the ! linear equation is solved. ! If ITASK > 1, the equation is solved using the existing ! factored matrix A (stored in WORK). ! If ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. IND=75 means ! that the solution vector X is zero. ! LT. 0 see error message corresponding to IND below. ! WORK REAL(N*(N+1)) ! a singly subscripted array of dimension at least N*(N+1). ! IWORK INTEGER(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than one. ! IND=-3 terminal ITASK is less than one. ! IND=-4 terminal The matrix A is computationally singular. ! A solution has not been computed. ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! Note- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED R1MACH, SASUM, SCOPY, SDSDOT, SGEFA, SGESL, XERMSG !***REVISION HISTORY (YYMMDD) ! 800430 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGEIR ! INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J REAL A(LDA,*),V(*),WORK(N,*),XNORM,DNORM,SDSDOT,SASUM,R1MACH CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT SGEIR if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'SGEIR', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'SGEIR', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'SGEIR', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ITASK == 1) THEN ! ! MOVE MATRIX A TO WORK ! DO 10 J=1,N call SCOPY(N,A(1,J),1,WORK(1,J),1) 10 CONTINUE ! ! FACTOR MATRIX A INTO LU ! call SGEFA(WORK,N,N,IWORK,INFO) ! ! CHECK FOR COMPUTATIONALLY SINGULAR MATRIX ! if (INFO /= 0) THEN IND = -4 call XERMSG ('SLATEC', 'SGEIR', & 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) return ENDIF end if ! ! SOLVE WHEN FACTORING COMPLETE ! MOVE VECTOR B TO WORK ! call SCOPY(N,V(1),1,WORK(1,N+1),1) call SGESL(WORK,N,N,IWORK,V,0) ! ! FORM NORM OF X0 ! XNORM=SASUM(N,V(1),1) if (XNORM == 0.0) THEN IND = 75 return end if ! ! COMPUTE RESIDUAL ! DO 40 J=1,N WORK(J,N+1) = SDSDOT(N,-WORK(J,N+1),A(J,1),LDA,V,1) 40 CONTINUE ! ! SOLVE A*DELTA=R ! call SGESL(WORK,N,N,IWORK,WORK(1,N+1),0) ! ! FORM NORM OF DELTA ! DNORM = SASUM(N,WORK(1,N+1),1) ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'SGEIR', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) end if return end subroutine SGEMM (TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, & BETA, C, LDC) ! !! SGEMM multiplies a real general matrix by a real general matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE SINGLE PRECISION (SGEMM-S, DGEMM-D, CGEMM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! SGEMM performs one of the matrix-matrix operations ! ! C := alpha*op( A )*op( B ) + beta*C, ! ! where op( X ) is one of ! ! op( X ) = X or op( X ) = X', ! ! alpha and beta are scalars, and A, B and C are matrices, with op( A ) ! an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. ! ! Parameters ! ========== ! ! TRANSA - CHARACTER*1. ! On entry, TRANSA specifies the form of op( A ) to be used in ! the matrix multiplication as follows: ! ! TRANSA = 'N' or 'n', op( A ) = A. ! ! TRANSA = 'T' or 't', op( A ) = A'. ! ! TRANSA = 'C' or 'c', op( A ) = A'. ! ! Unchanged on exit. ! ! TRANSB - CHARACTER*1. ! On entry, TRANSB specifies the form of op( B ) to be used in ! the matrix multiplication as follows: ! ! TRANSB = 'N' or 'n', op( B ) = B. ! ! TRANSB = 'T' or 't', op( B ) = B'. ! ! TRANSB = 'C' or 'c', op( B ) = B'. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix ! op( A ) and of the matrix C. M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix ! op( B ) and the number of columns of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry, K specifies the number of columns of the matrix ! op( A ) and the number of rows of the matrix op( B ). K must ! be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, ka ), where ka is ! k when TRANSA = 'N' or 'n', and is m otherwise. ! Before entry with TRANSA = 'N' or 'n', the leading m by k ! part of the array A must contain the matrix A, otherwise ! the leading k by m part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANSA = 'N' or 'n' then ! LDA must be at least max( 1, m ), otherwise LDA must be at ! least max( 1, k ). ! Unchanged on exit. ! ! B - REAL array of DIMENSION ( LDB, kb ), where kb is ! n when TRANSB = 'N' or 'n', and is k otherwise. ! Before entry with TRANSB = 'N' or 'n', the leading k by n ! part of the array B must contain the matrix B, otherwise ! the leading n by k part of the array B must contain the ! matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. When TRANSB = 'N' or 'n' then ! LDB must be at least max( 1, k ), otherwise LDB must be at ! least max( 1, n ). ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then C need not be set on input. ! Unchanged on exit. ! ! C - REAL array of DIMENSION ( LDC, n ). ! Before entry, the leading m by n part of the array C must ! contain the matrix C, except when beta is zero, in which ! case C need not be set on entry. ! On exit, the array C is overwritten by the m by n matrix ! ( alpha*op( A )*op( B ) + beta*C ). ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SGEMM ! .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC REAL ALPHA, BETA ! .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB REAL TEMP ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) !***FIRST EXECUTABLE STATEMENT SGEMM ! ! Set NOTA and NOTB as true if A and B respectively are not ! transposed and set NROWA, NCOLA and NROWB as the number of rows ! and columns of A and the number of rows of B respectively. ! NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) if ( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M end if if ( NOTB )THEN NROWB = K ELSE NROWB = N end if ! ! Test the input parameters. ! INFO = 0 if ( ( .NOT.NOTA ).AND. & ( .NOT.LSAME( TRANSA, 'C' ) ).AND. & ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.NOTB ).AND. & ( .NOT.LSAME( TRANSB, 'C' ) ).AND. & ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE if ( M < 0 )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( K < 0 )THEN INFO = 5 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 8 ELSE if ( LDB < MAX( 1, NROWB ) )THEN INFO = 10 ELSE if ( LDC < MAX( 1, M ) )THEN INFO = 13 end if if ( INFO /= 0 )THEN call XERBLA( 'SGEMM ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And if alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if return end if ! ! Start the operations. ! if ( NOTB )THEN if ( NOTA )THEN ! ! Form C := alpha*A*B + beta*C. ! DO 90, J = 1, N if ( BETA == ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE if ( BETA /= ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE end if DO 80, L = 1, K if ( B( L, J ) /= ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE end if 80 CONTINUE 90 CONTINUE ELSE ! ! Form C := alpha*A'*B + beta*C ! DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 100 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 110 CONTINUE 120 CONTINUE end if ELSE if ( NOTA )THEN ! ! Form C := alpha*A*B' + beta*C ! DO 170, J = 1, N if ( BETA == ZERO )THEN DO 130, I = 1, M C( I, J ) = ZERO 130 CONTINUE ELSE if ( BETA /= ONE )THEN DO 140, I = 1, M C( I, J ) = BETA*C( I, J ) 140 CONTINUE end if DO 160, L = 1, K if ( B( J, L ) /= ZERO )THEN TEMP = ALPHA*B( J, L ) DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 150 CONTINUE end if 160 CONTINUE 170 CONTINUE ELSE ! ! Form C := alpha*A'*B' + beta*C ! DO 200, J = 1, N DO 190, I = 1, M TEMP = ZERO DO 180, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 180 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 190 CONTINUE 200 CONTINUE end if end if ! return ! ! End of SGEMM . ! end subroutine SGEMV (TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, & INCY) ! !! SGEMV multiplies a real vector by a real general matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SGEMV-S, DGEMV-D, CGEMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! SGEMV performs one of the matrix-vector operations ! ! y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, ! ! where alpha and beta are scalars, x and y are vectors and A is an ! m by n matrix. ! ! Parameters ! ========== ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' y := alpha*A*x + beta*y. ! ! TRANS = 'T' or 't' y := alpha*A'*x + beta*y. ! ! TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix A. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n ). ! Before entry, the leading m by n part of the array A must ! contain the matrix of coefficients. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, m ). ! Unchanged on exit. ! ! X - REAL array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. ! Before entry, the incremented array X must contain the ! vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - REAL array of DIMENSION at least ! ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' ! and at least ! ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. ! Before entry with BETA non-zero, the incremented array Y ! must contain the vector y. On exit, Y is overwritten by the ! updated vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SGEMV ! .. Scalar Arguments .. REAL ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS ! .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT SGEMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE if ( M < 0 )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( LDA < MAX( 1, M ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 ELSE if ( INCY == 0 )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'SGEMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set LENX and LENY, the lengths of the vectors x and y, and set ! up the start points in X and Y. ! if ( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N end if if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return if ( LSAME( TRANS, 'N' ) )THEN ! ! Form y := alpha*A*x + y. ! JX = KX if ( INCY == 1 )THEN DO 60, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE end if JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if ELSE ! ! Form y := alpha*A'*x + y. ! JY = KY if ( INCX == 1 )THEN DO 100, J = 1, N TEMP = ZERO DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX DO 110, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 120 CONTINUE end if end if ! return ! ! End of SGEMV . ! end subroutine SGER (M, N, ALPHA, X, INCX, Y, INCY, A, LDA) ! !! SGER performs a rank 1 update of a real general matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SGER-S) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! SGER performs the rank 1 operation ! ! A := alpha*x*y' + A, ! ! where alpha is a scalar, x is an m element vector, y is an n element ! vector and A is an m by n matrix. ! ! Parameters ! ========== ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix A. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( m - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the m ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! Y - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. ! Unchanged on exit. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n ). ! Before entry, the leading m by n part of the array A must ! contain the matrix of coefficients. On exit, A is ! overwritten by the updated matrix. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SGER ! .. Scalar Arguments .. REAL ALPHA INTEGER INCX, INCY, LDA, M, N ! .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JY, KX ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT SGER ! ! Test the input parameters. ! INFO = 0 if ( M < 0 )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( INCY == 0 )THEN INFO = 7 ELSE if ( LDA < MAX( 1, M ) )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'SGER ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( INCY > 0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY end if if ( INCX == 1 )THEN DO 20, J = 1, N if ( Y( JY ) /= ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE end if JY = JY + INCY 20 CONTINUE ELSE if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX end if DO 40, J = 1, N if ( Y( JY ) /= ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE end if JY = JY + INCY 40 CONTINUE end if ! return ! ! End of SGER . ! end subroutine SGESL (A, LDA, N, IPVT, B, JOB) ! !! SGESL solves the real system A*X=B or TRANS(A)*X=B using the ... ! factors of SGECO or SGEFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A1 !***TYPE SINGLE PRECISION (SGESL-S, DGESL-D, CGESL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SGESL solves the real system ! A * X = B or TRANS(A) * X = B ! using the factors computed by SGECO or SGEFA. ! ! On Entry ! ! A REAL(LDA, N) ! the output from SGECO or SGEFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! IPVT INTEGER(N) ! the pivot vector from SGECO or SGEFA. ! ! B REAL(N) ! the right hand side vector. ! ! JOB INTEGER ! = 0 to solve A*X = B , ! = nonzero to solve TRANS(A)*X = B where ! TRANS(A) is the transpose. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically, this indicates singularity, ! but it is often caused by improper arguments or improper ! setting of LDA . It will not occur if the subroutines are ! called correctly and if SGECO has set RCOND > 0.0 ! or SGEFA has set INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call SGECO(A,LDA,N,IPVT,RCOND,Z) ! if (RCOND is too small) go to ... ! DO 10 J = 1, P ! call SGESL(A,LDA,N,IPVT,C(1,J),0) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGESL INTEGER LDA,N,IPVT(*),JOB REAL A(LDA,*),B(*) ! REAL SDOT,T INTEGER K,KB,L,NM1 !***FIRST EXECUTABLE STATEMENT SGESL NM1 = N - 1 if (JOB /= 0) go to 50 ! ! JOB = 0 , SOLVE A * X = B ! FIRST SOLVE L*Y = B ! if (NM1 < 1) go to 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) if (L == 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 ! ! NOW SOLVE U*X = Y ! 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 ! ! JOB = NONZERO, SOLVE TRANS(A) * X = B ! FIRST SOLVE TRANS(U)*Y = B ! 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 ! ! NOW SOLVE TRANS(L)*X = Y ! if (NM1 < 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 == 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 SGLSS (A, MDA, M, N, B, MDB, NB, RNORM, WORK, LW, & IWORK, LIW, INFO) ! !! SGLSS solves a linear least squares problems by performing a QR ... ! factorization of the matrix using Householder ! transformations. Emphasis is put on detecting possible ! rank deficiency. ! !***LIBRARY SLATEC !***CATEGORY D9, D5 !***TYPE SINGLE PRECISION (SGLSS-S, DGLSS-D) !***KEYWORDS LINEAR LEAST SQUARES, LQ FACTORIZATION, QR FACTORIZATION, ! UNDERDETERMINED LINEAR SYSTEMS !***AUTHOR Manteuffel, T. A., (LANL) !***DESCRIPTION ! ! SGLSS solves both underdetermined and overdetermined ! LINEAR systems AX = B, where A is an M by N matrix ! and B is an M by NB matrix of right hand sides. If ! M >= N, the least squares solution is computed by ! decomposing the matrix A into the product of an ! orthogonal matrix Q and an upper triangular matrix ! R (QR factorization). If M < N, the minimal ! length solution is computed by factoring the ! matrix A into the product of a lower triangular ! matrix L and an orthogonal matrix Q (LQ factor- ! ization). If the matrix A is determined to be rank ! deficient, that is the rank of A is less than ! MIN(M,N), then the minimal length least squares ! solution is computed. ! ! SGLSS assumes full machine precision in the data. ! If more control over the uncertainty in the data ! is desired, the codes LLSIA and ULSIA are ! recommended. ! ! SGLSS requires MDA*N + (MDB + 1)*NB + 5*MIN(M,N) dimensioned ! real space and M+N dimensioned integer space. ! ! ! ****************************************************************** ! * * ! * WARNING - All input arrays are changed on exit. * ! * * ! ****************************************************************** ! SUBROUTINE SGLSS(A,MDA,M,N,B,MDB,NB,RNORM,WORK,LW,IWORK,LIW,INFO) ! ! Input.. ! ! A(,) Linear coefficient matrix of AX=B, with MDA the ! MDA,M,N actual first dimension of A in the calling program. ! M is the row dimension (no. of EQUATIONS of the ! problem) and N the col dimension (no. of UNKNOWNS). ! ! B(,) Right hand side(s), with MDB the actual first ! MDB,NB dimension of B in the calling program. NB is the ! number of M by 1 right hand sides. Must have ! MDB >= MAX(M,N). If NB = 0, B is never accessed. ! ! ! RNORM() Vector of length at least NB. On input the contents ! of RNORM are unused. ! ! WORK() A real work array dimensioned 5*MIN(M,N). ! ! LW Actual dimension of WORK. ! ! IWORK() Integer work array dimensioned at least N+M. ! ! LIW Actual dimension of IWORK. ! ! ! INFO A flag which provides for the efficient ! solution of subsequent problems involving the ! same A but different B. ! If INFO = 0 original call ! INFO = 1 subsequent calls ! On subsequent calls, the user must supply A, INFO, ! LW, IWORK, LIW, and the first 2*MIN(M,N) locations ! of WORK as output by the original call to SGLSS. ! ! ! Output.. ! ! A(,) Contains the triangular part of the reduced matrix ! and the transformation information. It together with ! the first 2*MIN(M,N) elements of WORK (see below) ! completely specify the factorization of A. ! ! B(,) Contains the N by NB solution matrix X. ! ! ! RNORM() Contains the Euclidean length of the NB residual ! vectors B(I)-AX(I), I=1,NB. ! ! WORK() The first 2*MIN(M,N) locations of WORK contain value ! necessary to reproduce the factorization of A. ! ! IWORK() The first M+N locations contain the order in ! which the rows and columns of A were used. ! If M >= N columns then rows. If M < N rows ! then columns. ! ! INFO Flag to indicate status of computation on completion ! -1 Parameter error(s) ! 0 - Full rank ! N > 0 - Reduced rank rank=MIN(M,N)-INFO ! !***REFERENCES T. Manteuffel, An interval analysis approach to rank ! determination in linear least squares problems, ! Report SAND80-0655, Sandia Laboratories, June 1980. !***ROUTINES CALLED LLSIA, ULSIA !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGLSS DIMENSION A(MDA,*),B(MDB,*),RNORM(*),WORK(*) INTEGER IWORK(*) ! !***FIRST EXECUTABLE STATEMENT SGLSS RE=0. AE=0. KEY=0 MODE=2 NP=0 ! ! if M >= N call LLSIA ! if M < N call ULSIA ! if ( M < N) go to 10 call LLSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, & KRANK,KSURE,RNORM,WORK,LW,IWORK,LIW,INFO) if ( INFO == -1) RETURN INFO=N-KRANK return 10 call ULSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP, & KRANK,KSURE,RNORM,WORK,LW,IWORK,LIW,INFO) if ( INFO == -1) RETURN INFO=M-KRANK return end subroutine SGMRES (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, SB, SX, RGWK, LRGW, & IGWK, LIGW, RWORK, IWORK) ! !! SGMRES is a Preconditioned GMRES Iterative Sparse Ax=b Solver. ! ! This routine uses the generalized minimum residual ! (GMRES) method with preconditioning to solve ! non-symmetric linear systems of the form: Ax = b. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SGMRES-S, DGMRES-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LRGW, IGWK(LIGW), LIGW ! INTEGER IWORK(USER DEFINED) ! REAL B(N), X(N), A(NELT), TOL, ERR, SB(N), SX(N) ! REAL RGWK(LRGW), RWORK(USER DEFINED) ! EXTERNAL MATVEC, MSOLVE ! ! call SGMRES(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ! $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, SB, SX, ! $ RGWK, LRGW, IGWK, LIGW, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for the solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, ! for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC(N, X, Y, NELT, IA, JA, A, ISYM) ! where N is the number of unknowns, Y is the product A*X ! upon return, X is an input vector, and NELT is the number of ! non-zeros in the SLAP IA, JA, A storage for the matrix A. ! ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of the routine which solves a linear system Mz = r for ! z given r with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays. The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a real array that can ! be used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate the type of convergence criterion used. ! ITOL=0 Means the iteration stops when the test described ! below on the residual RL is satisfied. This is ! the "Natural Stopping Criteria" for this routine. ! Other values of ITOL cause extra, otherwise ! unnecessary, computation per iteration and are ! therefore much less efficient. See ISSGMR (the ! stop test routine) for more information. ! ITOL=1 Means the iteration stops when the first test ! described below on the residual RL is satisfied, ! and there is either right or no preconditioning ! being used. ! ITOL=2 Implies that the user is using left ! preconditioning, and the second stopping criterion ! below is used. ! ITOL=3 Means the iteration stops when the third test ! described below on Minv*Residual is satisfied, and ! there is either left or no preconditioning being ! used. ! ITOL=11 is often useful for checking and comparing ! different routines. For this case, the user must ! supply the "exact" solution or a very accurate ! approximation (one with an error much less than ! TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the ! difference between the iterative approximation and ! the user-supplied solution divided by the 2-norm ! of the user-supplied solution is less than TOL. ! Note that this requires the user to set up the ! "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling ! routine. The routine with this declaration should ! be loaded before the stop test so that the correct ! length is used by the loader. This procedure is ! not standard Fortran and may not work correctly on ! your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 ! then this common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described below. If TOL is set ! to zero on input, then a default value of 500*(the smallest ! positive magnitude, machine epsilon) is used. ! ITMAX :DUMMY Integer. ! Maximum number of iterations in most SLAP routines. In ! this routine this does not make sense. The maximum number ! of iterations here is given by ITMAX = MAXL*(NRMAX+1). ! See IGWK for definitions of MAXL and NRMAX. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. Letting norm() denote the Euclidean ! norm, ERR is defined as follows.. ! ! If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! for right or no preconditioning, and ! ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! for left preconditioning. ! If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! since right or no preconditioning ! being used. ! If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! since left preconditioning is being ! used. ! If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| ! i=1,n ! If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient storage allocated for ! RGWK or IGWK. ! IERR = 2 => Routine SGMRES failed to reduce the norm ! of the current residual on its last call, ! and so the iteration has stalled. In ! this case, X equals the last computed ! approximation. The user must either ! increase MAXL, or choose a different ! initial guess. ! IERR =-1 => Insufficient length for RGWK array. ! IGWK(6) contains the required minimum ! length of the RGWK array. ! IERR =-2 => Illegal value of ITOL, or ITOL and JPRE ! values are inconsistent. ! For IERR <= 2, RGWK(1) = RHOL, which is the norm on the ! left-hand-side of the relevant stopping test defined ! below associated with the residual for the current ! approximation X(L). ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! SB :IN Real SB(N). ! Array of length N containing scale factors for the right ! hand side vector B. If JSCAL.eq.0 (see below), SB need ! not be supplied. ! SX :IN Real SX(N). ! Array of length N containing scale factors for the solution ! vector X. If JSCAL.eq.0 (see below), SX need not be ! supplied. SB and SX can be the same array in the calling ! program if desired. ! RGWK :INOUT Real RGWK(LRGW). ! Real array used for workspace by SGMRES. ! On return, RGWK(1) = RHOL. See IERR for definition of RHOL. ! LRGW :IN Integer. ! Length of the real workspace, RGWK. ! LRGW >= 1 + N*(MAXL+6) + MAXL*(MAXL+3). ! See below for definition of MAXL. ! For the default values, RGWK has size at least 131 + 16*N. ! IGWK :INOUT Integer IGWK(LIGW). ! The following IGWK parameters should be set by the user ! before calling this routine. ! IGWK(1) = MAXL. Maximum dimension of Krylov subspace in ! which X - X0 is to be found (where, X0 is the initial ! guess). The default value of MAXL is 10. ! IGWK(2) = KMP. Maximum number of previous Krylov basis ! vectors to which each new basis vector is made orthogonal. ! The default value of KMP is MAXL. ! IGWK(3) = JSCAL. Flag indicating whether the scaling ! arrays SB and SX are to be used. ! JSCAL = 0 => SB and SX are not used and the algorithm ! will perform as if all SB(I) = 1 and SX(I) = 1. ! JSCAL = 1 => Only SX is used, and the algorithm ! performs as if all SB(I) = 1. ! JSCAL = 2 => Only SB is used, and the algorithm ! performs as if all SX(I) = 1. ! JSCAL = 3 => Both SB and SX are used. ! IGWK(4) = JPRE. Flag indicating whether preconditioning ! is being used. ! JPRE = 0 => There is no preconditioning. ! JPRE > 0 => There is preconditioning on the right ! only, and the solver will call routine MSOLVE. ! JPRE < 0 => There is preconditioning on the left ! only, and the solver will call routine MSOLVE. ! IGWK(5) = NRMAX. Maximum number of restarts of the ! Krylov iteration. The default value of NRMAX = 10. ! if IWORK(5) = -1, then no restarts are performed (in ! this case, NRMAX is set to zero internally). ! The following IWORK parameters are diagnostic information ! made available to the user after this routine completes. ! IGWK(6) = MLWK. Required minimum length of RGWK array. ! IGWK(7) = NMS. The total number of calls to MSOLVE. ! LIGW :IN Integer. ! Length of the integer workspace, IGWK. LIGW >= 20. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used for workspace in MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE. ! ! *Description: ! SGMRES solves a linear system A*X = B rewritten in the form: ! ! (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, ! ! with right preconditioning, or ! ! (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, ! ! with left preconditioning, where A is an N-by-N real matrix, ! X and B are N-vectors, SB and SX are diagonal scaling ! matrices, and M is a preconditioning matrix. It uses ! preconditioned Krylov subpace methods based on the ! generalized minimum residual method (GMRES). This routine ! optionally performs either the full orthogonalization ! version of the GMRES algorithm or an incomplete variant of ! it. Both versions use restarting of the linear iteration by ! default, although the user can disable this feature. ! ! The GMRES algorithm generates a sequence of approximations ! X(L) to the true solution of the above linear system. The ! convergence criteria for stopping the iteration is based on ! the size of the scaled norm of the residual R(L) = B - ! A*X(L). The actual stopping test is either: ! ! norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), ! ! for right preconditioning, or ! ! norm(SB*(M-inverse)*(B-A*X(L))) .le. ! TOL*norm(SB*(M-inverse)*B), ! ! for left preconditioning, where norm() denotes the Euclidean ! norm, and TOL is a positive scalar less than one input by ! the user. If TOL equals zero when SGMRES is called, then a ! default value of 500*(the smallest positive magnitude, ! machine epsilon) is used. If the scaling arrays SB and SX ! are used, then ideally they should be chosen so that the ! vectors SX*X(or SX*M*X) and SB*B have all their components ! approximately equal to one in magnitude. If one wants to ! use the same scaling in X and B, then SB and SX can be the ! same array in the calling program. ! ! The following is a list of the other routines and their ! functions used by SGMRES: ! SPIGMR Contains the main iteration loop for GMRES. ! SORTH Orthogonalizes a new vector against older basis vectors. ! SHEQR Computes a QR decomposition of a Hessenberg matrix. ! SHELS Solves a Hessenberg least-squares system, using QR ! factors. ! SRLCAL Computes the scaled residual RL. ! SXLCAL Computes the solution XL. ! ISSGMR User-replaceable stopping routine. ! ! This routine does not care what matrix data structure is ! used for A and M. It simply calls the MATVEC and MSOLVE ! routines, with the arguments as described above. The user ! could write any type of structure and the appropriate MATVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK in some fashion. The SLAP ! routines SSDCG and SSICCG are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage ! Matrix Methods in Stiff ODE Systems, Lawrence Liver- ! more National Laboratory Report UCRL-95088, Rev. 1, ! Livermore, California, June 1987. ! 2. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED R1MACH, SCOPY, SNRM2, SPIGMR !***REVISION HISTORY (YYMMDD) ! 871001 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Corrected errors in C***ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) ! 921026 Added check for valid value of ITOL. (FNF) !***END PROLOGUE SGMRES ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LIGW, LRGW, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RGWK(LRGW), RWORK(*), SB(N), SX(N), X(N) INTEGER IA(NELT), IGWK(LIGW), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. REAL BNRM, RHOL, SUM INTEGER I, IFLAG, JPRE, JSCAL, KMP, LDL, LGMR, LHES, LQ, LR, LV, & LW, LXL, LZ, LZM1, MAXL, MAXLP1, NMS, NMSL, NRMAX, NRSTS ! .. External Functions .. REAL R1MACH, SNRM2 EXTERNAL R1MACH, SNRM2 ! .. External Subroutines .. EXTERNAL SCOPY, SPIGMR ! .. Intrinsic Functions .. INTRINSIC SQRT !***FIRST EXECUTABLE STATEMENT SGMRES IERR = 0 ! ------------------------------------------------------------------ ! Load method parameters with user values or defaults. ! ------------------------------------------------------------------ MAXL = IGWK(1) if (MAXL == 0) MAXL = 10 if (MAXL > N) MAXL = N KMP = IGWK(2) if (KMP == 0) KMP = MAXL if (KMP > MAXL) KMP = MAXL JSCAL = IGWK(3) JPRE = IGWK(4) ! Check for valid value of ITOL. if ( (ITOL < 0) .OR. ((ITOL > 3).AND.(ITOL /= 11)) ) GOTO 650 ! Check for consistent values of ITOL and JPRE. if ( ITOL == 1 .AND. JPRE < 0 ) GOTO 650 if ( ITOL == 2 .AND. JPRE >= 0 ) GOTO 650 NRMAX = IGWK(5) if ( NRMAX == 0 ) NRMAX = 10 ! If NRMAX .eq. -1, then set NRMAX = 0 to turn off restarting. if ( NRMAX == -1 ) NRMAX = 0 ! If input value of TOL is zero, set it to its default value. if ( TOL == 0.0E0 ) TOL = 500*R1MACH(3) ! ! Initialize counters. ITER = 0 NMS = 0 NRSTS = 0 ! ------------------------------------------------------------------ ! Form work array segment pointers. ! ------------------------------------------------------------------ MAXLP1 = MAXL + 1 LV = 1 LR = LV + N*MAXLP1 LHES = LR + N + 1 LQ = LHES + MAXL*MAXLP1 LDL = LQ + 2*MAXL LW = LDL + N LXL = LW + N LZ = LXL + N ! ! Load IGWK(6) with required minimum length of the RGWK array. IGWK(6) = LZ + N - 1 if ( LZ+N-1 > LRGW ) GOTO 640 ! ------------------------------------------------------------------ ! Calculate scaled-preconditioned norm of RHS vector b. ! ------------------------------------------------------------------ if (JPRE < 0) THEN call MSOLVE(N, B, RGWK(LR), NELT, IA, JA, A, ISYM, & RWORK, IWORK) NMS = NMS + 1 ELSE call SCOPY(N, B, 1, RGWK(LR), 1) end if if ( JSCAL == 2 .OR. JSCAL == 3 ) THEN SUM = 0 DO 10 I = 1,N SUM = SUM + (RGWK(LR-1+I)*SB(I))**2 10 CONTINUE BNRM = SQRT(SUM) ELSE BNRM = SNRM2(N,RGWK(LR),1) end if ! ------------------------------------------------------------------ ! Calculate initial residual. ! ------------------------------------------------------------------ call MATVEC(N, X, RGWK(LR), NELT, IA, JA, A, ISYM) DO 50 I = 1,N RGWK(LR-1+I) = B(I) - RGWK(LR-1+I) 50 CONTINUE ! ------------------------------------------------------------------ ! If performing restarting, then load the residual into the ! correct location in the RGWK array. ! ------------------------------------------------------------------ 100 CONTINUE if ( NRSTS > NRMAX ) GOTO 610 if ( NRSTS > 0 ) THEN ! Copy the current residual to a different location in the RGWK ! array. call SCOPY(N, RGWK(LDL), 1, RGWK(LR), 1) end if ! ------------------------------------------------------------------ ! Use the SPIGMR algorithm to solve the linear system A*Z = R. ! ------------------------------------------------------------------ call SPIGMR(N, RGWK(LR), SB, SX, JSCAL, MAXL, MAXLP1, KMP, & NRSTS, JPRE, MATVEC, MSOLVE, NMSL, RGWK(LZ), RGWK(LV), & RGWK(LHES), RGWK(LQ), LGMR, RWORK, IWORK, RGWK(LW), & RGWK(LDL), RHOL, NRMAX, B, BNRM, X, RGWK(LXL), ITOL, & TOL, NELT, IA, JA, A, ISYM, IUNIT, IFLAG, ERR) ITER = ITER + LGMR NMS = NMS + NMSL ! ! Increment X by the current approximate solution Z of A*Z = R. ! LZM1 = LZ - 1 DO 110 I = 1,N X(I) = X(I) + RGWK(LZM1+I) 110 CONTINUE if ( IFLAG == 0 ) GOTO 600 if ( IFLAG == 1 ) THEN NRSTS = NRSTS + 1 GOTO 100 end if if ( IFLAG == 2 ) GOTO 620 ! ------------------------------------------------------------------ ! All returns are made through this section. ! ------------------------------------------------------------------ ! The iteration has converged. ! 600 CONTINUE IGWK(7) = NMS RGWK(1) = RHOL IERR = 0 return ! ! Max number((NRMAX+1)*MAXL) of linear iterations performed. 610 CONTINUE IGWK(7) = NMS RGWK(1) = RHOL IERR = 1 return ! ! GMRES failed to reduce last residual in MAXL iterations. ! The iteration has stalled. 620 CONTINUE IGWK(7) = NMS RGWK(1) = RHOL IERR = 2 return ! Error return. Insufficient length for RGWK array. 640 CONTINUE ERR = TOL IERR = -1 return ! Error return. Inconsistent ITOL and JPRE values. 650 CONTINUE ERR = TOL IERR = -2 return !------------- LAST LINE OF SGMRES FOLLOWS ---------------------------- end subroutine SGTSL (N, C, D, E, B, INFO) ! !! SGTSL solves a tridiagonal linear system. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A2A !***TYPE SINGLE PRECISION (SGTSL-S, DGTSL-D, CGTSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, TRIDIAGONAL !***AUTHOR Dongarra, J., (ANL) !***DESCRIPTION ! ! SGTSL given a general tridiagonal matrix and a right hand ! side will find the solution. ! ! On Entry ! ! N INTEGER ! is the order of the tridiagonal matrix. ! ! C REAL(N) ! is the subdiagonal of the tridiagonal matrix. ! C(2) through C(N) should contain the subdiagonal. ! On output, C is destroyed. ! ! D REAL(N) ! is the diagonal of the tridiagonal matrix. ! On output, D is destroyed. ! ! E REAL(N) ! is the superdiagonal of the tridiagonal matrix. ! E(1) through E(N-1) should contain the superdiagonal. ! On output, E is destroyed. ! ! B REAL(N) ! is the right hand side vector. ! ! On Return ! ! B is the solution vector. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th element of the diagonal becomes ! exactly zero. The subroutine returns when ! this is detected. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SGTSL INTEGER N,INFO REAL C(*),D(*),E(*),B(*) ! INTEGER K,KB,KP1,NM1,NM2 REAL T !***FIRST EXECUTABLE STATEMENT SGTSL INFO = 0 C(1) = D(1) NM1 = N - 1 if (NM1 < 1) go to 40 D(1) = E(1) E(1) = 0.0E0 E(N) = 0.0E0 ! DO 30 K = 1, NM1 KP1 = K + 1 ! ! FIND THE LARGEST OF THE TWO ROWS ! if (ABS(C(KP1)) < ABS(C(K))) go to 10 ! ! INTERCHANGE ROW ! T = C(KP1) C(KP1) = C(K) C(K) = T T = D(KP1) D(KP1) = D(K) D(K) = T T = E(KP1) E(KP1) = E(K) E(K) = T T = B(KP1) B(KP1) = B(K) B(K) = T 10 CONTINUE ! ! ZERO ELEMENTS ! if (C(K) /= 0.0E0) go to 20 INFO = K go to 100 20 CONTINUE T = -C(KP1)/C(K) C(KP1) = D(KP1) + T*D(K) D(KP1) = E(KP1) + T*E(K) E(KP1) = 0.0E0 B(KP1) = B(KP1) + T*B(K) 30 CONTINUE 40 CONTINUE if (C(N) /= 0.0E0) go to 50 INFO = N go to 90 50 CONTINUE ! ! BACK SOLVE ! NM2 = N - 2 B(N) = B(N)/C(N) if (N == 1) go to 80 B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1) if (NM2 < 1) go to 70 DO 60 KB = 1, NM2 K = NM2 - KB + 1 B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K) 60 CONTINUE 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE ! return end subroutine SHELS (A, LDA, N, Q, B) ! !! SHELS is an internal routine for SGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SHELS-S, DHELS-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine is extracted from the LINPACK routine SGESL with ! changes due to the fact that A is an upper Hessenberg matrix. ! ! SHELS solves the least squares problem: ! ! MIN(B-A*X,B-A*X) ! ! using the factors computed by SHEQR. ! ! *Usage: ! INTEGER LDA, N ! REAL A(LDA,N), Q(2*N), B(N+1) ! ! call SHELS(A, LDA, N, Q, B) ! ! *Arguments: ! A :IN Real A(LDA,N) ! The output from SHEQR which contains the upper ! triangular factor R in the QR decomposition of A. ! LDA :IN Integer ! The leading dimension of the array A. ! N :IN Integer ! A is originally an (N+1) by N matrix. ! Q :IN Real Q(2*N) ! The coefficients of the N Givens rotations ! used in the QR factorization of A. ! B :INOUT Real B(N+1) ! On input, B is the right hand side vector. ! On output, B is the solution vector X. ! !***SEE ALSO SGMRES !***ROUTINES CALLED SAXPY !***REVISION HISTORY (YYMMDD) ! 871001 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Added C***FIRST EXECUTABLE STATEMENT line. (FNF) ! 910506 Made subsidiary to SGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE SHELS ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. INTEGER LDA, N ! .. Array Arguments .. REAL A(LDA,*), B(*), Q(*) ! .. Local Scalars .. REAL C, S, T, T1, T2 INTEGER IQ, K, KB, KP1 ! .. External Subroutines .. EXTERNAL SAXPY !***FIRST EXECUTABLE STATEMENT SHELS ! ! Minimize(B-A*X,B-A*X). First form Q*B. ! DO K = 1, N KP1 = K + 1 IQ = 2*(K-1) + 1 C = Q(IQ) S = Q(IQ+1) T1 = B(K) T2 = B(KP1) B(K) = C*T1 - S*T2 B(KP1) = S*T1 + C*T2 end do ! ! Now solve R*X = Q*B. ! DO 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) end do return end subroutine SHEQR (A, LDA, N, Q, INFO, IJOB) ! !! SHEQR is an internal routine for SGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SHEQR-S, DHEQR-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine performs a QR decomposition of an upper ! Hessenberg matrix A using Givens rotations. There are two ! options available: 1) Performing a fresh decomposition 2) ! updating the QR factors by adding a row and a column to the ! matrix A. ! ! *Usage: ! INTEGER LDA, N, INFO, IJOB ! REAL A(LDA,N), Q(2*N) ! ! call SHEQR(A, LDA, N, Q, INFO, IJOB) ! ! *Arguments: ! A :INOUT Real A(LDA,N) ! On input, the matrix to be decomposed. ! On output, the upper triangular matrix R. ! The factorization can be written Q*A = R, where ! Q is a product of Givens rotations and R is upper ! triangular. ! LDA :IN Integer ! The leading dimension of the array A. ! N :IN Integer ! A is an (N+1) by N Hessenberg matrix. ! Q :OUT Real Q(2*N) ! The factors c and s of each Givens rotation used ! in decomposing A. ! INFO :OUT Integer ! = 0 normal value. ! = K if A(K,K) .eq. 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that SHELS will divide by zero ! if called. ! IJOB :IN Integer ! = 1 means that a fresh decomposition of the ! matrix A is desired. ! .ge. 2 means that the current decomposition of A ! will be updated by the addition of a row ! and a column. ! !***SEE ALSO SGMRES !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871001 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Made subsidiary to SGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE SHEQR ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. INTEGER IJOB, INFO, LDA, N ! .. Array Arguments .. REAL A(LDA,*), Q(*) ! .. Local Scalars .. REAL C, S, T, T1, T2 INTEGER I, IQ, J, K, KM1, KP1, NM1 ! .. Intrinsic Functions .. INTRINSIC ABS, SQRT !***FIRST EXECUTABLE STATEMENT SHEQR if (IJOB > 1) go to 70 ! ------------------------------------------------------------------- ! A new factorization is desired. ! ------------------------------------------------------------------- ! QR decomposition without pivoting. ! INFO = 0 DO 60 K = 1, N KM1 = K - 1 KP1 = K + 1 ! ! Compute K-th column of R. ! First, multiply the K-th column of A by the previous ! K-1 Givens rotations. ! if (KM1 < 1) go to 20 DO 10 J = 1, KM1 I = 2*(J-1) + 1 T1 = A(J,K) T2 = A(J+1,K) C = Q(I) S = Q(I+1) A(J,K) = C*T1 - S*T2 A(J+1,K) = S*T1 + C*T2 10 CONTINUE ! ! Compute Givens components C and S. ! 20 CONTINUE IQ = 2*KM1 + 1 T1 = A(K,K) T2 = A(KP1,K) if ( T2 == 0.0E0 ) THEN C = 1 S = 0 ELSEIF( ABS(T2) >= ABS(T1) ) THEN T = T1/T2 S = -1.0E0/SQRT(1.0E0+T*T) C = -S*T ELSE T = T2/T1 C = 1.0E0/SQRT(1.0E0+T*T) S = -C*T ENDIF Q(IQ) = C Q(IQ+1) = S A(K,K) = C*T1 - S*T2 if ( A(K,K) == 0.0E0 ) INFO = K 60 CONTINUE return ! ------------------------------------------------------------------- ! The old factorization of a will be updated. A row and a ! column has been added to the matrix A. N by N-1 is now ! the old size of the matrix. ! ------------------------------------------------------------------- 70 CONTINUE NM1 = N - 1 ! ------------------------------------------------------------------- ! Multiply the new column by the N previous Givens rotations. ! ------------------------------------------------------------------- DO 100 K = 1,NM1 I = 2*(K-1) + 1 T1 = A(K,N) T2 = A(K+1,N) C = Q(I) S = Q(I+1) A(K,N) = C*T1 - S*T2 A(K+1,N) = S*T1 + C*T2 100 CONTINUE ! ------------------------------------------------------------------- ! Complete update of decomposition by forming last Givens ! rotation, and multiplying it times the column ! vector(A(N,N),A(NP1,N)). ! ------------------------------------------------------------------- INFO = 0 T1 = A(N,N) T2 = A(N+1,N) if ( T2 == 0.0E0 ) THEN C = 1 S = 0 ELSEIF( ABS(T2) >= ABS(T1) ) THEN T = T1/T2 S = -1.0E0/SQRT(1.0E0+T*T) C = -S*T ELSE T = T2/T1 C = 1.0E0/SQRT(1.0E0+T*T) S = -C*T end if IQ = 2*N - 1 Q(IQ) = C Q(IQ+1) = S A(N,N) = C*T1 - S*T2 if (A(N,N) == 0.0E0) INFO = N return !------------- LAST LINE OF SHEQR FOLLOWS ---------------------------- end function SINDG (X) ! !! SINDG computes the sine of an argument in degrees. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C4A !***TYPE SINGLE PRECISION (SINDG-S, DSINDG-D) !***KEYWORDS DEGREES, ELEMENTARY FUNCTIONS, FNLIB, SINE, TRIGONOMETRIC !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! SINDG(X) evaluates the single precision sine of X where ! X is in degrees. ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 770601 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE SINDG ! JUNE 1977 EDITION. W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB. SAVE RADDEG DATA RADDEG / .017453292519943296E0 / ! !***FIRST EXECUTABLE STATEMENT SINDG SINDG = SIN (RADDEG*X) ! if (MOD(X,90.) /= 0.) RETURN N = ABS(X)/90.0 + 0.5 N = MOD (N, 2) if (N == 0) SINDG = 0. if (N == 1) SINDG = SIGN (1.0, SINDG) ! return end subroutine sinit ( n, sa, x, incx ) ! !******************************************************************************* ! !! SINIT initializes a real vector to a constant. ! ! ! Modified: ! ! 08 April 1999 ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real SA, the constant value to be used to initialize X. ! ! Output, real X(*), the vector to be initialized. ! ! Input, integer INCX, the increment between successive entries of X. ! implicit none ! integer i integer incx integer ix integer n real sa real x(*) ! if ( n <= 0 ) then else if ( incx == 1 ) then x(1:n) = sa else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if do i = 1, n x(ix) = sa ix = ix + incx end do end if return end subroutine SINQB (N, X, WSAVE) ! !! SINQB computes the unnormalized inverse of SINQF. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (SINQB-S) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine SINQB computes the fast Fourier transform of quarter ! wave data. That is, SINQB computes a sequence from its ! representation in terms of a sine series with odd wave numbers. ! the transform is defined below at output parameter X. ! ! SINQF is the unnormalized inverse of SINQB since a call of SINQB ! followed by a call of SINQF will multiply the input sequence X ! by 4*N. ! ! The array WSAVE which is used by subroutine SINQB must be ! initialized by calling subroutine SINQI(N,WSAVE). ! ! Input Parameters ! ! N the length of the array X to be transformed. The method ! is most efficient when N is a product of small primes. ! ! X an array which contains the sequence to be transformed ! ! WSAVE a work array which must be dimensioned at least 3*N+15 ! in the program that calls SINQB. The WSAVE array must be ! initialized by calling subroutine SINQI(N,WSAVE), and a ! different WSAVE array must be used for each different ! value of N. This initialization does not have to be ! repeated so long as N remains unchanged. Thus subsequent ! transforms can be obtained faster than the first. ! ! Output Parameters ! ! X For I=1,...,N ! ! X(I)= the sum from K=1 to K=N of ! ! 4*X(K)*SIN((2*K-1)*I*PI/(2*N)) ! ! a call of SINQB followed by a call of ! SINQF will multiply the sequence X by 4*N. ! Therefore SINQF is the unnormalized inverse ! of SINQB. ! ! WSAVE contains initialization calculations which must not ! be destroyed between calls of SINQB or SINQF. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED COSQB !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*). ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SINQB DIMENSION X(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT SINQB if (N > 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 subroutine SINQF (N, X, WSAVE) ! !! SINQF computes the forward sine transform with odd wave numbers. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (SINQF-S) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine SINQF computes the fast Fourier transform of quarter ! wave data. That is, SINQF computes the coefficients in a sine ! series representation with only odd wave numbers. The transform ! is defined below at output parameter X. ! ! SINQB is the unnormalized inverse of SINQF since a call of SINQF ! followed by a call of SINQB will multiply the input sequence X ! by 4*N. ! ! The array WSAVE which is used by subroutine SINQF must be ! initialized by calling subroutine SINQI(N,WSAVE). ! ! Input Parameters ! ! N the length of the array X to be transformed. The method ! is most efficient when N is a product of small primes. ! ! X an array which contains the sequence to be transformed ! ! WSAVE a work array which must be dimensioned at least 3*N+15 ! in the program that calls SINQF. The WSAVE array must be ! initialized by calling subroutine SINQI(N,WSAVE), and a ! different WSAVE array must be used for each different ! value of N. This initialization does not have to be ! repeated so long as N remains unchanged. Thus subsequent ! transforms can be obtained faster than the first. ! ! Output Parameters ! ! X For I=1,...,N ! ! X(I) = (-1)**(I-1)*X(N) ! ! + the sum from K=1 to K=N-1 of ! ! 2*X(K)*SIN((2*I-1)*K*PI/(2*N)) ! ! A call of SINQF followed by a call of ! SINQB will multiply the sequence X by 4*N. ! Therefore SINQB is the unnormalized inverse ! of SINQF. ! ! WSAVE contains initialization calculations which must not ! be destroyed between calls of SINQF or SINQB. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED COSQF !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*) ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SINQF DIMENSION X(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT SINQF if (N == 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 subroutine SINQI (N, WSAVE) ! !! SINQI initializes a work array for SINQF and SINQB. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (SINQI-S) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine SINQI initializes the array WSAVE which is used in ! both SINQF and SINQB. The prime factorization of N together with ! a tabulation of the trigonometric functions are computed and ! stored in WSAVE. ! ! Input Parameter ! ! N the length of the sequence to be transformed. The method ! is most efficient when N is a product of small primes. ! ! Output Parameter ! ! WSAVE a work array which must be dimensioned at least 3*N+15. ! The same work array can be used for both SINQF and SINQB ! as long as N remains unchanged. Different WSAVE arrays ! are required for different values of N. The contents of ! WSAVE must not be changed between calls of SINQF or SINQB. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED COSQI !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! changing dummy array size declarations (1) to (*) ! 861211 REVISION DATE from Version 3.2 ! 881128 Modified by Dick Valent to meet prologue standards. ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SINQI DIMENSION WSAVE(*) !***FIRST EXECUTABLE STATEMENT SINQI call COSQI (N,WSAVE) return end subroutine SINT (N, X, WSAVE) ! !! SINT computes the sine transform of a real, odd sequence. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (SINT-S) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine SINT computes the discrete Fourier sine transform ! of an odd sequence X(I). The transform is defined below at ! output parameter X. ! ! SINT is the unnormalized inverse of itself since a call of SINT ! followed by another call of SINT will multiply the input sequence ! X by 2*(N+1). ! ! The array WSAVE which is used by subroutine SINT must be ! initialized by calling subroutine SINTI(N,WSAVE). ! ! Input Parameters ! ! N the length of the sequence to be transformed. The method ! is most efficient when N+1 is the product of small primes. ! ! X an array which contains the sequence to be transformed ! ! ! WSAVE a work array with dimension at least INT(3.5*N+16) ! in the program that calls SINT. The WSAVE array must be ! initialized by calling subroutine SINTI(N,WSAVE), and a ! different WSAVE array must be used for each different ! value of N. This initialization does not have to be ! repeated so long as N remains unchanged. Thus subsequent ! transforms can be obtained faster than the first. ! ! Output Parameters ! ! X For I=1,...,N ! ! X(I)= the sum from K=1 to K=N ! ! 2*X(K)*SIN(K*I*PI/(N+1)) ! ! A call of SINT followed by another call of ! SINT will multiply the sequence X by 2*(N+1). ! Hence SINT is the unnormalized inverse ! of itself. ! ! WSAVE contains initialization calculations which must not be ! destroyed between calls of SINT. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTF !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing definition of variable SQRT3 by using ! FORTRAN intrinsic function SQRT instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 891009 Removed unreferenced statement label. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SINT DIMENSION X(*), WSAVE(*) !***FIRST EXECUTABLE STATEMENT SINT SQRT3 = SQRT(3.) if (N-2) 101,102,103 101 X(1) = X(1)+X(1) return 102 XH = SQRT3*(X(1)+X(2)) X(2) = SQRT3*(X(1)-X(2)) X(1) = XH return 103 NP1 = N+1 NS2 = N/2 WSAVE(1) = 0. KW = NP1 DO 104 K=1,NS2 KW = KW+1 KC = NP1-K T1 = X(K)-X(KC) T2 = WSAVE(KW)*(X(K)+X(KC)) WSAVE(K+1) = T1+T2 WSAVE(KC+1) = T2-T1 104 CONTINUE MODN = MOD(N,2) if (MODN /= 0) WSAVE(NS2+2) = 4.*X(NS2+1) NF = NP1+NS2+1 call RFFTF (NP1,WSAVE,WSAVE(NF)) X(1) = .5*WSAVE(1) DO 105 I=3,N,2 X(I-1) = -WSAVE(I) X(I) = X(I-2)+WSAVE(I-1) 105 CONTINUE if (MODN /= 0) RETURN X(N) = -WSAVE(N+1) return end subroutine SINTI (N, WSAVE) ! !! SINTI initializes a work array for SINT. ! !***LIBRARY SLATEC (FFTPACK) !***CATEGORY J1A3 !***TYPE SINGLE PRECISION (SINTI-S) !***KEYWORDS FFTPACK, FOURIER TRANSFORM !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! Subroutine SINTI initializes the array WSAVE which is used in ! subroutine SINT. The prime factorization of N together with ! a tabulation of the trigonometric functions are computed and ! stored in WSAVE. ! ! Input Parameter ! ! N the length of the sequence to be transformed. The method ! is most efficient when N+1 is a product of small primes. ! ! Output Parameter ! ! WSAVE a work array with at least INT(3.5*N+16) locations. ! Different WSAVE arrays are required for different values ! of N. The contents of WSAVE must not be changed between ! calls of SINT. ! !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel ! Computations (G. Rodrigue, ed.), Academic Press, ! 1982, pp. 51-83. !***ROUTINES CALLED RFFTI !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 830401 Modified to use SLATEC library source file format. ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by ! (a) changing dummy array size declarations (1) to (*), ! (b) changing references to intrinsic function FLOAT ! to REAL, and ! (c) changing definition of variable PI by using ! FORTRAN intrinsic function ATAN instead of a DATA ! statement. ! 881128 Modified by Dick Valent to meet prologue standards. ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SINTI DIMENSION WSAVE(*) !***FIRST EXECUTABLE STATEMENT SINTI if (N <= 1) RETURN PI = 4.*ATAN(1.) NP1 = N+1 NS2 = N/2 DT = PI/NP1 KS = N+2 KF = KS+NS2-1 FK = 0. DO 101 K=KS,KF FK = FK+1. WSAVE(K) = 2.*SIN(FK*DT) 101 CONTINUE call RFFTI (NP1,WSAVE(KF+1)) return end subroutine SINTRP (X, Y, XOUT, YOUT, YPOUT, NEQN, KOLD, PHI, IVC, & IV, KGI, GI, ALPHA, OG, OW, OX, OY) ! !! SINTRP approximates the solution at XOUT by evaluating the polynomial ... ! computed in STEPS at XOUT. Must be used in conjunction with STEPS. ! !***LIBRARY SLATEC (DEPAC) !***CATEGORY I1A1B !***TYPE SINGLE PRECISION (SINTRP-S, DINTP-D) !***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR, ! SMOOTH INTERPOLANT !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! The methods in subroutine STEPS approximate the solution near X ! by a polynomial. Subroutine SINTRP approximates the solution at ! XOUT by evaluating the polynomial there. Information defining this ! polynomial is passed from STEPS so SINTRP cannot be used alone. ! ! Subroutine STEPS is completely explained and documented in the text, ! "Computer Solution of Ordinary Differential Equations, the Initial ! Value Problem" by L. F. Shampine and M. K. Gordon. ! ! Input to SINTRP -- ! ! The user provides storage in the calling program for the arrays in ! the call list ! DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),OY(NEQN) ! AND ALPHA(12),OG(13),OW(12),GI(11),IV(10) ! and defines ! XOUT -- point at which solution is desired. ! The remaining parameters are defined in STEPS and passed to ! SINTRP from that subroutine ! ! Output from SINTRP -- ! ! YOUT(*) -- solution at XOUT ! YPOUT(*) -- derivative of solution at XOUT ! The remaining parameters are returned unaltered from their input ! values. Integration with STEPS may be continued. ! !***REFERENCES H. A. Watts, A smoother interpolant for DE/STEP, INTRP ! II, Report SAND84-0293, Sandia Laboratories, 1984. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 840201 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SINTRP ! DIMENSION Y(*),YOUT(*),YPOUT(*),PHI(NEQN,16),OY(*) DIMENSION G(13),C(13),W(13),OG(13),OW(12),ALPHA(12),GI(11),IV(10) ! !***FIRST EXECUTABLE STATEMENT SINTRP KP1 = KOLD + 1 KP2 = KOLD + 2 ! HI = XOUT - OX H = X - OX XI = HI/H XIM1 = XI - 1. ! ! INITIALIZE W(*) FOR COMPUTING G(*) ! XIQ = XI DO 10 IQ = 1,KP1 XIQ = XI*XIQ TEMP1 = IQ*(IQ+1) 10 W(IQ) = XIQ/TEMP1 ! ! COMPUTE THE DOUBLE INTEGRAL TERM GDI ! if (KOLD <= KGI) go to 50 if (IVC > 0) go to 20 GDI = 1.0/TEMP1 M = 2 go to 30 20 IW = IV(IVC) GDI = OW(IW) M = KOLD - IW + 3 30 if (M > KOLD) go to 60 DO 40 I = M,KOLD 40 GDI = OW(KP2-I) - ALPHA(I)*GDI go to 60 50 GDI = GI(KOLD) ! ! COMPUTE G(*) AND C(*) ! 60 G(1) = XI G(2) = 0.5*XI*XI C(1) = 1.0 C(2) = XI if (KOLD < 2) go to 90 DO 80 I = 2,KOLD ALP = ALPHA(I) GAMMA = 1.0 + XIM1*ALP L = KP2 - I DO 70 JQ = 1,L 70 W(JQ) = GAMMA*W(JQ) - ALP*W(JQ+1) G(I+1) = W(1) 80 C(I+1) = GAMMA*C(I) ! ! DEFINE INTERPOLATION PARAMETERS ! 90 SIGMA = (W(2) - XIM1*W(1))/GDI RMU = XIM1*C(KP1)/GDI HMU = RMU/H ! ! INTERPOLATE FOR THE SOLUTION -- YOUT ! AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT ! DO 100 L = 1,NEQN YOUT(L) = 0.0 100 YPOUT(L) = 0.0 DO 120 J = 1,KOLD I = KP2 - J GDIF = OG(I) - OG(I-1) TEMP2 = (G(I) - G(I-1)) - SIGMA*GDIF TEMP3 = (C(I) - C(I-1)) + RMU*GDIF DO 110 L = 1,NEQN YOUT(L) = YOUT(L) + TEMP2*PHI(L,I) 110 YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I) 120 CONTINUE DO 130 L = 1,NEQN YOUT(L) = ((1.0 - SIGMA)*OY(L) + SIGMA*Y(L)) + & H*(YOUT(L) + (G(1) - SIGMA*OG(1))*PHI(L,1)) 130 YPOUT(L) = HMU*(OY(L) - Y(L)) + & (YPOUT(L) + (C(1) + RMU*OG(1))*PHI(L,1)) ! return end subroutine SIR (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, & IWORK) ! !! SIR is the Preconditioned Iterative Refinement Sparse Ax = b Solver. ! ! Routine to solve a general linear system Ax = b using ! iterative refinement with a matrix splitting. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SIR-S, DIR-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), DZ(N), ! REAL RWORK(USER DEFINED) ! EXTERNAL MATVEC, MSOLVE ! ! call SIR(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ITOL, ! $ TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, ! for more details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X ! upon return, X is an input vector, NELT is the number of ! non-zeros in the SLAP IA, JA, A storage for the matrix A. ! ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a real array that can ! be used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Real R(N). ! Z :WORK Real Z(N). ! DZ :WORK Real DZ(N). ! Real arrays used for workspace. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used by MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used by MSOLVE. ! ! *Description: ! The basic algorithm for iterative refinement (also known as ! iterative improvement) is: ! ! n+1 n -1 n ! X = X + M (B - AX ). ! ! -1 -1 ! If M = A then this is the standard iterative refinement ! algorithm and the "subtraction" in the residual calculation ! should be done in double precision (which it is not in this ! routine). ! If M = DIAG(A), the diagonal of A, then iterative refinement ! is known as Jacobi's method. The SLAP routine SSJAC ! implements this iterative strategy. ! If M = L, the lower triangle of A, then iterative refinement ! is known as Gauss-Seidel. The SLAP routine SSGS implements ! this iterative strategy. ! ! This routine does not care what matrix data structure is ! used for A and M. It simply calls the MATVEC and MSOLVE ! routines, with the arguments as described above. The user ! could write any type of structure and the appropriate MATVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK) in some fashion. The SLAP ! routines SSJAC and SSGS are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the real array A. ! In other words, for each column in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have JA(N+1) ! = NELT+1, where N is the number of columns in the matrix and ! NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Examples: ! See the SLAP routines SSJAC, SSGS ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SSJAC, SSGS !***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, ! Johns Hopkins University Press, Baltimore, Maryland, ! 1983. ! 2. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED ISSIR, R1MACH !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) !***END PROLOGUE SIR ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), DZ(N), R(N), RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. REAL BNRM, SOLNRM, TOLMIN INTEGER I, K ! .. External Functions .. REAL R1MACH INTEGER ISSIR EXTERNAL R1MACH, ISSIR !***FIRST EXECUTABLE STATEMENT SIR ! ! Check some of the input data. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if TOLMIN = 500*R1MACH(3) if ( TOL < TOLMIN ) THEN TOL = TOLMIN IERR = 4 end if ! ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N R(I) = B(I) - R(I) 10 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! if ( ISSIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, & IWORK, BNRM, SOLNRM) /= 0 ) go to 200 if ( IERR /= 0 ) RETURN ! ! ***** iteration loop ***** ! DO 100 K=1,ITMAX ITER = K ! ! Calculate new iterate x, new residual r, and new ! pseudo-residual z. DO 20 I = 1, N X(I) = X(I) + Z(I) 20 CONTINUE call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 30 I = 1, N R(I) = B(I) - R(I) 30 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! ! check stopping criterion. if ( ISSIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, & IWORK, BNRM, SOLNRM) /= 0 ) go to 200 ! 100 CONTINUE ! ! ***** end of loop ***** ! Stopping criterion not satisfied. ITER = ITMAX + 1 IERR = 2 ! 200 return !------------- LAST LINE OF SIR FOLLOWS ------------------------------- end subroutine SLLTI2 (N, B, X, NEL, IEL, JEL, EL, DINV) ! !! SLLTI2 is the SLAP Backsolve routine for LDL' Factorization. ! ! Routine to solve a system of the form L*D*L' X = B, ! where L is a unit lower triangular matrix and D is a ! diagonal matrix and ' means transpose. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SLLTI2-S, DLLTI2-D) !***KEYWORDS INCOMPLETE FACTORIZATION, ITERATIVE PRECONDITION, SLAP, ! SPARSE, SYMMETRIC LINEAR SYSTEM SOLVE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NEL, IEL(NEL), JEL(NEL) ! REAL B(N), X(N), EL(NEL), DINV(N) ! ! call SLLTI2( N, B, X, NEL, IEL, JEL, EL, DINV ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right hand side vector. ! X :OUT Real X(N). ! Solution to L*D*L' x = b. ! NEL :IN Integer. ! Number of non-zeros in the EL array. ! IEL :IN Integer IEL(NEL). ! JEL :IN Integer JEL(NEL). ! EL :IN Real EL(NEL). ! IEL, JEL, EL contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in ! SLAP Row format. The diagonal of ones *IS* stored. This ! structure can be set up by the SS2LT routine. See the ! "Description", below for more details about the SLAP Row ! format. ! DINV :IN Real DINV(N). ! Inverse of the diagonal matrix D. ! ! *Description: ! This routine is supplied with the SLAP package as a routine ! to perform the MSOLVE operation in the SCG iteration routine ! for the driver routine SSICCG. It must be called via the ! SLAP MSOLVE calling sequence convention interface routine ! SSLLI. ! **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** ! **** SLAP MSOLVE CALLING CONVENTION **** ! ! IEL, JEL, EL should contain the unit lower triangular factor ! of the incomplete decomposition of the A matrix stored in ! SLAP Row format. This IC factorization can be computed by ! the SSICS routine. The diagonal (which is all one's) is ! stored. ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the real ! array A. In other words, for each row in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going across the row (except the diagonal) in ! order. The JA array holds the column index for each ! non-zero. The IA array holds the offsets into the JA, A ! arrays for the beginning of each row. That is, ! JA(IA(IROW)), A(IA(IROW)) points to the beginning of the ! IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! points to the end of the IROW-th row. Note that we always ! have IA(N+1) = NELT+1, where N is the number of rows in ! the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP Row format the "inner loop" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! !***SEE ALSO SSICCG, SSICS !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SLLTI2 ! .. Scalar Arguments .. INTEGER N, NEL ! .. Array Arguments .. REAL B(N), DINV(N), EL(NEL), X(N) INTEGER IEL(NEL), JEL(NEL) ! .. Local Scalars .. INTEGER I, IBGN, IEND, IROW !***FIRST EXECUTABLE STATEMENT SLLTI2 ! ! Solve L*y = b, storing result in x. ! DO 10 I=1,N X(I) = B(I) 10 CONTINUE DO 30 IROW = 1, N IBGN = IEL(IROW) + 1 IEND = IEL(IROW+1) - 1 if ( IBGN <= IEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NOCONCUR !VD$ NODEPCHK DO 20 I = IBGN, IEND X(IROW) = X(IROW) - EL(I)*X(JEL(I)) 20 CONTINUE ENDIF 30 CONTINUE ! ! Solve D*Z = Y, storing result in X. ! DO 40 I=1,N X(I) = X(I)*DINV(I) 40 CONTINUE ! ! Solve L-trans*X = Z. ! DO 60 IROW = N, 2, -1 IBGN = IEL(IROW) + 1 IEND = IEL(IROW+1) - 1 if ( IBGN <= IEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NOCONCUR !VD$ NODEPCHK DO I = IBGN, IEND X(JEL(I)) = X(JEL(I)) - EL(I)*X(IROW) end do ENDIF 60 CONTINUE return end subroutine SLPDOC ! !! SLPDOC is the Sparse Linear Algebra Package Version 2.0.2 Documentation. ! ! Routines to solve large sparse symmetric and nonsymmetric ! positive definite linear systems, Ax = b, using precondi- ! tioned iterative methods. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4, Z !***TYPE SINGLE PRECISION (SLPDOC-S, DLPDOC-D) !***KEYWORDS BICONJUGATE GRADIENT SQUARED, DOCUMENTATION, ! GENERALIZED MINIMUM RESIDUAL, ITERATIVE IMPROVEMENT, ! NORMAL EQUATIONS, ORTHOMIN, ! PRECONDITIONED CONJUGATE GRADIENT, SLAP, ! SPARSE ITERATIVE METHODS !***AUTHOR Seager, Mark. K., (LLNL) ! User Systems Division ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 ! (FTS) 543-3141, (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! The ! Sparse Linear Algebra Package ! ! @@@@@@@ @ @@@ @@@@@@@@ ! @ @ @ @ @ @ @ ! @ @ @ @ @ @ ! @@@@@@@ @ @ @ @@@@@@@@ ! @ @ @@@@@@@@@ @ ! @ @ @ @ @ @ ! @@@@@@@ @@@@@@@@@ @ @ @ ! ! @ @ @@@@@@@ @@@@@ ! @ @ @ @ @ @@ ! @ @ @@@@@@@ @ @@ @ @ @ @ ! @ @ @ @ @@ @ @@@@@@ @ @ @ ! @ @ @@@@@@@@@ @ @ @ @ @ ! @ @ @ @ @ @@@ @@ @ ! @@@ @@@@@@@ @ @@@@@@@@@ @@@ @@@@@ ! ! ! ================================================================= ! ========================== Introduction ========================= ! ================================================================= ! This package was originally derived from a set of iterative ! routines written by Anne Greenbaum, as announced in "Routines ! for Solving Large Sparse Linear Systems", Tentacle, Lawrence ! Livermore National Laboratory, Livermore Computing Center ! (January 1986), pp 15-21. ! ! This document contains the specifications for the SLAP Version ! 2.0 package, a Fortran 77 package for the solution of large ! sparse linear systems, Ax = b, via preconditioned iterative ! methods. Included in this package are "core" routines to do ! Iterative Refinement (Jacobi's method), Conjugate Gradient, ! Conjugate Gradient on the normal equations, AA'y = b, (where x = ! A'y and A' denotes the transpose of A), BiConjugate Gradient, ! BiConjugate Gradient Squared, Orthomin and Generalized Minimum ! Residual Iteration. These "core" routines do not require a ! "fixed" data structure for storing the matrix A and the ! preconditioning matrix M. The user is free to choose any ! structure that facilitates efficient solution of the problem at ! hand. The drawback to this approach is that the user must also ! supply at least two routines (MATVEC and MSOLVE, say). MATVEC ! must calculate, y = Ax, given x and the user's data structure for ! A. MSOLVE must solve, r = Mz, for z (*NOT* r) given r and the ! user's data structure for M (or its inverse). The user should ! choose M so that inv(M)*A is approximately the identity and the ! solution step r = Mz is "easy" to solve. For some of the "core" ! routines (Orthomin, BiConjugate Gradient and Conjugate Gradient ! on the normal equations) the user must also supply a matrix ! transpose times vector routine (MTTVEC, say) and (possibly, ! depending on the "core" method) a routine that solves the ! transpose of the preconditioning step (MTSOLV, say). ! Specifically, MTTVEC is a routine which calculates y = A'x, given ! x and the user's data structure for A (A' is the transpose of A). ! MTSOLV is a routine which solves the system r = M'z for z given r ! and the user's data structure for M. ! ! This process of writing the matrix vector operations can be time ! consuming and error prone. To alleviate these problems we have ! written drivers for the "core" methods that assume the user ! supplies one of two specific data structures (SLAP Triad and SLAP ! Column format), see below. Utilizing these data structures we ! have augmented each "core" method with two preconditioners: ! Diagonal Scaling and Incomplete Factorization. Diagonal scaling ! is easy to implement, vectorizes very well and for problems that ! are not too ill-conditioned reduces the number of iterations ! enough to warrant its use. On the other hand, an Incomplete ! factorization (Incomplete Cholesky for symmetric systems and ! Incomplete LU for nonsymmetric systems) may take much longer to ! calculate, but it reduces the iteration count (for most problems) ! significantly. Our implementations of IC and ILU vectorize for ! machines with hardware gather scatter, but the vector lengths can ! be quite short if the number of non-zeros in a column is not ! large. ! ! ================================================================= ! ==================== Supplied Data Structures =================== ! ================================================================= ! The following describes the data structures supplied with the ! package: SLAP Triad and Column formats. ! ! ====================== S L A P Triad format ===================== ! ! In the SLAP Triad format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of length ! NELT, where NELT is the number of non-zeros in the matrix: ! (IA(NELT), JA(NELT), A(NELT)). If the matrix is symmetric then ! one need only store the lower triangle (including the diagonal) ! and NELT would be the corresponding number of non-zeros stored. ! For each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding location ! of the A array. This is an extremely easy data structure to ! generate. On the other hand, it is not very efficient on vector ! computers for the iterative solution of linear systems. Hence, ! SLAP changes this input data structure to the SLAP Column format ! for the iteration (but does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! nonsymmetric 5x5 Matrix. NELT=11. Recall that the entries may ! appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! ====================== S L A P Column format ==================== ! ! In the SLAP Column format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear first ! in each "column") and are stored in the real array A. In other ! words, for each column in the matrix first put the diagonal entry ! in A. Then put in the other non-zero elements going down the ! column (except the diagonal) in order. The IA array holds the ! row index for each non-zero. The JA array holds the offsets into ! the IA, A arrays for the beginning of each column. That is, ! IA(JA(ICOL)), A(JA(ICOL)) are the first elements of the ICOL-th ! column in IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) are the ! last elements of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the matrix ! and NELT is the number of non-zeros in the matrix. If the matrix ! is symmetric one need only store the lower triangle (including ! the diagonal) and NELT would be the corresponding number of ! non-zeros stored. ! ! Here is an example of the SLAP Column storage format for a ! nonsymmetric 5x5 Matrix (in the A and IA arrays '|' denotes the ! end of a column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ================================================================= ! ====================== Which Method To Use ====================== ! ================================================================= ! ! BACKGROUND ! In solving a large sparse linear system Ax = b using an iterative ! method, it is not necessary to actually store the matrix A. ! Rather, what is needed is a procedure for multiplying the matrix ! A times a given vector y to obtain the matrix-vector product, Ay. ! SLAP has been written to take advantage of this fact. The higher ! level routines in the package require storage only of the non-zero ! elements of A (and their positions), and even this can be ! avoided, if the user writes his own subroutine for multiplying ! the matrix times a vector and calls the lower-level iterative ! routines in the package. ! ! If the matrix A is ill-conditioned, then most iterative methods ! will be slow to converge (if they converge at all!). To improve ! the convergence rate, one may use a "matrix splitting," or, ! "preconditioning matrix," say, M. It is then necessary to solve, ! at each iteration, a linear system with coefficient matrix M. A ! good preconditioner M should have two properties: (1) M should ! "approximate" A, in the sense that the matrix inv(M)*A (or some ! variant thereof) is better conditioned than the original matrix ! A; and (2) linear systems with coefficient matrix M should be ! much easier to solve than the original system with coefficient ! matrix A. Preconditioning routines in the SLAP package are ! separate from the iterative routines, so that any of the ! preconditioners provided in the package, or one that the user ! codes himself, can be used with any of the iterative routines. ! ! CHOICE OF PRECONDITIONER ! If you willing to live with either the SLAP Triad or Column ! matrix data structure you can then choose one of two types of ! preconditioners to use: diagonal scaling or incomplete ! factorization. To choose between these two methods requires ! knowing something about the computer you're going to run these ! codes on and how well incomplete factorization approximates the ! inverse of your matrix. ! ! Let us suppose you have a scalar machine. Then, unless the ! incomplete factorization is very, very poor this is *GENERALLY* ! the method to choose. It will reduce the number of iterations ! significantly and is not all that expensive to compute. So if ! you have just one linear system to solve and "just want to get ! the job done" then try incomplete factorization first. If you ! are thinking of integrating some SLAP iterative method into your ! favorite "production code" then try incomplete factorization ! first, but also check to see that diagonal scaling is indeed ! slower for a large sample of test problems. ! ! Let us now suppose you have a vector computer with hardware ! gather/scatter support (Cray X-MP, Y-MP, SCS-40 or Cyber 205, ETA ! 10, ETA Piper, Convex C-1, etc.). Then it is much harder to ! choose between the two methods. The versions of incomplete ! factorization in SLAP do in fact vectorize, but have short vector ! lengths and the factorization step is relatively more expensive. ! Hence, for most problems (i.e., unless your problem is ill ! conditioned, sic!) diagonal scaling is faster, with its very ! fast set up time and vectorized (with long vectors) ! preconditioning step (even though it may take more iterations). ! If you have several systems (or right hand sides) to solve that ! can utilize the same preconditioner then the cost of the ! incomplete factorization can be amortized over these several ! solutions. This situation gives more advantage to the incomplete ! factorization methods. If you have a vector machine without ! hardware gather/scatter (Cray 1, Cray 2 & Cray 3) then the ! advantages for incomplete factorization are even less. ! ! If you're trying to shoehorn SLAP into your favorite "production ! code" and can not easily generate either the SLAP Triad or Column ! format then you are left to your own devices in terms of ! preconditioning. Also, you may find that the preconditioners ! supplied with SLAP are not sufficient for your problem. In this ! situation we would recommend that you talk with a numerical ! analyst versed in iterative methods about writing other ! preconditioning subroutines (e.g., polynomial preconditioning, ! shifted incomplete factorization, SOR or SSOR iteration). You ! can always "roll your own" by using the "core" iterative methods ! and supplying your own MSOLVE and MATVEC (and possibly MTSOLV and ! MTTVEC) routines. ! ! SYMMETRIC SYSTEMS ! If your matrix is symmetric then you would want to use one of the ! symmetric system solvers. If your system is also positive ! definite, (Ax,x) (Ax dot product with x) is positive for all ! non-zero vectors x, then use Conjugate Gradient (SCG, SSDCG, ! SSICSG). If you're not sure it's SPD (symmetric and Positive ! Definite) then try SCG anyway and if it works, fine. If you're ! sure your matrix is not positive definite then you may want to ! try the iterative refinement methods (SIR) or the GMRES code ! (SGMRES) if SIR converges too slowly. ! ! NONSYMMETRIC SYSTEMS ! This is currently an area of active research in numerical ! analysis and there are new strategies being developed. ! Consequently take the following advice with a grain of salt. If ! you matrix is positive definite, (Ax,x) (Ax dot product with x ! is positive for all non-zero vectors x), then you can use any of ! the methods for nonsymmetric systems (Orthomin, GMRES, ! BiConjugate Gradient, BiConjugate Gradient Squared and Conjugate ! Gradient applied to the normal equations). If your system is not ! too ill conditioned then try BiConjugate Gradient Squared (BCGS) ! or GMRES (SGMRES). Both of these methods converge very quickly ! and do not require A' or M' (' denotes transpose) information. ! SGMRES does require some additional storage, though. If the ! system is very ill conditioned or nearly positive indefinite ! ((Ax,x) is positive, but may be very small), then GMRES should ! be the first choice, but try the other methods if you have to ! fine tune the solution process for a "production code". If you ! have a great preconditioner for the normal equations (i.e., M is ! an approximation to the inverse of AA' rather than just A) then ! this is not a bad route to travel. Old wisdom would say that the ! normal equations are a disaster (since it squares the condition ! number of the system and SCG convergence is linked to this number ! of infamy), but some preconditioners (like incomplete ! factorization) can reduce the condition number back below that of ! the original system. ! ! ================================================================= ! ======================= Naming Conventions ====================== ! ================================================================= ! SLAP iterative methods, matrix vector and preconditioner ! calculation routines follow a naming convention which, when ! understood, allows one to determine the iterative method and data ! structure(s) used. The subroutine naming convention takes the ! following form: ! P[S][M]DESC ! where ! P stands for the precision (or data type) of the routine and ! is required in all names, ! S denotes whether or not the routine requires the SLAP Triad ! or Column format (it does if the second letter of the name ! is S and does not otherwise), ! M stands for the type of preconditioner used (only appears ! in drivers for "core" routines), and ! DESC is some number of letters describing the method or purpose ! of the routine. The following is a list of the "DESC" ! fields for iterative methods and their meaning: ! BCG,BC: BiConjugate Gradient ! CG: Conjugate Gradient ! CGN,CN: Conjugate Gradient on the Normal equations ! CGS,CS: biConjugate Gradient Squared ! GMRES,GMR,GM: Generalized Minimum RESidual ! IR,R: Iterative Refinement ! JAC: JACobi's method ! GS: Gauss-Seidel ! OMN,OM: OrthoMiN ! ! In the single precision version of SLAP, all routine names start ! with an S. The brackets around the S and M designate that these ! fields are optional. ! ! Here are some examples of the routines: ! 1) SBCG: Single precision BiConjugate Gradient "core" routine. ! One can deduce that this is a "core" routine, because the S and ! M fields are missing and BiConjugate Gradient is an iterative ! method. ! 2) SSDBCG: Single precision, SLAP data structure BCG with Diagonal ! scaling. ! 3) SSLUBC: Single precision, SLAP data structure BCG with incom- ! plete LU factorization as the preconditioning. ! 4) SCG: Single precision Conjugate Gradient "core" routine. ! 5) SSDCG: Single precision, SLAP data structure Conjugate Gradient ! with Diagonal scaling. ! 6) SSICCG: Single precision, SLAP data structure Conjugate Gra- ! dient with Incomplete Cholesky factorization preconditioning. ! ! ! ================================================================= ! ===================== USER CALLABLE ROUTINES ==================== ! ================================================================= ! The following is a list of the "user callable" SLAP routines and ! their one line descriptions. The headers denote the file names ! where the routines can be found, as distributed for UNIX systems. ! ! Note: Each core routine, SXXX, has a corresponding stop routine, ! ISSXXX. If the stop routine does not have the specific stop ! test the user requires (e.g., weighted infinity norm), then ! the user should modify the source for ISSXXX accordingly. ! ! ============================= sir.f ============================= ! SIR: Preconditioned Iterative Refinement Sparse Ax = b Solver. ! SSJAC: Jacobi's Method Iterative Sparse Ax = b Solver. ! SSGS: Gauss-Seidel Method Iterative Sparse Ax = b Solver. ! SSILUR: Incomplete LU Iterative Refinement Sparse Ax = b Solver. ! ! ============================= scg.f ============================= ! SCG: Preconditioned Conjugate Gradient Sparse Ax=b Solver. ! SSDCG: Diagonally Scaled Conjugate Gradient Sparse Ax=b Solver. ! SSICCG: Incomplete Cholesky Conjugate Gradient Sparse Ax=b Solver. ! ! ============================= scgn.f ============================ ! SCGN: Preconditioned CG Sparse Ax=b Solver for Normal Equations. ! SSDCGN: Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's. ! SSLUCN: Incomplete LU CG Sparse Ax=b Solver for Normal Equations. ! ! ============================= sbcg.f ============================ ! SBCG: Preconditioned BiConjugate Gradient Sparse Ax = b Solver. ! SSDBCG: Diagonally Scaled BiConjugate Gradient Sparse Ax=b Solver. ! SSLUBC: Incomplete LU BiConjugate Gradient Sparse Ax=b Solver. ! ! ============================= scgs.f ============================ ! SCGS: Preconditioned BiConjugate Gradient Squared Ax=b Solver. ! SSDCGS: Diagonally Scaled CGS Sparse Ax=b Solver. ! SSLUCS: Incomplete LU BiConjugate Gradient Squared Ax=b Solver. ! ! ============================= somn.f ============================ ! SOMN: Preconditioned Orthomin Sparse Iterative Ax=b Solver. ! SSDOMN: Diagonally Scaled Orthomin Sparse Iterative Ax=b Solver. ! SSLUOM: Incomplete LU Orthomin Sparse Iterative Ax=b Solver. ! ! ============================ sgmres.f =========================== ! SGMRES: Preconditioned GMRES Iterative Sparse Ax=b Solver. ! SSDGMR: Diagonally Scaled GMRES Iterative Sparse Ax=b Solver. ! SSLUGM: Incomplete LU GMRES Iterative Sparse Ax=b Solver. ! ! ============================ smset.f ============================ ! The following routines are used to set up preconditioners. ! ! SSDS: Diagonal Scaling Preconditioner SLAP Set Up. ! SSDSCL: Diagonally Scales/Unscales a SLAP Column Matrix. ! SSD2S: Diagonal Scaling Preconditioner SLAP Normal Eqns Set Up. ! SS2LT: Lower Triangle Preconditioner SLAP Set Up. ! SSICS: Incomplete Cholesky Decomp. Preconditioner SLAP Set Up. ! SSILUS: Incomplete LU Decomposition Preconditioner SLAP Set Up. ! ! ============================ smvops.f =========================== ! Most of the incomplete factorization (LL' and LDU) solvers ! in this file require an intermediate routine to translate ! from the SLAP MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, ! IWORK) calling convention to the calling sequence required ! by the solve routine. This generally is accomplished by ! fishing out pointers to the preconditioner (stored in RWORK) ! from the IWORK array and then making a call to the routine ! that actually does the backsolve. ! ! SSMV: SLAP Column Format Sparse Matrix Vector Product. ! SSMTV: SLAP Column Format Sparse Matrix (transpose) Vector Prod. ! SSDI: Diagonal Matrix Vector Multiply. ! SSLI: SLAP MSOLVE for Lower Triangle Matrix (set up for SSLI2). ! SSLI2: Lower Triangle Matrix Backsolve. ! SSLLTI: SLAP MSOLVE for LDL' (IC) Fact. (set up for SLLTI2). ! SLLTI2: Backsolve routine for LDL' Factorization. ! SSLUI: SLAP MSOLVE for LDU Factorization (set up for SSLUI2). ! SSLUI2: SLAP Backsolve for LDU Factorization. ! SSLUTI: SLAP MTSOLV for LDU Factorization (set up for SSLUI4). ! SSLUI4: SLAP Backsolve for LDU Factorization. ! SSMMTI: SLAP MSOLVE for LDU Fact of Normal Eq (set up for SSMMI2). ! SSMMI2: SLAP Backsolve for LDU Factorization of Normal Equations. ! ! =========================== slaputil.f ========================== ! The following utility routines are useful additions to SLAP. ! ! SBHIN: Read Sparse Linear System in the Boeing/Harwell Format. ! SCHKW: SLAP WORK/IWORK Array Bounds Checker. ! SCPPLT: Printer Plot of SLAP Column Format Matrix. ! SS2Y: SLAP Triad to SLAP Column Format Converter. ! QS2I1R: Quick Sort Integer array, moving integer and real arrays. ! (Used by SS2Y.) ! STIN: Read in SLAP Triad Format Linear System. ! STOUT: Write out SLAP Triad Format Linear System. ! ! !***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 880715 DATE WRITTEN ! 890404 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! -----( This produced Version 2.0.1. )----- ! 891003 Rearranged list of user callable routines to agree with ! order in source deck. (FNF) ! 891004 Updated reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! -----( This produced Version 2.0.2. )----- ! 910506 Minor improvements to prologue. (FNF) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 921019 Improved one-line descriptions, reordering some. (FNF) !***END PROLOGUE SLPDOC !***FIRST EXECUTABLE STATEMENT SLPDOC ! ! This is a *DUMMY* subroutine and should never be called. ! return !------------- LAST LINE OF SLPDOC FOLLOWS ----------------------------- end subroutine SLVS (WM, IWM, X, TEM) ! !! SLVS solves the linear system for the integrator package DEBDF. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DEBDF !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SLVS-S, DSLVS-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! SLVS solves the linear system in the iteration scheme for the ! integrator package DEBDF. ! !***SEE ALSO DEBDF !***ROUTINES CALLED SGBSL, SGESL !***COMMON BLOCKS DEBDF1 !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920422 Changed DIMENSION statement. (WRB) !***END PROLOGUE SLVS ! !LLL. OPTIMIZE INTEGER IWM, I, IER, IOWND, IOWNS, JSTART, KFLAG, L, MAXORD, & MEBAND, METH, MITER, ML, MU, N, NFE, NJE, NQ, NQU, NST REAL WM, X, TEM, & ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND, & DI, HL0, PHL0, R DIMENSION WM(*), IWM(*), X(*), TEM(*) COMMON /DEBDF1/ ROWND, ROWNS(210), & EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6), & IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, & NJE, NQU !----------------------------------------------------------------------- ! THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING FROM ! A CHORD ITERATION. IT IS CALLED BY STOD if MITER /= 0. ! if MITER IS 1 OR 2, IT CALLS SGESL TO ACCOMPLISH THIS. ! if MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL ! MATRIX, AND THEN COMPUTES THE SOLUTION. ! if MITER IS 4 OR 5, IT CALLS SGBSL. ! COMMUNICATION WITH SLVS USES THE FOLLOWING VARIABLES.. ! WM = REAL WORK SPACE CONTAINING THE INVERSE DIAGONAL MATRIX if MITER ! IS 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. ! STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). ! WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. ! WM(1) = SQRT(UROUND) (NOT USED HERE), ! WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED if MITER = 3. ! IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT ! IWM(21), if MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS THE ! BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) if MITER IS 4 OR 5. ! X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR ! ON OUTPUT, OF LENGTH N. ! TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. ! IER = OUTPUT FLAG (IN COMMON). IER = 0 if NO TROUBLE OCCURRED. ! IER = -1 if A SINGULAR MATRIX AROSE WITH MITER = 3. ! THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. !----------------------------------------------------------------------- !***FIRST EXECUTABLE STATEMENT SLVS IER = 0 go to (100, 100, 300, 400, 400), MITER 100 call SGESL (WM(3), N, N, IWM(21), X, 0) return ! 300 PHL0 = WM(2) HL0 = H*EL0 WM(2) = HL0 if (HL0 == 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) == 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 ! 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 !----------------------- END OF SUBROUTINE SLVS ----------------------- end subroutine SMOUT (M, N, LDA, A, IFMT, IDIGIT) ! !! SMOUT prints a single precision matrix. ! !***SUBSIDIARY !***PURPOSE Subsidiary to FC and SBOCLS !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SMOUT-S, DMOUT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! SINGLE PRECISION MATRIX OUTPUT ROUTINE. ! ! INPUT.. ! ! M,N,LDA,A(*,*) PRINT THE SINGLE PRECISION ARRAY A(I,J),I = 1,...,M, ! J=1,...,N, ON OUTPUT UNIT LOUT=6. LDA IS THE DECLARED ! FIRST DIMENSION OF A(*,*) AS SPECIFIED IN THE CALLING ! PROGRAM. THE HEADING IN THE FORTRAN FORMAT STATEMENT ! IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST STEP. ! THE COMPONENTS A(I,J) ARE INDEXED, ON OUTPUT, IN A ! PLEASANT FORMAT. ! IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON ! OUTPUT UNIT LOUT=6 WITH THE VARIABLE FORMAT FORTRAN ! STATEMENT ! WRITE(LOUT,IFMT). ! IDIGIT PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. ! THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10, OR 14 ! WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF ! PLACES. if IDIGIT < 0, 72 PRINTING COLUMNS ARE ! UTILIZED TO WRITE EACH LINE OF OUTPUT OF THE ARRAY ! A(*,*). (THIS CAN BE USED ON MOST TIME-SHARING ! TERMINALS). if IDIGIT >= 0, 133 PRINTING COLUMNS ARE ! UTILIZED. (THIS CAN BE USED ON MOST LINE PRINTERS). ! ! EXAMPLE.. ! ! PRINT AN ARRAY CALLED (SIMPLEX TABLEAU ) OF SIZE 10 BY 20 SHOWING ! 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING ! SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. ! ! DIMENSION TABLEU(20,20) ! M = 10 ! N = 20 ! LDTABL = 20 ! IDIGIT = -6 ! call SMOUT(M,N,LDTABL,TABLEU,21H(16H1SIMPLEX TABLEAU),IDIGIT) ! !***SEE ALSO FC, SBOCLS !***ROUTINES CALLED I1MACH !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891107 Added comma after 1P edit descriptor in FORMAT ! statements. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SMOUT DIMENSION A(LDA,*) CHARACTER IFMT*(*),ICOL*3 SAVE ICOL DATA ICOL /'COL'/ !***FIRST EXECUTABLE STATEMENT SMOUT LOUT=I1MACH(2) WRITE(LOUT,IFMT) if ( M <= 0.OR.N <= 0.OR.LDA <= 0) RETURN NDIGIT = IDIGIT if ( IDIGIT == 0) NDIGIT = 4 if ( IDIGIT >= 0) go to 80 ! NDIGIT = -IDIGIT if ( NDIGIT > 4) go to 20 ! DO 10 K1=1,N,5 K2 = MIN(N,K1+4) WRITE(LOUT,1000) (ICOL,I,I = K1, K2) DO 10 I = 1, M WRITE(LOUT,1004) I,(A(I,J),J = K1, K2) 10 CONTINUE return ! 20 CONTINUE if ( NDIGIT > 6) go to 40 ! DO 30 K1=1,N,4 K2 = MIN(N,K1+3) WRITE(LOUT,1001) (ICOL,I,I = K1, K2) DO 30 I = 1, M WRITE(LOUT,1005) I,(A(I,J),J = K1, K2) 30 CONTINUE return ! 40 CONTINUE if ( NDIGIT > 10) go to 60 ! DO 50 K1=1,N,3 K2=MIN(N,K1+2) WRITE(LOUT,1002) (ICOL,I,I = K1, K2) DO 50 I = 1, M WRITE(LOUT,1006) I,(A(I,J),J = K1, K2) 50 CONTINUE return ! 60 CONTINUE DO 70 K1=1,N,2 K2 = MIN(N,K1+1) WRITE(LOUT,1003) (ICOL,I,I = K1, K2) DO 70 I = 1, M WRITE(LOUT,1007) I,(A(I,J),J = K1, K2) 70 CONTINUE return ! 80 CONTINUE if ( NDIGIT > 4) go to 100 ! DO 90 K1=1,N,10 K2 = MIN(N,K1+9) WRITE(LOUT,1000) (ICOL,I,I = K1, K2) DO 90 I = 1, M WRITE(LOUT,1004) I,(A(I,J),J = K1, K2) 90 CONTINUE return ! 100 CONTINUE if ( NDIGIT > 6) go to 120 ! DO 110 K1=1,N,8 K2 = MIN(N,K1+7) WRITE(LOUT,1001) (ICOL,I,I = K1, K2) DO 110 I = 1, M WRITE(LOUT,1005) I,(A(I,J),J = K1, K2) 110 CONTINUE return ! 120 CONTINUE if ( NDIGIT > 10) go to 140 ! DO 130 K1=1,N,6 K2 = MIN(N,K1+5) WRITE(LOUT,1002) (ICOL,I,I = K1, K2) DO 130 I = 1, M WRITE(LOUT,1006) I,(A(I,J),J = K1, K2) 130 CONTINUE return ! 140 CONTINUE DO 150 K1=1,N,5 K2 = MIN(N,K1+4) WRITE(LOUT,1003) (ICOL,I,I = K1, K2) DO 150 I = 1, M WRITE(LOUT,1007) I,(A(I,J),J = K1, K2) 150 CONTINUE return 1000 FORMAT(10X,10(4X,A,I4,1X)) 1001 FORMAT(10X,8(5X,A,I4,2X)) 1002 FORMAT(10X,6(7X,A,I4,4X)) 1003 FORMAT(10X,5(9X,A,I4,6X)) 1004 FORMAT(1X,3HROW,I4,2X,1P,10E12.3) 1005 FORMAT(1X,3HROW,I4,2X,1P,8E14.5) 1006 FORMAT(1X,3HROW,I4,2X,1P,6E18.9) 1007 FORMAT(1X,3HROW,I4,2X,1P,5E22.13) end subroutine SNBCO (ABE, LDA, N, ML, MU, IPVT, RCOND, Z) ! !! SNBCO factors a band matrix using Gaussian elimination and estimates ... ! the condition number. ! !***LIBRARY SLATEC !***CATEGORY D2A2 !***TYPE SINGLE PRECISION (SNBCO-S, DNBCO-D, CNBCO-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, ! NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! SNBCO factors a real band matrix by Gaussian ! elimination and estimates the condition of the matrix. ! ! If RCOND is not needed, SNBFA is slightly faster. ! To solve A*X = B , follow SNBCO by SNBSL. ! To compute INVERSE(A)*C , follow SNBCO by SNBSL. ! To compute DETERMINANT(A) , follow SNBCO by SNBDI. ! ! On Entry ! ! ABE REAL(LDA, NC) ! contains the matrix in band storage. The rows ! of the original matrix are stored in the rows ! of ABE and the diagonals of the original matrix ! are stored in columns 1 through ML+MU+1 of ABE. ! NC must be >= 2*ML+MU+1 . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABE. ! LDA must be >= N . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! ! On Return ! ! ABE an upper triangular matrix in band storage ! and the multipliers which were used to obtain it. ! The factorization can be written A = L*U , where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z REAL(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 through ML+MU+1 of ABE . ! Furthermore, ML additional columns are needed in ! ABE starting with column ML+MU+2 for elements ! generated during the triangularization. The total ! number of columns needed in ABE is 2*ML+MU+1 . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 + , * = not used ! 21222324 + , + = used for pivoting ! 32333435 + ! 43444546 + ! 545556 * + ! 6566 * * + ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SASUM, SAXPY, SDOT, SNBFA, SSCAL !***REVISION HISTORY (YYMMDD) ! 800723 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNBCO INTEGER LDA,N,ML,MU,IPVT(*) REAL ABE(LDA,*),Z(*) REAL RCOND ! REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER I,INFO,J,JU,K,KB,KP1,L,LDB,LM,LZ,M,ML1,MM,NL,NU !***FIRST EXECUTABLE STATEMENT SNBCO ML1=ML+1 LDB = LDA - 1 ANORM = 0.0E0 DO 10 J = 1, N NU = MIN(MU,J-1) NL = MIN(ML,N-J) L = 1 + NU + NL ANORM = MAX(ANORM,SASUM(L,ABE(J+NL,ML1-NL),LDB)) 10 CONTINUE ! ! FACTOR ! call SNBFA(ABE,LDA,N,ML,MU,IPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . ! TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE ! CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE ! TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID ! OVERFLOW. ! ! SOLVE TRANS(U)*W = E ! EK = 1.0E0 DO 20 J = 1, N Z(J) = 0.0E0 20 CONTINUE M = ML + MU + 1 JU = 0 DO 100 K = 1, N if (Z(K) /= 0.0E0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= ABS(ABE(K,ML1))) go to 30 S = ABS(ABE(K,ML1))/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 (ABE(K,ML1) == 0.0E0) go to 40 WK = WK/ABE(K,ML1) WKM = WKM/ABE(K,ML1) go to 50 40 CONTINUE WK = 1.0E0 WKM = 1.0E0 50 CONTINUE KP1 = K + 1 JU = MIN(MAX(JU,MU+IPVT(K)),N) MM = ML1 if (KP1 > JU) go to 90 DO 60 I = KP1, JU MM = MM + 1 SM = SM + ABS(Z(I)+WKM*ABE(K,MM)) Z(I) = Z(I) + WK*ABE(K,MM) S = S + ABS(Z(I)) 60 CONTINUE if (S >= SM) go to 80 T = WKM -WK WK = WKM MM = ML1 DO 70 I = KP1, JU MM = MM + 1 Z(I) = Z(I) + T*ABE(K,MM) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) ! ! SOLVE TRANS(L)*Y = W ! DO 120 KB = 1, N K = N + 1 - KB NL = MIN(ML,N-K) if (K < N) Z(K) = Z(K) + SDOT(NL,ABE(K+NL,ML1-NL),-LDB,Z(K+1) & ,1) if (ABS(Z(K)) <= 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) ! YNORM = 1.0E0 ! ! SOLVE L*V = Y ! DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T NL = MIN(ML,N-K) if (K < N) call SAXPY(NL,T,ABE(K+NL,ML1-NL),-LDB,Z(K+1),1) if (ABS(Z(K)) <= 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 ! ! SOLVE U*Z = V ! DO 160 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= ABS(ABE(K,ML1))) go to 150 S = ABS(ABE(K,ML1))/ABS(Z(K)) call SSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE if (ABE(K,ML1) /= 0.0E0) Z(K) = Z(K)/ABE(K,ML1) if (ABE(K,ML1) == 0.0E0) Z(K) = 1.0E0 LM = MIN(K,M) - 1 LZ = K - LM T = -Z(K) call SAXPY(LM,T,ABE(K-1,ML+2),-LDB,Z(LZ),1) 160 CONTINUE ! MAKE ZNORM = 1.0E0 S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine SNBDI (ABE, LDA, N, ML, MU, IPVT, DET) ! !! SNBDI computes the determinant of a band matrix using the factors ... ! computed by SNBCO or SNBFA. ! !***LIBRARY SLATEC !***CATEGORY D3A2 !***TYPE SINGLE PRECISION (SNBDI-S, DNBDI-D, CNBDI-C) !***KEYWORDS BANDED, DETERMINANT, LINEAR EQUATIONS, NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! SNBDI computes the determinant of a band matrix ! using the factors computed by SNBCO or SNBFA. ! If the inverse is needed, use SNBSL N times. ! ! On Entry ! ! ABE REAL(LDA, NC) ! the output from SNBCO or SNBFA. ! NC must be >= 2*ML+MU+1 . ! ! LDA INTEGER ! the leading dimension of the array ABE . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from SNBCO or SNBFA. ! ! On Return ! ! DET REAL(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800725 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNBDI INTEGER LDA,N,ML,MU,IPVT(*) REAL ABE(LDA,*),DET(2) ! REAL TEN INTEGER I !***FIRST EXECUTABLE STATEMENT SNBDI DET(1) = 1.0E0 DET(2) = 0.0E0 TEN = 10.0E0 DO 50 I = 1, N if (IPVT(I) /= I) DET(1) = -DET(1) DET(1) = ABE(I,ML+1)*DET(1) if (DET(1) == 0.0E0) go to 60 10 if (ABS(DET(1)) >= 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)) < TEN) go to 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 go to 30 40 CONTINUE 50 CONTINUE 60 CONTINUE return end subroutine SNBFA (ABE, LDA, N, ML, MU, IPVT, INFO) ! !! SNBFA factors a real band matrix by elimination. ! !***LIBRARY SLATEC !***CATEGORY D2A2 !***TYPE SINGLE PRECISION (SNBFA-S, DNBFA-D, CNBFA-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION, ! NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! SNBFA factors a real band matrix by elimination. ! ! SNBFA is usually called by SNBCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! ! On Entry ! ! ABE REAL(LDA, NC) ! contains the matrix in band storage. The rows ! of the original matrix are stored in the rows ! of ABE and the diagonals of the original matrix ! are stored in columns 1 through ML+MU+1 of ABE. ! NC must be >= 2*ML+MU+1 . ! See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABE. ! LDA must be >= N . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! 0 <= ML < N . ! ! MU INTEGER ! number of diagonals above the main diagonal. ! 0 <= MU < N . ! More efficient if ML <= MU . ! ! On Return ! ! ABE an upper triangular matrix in band storage ! and the multipliers which were used to obtain it. ! The factorization can be written A = L*U , where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! IPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! =0 normal value ! =K if U(K,K) == 0.0 . This is not an error ! condition for this subroutine, but it does ! indicate that SNBSL will divide by zero if ! called. Use RCOND in SNBCO for a reliable ! indication of singularity. ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 through ML+MU+1 of ABE . ! Furthermore, ML additional columns are needed in ! ABE starting with column ML+MU+2 for elements ! generated during the triangularization. The total ! number of columns needed in ABE is 2*ML+MU+1 . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 + , * = not used ! 21222324 + , + = used for pivoting ! 32333435 + ! 43444546 + ! 545556 * + ! 6566 * * + ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED ISAMAX, SAXPY, SSCAL, SSWAP !***REVISION HISTORY (YYMMDD) ! 800606 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNBFA INTEGER LDA,N,ML,MU,IPVT(*),INFO REAL ABE(LDA,*) ! INTEGER ML1,MB,M,N1,LDB,I,J,K,L,LM,LM1,LM2,MP,ISAMAX REAL T !***FIRST EXECUTABLE STATEMENT SNBFA ML1=ML+1 MB=ML+MU M=ML+MU+1 N1=N-1 LDB=LDA-1 INFO=0 ! ! SET FILL-IN COLUMNS TO ZERO ! if ( N <= 1)go to 50 if ( ML <= 0)go to 7 DO 6 J=1,ML DO 5 I=1,N ABE(I,M+J)=0.0E0 5 CONTINUE 6 CONTINUE 7 CONTINUE ! ! GAUSSIAN ELIMINATION WITH PARTIAL ELIMINATION ! DO 40 K=1,N1 LM=MIN(N-K,ML) LM1=LM+1 LM2=ML1-LM ! ! SEARCH FOR PIVOT INDEX ! L=-ISAMAX(LM1,ABE(LM+K,LM2),LDB)+LM1+K IPVT(K)=L MP=MIN(MB,N-K) ! ! SWAP ROWS if NECESSARY ! if ( L /= K)CALL SSWAP(MP+1,ABE(K,ML1),LDA,ABE(L,ML1+K-L),LDA) ! ! SKIP COLUMN REDUCTION if PIVOT IS ZERO ! if ( ABE(K,ML1) == 0.0E0) go to 20 ! ! COMPUTE MULTIPLIERS ! T=-1.0/ABE(K,ML1) call SSCAL(LM,T,ABE(LM+K,LM2),LDB) ! ! ROW ELIMINATION WITH COLUMN INDEXING ! DO 10 J=1,MP call SAXPY (LM,ABE(K,ML1+J),ABE(LM+K,LM2),LDB,ABE(LM+K,LM2+J), & LDB) 10 CONTINUE go to 30 20 CONTINUE INFO=K 30 CONTINUE 40 CONTINUE 50 CONTINUE IPVT(N)=N if ( ABE(N,ML1) == 0.0E0) INFO=N return end subroutine SNBFS (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK) ! !! SNBFS solves a general nonsymmetric banded system of linear equations. ! !***LIBRARY SLATEC !***CATEGORY D2A2 !***TYPE SINGLE PRECISION (SNBFS-S, DNBFS-D, CNBFS-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine SNBFS solves a general nonsymmetric banded NxN ! system of single precision real linear equations using ! SLATEC subroutines SNBCO and SNBSL. These are adaptations ! of the LINPACK subroutines SBGCO and SGBSL, which require ! a different format for storing the matrix elements. If ! A is an NxN real matrix and if X and B are real ! N-vectors, then SNBFS solves the equation ! ! A*X=B. ! ! A band matrix is a matrix whose nonzero elements are all ! fairly near the main diagonal, specifically A(I,J) = 0 ! if I-J is greater than ML or J-I is greater than ! MU . The integers ML and MU are called the lower and upper ! band widths and M = ML+MU+1 is the total band width. ! SNBFS uses less time and storage than the corresponding ! program for general matrices (SGEFS) if 2*ML+MU < N . ! ! The matrix A is first factored into upper and lower tri- ! angular matrices U and L using partial pivoting. These ! factors and the pivoting information are used to find the ! solution vector X. An approximate condition number is ! calculated to provide a rough estimate of the number of ! digits of accuracy in the computed solution. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N and IWORK must not have been altered by the user follow- ! ing factorization (ITASK=1). IND will not be changed by SNBFS ! in this case. ! ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 through ML+MU+1 of ABE . ! Furthermore, ML additional columns are needed in ! ABE starting with column ML+MU+2 for elements ! generated during the triangularization. The total ! number of columns needed in ABE is 2*ML+MU+1 . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 + , * = not used ! 21222324 + , + = used for pivoting ! 32333435 + ! 43444546 + ! 545556 * + ! 6566 * * + ! ! ! Argument Description *** ! ! ABE REAL(LDA,NC) ! on entry, contains the matrix in band storage as ! described above. NC must not be less than ! 2*ML+MU+1 . The user is cautioned to specify NC ! with care since it is not an argument and cannot ! be checked by SNBFS. The rows of the original ! matrix are stored in the rows of ABE and the ! diagonals of the original matrix are stored in ! columns 1 through ML+MU+1 of ABE . ! on return, contains an upper triangular matrix U and ! the multipliers necessary to construct a matrix L ! so that A=L*U. ! LDA INTEGER ! the leading dimension of array ABE. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. N must be greater ! than or equal to 1 . (terminal error message IND=-2) ! ML INTEGER ! the number of diagonals below the main diagonal. ! ML must not be less than zero nor greater than or ! equal to N . (terminal error message IND=-5) ! MU INTEGER ! the number of diagonals above the main diagonal. ! MU must not be less than zero nor greater than or ! equal to N . (terminal error message IND=-6) ! V REAL(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! If ITASK=1, the matrix A is factored and then the ! linear equation is solved. ! If ITASK > 1, the equation is solved using the existing ! factored matrix A and IWORK. ! If ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. ! LT. 0 See error message corresponding to IND below. ! WORK REAL(N) ! a singly subscripted array of dimension at least N. ! IWORK INTEGER(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than 1. ! IND=-3 terminal ITASK is less than 1. ! IND=-4 terminal the matrix A is computationally singular. ! A solution has not been computed. ! IND=-5 terminal ML is less than zero or is greater than ! or equal to N . ! IND=-6 terminal MU is less than zero or is greater than ! or equal to N . ! IND=-10 warning the solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! Note- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED R1MACH, SNBCO, SNBSL, XERMSG !***REVISION HISTORY (YYMMDD) ! 800808 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNBFS ! INTEGER LDA,N,ITASK,IND,IWORK(*),ML,MU REAL ABE(LDA,*),V(*),WORK(*),R1MACH REAL RCOND CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT SNBFS if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'SNBFS', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'SNBFS', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'SNBFS', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ML < 0 .OR. ML >= N) THEN IND = -5 WRITE (XERN1, '(I8)') ML call XERMSG ('SLATEC', 'SNBFS', & 'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1) return end if ! if (MU < 0 .OR. MU >= N) THEN IND = -6 WRITE (XERN1, '(I8)') MU call XERMSG ('SLATEC', 'SNBFS', & 'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1) return end if ! if (ITASK == 1) THEN ! ! FACTOR MATRIX A INTO LU ! call SNBCO(ABE,LDA,N,ML,MU,IWORK,RCOND,WORK) ! ! CHECK FOR COMPUTATIONALLY SINGULAR MATRIX ! if (RCOND == 0.0) THEN IND = -4 call XERMSG ('SLATEC', 'SNBFS', & 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) return ENDIF ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(R1MACH(4)/RCOND) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'SNBFS', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) ENDIF end if ! ! SOLVE AFTER FACTORING ! call SNBSL(ABE,LDA,N,ML,MU,IWORK,V,0) return end subroutine SNBIR (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK) ! !! SNBIR solves a general nonsymmetric banded system of linear equations. ! Iterative refinement is used to obtain an error estimate. ! !***LIBRARY SLATEC !***CATEGORY D2A2 !***TYPE SINGLE PRECISION (SNBIR-S, CNBIR-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine SNBIR solves a general nonsymmetric banded NxN ! system of single precision real linear equations using ! SLATEC subroutines SNBFA and SNBSL. These are adaptations ! of the LINPACK subroutines SGBFA and SGBSL, which require ! a different format for storing the matrix elements. ! One pass of iterative refinement is used only to obtain an ! estimate of the accuracy. If A is an NxN real banded ! matrix and if X and B are real N-vectors, then SNBIR ! solves the equation ! ! A*X=B. ! ! A band matrix is a matrix whose nonzero elements are all ! fairly near the main diagonal, specifically A(I,J) = 0 ! if I-J is greater than ML or J-I is greater than ! MU . The integers ML and MU are called the lower and upper ! band widths and M = ML+MU+1 is the total band width. ! SNBIR uses less time and storage than the corresponding ! program for general matrices (SGEIR) if 2*ML+MU < N . ! ! The matrix A is first factored into upper and lower tri- ! angular matrices U and L using partial pivoting. These ! factors and the pivoting information are used to find the ! solution vector X . Then the residual vector is found and used ! to calculate an estimate of the relative error, IND . IND esti- ! mates the accuracy of the solution only when the input matrix ! and the right hand side are represented exactly in the computer ! and does not take into account any errors in the input data. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, LDA, ! N, work and IWORK must not have been altered by the user follow- ! ing factorization (ITASK=1). IND will not be changed by SNBIR ! in this case. ! ! ! Band Storage ! ! If A is a band matrix, the following program segment ! will set up the input. ! ! ML = (band width below the diagonal) ! MU = (band width above the diagonal) ! DO 20 I = 1, N ! J1 = MAX(1, I-ML) ! J2 = MIN(N, I+MU) ! DO 10 J = J1, J2 ! K = J - I + ML + 1 ! ABE(I,K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses columns 1 Through ML+MU+1 of ABE . ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 21222324 0 0 ! 032333435 0 ! 0 043444546 ! 0 0 0545556 ! 0 0 0 06566 ! ! then N = 6, ML = 1, MU = 2, LDA >= 5 and ABE should contain ! ! * 111213 , * = not used ! 21222324 ! 32333435 ! 43444546 ! 545556 * ! 6566 * * ! ! ! Argument Description *** ! ! ABE REAL(LDA,MM) ! on entry, contains the matrix in band storage as ! described above. MM must not be less than M = ! ML+MU+1 . The user is cautioned to dimension ABE ! with care since MM is not an argument and cannot ! be checked by SNBIR. The rows of the original ! matrix are stored in the rows of ABE and the ! diagonals of the original matrix are stored in ! columns 1 through ML+MU+1 of ABE . ABE is ! not altered by the program. ! LDA INTEGER ! the leading dimension of array ABE. LDA must be great- ! er than or equal to N. (terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. N must be greater ! than or equal to 1 . (terminal error message IND=-2) ! ML INTEGER ! the number of diagonals below the main diagonal. ! ML must not be less than zero nor greater than or ! equal to N . (terminal error message IND=-5) ! MU INTEGER ! the number of diagonals above the main diagonal. ! MU must not be less than zero nor greater than or ! equal to N . (terminal error message IND=-6) ! V REAL(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! If ITASK=1, the matrix A is factored and then the ! linear equation is solved. ! If ITASK > 1, the equation is solved using the existing ! factored matrix A and IWORK. ! If ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X . IND=75 means ! that the solution vector X is zero. ! LT. 0 See error message corresponding to IND below. ! WORK REAL(N*(NC+1)) ! a singly subscripted array of dimension at least ! N*(NC+1) where NC = 2*ML+MU+1 . ! IWORK INTEGER(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than 1. ! IND=-3 terminal ITASK is less than 1. ! IND=-4 terminal the matrix A is computationally singular. ! A solution has not been computed. ! IND=-5 terminal ML is less than zero or is greater than ! or equal to N . ! IND=-6 terminal MU is less than zero or is greater than ! or equal to N . ! IND=-10 warning the solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! Note- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED R1MACH, SASUM, SCOPY, SDSDOT, SNBFA, SNBSL, XERMSG !***REVISION HISTORY (YYMMDD) ! 800815 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNBIR ! INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J,K,KK,L,M,ML,MU,NC REAL ABE(LDA,*),V(*),WORK(N,*),XNORM,DNORM,SDSDOT,SASUM,R1MACH CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT SNBIR if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'SNBIR', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'SNBIR', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'SNBIR', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ML < 0 .OR. ML >= N) THEN IND = -5 WRITE (XERN1, '(I8)') ML call XERMSG ('SLATEC', 'SNBIR', & 'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1) return end if ! if (MU < 0 .OR. MU >= N) THEN IND = -6 WRITE (XERN1, '(I8)') MU call XERMSG ('SLATEC', 'SNBIR', & 'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1) return end if ! NC = 2*ML+MU+1 if (ITASK == 1) THEN ! ! MOVE MATRIX ABE TO WORK ! M=ML+MU+1 DO 10 J=1,M call SCOPY(N,ABE(1,J),1,WORK(1,J),1) 10 CONTINUE ! ! FACTOR MATRIX A INTO LU ! call SNBFA(WORK,N,N,ML,MU,IWORK,INFO) ! ! CHECK FOR COMPUTATIONALLY SINGULAR MATRIX ! if (INFO /= 0) THEN IND = -4 call XERMSG ('SLATEC', 'SNBIR', & 'SINGULAR MATRIX A - NO SOLUTION', -4, 1) return ENDIF end if ! ! SOLVE WHEN FACTORING COMPLETE ! MOVE VECTOR B TO WORK ! call SCOPY(N,V(1),1,WORK(1,NC+1),1) call SNBSL(WORK,N,N,ML,MU,IWORK,V,0) ! ! FORM NORM OF X0 ! XNORM = SASUM(N,V(1),1) if (XNORM == 0.0) THEN IND = 75 return end if ! ! COMPUTE RESIDUAL ! DO 40 J=1,N K = MAX(1,ML+2-J) KK = MAX(1,J-ML) L = MIN(J-1,ML)+MIN(N-J,MU)+1 WORK(J,NC+1) = SDSDOT(L,-WORK(J,NC+1),ABE(J,K),LDA,V(KK),1) 40 CONTINUE ! ! SOLVE A*DELTA=R ! call SNBSL(WORK,N,N,ML,MU,IWORK,WORK(1,NC+1),0) ! ! FORM NORM OF DELTA ! DNORM = SASUM(N,WORK(1,NC+1),1) ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'SNBIR', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) end if return end subroutine SNBSL (ABE, LDA, N, ML, MU, IPVT, B, JOB) ! !! SNBSL solves a real band system using the factors computed by SNBCO or SNBFA. ! !***LIBRARY SLATEC !***CATEGORY D2A2 !***TYPE SINGLE PRECISION (SNBSL-S, DNBSL-D, CNBSL-C) !***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC, SOLVE !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! SNBSL solves the real band system ! A * X = B or TRANS(A) * X = B ! using the factors computed by SNBCO or SNBFA. ! ! On Entry ! ! ABE REAL(LDA, NC) ! the output from SNBCO or SNBFA. ! NC must be >= 2*ML+MU+1 . ! ! LDA INTEGER ! the leading dimension of the array ABE . ! ! N INTEGER ! the order of the original matrix. ! ! ML INTEGER ! number of diagonals below the main diagonal. ! ! MU INTEGER ! number of diagonals above the main diagonal. ! ! IPVT INTEGER(N) ! the pivot vector from SNBCO or SNBFA. ! ! B REAL(N) ! the right hand side vector. ! ! JOB INTEGER ! = 0 to solve A*X = B . ! = nonzero to solve TRANS(A)*X = B , where ! TRANS(A) is the transpose. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically, this indicates singularity, ! but it is often caused by improper arguments or improper ! setting of LDA. It will not occur if the subroutines are ! called correctly and if SNBCO has set RCOND > 0.0 ! or SNBFA has set INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call SNBCO(ABE,LDA,N,ML,MU,IPVT,RCOND,Z) ! if (RCOND is too small) go to ... ! DO 10 J = 1, P ! call SNBSL(ABE,LDA,N,ML,MU,IPVT,C(1,J),0) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT !***REVISION HISTORY (YYMMDD) ! 800717 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNBSL INTEGER LDA,N,ML,MU,IPVT(*),JOB REAL ABE(LDA,*),B(*) ! REAL SDOT,T INTEGER K,KB,L,LB,LDB,LM,M,MLM,NM1 !***FIRST EXECUTABLE STATEMENT SNBSL M=MU+ML+1 NM1=N-1 LDB=1-LDA if ( JOB /= 0)go to 50 ! ! JOB = 0 , SOLVE A * X = B ! FIRST SOLVE L*Y = B ! if ( ML == 0)go to 30 if ( NM1 < 1)go to 30 DO 20 K=1,NM1 LM=MIN(ML,N-K) L=IPVT(K) T=B(L) if ( L == K)go to 10 B(L)=B(K) B(K)=T 10 CONTINUE MLM=ML-(LM-1) call SAXPY(LM,T,ABE(K+LM,MLM),LDB,B(K+1),1) 20 CONTINUE 30 CONTINUE ! ! NOW SOLVE U*X = Y ! DO 40 KB=1,N K=N+1-KB B(K)=B(K)/ABE(K,ML+1) LM=MIN(K,M)-1 LB=K-LM T=-B(K) call SAXPY(LM,T,ABE(K-1,ML+2),LDB,B(LB),1) 40 CONTINUE go to 100 50 CONTINUE ! ! JOB = NONZERO, SOLVE TRANS(A) * X = B ! FIRST SOLVE TRANS(U)*Y = B ! DO 60 K = 1, N LM = MIN(K,M) - 1 LB = K - LM T = SDOT(LM,ABE(K-1,ML+2),LDB,B(LB),1) B(K) = (B(K) - T)/ABE(K,ML+1) 60 CONTINUE ! ! NOW SOLVE TRANS(L)*X = Y ! if (ML == 0) go to 90 if (NM1 < 1) go to 90 DO 80 KB = 1, NM1 K = N - KB LM = MIN(ML,N-K) MLM = ML - (LM - 1) B(K) = B(K) + SDOT(LM,ABE(K+LM,MLM),LDB,B(K+1),1) L = IPVT(K) if (L == 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 SNLS1E (FCN, IOPT, M, N, X, FVEC, TOL, NPRINT, INFO, & IW, WA, LWA) ! !! SNLS1E is the easy-to-use version of SNLS1. ! !***PURPOSE An easy-to-use code which minimizes the sum of the squares ! of M nonlinear functions in N variables by a modification ! of the Levenberg-Marquardt algorithm. !***LIBRARY SLATEC !***CATEGORY K1B1A1, K1B1A2 !***TYPE SINGLE PRECISION (SNLS1E-S, DNLS1E-D) !***KEYWORDS EASY-TO-USE, LEVENBERG-MARQUARDT, NONLINEAR DATA FITTING, ! NONLINEAR LEAST SQUARES !***AUTHOR Hiebert, K. L., (SNLA) !***DESCRIPTION ! ! 1. Purpose. ! ! The purpose of SNLS1E is to minimize the sum of the squares of M ! nonlinear functions in N variables by a modification of the ! Levenberg-Marquardt algorithm. This is done by using the more ! general least-squares solver SNLS1. The user must provide a ! subroutine which calculates the functions. The user has the ! option of how the Jacobian will be supplied. The user can ! supply the full Jacobian, or the rows of the Jacobian (to avoid ! storing the full Jacobian), or let the code approximate the ! Jacobian by forward-differencing. This code is the combination ! of the MINPACK codes (Argonne) LMDER1, LMDIF1, and LMSTR1. ! ! ! 2. Subroutine and Type Statements. ! ! SUBROUTINE SNLS1E(FCN,IOPT,M,N,X,FVEC,TOL,NPRINT, ! * INFO,IW,WA,LWA) ! INTEGER IOPT,M,N,NPRINT,INFO,LWA ! INTEGER IW(N) ! REAL TOL ! REAL X(N),FVEC(M),WA(LWA) ! EXTERNAL FCN ! ! ! 3. Parameters. ! ! Parameters designated as input parameters must be specified on ! entry to SNLS1E and are not changed on exit, while parameters ! designated as output parameters need not be specified on entry ! and are set to appropriate values on exit from SNLS1E. ! ! FCN is the name of the user-supplied subroutine which calculates ! the functions. If the user wants to supply the Jacobian ! (IOPT=2 or 3), then FCN must be written to calculate the ! Jacobian, as well as the functions. See the explanation ! of the IOPT argument below. ! If the user wants the iterates printed (NPRINT positive), then ! FCN must do the printing. See the explanation of NPRINT ! below. FCN must be declared in an EXTERNAL statement in the ! calling program and should be written as follows. ! ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! INTEGER IFLAG,LDFJAC,M,N ! REAL X(N),FVEC(M) ! ---------- ! FJAC and LDFJAC may be ignored , if IOPT=1. ! REAL FJAC(LDFJAC,N) , if IOPT=2. ! REAL FJAC(N) , if IOPT=3. ! ---------- ! If IFLAG=0, the values in X and FVEC are available ! for printing. See the explanation of NPRINT below. ! IFLAG will never be zero unless NPRINT is positive. ! The values of X and FVEC must not be changed. ! return ! ---------- ! If IFLAG=1, calculate the functions at X and return ! this vector in FVEC. ! return ! ---------- ! If IFLAG=2, calculate the full Jacobian at X and return ! this matrix in FJAC. Note that IFLAG will never be 2 unless ! IOPT=2. FVEC contains the function values at X and must ! not be altered. FJAC(I,J) must be set to the derivative ! of FVEC(I) with respect to X(J). ! return ! ---------- ! If IFLAG=3, calculate the LDFJAC-th row of the Jacobian ! and return this vector in FJAC. Note that IFLAG will ! never be 3 unless IOPT=3. FVEC contains the function ! values at X and must not be altered. FJAC(J) must be ! set to the derivative of FVEC(LDFJAC) with respect to X(J). ! return ! ---------- ! END ! ! ! The value of IFLAG should not be changed by FCN unless the ! user wants to terminate execution of SNLS1E. In this case, ! set IFLAG to a negative integer. ! ! ! IOPT is an input variable which specifies how the Jacobian will ! be calculated. If IOPT=2 or 3, then the user must supply the ! Jacobian, as well as the function values, through the ! subroutine FCN. If IOPT=2, the user supplies the full ! Jacobian with one call to FCN. If IOPT=3, the user supplies ! one row of the Jacobian with each call. (In this manner, ! storage can be saved because the full Jacobian is not stored.) ! If IOPT=1, the code will approximate the Jacobian by forward ! differencing. ! ! M is a positive integer input variable set to the number of ! functions. ! ! N is a positive integer input variable set to the number of ! variables. N must not exceed M. ! ! X is an array of length N. On input, X must contain an initial ! estimate of the solution vector. On output, X contains the ! final estimate of the solution vector. ! ! FVEC is an output array of length M which contains the functions ! evaluated at the output X. ! ! TOL is a non-negative input variable. Termination occurs when ! the algorithm estimates either that the relative error in the ! sum of squares is at most TOL or that the relative error ! between X and the solution is at most TOL. Section 4 contains ! more details about TOL. ! ! NPRINT is an integer input variable that enables controlled ! printing of iterates if it is positive. In this case, FCN is ! called with IFLAG = 0 at the beginning of the first iteration ! and every NPRINT iterations thereafter and immediately prior ! to return, with X and FVEC available for printing. Appropriate ! print statements must be added to FCN (see example) and ! FVEC should not be altered. If NPRINT is not positive, no ! special calls of FCN with IFLAG = 0 are made. ! ! INFO is an integer output variable. If the user has terminated ! execution, INFO is set to the (negative) value of IFLAG. See ! description of FCN and JAC. Otherwise, INFO is set as follows. ! ! INFO = 0 improper input parameters. ! ! INFO = 1 algorithm estimates that the relative error in the ! sum of squares is at most TOL. ! ! INFO = 2 algorithm estimates that the relative error between ! X and the solution is at most TOL. ! ! INFO = 3 conditions for INFO = 1 and INFO = 2 both hold. ! ! INFO = 4 FVEC is orthogonal to the columns of the Jacobian to ! machine precision. ! ! INFO = 5 number of calls to FCN has reached 100*(N+1) ! for IOPT=2 or 3 or 200*(N+1) for IOPT=1. ! ! INFO = 6 TOL is too small. No further reduction in the sum ! of squares is possible. ! ! INFO = 7 TOL is too small. No further improvement in the ! approximate solution X is possible. ! ! Sections 4 and 5 contain more details about INFO. ! ! IW is an INTEGER work array of length N. ! ! WA is a work array of length LWA. ! ! LWA is a positive integer input variable not less than ! N*(M+5)+M for IOPT=1 and 2 or N*(N+5)+M for IOPT=3. ! ! ! 4. Successful Completion. ! ! The accuracy of SNLS1E is controlled by the convergence parame- ! ter TOL. This parameter is used in tests which make three types ! of comparisons between the approximation X and a solution XSOL. ! SNLS1E terminates when any of the tests is satisfied. If TOL is ! less than the machine precision (as defined by the function ! R1MACH(4)), then SNLS1E only attempts to satisfy the test ! defined by the machine precision. Further progress is not usu- ! ally possible. Unless high precision solutions are required, ! the recommended value for TOL is the square root of the machine ! precision. ! ! The tests assume that the functions are reasonably well behaved, ! and, if the Jacobian is supplied by the user, that the functions ! and the Jacobian are coded consistently. If these conditions ! are not satisfied, then SNLS1E may incorrectly indicate conver- ! gence. If the Jacobian is coded correctly or IOPT=1, ! then the validity of the answer can be checked, for example, by ! rerunning SNLS1E with tighter tolerances. ! ! First Convergence Test. If ENORM(Z) denotes the Euclidean norm ! of a vector Z, then this test attempts to guarantee that ! ! ENORM(FVEC) <= (1+TOL)*ENORM(FVECS), ! ! where FVECS denotes the functions evaluated at XSOL. If this ! condition is satisfied with TOL = 10**(-K), then the final ! residual norm ENORM(FVEC) has K significant decimal digits and ! INFO is set to 1 (or to 3 if the second test is also satis- ! fied). ! ! Second Convergence Test. If D is a diagonal matrix (implicitly ! generated by SNLS1E) whose entries contain scale factors for ! the variables, then this test attempts to guarantee that ! ! ENORM(D*(X-XSOL)) <= TOL*ENORM(D*XSOL). ! ! If this condition is satisfied with TOL = 10**(-K), then the ! larger components of D*X have K significant decimal digits and ! INFO is set to 2 (or to 3 if the first test is also satis- ! fied). There is a danger that the smaller components of D*X ! may have large relative errors, but the choice of D is such ! that the accuracy of the components of X is usually related to ! their sensitivity. ! ! Third Convergence Test. This test is satisfied when FVEC is ! orthogonal to the columns of the Jacobian to machine preci- ! sion. There is no clear relationship between this test and ! the accuracy of SNLS1E, and furthermore, the test is equally ! well satisfied at other critical points, namely maximizers and ! saddle points. Therefore, termination caused by this test ! (INFO = 4) should be examined carefully. ! ! ! 5. Unsuccessful Completion. ! ! Unsuccessful termination of SNLS1E can be due to improper input ! parameters, arithmetic interrupts, or an excessive number of ! function evaluations. ! ! Improper Input Parameters. INFO is set to 0 if IOPT < 1 ! or IOPT > 3, or N <= 0, or M < N, or TOL < 0.E0, ! or for IOPT=1 or 2 LWA < N*(M+5)+M, or for IOPT=3 ! LWA < N*(N+5)+M. ! ! Arithmetic Interrupts. If these interrupts occur in the FCN ! subroutine during an early stage of the computation, they may ! be caused by an unacceptable choice of X by SNLS1E. In this ! case, it may be possible to remedy the situation by not evalu- ! ating the functions here, but instead setting the components ! of FVEC to numbers that exceed those in the initial FVEC. ! ! Excessive Number of Function Evaluations. If the number of ! calls to FCN reaches 100*(N+1) for IOPT=2 or 3 or 200*(N+1) ! for IOPT=1, then this indicates that the routine is converging ! very slowly as measured by the progress of FVEC, and INFO is ! set to 5. In this case, it may be helpful to restart SNLS1E, ! thereby forcing it to disregard old (and possibly harmful) ! information. ! ! ! 6. Characteristics of the Algorithm. ! ! SNLS1E is a modification of the Levenberg-Marquardt algorithm. ! Two of its main characteristics involve the proper use of ! implicitly scaled variables and an optimal choice for the cor- ! rection. The use of implicitly scaled variables achieves scale ! invariance of SNLS1E and limits the size of the correction in ! any direction where the functions are changing rapidly. The ! optimal choice of the correction guarantees (under reasonable ! conditions) global convergence from starting points far from the ! solution and a fast rate of convergence for problems with small ! residuals. ! ! Timing. The time required by SNLS1E to solve a given problem ! depends on M and N, the behavior of the functions, the accu- ! racy requested, and the starting point. The number of arith- ! metic operations needed by SNLS1E is about N**3 to process ! each evaluation of the functions (call to FCN) and to process ! each evaluation of the Jacobian SNLS1E takes M*N**2 for IOPT=2 ! (one call to JAC), M*N**2 for IOPT=1 (N calls to FCN) and ! 1.5*M*N**2 for IOPT=3 (M calls to FCN). Unless FCN ! can be evaluated quickly, the timing of SNLS1E will be ! strongly influenced by the time spent in FCN. ! ! Storage. SNLS1E requires (M*N + 2*M + 6*N) for IOPT=1 or 2 and ! (N**2 + 2*M + 6*N) for IOPT=3 single precision storage ! locations and N integer storage locations, in addition to ! the storage required by the program. There are no internally ! declared storage arrays. ! ! *Long Description: ! ! 7. Example. ! ! The problem is to determine the values of X(1), X(2), and X(3) ! which provide the best fit (in the least squares sense) of ! ! X(1) + U(I)/(V(I)*X(2) + W(I)*X(3)), I = 1, 15 ! ! to the data ! ! Y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, ! 0.37,0.58,0.73,0.96,1.34,2.10,4.39), ! ! where U(I) = I, V(I) = 16 - I, and W(I) = MIN(U(I),V(I)). The ! I-th component of FVEC is thus defined by ! ! Y(I) - (X(1) + U(I)/(V(I)*X(2) + W(I)*X(3))). ! ! ********** ! ! PROGRAM TEST ! C ! C Driver for SNLS1E example. ! C ! INTEGER I,IOPT,M,N,NPRINT,JNFO,LWA,NWRITE ! INTEGER IW(3) ! REAL TOL,FNORM ! REAL X(3),FVEC(15),WA(75) ! REAL ENORM,R1MACH ! EXTERNAL FCN ! DATA NWRITE /6/ ! C ! IOPT = 1 ! M = 15 ! N = 3 ! C ! C The following starting values provide a rough fit. ! C ! X(1) = 1.E0 ! X(2) = 1.E0 ! X(3) = 1.E0 ! C ! LWA = 75 ! NPRINT = 0 ! C ! C Set TOL to the square root of the machine precision. ! C Unless high precision solutions are required, ! C this is the recommended setting. ! C ! TOL = SQRT(R1MACH(4)) ! C ! call SNLS1E(FCN,IOPT,M,N,X,FVEC,TOL,NPRINT, ! * INFO,IW,WA,LWA) ! FNORM = ENORM(M,FVEC) ! WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) ! STOP ! 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // ! * 5X,' EXIT PARAMETER',16X,I10 // ! * 5X,' FINAL APPROXIMATE SOLUTION' // 5X,3E15.7) ! END ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,DUM,IDUM) ! C This is the form of the FCN routine if IOPT=1, ! C that is, if the user does not calculate the Jacobian. ! INTEGER M,N,IFLAG ! REAL X(N),FVEC(M) ! INTEGER I ! REAL TMP1,TMP2,TMP3,TMP4 ! REAL Y(15) ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! END ! ! ! Results obtained with different compilers or machines ! may be slightly different. ! ! FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 ! ! EXIT PARAMETER 1 ! ! FINAL APPROXIMATE SOLUTION ! ! 0.8241058E-01 0.1133037E+01 0.2343695E+01 ! ! ! For IOPT=2, FCN would be modified as follows to also ! calculate the full Jacobian when IFLAG=2. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! C ! C This is the form of the FCN routine if IOPT=2, ! C that is, if the user calculates the full Jacobian. ! C ! INTEGER LDFJAC,M,N,IFLAG ! REAL X(N),FVEC(M) ! REAL FJAC(LDFJAC,N) ! INTEGER I ! REAL TMP1,TMP2,TMP3,TMP4 ! REAL Y(15) ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! if ( IFLAG /= 1) go to 20 ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! C ! C Below, calculate the full Jacobian. ! C ! 20 CONTINUE ! C ! DO 30 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 ! FJAC(I,1) = -1.E0 ! FJAC(I,2) = TMP1*TMP2/TMP4 ! FJAC(I,3) = TMP1*TMP3/TMP4 ! 30 CONTINUE ! return ! END ! ! ! For IOPT = 3, FJAC would be dimensioned as FJAC(3,3), ! LDFJAC would be set to 3, and FCN would be written as ! follows to calculate a row of the Jacobian when IFLAG=3. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! C This is the form of the FCN routine if IOPT=3, ! C that is, if the user calculates the Jacobian row by row. ! INTEGER M,N,IFLAG ! REAL X(N),FVEC(M) ! REAL FJAC(N) ! INTEGER I ! REAL TMP1,TMP2,TMP3,TMP4 ! REAL Y(15) ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! if ( IFLAG /= 1) go to 20 ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! C ! C Below, calculate the LDFJAC-th row of the Jacobian. ! C ! 20 CONTINUE ! ! I = LDFJAC ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 ! FJAC(1) = -1.E0 ! FJAC(2) = TMP1*TMP2/TMP4 ! FJAC(3) = TMP1*TMP3/TMP4 ! return ! END ! !***REFERENCES Jorge J. More, The Levenberg-Marquardt algorithm: ! implementation and theory. In Numerical Analysis ! Proceedings (Dundee, June 28 - July 1, 1977, G. A. ! Watson, Editor), Lecture Notes in Mathematics 630, ! Springer-Verlag, 1978. !***ROUTINES CALLED SNLS1, XERMSG !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNLS1E INTEGER M,N,NPRINT,INFO,LWA,IOPT INTEGER INDEX,IW(*) REAL TOL REAL X(*),FVEC(*),WA(*) EXTERNAL FCN INTEGER MAXFEV,MODE,NFEV,NJEV REAL FACTOR,FTOL,GTOL,XTOL,ZERO,EPSFCN SAVE FACTOR, ZERO DATA FACTOR,ZERO /1.0E2,0.0E0/ !***FIRST EXECUTABLE STATEMENT SNLS1E INFO = 0 ! ! CHECK THE INPUT PARAMETERS FOR ERRORS. ! if (IOPT < 1 .OR. IOPT > 3 .OR. & N <= 0 .OR. M < N .OR. TOL < ZERO & .OR. LWA < N*(N+5) + M) go to 10 if (IOPT < 3 .AND. LWA < N*(M+5) + M) go to 10 ! ! call SNLS1. ! MAXFEV = 100*(N + 1) if (IOPT == 1) MAXFEV = 2*MAXFEV FTOL = TOL XTOL = TOL GTOL = ZERO EPSFCN = ZERO MODE = 1 INDEX = 5*N+M call SNLS1(FCN,IOPT,M,N,X,FVEC,WA(INDEX+1),M,FTOL,XTOL,GTOL, & MAXFEV,EPSFCN,WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, & IW,WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) if (INFO == 8) INFO = 4 10 CONTINUE if (INFO == 0) call XERMSG ('SLATEC', 'SNLS1E', & 'INVALID INPUT PARAMETER.', 2, 1) return ! ! LAST CARD OF SUBROUTINE SNLS1E. ! end subroutine SNLS1 (FCN, IOPT, M, N, X, FVEC, FJAC, LDFJAC, FTOL, & XTOL, GTOL, MAXFEV, EPSFCN, DIAG, MODE, FACTOR, NPRINT, INFO, & NFEV, NJEV, IPVT, QTF, WA1, WA2, WA3, WA4) ! !! SNLS1 minimizes the sum of the squares of M nonlinear functions ... ! in N variables by a modification of the Levenberg-Marquardt ! algorithm. ! !***LIBRARY SLATEC !***CATEGORY K1B1A1, K1B1A2 !***TYPE SINGLE PRECISION (SNLS1-S, DNLS1-D) !***KEYWORDS LEVENBERG-MARQUARDT, NONLINEAR DATA FITTING, ! NONLINEAR LEAST SQUARES !***AUTHOR Hiebert, K. L., (SNLA) !***DESCRIPTION ! ! 1. Purpose. ! ! The purpose of SNLS1 is to minimize the sum of the squares of M ! nonlinear functions in N variables by a modification of the ! Levenberg-Marquardt algorithm. The user must provide a subrou- ! tine which calculates the functions. The user has the option ! of how the Jacobian will be supplied. The user can supply the ! full Jacobian, or the rows of the Jacobian (to avoid storing ! the full Jacobian), or let the code approximate the Jacobian by ! forward-differencing. This code is the combination of the ! MINPACK codes (Argonne) LMDER, LMDIF, and LMSTR. ! ! ! 2. Subroutine and Type Statements. ! ! SUBROUTINE SNLS1(FCN,IOPT,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL, ! * GTOL,MAXFEV,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO ! * ,NFEV,NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) ! INTEGER IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV ! INTEGER IPVT(N) ! REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR ! REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), ! * WA1(N),WA2(N),WA3(N),WA4(M) ! ! ! 3. Parameters. ! ! Parameters designated as input parameters must be specified on ! entry to SNLS1 and are not changed on exit, while parameters ! designated as output parameters need not be specified on entry ! and are set to appropriate values on exit from SNLS1. ! ! FCN is the name of the user-supplied subroutine which calculates ! the functions. If the user wants to supply the Jacobian ! (IOPT=2 or 3), then FCN must be written to calculate the ! Jacobian, as well as the functions. See the explanation ! of the IOPT argument below. ! If the user wants the iterates printed (NPRINT positive), then ! FCN must do the printing. See the explanation of NPRINT ! below. FCN must be declared in an EXTERNAL statement in the ! calling program and should be written as follows. ! ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! INTEGER IFLAG,LDFJAC,M,N ! REAL X(N),FVEC(M) ! ---------- ! FJAC and LDFJAC may be ignored , if IOPT=1. ! REAL FJAC(LDFJAC,N) , if IOPT=2. ! REAL FJAC(N) , if IOPT=3. ! ---------- ! If IFLAG=0, the values in X and FVEC are available ! for printing. See the explanation of NPRINT below. ! IFLAG will never be zero unless NPRINT is positive. ! The values of X and FVEC must not be changed. ! return ! ---------- ! If IFLAG=1, calculate the functions at X and return ! this vector in FVEC. ! return ! ---------- ! If IFLAG=2, calculate the full Jacobian at X and return ! this matrix in FJAC. Note that IFLAG will never be 2 unless ! IOPT=2. FVEC contains the function values at X and must ! not be altered. FJAC(I,J) must be set to the derivative ! of FVEC(I) with respect to X(J). ! return ! ---------- ! If IFLAG=3, calculate the LDFJAC-th row of the Jacobian ! and return this vector in FJAC. Note that IFLAG will ! never be 3 unless IOPT=3. FVEC contains the function ! values at X and must not be altered. FJAC(J) must be ! set to the derivative of FVEC(LDFJAC) with respect to X(J). ! return ! ---------- ! END ! ! ! The value of IFLAG should not be changed by FCN unless the ! user wants to terminate execution of SNLS1. In this case, set ! IFLAG to a negative integer. ! ! ! IOPT is an input variable which specifies how the Jacobian will ! be calculated. If IOPT=2 or 3, then the user must supply the ! Jacobian, as well as the function values, through the ! subroutine FCN. If IOPT=2, the user supplies the full ! Jacobian with one call to FCN. If IOPT=3, the user supplies ! one row of the Jacobian with each call. (In this manner, ! storage can be saved because the full Jacobian is not stored.) ! If IOPT=1, the code will approximate the Jacobian by forward ! differencing. ! ! M is a positive integer input variable set to the number of ! functions. ! ! N is a positive integer input variable set to the number of ! variables. N must not exceed M. ! ! X is an array of length N. On input, X must contain an initial ! estimate of the solution vector. On output, X contains the ! final estimate of the solution vector. ! ! FVEC is an output array of length M which contains the functions ! evaluated at the output X. ! ! FJAC is an output array. For IOPT=1 and 2, FJAC is an M by N ! array. For IOPT=3, FJAC is an N by N array. The upper N by N ! submatrix of FJAC contains an upper triangular matrix R with ! diagonal elements of nonincreasing magnitude such that ! ! T T T ! P *(JAC *JAC)*P = R *R, ! ! where P is a permutation matrix and JAC is the final calcu- ! lated Jacobian. Column J of P is column IPVT(J) (see below) ! of the identity matrix. The lower part of FJAC contains ! information generated during the computation of R. ! ! LDFJAC is a positive integer input variable which specifies ! the leading dimension of the array FJAC. For IOPT=1 and 2, ! LDFJAC must not be less than M. For IOPT=3, LDFJAC must not ! be less than N. ! ! FTOL is a non-negative input variable. Termination occurs when ! both the actual and predicted relative reductions in the sum ! of squares are at most FTOL. Therefore, FTOL measures the ! relative error desired in the sum of squares. Section 4 con- ! tains more details about FTOL. ! ! XTOL is a non-negative input variable. Termination occurs when ! the relative error between two consecutive iterates is at most ! XTOL. Therefore, XTOL measures the relative error desired in ! the approximate solution. Section 4 contains more details ! about XTOL. ! ! GTOL is a non-negative input variable. Termination occurs when ! the cosine of the angle between FVEC and any column of the ! Jacobian is at most GTOL in absolute value. Therefore, GTOL ! measures the orthogonality desired between the function vector ! and the columns of the Jacobian. Section 4 contains more ! details about GTOL. ! ! MAXFEV is a positive integer input variable. Termination occurs ! when the number of calls to FCN to evaluate the functions ! has reached MAXFEV. ! ! EPSFCN is an input variable used in determining a suitable step ! for the forward-difference approximation. This approximation ! assumes that the relative errors in the functions are of the ! order of EPSFCN. If EPSFCN is less than the machine preci- ! sion, it is assumed that the relative errors in the functions ! are of the order of the machine precision. If IOPT=2 or 3, ! then EPSFCN can be ignored (treat it as a dummy argument). ! ! DIAG is an array of length N. If MODE = 1 (see below), DIAG is ! internally set. If MODE = 2, DIAG must contain positive ! entries that serve as implicit (multiplicative) scale factors ! for the variables. ! ! MODE is an integer input variable. If MODE = 1, the variables ! will be scaled internally. If MODE = 2, the scaling is speci- ! fied by the input DIAG. Other values of MODE are equivalent ! to MODE = 1. ! ! FACTOR is a positive input variable used in determining the ini- ! tial step bound. This bound is set to the product of FACTOR ! and the Euclidean norm of DIAG*X if nonzero, or else to FACTOR ! itself. In most cases FACTOR should lie in the interval ! (.1,100.). 100. is a generally recommended value. ! ! NPRINT is an integer input variable that enables controlled ! printing of iterates if it is positive. In this case, FCN is ! called with IFLAG = 0 at the beginning of the first iteration ! and every NPRINT iterations thereafter and immediately prior ! to return, with X and FVEC available for printing. Appropriate ! print statements must be added to FCN (see example) and ! FVEC should not be altered. If NPRINT is not positive, no ! special calls to FCN with IFLAG = 0 are made. ! ! INFO is an integer output variable. If the user has terminated ! execution, INFO is set to the (negative) value of IFLAG. See ! description of FCN and JAC. Otherwise, INFO is set as follows. ! ! INFO = 0 improper input parameters. ! ! INFO = 1 both actual and predicted relative reductions in the ! sum of squares are at most FTOL. ! ! INFO = 2 relative error between two consecutive iterates is ! at most XTOL. ! ! INFO = 3 conditions for INFO = 1 and INFO = 2 both hold. ! ! INFO = 4 the cosine of the angle between FVEC and any column ! of the Jacobian is at most GTOL in absolute value. ! ! INFO = 5 number of calls to FCN for function evaluation ! has reached MAXFEV. ! ! INFO = 6 FTOL is too small. No further reduction in the sum ! of squares is possible. ! ! INFO = 7 XTOL is too small. No further improvement in the ! approximate solution X is possible. ! ! INFO = 8 GTOL is too small. FVEC is orthogonal to the ! columns of the Jacobian to machine precision. ! ! Sections 4 and 5 contain more details about INFO. ! ! NFEV is an integer output variable set to the number of calls to ! FCN for function evaluation. ! ! NJEV is an integer output variable set to the number of ! evaluations of the full Jacobian. If IOPT=2, only one call to ! FCN is required for each evaluation of the full Jacobian. ! If IOPT=3, the M calls to FCN are required. ! If IOPT=1, then NJEV is set to zero. ! ! IPVT is an integer output array of length N. IPVT defines a ! permutation matrix P such that JAC*P = Q*R, where JAC is the ! final calculated Jacobian, Q is orthogonal (not stored), and R ! is upper triangular with diagonal elements of nonincreasing ! magnitude. Column J of P is column IPVT(J) of the identity ! matrix. ! ! QTF is an output array of length N which contains the first N ! elements of the vector (Q transpose)*FVEC. ! ! WA1, WA2, and WA3 are work arrays of length N. ! ! WA4 is a work array of length M. ! ! ! 4. Successful Completion. ! ! The accuracy of SNLS1 is controlled by the convergence parame- ! ters FTOL, XTOL, and GTOL. These parameters are used in tests ! which make three types of comparisons between the approximation ! X and a solution XSOL. SNLS1 terminates when any of the tests ! is satisfied. If any of the convergence parameters is less than ! the machine precision (as defined by the function R1MACH(4)), ! then SNLS1 only attempts to satisfy the test defined by the ! machine precision. Further progress is not usually possible. ! ! The tests assume that the functions are reasonably well behaved, ! and, if the Jacobian is supplied by the user, that the functions ! and the Jacobian are coded consistently. If these conditions ! are not satisfied, then SNLS1 may incorrectly indicate conver- ! gence. If the Jacobian is coded correctly or IOPT=1, ! then the validity of the answer can be checked, for example, by ! rerunning SNLS1 with tighter tolerances. ! ! First Convergence Test. If ENORM(Z) denotes the Euclidean norm ! of a vector Z, then this test attempts to guarantee that ! ! ENORM(FVEC) <= (1+FTOL)*ENORM(FVECS), ! ! where FVECS denotes the functions evaluated at XSOL. If this ! condition is satisfied with FTOL = 10**(-K), then the final ! residual norm ENORM(FVEC) has K significant decimal digits and ! INFO is set to 1 (or to 3 if the second test is also satis- ! fied). Unless high precision solutions are required, the ! recommended value for FTOL is the square root of the machine ! precision. ! ! Second Convergence Test. If D is the diagonal matrix whose ! entries are defined by the array DIAG, then this test attempts ! to guarantee that ! ! ENORM(D*(X-XSOL)) <= XTOL*ENORM(D*XSOL). ! ! If this condition is satisfied with XTOL = 10**(-K), then the ! larger components of D*X have K significant decimal digits and ! INFO is set to 2 (or to 3 if the first test is also satis- ! fied). There is a danger that the smaller components of D*X ! may have large relative errors, but if MODE = 1, then the ! accuracy of the components of X is usually related to their ! sensitivity. Unless high precision solutions are required, ! the recommended value for XTOL is the square root of the ! machine precision. ! ! Third Convergence Test. This test is satisfied when the cosine ! of the angle between FVEC and any column of the Jacobian at X ! is at most GTOL in absolute value. There is no clear rela- ! tionship between this test and the accuracy of SNLS1, and ! furthermore, the test is equally well satisfied at other crit- ! ical points, namely maximizers and saddle points. Therefore, ! termination caused by this test (INFO = 4) should be examined ! carefully. The recommended value for GTOL is zero. ! ! ! 5. Unsuccessful Completion. ! ! Unsuccessful termination of SNLS1 can be due to improper input ! parameters, arithmetic interrupts, or an excessive number of ! function evaluations. ! ! Improper Input Parameters. INFO is set to 0 if IOPT < 1 ! or IOPT > 3, or N <= 0, or M < N, or for IOPT=1 or 2 ! LDFJAC < M, or for IOPT=3 LDFJAC < N, or FTOL < 0.E0, ! or XTOL < 0.E0, or GTOL < 0.E0, or MAXFEV <= 0, or ! FACTOR <= 0.E0. ! ! Arithmetic Interrupts. If these interrupts occur in the FCN ! subroutine during an early stage of the computation, they may ! be caused by an unacceptable choice of X by SNLS1. In this ! case, it may be possible to remedy the situation by rerunning ! SNLS1 with a smaller value of FACTOR. ! ! Excessive Number of Function Evaluations. A reasonable value ! for MAXFEV is 100*(N+1) for IOPT=2 or 3 and 200*(N+1) for ! IOPT=1. If the number of calls to FCN reaches MAXFEV, then ! this indicates that the routine is converging very slowly ! as measured by the progress of FVEC, and INFO is set to 5. ! In this case, it may be helpful to restart SNLS1 with MODE ! set to 1. ! ! ! 6. Characteristics of the Algorithm. ! ! SNLS1 is a modification of the Levenberg-Marquardt algorithm. ! Two of its main characteristics involve the proper use of ! implicitly scaled variables (if MODE = 1) and an optimal choice ! for the correction. The use of implicitly scaled variables ! achieves scale invariance of SNLS1 and limits the size of the ! correction in any direction where the functions are changing ! rapidly. The optimal choice of the correction guarantees (under ! reasonable conditions) global convergence from starting points ! far from the solution and a fast rate of convergence for ! problems with small residuals. ! ! Timing. The time required by SNLS1 to solve a given problem ! depends on M and N, the behavior of the functions, the accu- ! racy requested, and the starting point. The number of arith- ! metic operations needed by SNLS1 is about N**3 to process each ! evaluation of the functions (call to FCN) and to process each ! evaluation of the Jacobian it takes M*N**2 for IOPT=2 (one ! call to FCN), M*N**2 for IOPT=1 (N calls to FCN) and ! 1.5*M*N**2 for IOPT=3 (M calls to FCN). Unless FCN ! can be evaluated quickly, the timing of SNLS1 will be ! strongly influenced by the time spent in FCN. ! ! Storage. SNLS1 requires (M*N + 2*M + 6*N) for IOPT=1 or 2 and ! (N**2 + 2*M + 6*N) for IOPT=3 single precision storage ! locations and N integer storage locations, in addition to ! the storage required by the program. There are no internally ! declared storage arrays. ! ! *Long Description: ! ! 7. Example. ! ! The problem is to determine the values of X(1), X(2), and X(3) ! which provide the best fit (in the least squares sense) of ! ! X(1) + U(I)/(V(I)*X(2) + W(I)*X(3)), I = 1, 15 ! ! to the data ! ! Y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, ! 0.37,0.58,0.73,0.96,1.34,2.10,4.39), ! ! where U(I) = I, V(I) = 16 - I, and W(I) = MIN(U(I),V(I)). The ! I-th component of FVEC is thus defined by ! ! Y(I) - (X(1) + U(I)/(V(I)*X(2) + W(I)*X(3))). ! ! ********** ! ! PROGRAM TEST ! C ! C Driver for SNLS1 example. ! C ! INTEGER J,IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV, ! * NWRITE ! INTEGER IPVT(3) ! REAL FTOL,XTOL,GTOL,FACTOR,FNORM,EPSFCN ! REAL X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3), ! * WA1(3),WA2(3),WA3(3),WA4(15) ! REAL ENORM,R1MACH ! EXTERNAL FCN ! DATA NWRITE /6/ ! C ! IOPT = 1 ! M = 15 ! N = 3 ! C ! C The following starting values provide a rough fit. ! C ! X(1) = 1.E0 ! X(2) = 1.E0 ! X(3) = 1.E0 ! C ! LDFJAC = 15 ! C ! C Set FTOL and XTOL to the square root of the machine precision ! C and GTOL to zero. Unless high precision solutions are ! C required, these are the recommended settings. ! C ! FTOL = SQRT(R1MACH(4)) ! XTOL = SQRT(R1MACH(4)) ! GTOL = 0.E0 ! C ! MAXFEV = 400 ! EPSFCN = 0.0 ! MODE = 1 ! FACTOR = 1.E2 ! NPRINT = 0 ! C ! call SNLS1(FCN,IOPT,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL, ! * GTOL,MAXFEV,EPSFCN,DIAG,MODE,FACTOR,NPRINT, ! * INFO,NFEV,NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) ! FNORM = ENORM(M,FVEC) ! WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) ! STOP ! 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // ! * 5X,' NUMBER OF FUNCTION EVALUATIONS',I10 // ! * 5X,' NUMBER OF JACOBIAN EVALUATIONS',I10 // ! * 5X,' EXIT PARAMETER',16X,I10 // ! * 5X,' FINAL APPROXIMATE SOLUTION' // 5X,3E15.7) ! END ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,DUM,IDUM) ! C This is the form of the FCN routine if IOPT=1, ! C that is, if the user does not calculate the Jacobian. ! INTEGER M,N,IFLAG ! REAL X(N),FVEC(M) ! INTEGER I ! REAL TMP1,TMP2,TMP3,TMP4 ! REAL Y(15) ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! END ! ! ! Results obtained with different compilers or machines ! may be slightly different. ! ! FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 ! ! NUMBER OF FUNCTION EVALUATIONS 25 ! ! NUMBER OF JACOBIAN EVALUATIONS 0 ! ! EXIT PARAMETER 1 ! ! FINAL APPROXIMATE SOLUTION ! ! 0.8241058E-01 0.1133037E+01 0.2343695E+01 ! ! ! For IOPT=2, FCN would be modified as follows to also ! calculate the full Jacobian when IFLAG=2. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! C ! C This is the form of the FCN routine if IOPT=2, ! C that is, if the user calculates the full Jacobian. ! C ! INTEGER LDFJAC,M,N,IFLAG ! REAL X(N),FVEC(M) ! REAL FJAC(LDFJAC,N) ! INTEGER I ! REAL TMP1,TMP2,TMP3,TMP4 ! REAL Y(15) ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! if ( IFLAG /= 1) go to 20 ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! C ! C Below, calculate the full Jacobian. ! C ! 20 CONTINUE ! C ! DO 30 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 ! FJAC(I,1) = -1.E0 ! FJAC(I,2) = TMP1*TMP2/TMP4 ! FJAC(I,3) = TMP1*TMP3/TMP4 ! 30 CONTINUE ! return ! END ! ! ! For IOPT = 3, FJAC would be dimensioned as FJAC(3,3), ! LDFJAC would be set to 3, and FCN would be written as ! follows to calculate a row of the Jacobian when IFLAG=3. ! ! SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) ! C This is the form of the FCN routine if IOPT=3, ! C that is, if the user calculates the Jacobian row by row. ! INTEGER M,N,IFLAG ! REAL X(N),FVEC(M) ! REAL FJAC(N) ! INTEGER I ! REAL TMP1,TMP2,TMP3,TMP4 ! REAL Y(15) ! DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), ! * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) ! * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, ! * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! if ( IFLAG /= 1) go to 20 ! DO 10 I = 1, M ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) ! 10 CONTINUE ! return ! C ! C Below, calculate the LDFJAC-th row of the Jacobian. ! C ! 20 CONTINUE ! ! I = LDFJAC ! TMP1 = I ! TMP2 = 16 - I ! TMP3 = TMP1 ! if (I > 8) TMP3 = TMP2 ! TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 ! FJAC(1) = -1.E0 ! FJAC(2) = TMP1*TMP2/TMP4 ! FJAC(3) = TMP1*TMP3/TMP4 ! return ! END ! !***REFERENCES Jorge J. More, The Levenberg-Marquardt algorithm: ! implementation and theory. In Numerical Analysis ! Proceedings (Dundee, June 28 - July 1, 1977, G. A. ! Watson, Editor), Lecture Notes in Mathematics 630, ! Springer-Verlag, 1978. !***ROUTINES CALLED CHKDER, ENORM, FDJAC3, LMPAR, QRFAC, R1MACH, ! RWUPDT, XERMSG !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNLS1 INTEGER IOPT,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV INTEGER IJUNK,NROW,IPVT(*) REAL FTOL,XTOL,GTOL,FACTOR,EPSFCN REAL X(*),FVEC(*),FJAC(LDFJAC,*),DIAG(*),QTF(*),WA1(*),WA2(*), & WA3(*),WA4(*) LOGICAL SING EXTERNAL FCN INTEGER I,IFLAG,ITER,J,L,MODECH REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR, & PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1, & TEMP2,XNORM,ZERO REAL R1MACH,ENORM,ERR,CHKLIM CHARACTER*8 XERN1 CHARACTER*16 XERN3 ! SAVE CHKLIM, ONE, P1, P5, P25, P75, P0001, ZERO DATA CHKLIM/.1E0/ DATA ONE,P1,P5,P25,P75,P0001,ZERO & /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/ ! !***FIRST EXECUTABLE STATEMENT SNLS1 EPSMCH = R1MACH(4) ! INFO = 0 IFLAG = 0 NFEV = 0 NJEV = 0 ! ! CHECK THE INPUT PARAMETERS FOR ERRORS. ! if (IOPT < 1 .OR. IOPT > 3 .OR. N <= 0 .OR. & M < N .OR. LDFJAC < N .OR. FTOL < ZERO & .OR. XTOL < ZERO .OR. GTOL < ZERO & .OR. MAXFEV <= 0 .OR. FACTOR <= ZERO) go to 300 if (IOPT < 3 .AND. LDFJAC < M) go to 300 if (MODE /= 2) go to 20 DO 10 J = 1, N if (DIAG(J) <= ZERO) go to 300 10 CONTINUE 20 CONTINUE ! ! EVALUATE THE FUNCTION AT THE STARTING POINT ! AND CALCULATE ITS NORM. ! IFLAG = 1 IJUNK = 1 call FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) NFEV = 1 if (IFLAG < 0) go to 300 FNORM = ENORM(M,FVEC) ! ! INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. ! PAR = ZERO ITER = 1 ! ! BEGINNING OF THE OUTER LOOP. ! 30 CONTINUE ! ! if REQUESTED, call FCN TO ENABLE PRINTING OF ITERATES. ! if (NPRINT <= 0) go to 40 IFLAG = 0 if (MOD(ITER-1,NPRINT) == 0) & call FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) if (IFLAG < 0) go to 300 40 CONTINUE ! ! CALCULATE THE JACOBIAN MATRIX. ! if (IOPT == 3) go to 475 ! ! STORE THE FULL JACOBIAN USING M*N STORAGE ! if (IOPT == 1) go to 410 ! ! THE USER SUPPLIES THE JACOBIAN ! IFLAG = 2 call FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) NJEV = NJEV + 1 ! ! ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN ! if (ITER <= 1) THEN if (IFLAG < 0) go to 300 ! ! GET THE INCREMENTED X-VALUES INTO WA1(*). ! MODECH = 1 call CHKDER(M,N,X,FVEC,FJAC,LDFJAC,WA1,WA4,MODECH,ERR) ! ! EVALUATE FUNCTION AT INCREMENTED VALUE AND PUT IN WA4(*). ! IFLAG = 1 call FCN(IFLAG,M,N,WA1,WA4,FJAC,LDFJAC) NFEV = NFEV + 1 if ( IFLAG < 0) go to 300 DO 350 I = 1, M MODECH = 2 call CHKDER(1,N,X,FVEC(I),FJAC(I,1),LDFJAC,WA1, & WA4(I),MODECH,ERR) if (ERR < CHKLIM) THEN WRITE (XERN1, '(I8)') I WRITE (XERN3, '(1PE15.6)') ERR call XERMSG ('SLATEC', 'SNLS1', 'DERIVATIVE OF ' // & 'FUNCTION ' // XERN1 // ' MAY BE WRONG, ERR = ' // & XERN3 // ' TOO CLOSE TO 0.', 7, 0) ENDIF 350 CONTINUE ENDIF ! go to 420 ! ! THE CODE APPROXIMATES THE JACOBIAN ! 410 IFLAG = 1 call FDJAC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) NFEV = NFEV + N 420 if (IFLAG < 0) go to 300 ! ! COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. ! call QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) ! ! FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN ! QTF. ! DO 430 I = 1, M WA4(I) = FVEC(I) 430 CONTINUE DO 470 J = 1, N if (FJAC(J,J) == ZERO) go to 460 SUM = ZERO DO 440 I = J, M SUM = SUM + FJAC(I,J)*WA4(I) 440 CONTINUE TEMP = -SUM/FJAC(J,J) DO 450 I = J, M WA4(I) = WA4(I) + FJAC(I,J)*TEMP 450 CONTINUE 460 CONTINUE FJAC(J,J) = WA1(J) QTF(J) = WA4(J) 470 CONTINUE go to 560 ! ! ACCUMULATE THE JACOBIAN BY ROWS IN ORDER TO SAVE STORAGE. ! COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX ! CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY ! FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST ! N COMPONENTS IN QTF. ! 475 DO 490 J = 1, N QTF(J) = ZERO DO 480 I = 1, N FJAC(I,J) = ZERO 480 CONTINUE 490 CONTINUE DO 500 I = 1, M NROW = I IFLAG = 3 call FCN(IFLAG,M,N,X,FVEC,WA3,NROW) if (IFLAG < 0) go to 300 ! ! ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN. ! if ( ITER > 1) go to 498 ! ! GET THE INCREMENTED X-VALUES INTO WA1(*). ! MODECH = 1 call CHKDER(M,N,X,FVEC,FJAC,LDFJAC,WA1,WA4,MODECH,ERR) ! ! EVALUATE AT INCREMENTED VALUES, if NOT ALREADY EVALUATED. ! if ( I /= 1) go to 495 ! ! EVALUATE FUNCTION AT INCREMENTED VALUE AND PUT INTO WA4(*). ! IFLAG = 1 call FCN(IFLAG,M,N,WA1,WA4,FJAC,NROW) NFEV = NFEV + 1 if ( IFLAG < 0) go to 300 495 CONTINUE MODECH = 2 call CHKDER(1,N,X,FVEC(I),WA3,1,WA1,WA4(I),MODECH,ERR) if (ERR < CHKLIM) THEN WRITE (XERN1, '(I8)') I WRITE (XERN3, '(1PE15.6)') ERR call XERMSG ('SLATEC', 'SNLS1', 'DERIVATIVE OF FUNCTION ' & // XERN1 // ' MAY BE WRONG, ERR = ' // XERN3 // & ' TOO CLOSE TO 0.', 7, 0) ENDIF 498 CONTINUE ! TEMP = FVEC(I) call RWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2) 500 CONTINUE NJEV = NJEV + 1 ! ! if THE JACOBIAN IS RANK DEFICIENT, call QRFAC TO ! REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF. ! SING = .FALSE. DO 510 J = 1, N if (FJAC(J,J) == ZERO) SING = .TRUE. IPVT(J) = J WA2(J) = ENORM(J,FJAC(1,J)) 510 CONTINUE if (.NOT.SING) go to 560 call QRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) DO 550 J = 1, N if (FJAC(J,J) == ZERO) go to 540 SUM = ZERO DO 520 I = J, N SUM = SUM + FJAC(I,J)*QTF(I) 520 CONTINUE TEMP = -SUM/FJAC(J,J) DO 530 I = J, N QTF(I) = QTF(I) + FJAC(I,J)*TEMP 530 CONTINUE 540 CONTINUE FJAC(J,J) = WA1(J) 550 CONTINUE 560 CONTINUE ! ! ON THE FIRST ITERATION AND if MODE IS 1, SCALE ACCORDING ! TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. ! if (ITER /= 1) go to 80 if (MODE == 2) go to 60 DO 50 J = 1, N DIAG(J) = WA2(J) if (WA2(J) == ZERO) DIAG(J) = ONE 50 CONTINUE 60 CONTINUE ! ! ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X ! AND INITIALIZE THE STEP BOUND DELTA. ! DO 70 J = 1, N WA3(J) = DIAG(J)*X(J) 70 CONTINUE XNORM = ENORM(N,WA3) DELTA = FACTOR*XNORM if (DELTA == ZERO) DELTA = FACTOR 80 CONTINUE ! ! COMPUTE THE NORM OF THE SCALED GRADIENT. ! GNORM = ZERO if (FNORM == ZERO) go to 170 DO 160 J = 1, N L = IPVT(J) if (WA2(L) == ZERO) go to 150 SUM = ZERO DO 140 I = 1, J SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) 140 CONTINUE GNORM = MAX(GNORM,ABS(SUM/WA2(L))) 150 CONTINUE 160 CONTINUE 170 CONTINUE ! ! TEST FOR CONVERGENCE OF THE GRADIENT NORM. ! if (GNORM <= GTOL) INFO = 4 if (INFO /= 0) go to 300 ! ! RESCALE if NECESSARY. ! if (MODE == 2) go to 190 DO 180 J = 1, N DIAG(J) = MAX(DIAG(J),WA2(J)) 180 CONTINUE 190 CONTINUE ! ! BEGINNING OF THE INNER LOOP. ! 200 CONTINUE ! ! DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. ! call LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, & WA3,WA4) ! ! STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. ! 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) ! ! ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. ! if (ITER == 1) DELTA = MIN(DELTA,PNORM) ! ! EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. ! IFLAG = 1 call FCN(IFLAG,M,N,WA2,WA4,FJAC,IJUNK) NFEV = NFEV + 1 if (IFLAG < 0) go to 300 FNORM1 = ENORM(M,WA4) ! ! COMPUTE THE SCALED ACTUAL REDUCTION. ! ACTRED = -ONE if (P1*FNORM1 < FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 ! ! COMPUTE THE SCALED PREDICTED REDUCTION AND ! THE SCALED DIRECTIONAL DERIVATIVE. ! DO 230 J = 1, N WA3(J) = ZERO 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) ! ! COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED ! REDUCTION. ! RATIO = ZERO if (PRERED /= ZERO) RATIO = ACTRED/PRERED ! ! UPDATE THE STEP BOUND. ! if (RATIO > P25) go to 240 if (ACTRED >= ZERO) TEMP = P5 if (ACTRED < ZERO) & TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) if (P1*FNORM1 >= FNORM .OR. TEMP < P1) TEMP = P1 DELTA = TEMP*MIN(DELTA,PNORM/P1) PAR = PAR/TEMP go to 260 240 CONTINUE if (PAR /= ZERO .AND. RATIO < P75) go to 250 DELTA = PNORM/P5 PAR = P5*PAR 250 CONTINUE 260 CONTINUE ! ! TEST FOR SUCCESSFUL ITERATION. ! if (RATIO < P0001) go to 290 ! ! SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. ! 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 ! ! TESTS FOR CONVERGENCE. ! if (ABS(ACTRED) <= FTOL .AND. PRERED <= FTOL & .AND. P5*RATIO <= ONE) INFO = 1 if (DELTA <= XTOL*XNORM) INFO = 2 if (ABS(ACTRED) <= FTOL .AND. PRERED <= FTOL & .AND. P5*RATIO <= ONE .AND. INFO == 2) INFO = 3 if (INFO /= 0) go to 300 ! ! TESTS FOR TERMINATION AND STRINGENT TOLERANCES. ! if (NFEV >= MAXFEV) INFO = 5 if (ABS(ACTRED) <= EPSMCH .AND. PRERED <= EPSMCH & .AND. P5*RATIO <= ONE) INFO = 6 if (DELTA <= EPSMCH*XNORM) INFO = 7 if (GNORM <= EPSMCH) INFO = 8 if (INFO /= 0) go to 300 ! ! END OF THE INNER LOOP. REPEAT if ITERATION UNSUCCESSFUL. ! if (RATIO < P0001) go to 200 ! ! END OF THE OUTER LOOP. ! go to 30 300 CONTINUE ! ! TERMINATION, EITHER NORMAL OR USER IMPOSED. ! if (IFLAG < 0) INFO = IFLAG IFLAG = 0 if (NPRINT > 0) call FCN(IFLAG,M,N,X,FVEC,FJAC,IJUNK) if (INFO < 0) call XERMSG ('SLATEC', 'SNLS1', & 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) if (INFO == 0) call XERMSG ('SLATEC', 'SNLS1', & 'INVALID INPUT PARAMETER.', 2, 1) if (INFO == 4) call XERMSG ('SLATEC', 'SNLS1', & 'THIRD CONVERGENCE CONDITION, CHECK RESULTS BEFORE ACCEPTING.', & 1, 1) if (INFO == 5) call XERMSG ('SLATEC', 'SNLS1', & 'TOO MANY FUNCTION EVALUATIONS.', 9, 1) if (INFO >= 6) call XERMSG ('SLATEC', 'SNLS1', & 'TOLERANCES TOO SMALL, NO FURTHER IMPROVEMENT POSSIBLE.', 3, 1) return ! ! LAST CARD OF SUBROUTINE SNLS1. ! end FUNCTION SNRM2 (N, SX, INCX) ! !! SNRM2 computes the Euclidean length (L2 norm) of a vector. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A3B !***TYPE SINGLE PRECISION (SNRM2-S, DNRM2-D, SCNRM2-C) !***KEYWORDS BLAS, EUCLIDEAN LENGTH, EUCLIDEAN NORM, L2, ! LINEAR ALGEBRA, UNITARY, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! ! --Output-- ! SNRM2 single precision result (zero if N <= 0) ! ! Euclidean norm of the N-vector stored in SX with storage ! increment INCX . ! If N <= 0, return with result = 0. ! If N >= 1, then INCX must be >= 1 ! ! Four Phase Method using two built-in constants that are ! hopefully applicable to all machines. ! CUTLO = maximum of SQRT(U/EPS) over all known machines. ! CUTHI = minimum of SQRT(V) over all known machines. ! where ! EPS = smallest no. such that EPS + 1. > 1. ! U = smallest positive no. (underflow limit) ! V = largest no. (overflow limit) ! ! Brief Outline of Algorithm. ! ! Phase 1 scans zero components. ! Move to phase 2 when a component is nonzero and <= CUTLO ! Move to phase 3 when a component is > CUTLO ! Move to phase 4 when a component is >= CUTHI/M ! where M = N for X() real and M = 2*N for complex. ! ! Values for CUTLO and CUTHI. ! From the environmental parameters listed in the IMSL converter ! document the limiting values are as follows: ! CUTLO, S.P. U/EPS = 2**(-102) for Honeywell. Close seconds are ! Univac and DEC at 2**(-103) ! Thus CUTLO = 2**(-51) = 4.44089E-16 ! CUTHI, S.P. V = 2**127 for Univac, Honeywell, and DEC. ! Thus CUTHI = 2**(63.5) = 1.30438E19 ! CUTLO, D.P. U/EPS = 2**(-67) for Honeywell and DEC. ! Thus CUTLO = 2**(-33.5) = 8.23181D-11 ! CUTHI, D.P. same as S.P. CUTHI = 1.30438D19 ! DATA CUTLO, CUTHI /8.232D-11, 1.304D19/ ! DATA CUTLO, CUTHI /4.441E-16, 1.304E19/ ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNRM2 real SNRM2 INTEGER NEXT REAL SX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE SAVE CUTLO, CUTHI, ZERO, ONE DATA ZERO, ONE /0.0E0, 1.0E0/ ! DATA CUTLO, CUTHI /4.441E-16, 1.304E19/ !***FIRST EXECUTABLE STATEMENT SNRM2 if (N > 0) go to 10 SNRM2 = ZERO go to 300 ! 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX ! ! BEGIN MAIN LOOP ! I = 1 20 go to NEXT,(30, 50, 70, 110) 30 if (ABS(SX(I)) > CUTLO) go to 85 ASSIGN 50 TO NEXT XMAX = ZERO ! ! PHASE 1. SUM IS ZERO ! 50 if (SX(I) == ZERO) go to 200 if (ABS(SX(I)) > CUTLO) go to 85 ! ! PREPARE FOR PHASE 2. ! ASSIGN 70 TO NEXT go to 105 ! ! PREPARE FOR PHASE 4. ! 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / SX(I)) / SX(I) 105 XMAX = ABS(SX(I)) go to 115 ! ! PHASE 2. SUM IS SMALL. ! SCALE TO AVOID DESTRUCTIVE UNDERFLOW. ! 70 if (ABS(SX(I)) > CUTLO) go to 75 ! ! COMMON CODE FOR PHASES 2 AND 4. ! IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. ! 110 if (ABS(SX(I)) <= XMAX) go to 115 SUM = ONE + SUM * (XMAX / SX(I))**2 XMAX = ABS(SX(I)) go to 200 ! 115 SUM = SUM + (SX(I)/XMAX)**2 go to 200 ! ! PREPARE FOR PHASE 3. ! 75 SUM = (SUM * XMAX) * XMAX ! ! FOR REAL OR D.P. SET HITEST = CUTHI/N ! FOR COMPLEX SET HITEST = CUTHI/(2*N) ! 85 HITEST = CUTHI / N ! ! PHASE 3. SUM IS MID-RANGE. NO SCALING. ! DO 95 J = I,NN,INCX if (ABS(SX(J)) >= HITEST) go to 100 95 SUM = SUM + SX(J)**2 SNRM2 = SQRT( SUM ) go to 300 ! 200 CONTINUE I = I + INCX if (I <= NN) go to 20 ! ! END OF MAIN LOOP. ! ! COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. ! SNRM2 = XMAX * SQRT(SUM) 300 CONTINUE return end subroutine SNSQE (FCN, JAC, IOPT, N, X, FVEC, TOL, NPRINT, INFO, & WA, LWA) ! !! SNSQE is an easy-to-use version of SNSQ. ! !***PURPOSE An easy-to-use code to find a zero of a system of N ! nonlinear functions in N variables by a modification of ! the Powell hybrid method. !***LIBRARY SLATEC !***CATEGORY F2A !***TYPE SINGLE PRECISION (SNSQE-S, DNSQE-D) !***KEYWORDS EASY-TO-USE, NONLINEAR SQUARE SYSTEM, ! POWELL HYBRID METHOD, ZEROS !***AUTHOR Hiebert, K. L., (SNLA) !***DESCRIPTION ! ! 1. Purpose. ! ! ! The purpose of SNSQE is to find a zero of a system of N non- ! linear functions in N variables by a modification of the Powell ! hybrid method. This is done by using the more general nonlinear ! equation solver SNSQ. The user must provide a subroutine which ! calculates the functions. The user has the option of either to ! provide a subroutine which calculates the Jacobian or to let the ! code calculate it by a forward-difference approximation. This ! code is the combination of the MINPACK codes (Argonne) HYBRD1 ! and HYBRJ1. ! ! ! 2. Subroutine and Type Statements. ! ! SUBROUTINE SNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO, ! * WA,LWA) ! INTEGER IOPT,N,NPRINT,INFO,LWA ! REAL TOL ! REAL X(N),FVEC(N),WA(LWA) ! EXTERNAL FCN,JAC ! ! ! 3. Parameters. ! ! Parameters designated as input parameters must be specified on ! entry to SNSQE and are not changed on exit, while parameters ! designated as output parameters need not be specified on entry ! and are set to appropriate values on exit from SNSQE. ! ! FCN is the name of the user-supplied subroutine which calculates ! the functions. FCN must be declared in an EXTERNAL statement ! in the user calling program, and should be written as follows. ! ! SUBROUTINE FCN(N,X,FVEC,IFLAG) ! INTEGER N,IFLAG ! REAL X(N),FVEC(N) ! ---------- ! Calculate the functions at X and ! return this vector in FVEC. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by FCN unless the ! user wants to terminate execution of SNSQE. In this case, set ! IFLAG to a negative integer. ! ! JAC is the name of the user-supplied subroutine which calculates ! the Jacobian. If IOPT=1, then JAC must be declared in an ! EXTERNAL statement in the user calling program, and should be ! written as follows. ! ! SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) ! INTEGER N,LDFJAC,IFLAG ! REAL X(N),FVEC(N),FJAC(LDFJAC,N) ! ---------- ! Calculate the Jacobian at X and return this ! matrix in FJAC. FVEC contains the function ! values at X and should not be altered. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by JAC unless the ! user wants to terminate execution of SNSQE. In this case, set ! IFLAG to a negative integer. ! ! If IOPT=2, JAC can be ignored (treat it as a dummy argument). ! ! IOPT is an input variable which specifies how the Jacobian will ! be calculated. If IOPT=1, then the user must supply the ! Jacobian through the subroutine JAC. If IOPT=2, then the ! code will approximate the Jacobian by forward-differencing. ! ! N is a positive integer input variable set to the number of ! functions and variables. ! ! X is an array of length N. On input, X must contain an initial ! estimate of the solution vector. On output, X contains the ! final estimate of the solution vector. ! ! FVEC is an output array of length N which contains the functions ! evaluated at the output X. ! ! TOL is a non-negative input variable. Termination occurs when ! the algorithm estimates that the relative error between X and ! the solution is at most TOL. Section 4 contains more details ! about TOL. ! ! NPRINT is an integer input variable that enables controlled ! printing of iterates if it is positive. In this case, FCN is ! called with IFLAG = 0 at the beginning of the first iteration ! and every NPRINT iteration thereafter and immediately prior ! to return, with X and FVEC available for printing. Appropriate ! print statements must be added to FCN (see example). If NPRINT ! is not positive, no special calls of FCN with IFLAG = 0 are ! made. ! ! INFO is an integer output variable. If the user has terminated ! execution, INFO is set to the (negative) value of IFLAG. See ! description of FCN and JAC. Otherwise, INFO is set as follows. ! ! INFO = 0 improper input parameters. ! ! INFO = 1 algorithm estimates that the relative error between ! X and the solution is at most TOL. ! ! INFO = 2 number of calls to FCN has reached or exceeded ! 100*(N+1) for IOPT=1 or 200*(N+1) for IOPT=2. ! ! INFO = 3 TOL is too small. No further improvement in the ! approximate solution X is possible. ! ! INFO = 4 iteration is not making good progress. ! ! Sections 4 and 5 contain more details about INFO. ! ! WA is a work array of length LWA. ! ! LWA is a positive integer input variable not less than ! (3*N**2+13*N))/2. ! ! ! 4. Successful Completion. ! ! The accuracy of SNSQE is controlled by the convergence parame- ! ter TOL. This parameter is used in a test which makes a compar- ! ison between the approximation X and a solution XSOL. SNSQE ! terminates when the test is satisfied. If TOL is less than the ! machine precision (as defined by the function R1MACH(4)), then ! SNSQE attempts only to satisfy the test defined by the machine ! precision. Further progress is not usually possible. Unless ! high precision solutions are required, the recommended value ! for TOL is the square root of the machine precision. ! ! The test assumes that the functions are reasonably well behaved, ! and, if the Jacobian is supplied by the user, that the functions ! and the Jacobian coded consistently. If these conditions ! are not satisfied, SNSQE may incorrectly indicate convergence. ! The coding of the Jacobian can be checked by the subroutine ! CHKDER. If the Jacobian is coded correctly or IOPT=2, then ! the validity of the answer can be checked, for example, by ! rerunning SNSQE with a tighter tolerance. ! ! Convergence Test. If ENORM(Z) denotes the Euclidean norm of a ! vector Z, then this test attempts to guarantee that ! ! ENORM(X-XSOL) <= TOL*ENORM(XSOL). ! ! If this condition is satisfied with TOL = 10**(-K), then the ! larger components of X have K significant decimal digits and ! INFO is set to 1. There is a danger that the smaller compo- ! nents of X may have large relative errors, but the fast rate ! of convergence of SNSQE usually avoids this possibility. ! ! ! 5. Unsuccessful Completion. ! ! Unsuccessful termination of SNSQE can be due to improper input ! parameters, arithmetic interrupts, an excessive number of func- ! tion evaluations, errors in the functions, or lack of good prog- ! ress. ! ! Improper Input Parameters. INFO is set to 0 if IOPT < 1, or ! IOPT > 2, or N <= 0, or TOL < 0.E0, or ! LWA < (3*N**2+13*N)/2. ! ! Arithmetic Interrupts. If these interrupts occur in the FCN ! subroutine during an early stage of the computation, they may ! be caused by an unacceptable choice of X by SNSQE. In this ! case, it may be possible to remedy the situation by not evalu- ! ating the functions here, but instead setting the components ! of FVEC to numbers that exceed those in the initial FVEC. ! ! Excessive Number of Function Evaluations. If the number of ! calls to FCN reaches 100*(N+1) for IOPT=1 or 200*(N+1) for ! IOPT=2, then this indicates that the routine is converging ! very slowly as measured by the progress of FVEC, and INFO is ! set to 2. This situation should be unusual because, as ! indicated below, lack of good progress is usually diagnosed ! earlier by SNSQE, causing termination with INFO = 4. ! ! Errors in the Functions. When IOPT=2, the choice of step length ! in the forward-difference approximation to the Jacobian ! assumes that the relative errors in the functions are of the ! order of the machine precision. If this is not the case, ! SNSQE may fail (usually with INFO = 4). The user should ! then either use SNSQ and set the step length or use IOPT=1 ! and supply the Jacobian. ! ! Lack of Good Progress. SNSQE searches for a zero of the system ! by minimizing the sum of the squares of the functions. In so ! doing, it can become trapped in a region where the minimum ! does not correspond to a zero of the system and, in this situ- ! ation, the iteration eventually fails to make good progress. ! In particular, this will happen if the system does not have a ! zero. If the system has a zero, rerunning SNSQE from a dif- ! ferent starting point may be helpful. ! ! ! 6. Characteristics of the Algorithm. ! ! SNSQE is a modification of the Powell hybrid method. Two of ! its main characteristics involve the choice of the correction as ! a convex combination of the Newton and scaled gradient direc- ! tions, and the updating of the Jacobian by the rank-1 method of ! Broyden. The choice of the correction guarantees (under reason- ! able conditions) global convergence for starting points far from ! the solution and a fast rate of convergence. The Jacobian is ! calculated at the starting point by either the user-supplied ! subroutine or a forward-difference approximation, but it is not ! recalculated until the rank-1 method fails to produce satis- ! factory progress. ! ! Timing. The time required by SNSQE to solve a given problem ! depends on N, the behavior of the functions, the accuracy ! requested, and the starting point. The number of arithmetic ! operations needed by SNSQE is about 11.5*(N**2) to process ! each evaluation of the functions (call to FCN) and 1.3*(N**3) ! to process each evaluation of the Jacobian (call to JAC, ! if IOPT = 1). Unless FCN and JAC can be evaluated quickly, ! the timing of SNSQE will be strongly influenced by the time ! spent in FCN and JAC. ! ! Storage. SNSQE requires (3*N**2 + 17*N)/2 single precision ! storage locations, in addition to the storage required by the ! program. There are no internally declared storage arrays. ! ! ! 7. Example. ! ! The problem is to determine the values of X(1), X(2), ..., X(9), ! which solve the system of tridiagonal equations ! ! (3-2*X(1))*X(1) -2*X(2) = -1 ! -X(I-1) + (3-2*X(I))*X(I) -2*X(I+1) = -1, I=2-8 ! -X(8) + (3-2*X(9))*X(9) = -1 ! ! ********** ! ! PROGRAM TEST ! C ! C Driver for SNSQE example. ! C ! INTEGER J,N,IOPT,NPRINT,INFO,LWA,NWRITE ! REAL TOL,FNORM ! REAL X(9),FVEC(9),WA(180) ! REAL ENORM,R1MACH ! EXTERNAL FCN ! DATA NWRITE /6/ ! C ! IOPT = 2 ! N = 9 ! C ! C The following starting values provide a rough solution. ! C ! DO 10 J = 1, 9 ! X(J) = -1.E0 ! 10 CONTINUE ! ! LWA = 180 ! NPRINT = 0 ! C ! C Set TOL to the square root of the machine precision. ! C Unless high precision solutions are required, ! C this is the recommended setting. ! C ! TOL = SQRT(R1MACH(4)) ! C ! call SNSQE(FCN,JAC,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ! FNORM = ENORM(N,FVEC) ! WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) ! STOP ! 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // ! * 5X,' EXIT PARAMETER',16X,I10 // ! * 5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7)) ! END ! SUBROUTINE FCN(N,X,FVEC,IFLAG) ! INTEGER N,IFLAG ! REAL X(N),FVEC(N) ! INTEGER K ! REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO ! DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ ! C ! DO 10 K = 1, N ! TEMP = (THREE - TWO*X(K))*X(K) ! TEMP1 = ZERO ! if (K /= 1) TEMP1 = X(K-1) ! TEMP2 = ZERO ! if (K /= N) TEMP2 = X(K+1) ! FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE ! 10 CONTINUE ! return ! END ! ! Results obtained with different compilers or machines ! may be slightly different. ! ! FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 ! ! EXIT PARAMETER 1 ! ! FINAL APPROXIMATE SOLUTION ! ! -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 ! -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 ! -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 ! !***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- ! tions. In Numerical Methods for Nonlinear Algebraic ! Equations, P. Rabinowitz, Editor. Gordon and Breach, ! 1988. !***ROUTINES CALLED SNSQ, XERMSG !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNSQE INTEGER IOPT,N,NPRINT,INFO,LWA REAL TOL REAL X(*),FVEC(*),WA(LWA) EXTERNAL FCN, JAC INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NJEV REAL EPSFCN,FACTOR,ONE,XTOL,ZERO SAVE FACTOR, ONE, ZERO DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ !***FIRST EXECUTABLE STATEMENT SNSQE INFO = 0 ! ! CHECK THE INPUT PARAMETERS FOR ERRORS. ! if (IOPT < 1 .OR. IOPT > 2 .OR. N <= 0 & .OR. TOL < ZERO .OR. LWA < (3*N**2 +13*N)/2) & go to 20 ! ! call SNSQ. ! MAXFEV = 100*(N + 1) if (IOPT == 2) MAXFEV = 2*MAXFEV XTOL = TOL ML = N - 1 MU = N - 1 EPSFCN = ZERO MODE = 2 DO 10 J = 1, N WA(J) = ONE 10 CONTINUE LR = (N*(N + 1))/2 INDEX=6*N+LR call SNSQ(FCN,JAC,IOPT,N,X,FVEC,WA(INDEX+1),N,XTOL,MAXFEV,ML,MU, & EPSFCN,WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, & 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 == 5) INFO = 4 20 CONTINUE if (INFO == 0) call XERMSG ('SLATEC', 'SNSQE', & 'INVALID INPUT PARAMETER.', 2, 1) return ! ! LAST CARD OF SUBROUTINE SNSQE. ! end subroutine SNSQ (FCN, JAC, IOPT, N, X, FVEC, FJAC, LDFJAC, XTOL, & MAXFEV, ML, MU, EPSFCN, DIAG, MODE, FACTOR, NPRINT, INFO, NFEV, & NJEV, R, LR, QTF, WA1, WA2, WA3, WA4) ! !! SNSQ finds a zero of a system of a N nonlinear functions in N variables ... ! by a modification of the Powell hybrid method. ! !***LIBRARY SLATEC !***CATEGORY F2A !***TYPE SINGLE PRECISION (SNSQ-S, DNSQ-D) !***KEYWORDS NONLINEAR SQUARE SYSTEM, POWELL HYBRID METHOD, ZEROS !***AUTHOR Hiebert, K. L., (SNLA) !***DESCRIPTION ! ! 1. Purpose. ! ! The purpose of SNSQ is to find a zero of a system of N non- ! linear functions in N variables by a modification of the Powell ! hybrid method. The user must provide a subroutine which calcu- ! lates the functions. The user has the option of either to ! provide a subroutine which calculates the Jacobian or to let the ! code calculate it by a forward-difference approximation. ! This code is the combination of the MINPACK codes (Argonne) ! HYBRD and HYBRDJ. ! ! ! 2. Subroutine and Type Statements. ! ! SUBROUTINE SNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV, ! * ML,MU,EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, ! * NJEV,R,LR,QTF,WA1,WA2,WA3,WA4) ! INTEGER IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,NJEV,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,JAC ! ! ! 3. Parameters. ! ! Parameters designated as input parameters must be specified on ! entry to SNSQ and are not changed on exit, while parameters ! designated as output parameters need not be specified on entry ! and are set to appropriate values on exit from SNSQ. ! ! FCN is the name of the user-supplied subroutine which calculates ! the functions. FCN must be declared in an EXTERNAL statement ! in the user calling program, and should be written as follows. ! ! SUBROUTINE FCN(N,X,FVEC,IFLAG) ! INTEGER N,IFLAG ! REAL X(N),FVEC(N) ! ---------- ! Calculate the functions at X and ! return this vector in FVEC. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by FCN unless the ! user wants to terminate execution of SNSQ. In this case, set ! IFLAG to a negative integer. ! ! JAC is the name of the user-supplied subroutine which calculates ! the Jacobian. If IOPT=1, then JAC must be declared in an ! EXTERNAL statement in the user calling program, and should be ! written as follows. ! ! SUBROUTINE JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) ! INTEGER N,LDFJAC,IFLAG ! REAL X(N),FVEC(N),FJAC(LDFJAC,N) ! ---------- ! Calculate the Jacobian at X and return this ! matrix in FJAC. FVEC contains the function ! values at X and should not be altered. ! ---------- ! return ! END ! ! The value of IFLAG should not be changed by JAC unless the ! user wants to terminate execution of SNSQ. In this case, set ! IFLAG to a negative integer. ! ! If IOPT=2, JAC can be ignored (treat it as a dummy argument). ! ! IOPT is an input variable which specifies how the Jacobian will ! be calculated. If IOPT=1, then the user must supply the ! Jacobian through the subroutine JAC. If IOPT=2, then the ! code will approximate the Jacobian by forward-differencing. ! ! N is a positive integer input variable set to the number of ! functions and variables. ! ! X is an array of length N. On input, X must contain an initial ! estimate of the solution vector. On output, X contains the ! final estimate of the solution vector. ! ! FVEC is an output array of length N which contains the functions ! evaluated at the output X. ! ! FJAC is an output N by N array which contains the orthogonal ! matrix Q produced by the QR factorization of the final approx- ! imate Jacobian. ! ! LDFJAC is a positive integer input variable not less than N ! which specifies the leading dimension of the array FJAC. ! ! XTOL is a non-negative input variable. Termination occurs when ! the relative error between two consecutive iterates is at most ! XTOL. Therefore, XTOL measures the relative error desired in ! the approximate solution. Section 4 contains more details ! about XTOL. ! ! MAXFEV is a positive integer input variable. Termination occurs ! when the number of calls to FCN is at least MAXFEV by the end ! of an iteration. ! ! ML is a non-negative integer input variable which specifies the ! number of subdiagonals within the band of the Jacobian matrix. ! If the Jacobian is not banded or IOPT=1, set ML to at ! least N - 1. ! ! MU is a non-negative integer input variable which specifies the ! number of superdiagonals within the band of the Jacobian ! matrix. If the Jacobian is not banded or IOPT=1, set MU to at ! least N - 1. ! ! EPSFCN is an input variable used in determining a suitable step ! for the forward-difference approximation. This approximation ! assumes that the relative errors in the functions are of the ! order of EPSFCN. If EPSFCN is less than the machine preci- ! sion, it is assumed that the relative errors in the functions ! are of the order of the machine precision. If IOPT=1, then ! EPSFCN can be ignored (treat it as a dummy argument). ! ! DIAG is an array of length N. If MODE = 1 (see below), DIAG is ! internally set. If MODE = 2, DIAG must contain positive ! entries that serve as implicit (multiplicative) scale factors ! for the variables. ! ! MODE is an integer input variable. If MODE = 1, the variables ! will be scaled internally. If MODE = 2, the scaling is speci- ! fied by the input DIAG. Other values of MODE are equivalent ! to MODE = 1. ! ! FACTOR is a positive input variable used in determining the ini- ! tial step bound. This bound is set to the product of FACTOR ! and the Euclidean norm of DIAG*X if nonzero, or else to FACTOR ! itself. In most cases FACTOR should lie in the interval ! (.1,100.). 100. is a generally recommended value. ! ! NPRINT is an integer input variable that enables controlled ! printing of iterates if it is positive. In this case, FCN is ! called with IFLAG = 0 at the beginning of the first iteration ! and every NPRINT iteration thereafter and immediately prior ! to return, with X and FVEC available for printing. Appropriate ! print statements must be added to FCN(see example). If NPRINT ! is not positive, no special calls of FCN with IFLAG = 0 are ! made. ! ! INFO is an integer output variable. If the user has terminated ! execution, INFO is set to the (negative) value of IFLAG. See ! description of FCN and JAC. Otherwise, INFO is set as follows. ! ! INFO = 0 improper input parameters. ! ! INFO = 1 relative error between two consecutive iterates is ! at most XTOL. ! ! INFO = 2 number of calls to FCN has reached or exceeded ! MAXFEV. ! ! INFO = 3 XTOL is too small. No further improvement in the ! approximate solution X is possible. ! ! INFO = 4 iteration is not making good progress, as measured ! by the improvement from the last five Jacobian eval- ! uations. ! ! INFO = 5 iteration is not making good progress, as measured ! by the improvement from the last ten iterations. ! ! Sections 4 and 5 contain more details about INFO. ! ! NFEV is an integer output variable set to the number of calls to ! FCN. ! ! NJEV is an integer output variable set to the number of calls to ! JAC. (If IOPT=2, then NJEV is set to zero.) ! ! R is an output array of length LR which contains the upper ! triangular matrix produced by the QR factorization of the ! final approximate Jacobian, stored rowwise. ! ! LR is a positive integer input variable not less than ! (N*(N+1))/2. ! ! QTF is an output array of length N which contains the vector ! (Q TRANSPOSE)*FVEC. ! ! WA1, WA2, WA3, and WA4 are work arrays of length N. ! ! ! 4. Successful Completion. ! ! The accuracy of SNSQ is controlled by the convergence parameter ! XTOL. This parameter is used in a test which makes a comparison ! between the approximation X and a solution XSOL. SNSQ termi- ! nates when the test is satisfied. If the convergence parameter ! is less than the machine precision (as defined by the function ! R1MACH(4)), then SNSQ only attempts to satisfy the test ! defined by the machine precision. Further progress is not ! usually possible. ! ! The test assumes that the functions are reasonably well behaved, ! and, if the Jacobian is supplied by the user, that the functions ! and the Jacobian are coded consistently. If these conditions ! are not satisfied, then SNSQ may incorrectly indicate conver- ! gence. The coding of the Jacobian can be checked by the ! subroutine CHKDER. If the Jacobian is coded correctly or IOPT=2, ! then the validity of the answer can be checked, for example, by ! rerunning SNSQ with a tighter tolerance. ! ! Convergence Test. If ENORM(Z) denotes the Euclidean norm of a ! vector Z and D is the diagonal matrix whose entries are ! defined by the array DIAG, then this test attempts to guaran- ! tee that ! ! ENORM(D*(X-XSOL)) <= XTOL*ENORM(D*XSOL). ! ! If this condition is satisfied with XTOL = 10**(-K), then the ! larger components of D*X have K significant decimal digits and ! INFO is set to 1. There is a danger that the smaller compo- ! nents of D*X may have large relative errors, but the fast rate ! of convergence of SNSQ usually avoids this possibility. ! Unless high precision solutions are required, the recommended ! value for XTOL is the square root of the machine precision. ! ! ! 5. Unsuccessful Completion. ! ! Unsuccessful termination of SNSQ can be due to improper input ! parameters, arithmetic interrupts, an excessive number of func- ! tion evaluations, or lack of good progress. ! ! Improper Input Parameters. INFO is set to 0 if IOPT < 1, ! or IOPT > 2, or N <= 0, or LDFJAC < N, or ! XTOL < 0.E0, or MAXFEV <= 0, or ML < 0, or MU < 0, ! or FACTOR <= 0.E0, or LR < (N*(N+1))/2. ! ! Arithmetic Interrupts. If these interrupts occur in the FCN ! subroutine during an early stage of the computation, they may ! be caused by an unacceptable choice of X by SNSQ. In this ! case, it may be possible to remedy the situation by rerunning ! SNSQ with a smaller value of FACTOR. ! ! Excessive Number of Function Evaluations. A reasonable value ! for MAXFEV is 100*(N+1) for IOPT=1 and 200*(N+1) for IOPT=2. ! If the number of calls to FCN reaches MAXFEV, then this ! indicates that the routine is converging very slowly as ! measured by the progress of FVEC, and INFO is set to 2. This ! situation should be unusual because, as indicated below, lack ! of good progress is usually diagnosed earlier by SNSQ, ! causing termination with INFO = 4 or INFO = 5. ! ! Lack of Good Progress. SNSQ searches for a zero of the system ! by minimizing the sum of the squares of the functions. In so ! doing, it can become trapped in a region where the minimum ! does not correspond to a zero of the system and, in this situ- ! ation, the iteration eventually fails to make good progress. ! In particular, this will happen if the system does not have a ! zero. If the system has a zero, rerunning SNSQ from a dif- ! ferent starting point may be helpful. ! ! ! 6. Characteristics of the Algorithm. ! ! SNSQ is a modification of the Powell hybrid method. Two of its ! main characteristics involve the choice of the correction as a ! convex combination of the Newton and scaled gradient directions, ! and the updating of the Jacobian by the rank-1 method of Broy- ! den. The choice of the correction guarantees (under reasonable ! conditions) global convergence for starting points far from the ! solution and a fast rate of convergence. The Jacobian is ! calculated at the starting point by either the user-supplied ! subroutine or a forward-difference approximation, but it is not ! recalculated until the rank-1 method fails to produce satis- ! factory progress. ! ! Timing. The time required by SNSQ to solve a given problem ! depends on N, the behavior of the functions, the accuracy ! requested, and the starting point. The number of arithmetic ! operations needed by SNSQ is about 11.5*(N**2) to process ! each evaluation of the functions (call to FCN) and 1.3*(N**3) ! to process each evaluation of the Jacobian (call to JAC, ! if IOPT = 1). Unless FCN and JAC can be evaluated quickly, ! the timing of SNSQ will be strongly influenced by the time ! spent in FCN and JAC. ! ! Storage. SNSQ requires (3*N**2 + 17*N)/2 single precision ! storage locations, in addition to the storage required by the ! program. There are no internally declared storage arrays. ! ! ! 7. Example. ! ! The problem is to determine the values of X(1), X(2), ..., X(9), ! which solve the system of tridiagonal equations ! ! (3-2*X(1))*X(1) -2*X(2) = -1 ! -X(I-1) + (3-2*X(I))*X(I) -2*X(I+1) = -1, I=2-8 ! -X(8) + (3-2*X(9))*X(9) = -1 ! C ********** ! ! PROGRAM TEST ! C ! C Driver for SNSQ example. ! C ! INTEGER J,IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR, ! * NWRITE ! REAL XTOL,EPSFCN,FACTOR,FNORM ! REAL X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9), ! * WA1(9),WA2(9),WA3(9),WA4(9) ! REAL ENORM,R1MACH ! EXTERNAL FCN ! DATA NWRITE /6/ ! C ! IOPT = 2 ! N = 9 ! C ! C The following starting values provide a rough solution. ! C ! DO 10 J = 1, 9 ! X(J) = -1.E0 ! 10 CONTINUE ! C ! LDFJAC = 9 ! LR = 45 ! C ! C Set XTOL to the square root of the machine precision. ! C Unless high precision solutions are required, ! C this is the recommended setting. ! C ! XTOL = SQRT(R1MACH(4)) ! C ! MAXFEV = 2000 ! ML = 1 ! MU = 1 ! EPSFCN = 0.E0 ! MODE = 2 ! DO 20 J = 1, 9 ! DIAG(J) = 1.E0 ! 20 CONTINUE ! FACTOR = 1.E2 ! NPRINT = 0 ! C ! call SNSQ(FCN,JAC,IOPT,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,ML,MU, ! * EPSFCN,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, ! * R,LR,QTF,WA1,WA2,WA3,WA4) ! FNORM = ENORM(N,FVEC) ! WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) ! STOP ! 1000 FORMAT (5X,' FINAL L2 NORM OF THE RESIDUALS',E15.7 // ! * 5X,' NUMBER OF FUNCTION EVALUATIONS',I10 // ! * 5X,' EXIT PARAMETER',16X,I10 // ! * 5X,' FINAL APPROXIMATE SOLUTION' // (5X,3E15.7)) ! END ! SUBROUTINE FCN(N,X,FVEC,IFLAG) ! INTEGER N,IFLAG ! REAL X(N),FVEC(N) ! INTEGER K ! REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO ! DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ ! C ! if (IFLAG /= 0) go to 5 ! C ! C Insert print statements here when NPRINT is positive. ! C ! return ! 5 CONTINUE ! DO 10 K = 1, N ! TEMP = (THREE - TWO*X(K))*X(K) ! TEMP1 = ZERO ! if (K /= 1) TEMP1 = X(K-1) ! TEMP2 = ZERO ! if (K /= N) TEMP2 = X(K+1) ! FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE ! 10 CONTINUE ! return ! END ! ! Results obtained with different compilers or machines ! may be slightly different. ! ! FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 ! ! NUMBER OF FUNCTION EVALUATIONS 14 ! ! EXIT PARAMETER 1 ! ! FINAL APPROXIMATE SOLUTION ! ! -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 ! -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 ! -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 ! !***REFERENCES M. J. D. Powell, A hybrid method for nonlinear equa- ! tions. In Numerical Methods for Nonlinear Algebraic ! Equations, P. Rabinowitz, Editor. Gordon and Breach, ! 1988. !***ROUTINES CALLED DOGLEG, ENORM, FDJAC1, QFORM, QRFAC, R1MACH, ! R1MPYQ, R1UPDT, XERMSG !***REVISION HISTORY (YYMMDD) ! 800301 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SNSQ INTEGER IOPT,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR,NJEV REAL XTOL,EPSFCN,FACTOR REAL X(*),FVEC(*),DIAG(*),FJAC(LDFJAC,*),R(LR),QTF(*),WA1(*), & WA2(*),WA3(*),WA4(*) EXTERNAL FCN INTEGER I,IFLAG,ITER,J,JM1,L,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 R1MACH,ENORM SAVE ONE, P1, P5, P001, P0001, ZERO DATA ONE,P1,P5,P001,P0001,ZERO & /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/ ! !***FIRST EXECUTABLE STATEMENT SNSQ EPSMCH = R1MACH(4) ! INFO = 0 IFLAG = 0 NFEV = 0 NJEV = 0 ! ! CHECK THE INPUT PARAMETERS FOR ERRORS. ! if (IOPT < 1 .OR. IOPT > 2 .OR. & N <= 0 .OR. XTOL < ZERO .OR. MAXFEV <= 0 & .OR. ML < 0 .OR. MU < 0 .OR. FACTOR <= ZERO & .OR. LDFJAC < N .OR. LR < (N*(N + 1))/2) go to 300 if (MODE /= 2) go to 20 DO 10 J = 1, N if (DIAG(J) <= ZERO) go to 300 10 CONTINUE 20 CONTINUE ! ! EVALUATE THE FUNCTION AT THE STARTING POINT ! AND CALCULATE ITS NORM. ! IFLAG = 1 call FCN(N,X,FVEC,IFLAG) NFEV = 1 if (IFLAG < 0) go to 300 FNORM = ENORM(N,FVEC) ! ! INITIALIZE ITERATION COUNTER AND MONITORS. ! ITER = 1 NCSUC = 0 NCFAIL = 0 NSLOW1 = 0 NSLOW2 = 0 ! ! BEGINNING OF THE OUTER LOOP. ! 30 CONTINUE JEVAL = .TRUE. ! ! CALCULATE THE JACOBIAN MATRIX. ! if (IOPT == 2) go to 31 ! ! USER SUPPLIES JACOBIAN ! call JAC(N,X,FVEC,FJAC,LDFJAC,IFLAG) NJEV = NJEV+1 go to 32 ! ! CODE APPROXIMATES THE JACOBIAN ! 31 IFLAG = 2 call FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1, & WA2) NFEV = NFEV + MIN(ML+MU+1,N) ! 32 if (IFLAG < 0) go to 300 ! ! COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. ! call QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) ! ! ON THE FIRST ITERATION AND if MODE IS 1, SCALE ACCORDING ! TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. ! if (ITER /= 1) go to 70 if (MODE == 2) go to 50 DO 40 J = 1, N DIAG(J) = WA2(J) if (WA2(J) == ZERO) DIAG(J) = ONE 40 CONTINUE 50 CONTINUE ! ! ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X ! AND INITIALIZE THE STEP BOUND DELTA. ! DO 60 J = 1, N WA3(J) = DIAG(J)*X(J) 60 CONTINUE XNORM = ENORM(N,WA3) DELTA = FACTOR*XNORM if (DELTA == ZERO) DELTA = FACTOR 70 CONTINUE ! ! FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. ! DO 80 I = 1, N QTF(I) = FVEC(I) 80 CONTINUE DO 120 J = 1, N if (FJAC(J,J) == 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 ! ! COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. ! SING = .FALSE. DO 150 J = 1, N L = J JM1 = J - 1 if (JM1 < 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) == ZERO) SING = .TRUE. 150 CONTINUE ! ! ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. ! call QFORM(N,N,FJAC,LDFJAC,WA1) ! ! RESCALE if NECESSARY. ! if (MODE == 2) go to 170 DO 160 J = 1, N DIAG(J) = MAX(DIAG(J),WA2(J)) 160 CONTINUE 170 CONTINUE ! ! BEGINNING OF THE INNER LOOP. ! 180 CONTINUE ! ! if REQUESTED, call FCN TO ENABLE PRINTING OF ITERATES. ! if (NPRINT <= 0) go to 190 IFLAG = 0 if (MOD(ITER-1,NPRINT) == 0) call FCN(N,X,FVEC,IFLAG) if (IFLAG < 0) go to 300 190 CONTINUE ! ! DETERMINE THE DIRECTION P. ! call DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) ! ! STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. ! 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) ! ! ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. ! if (ITER == 1) DELTA = MIN(DELTA,PNORM) ! ! EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. ! IFLAG = 1 call FCN(N,WA2,WA4,IFLAG) NFEV = NFEV + 1 if (IFLAG < 0) go to 300 FNORM1 = ENORM(N,WA4) ! ! COMPUTE THE SCALED ACTUAL REDUCTION. ! ACTRED = -ONE if (FNORM1 < FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 ! ! COMPUTE THE SCALED PREDICTED REDUCTION. ! 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 < FNORM) PRERED = ONE - (TEMP/FNORM)**2 ! ! COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED ! REDUCTION. ! RATIO = ZERO if (PRERED > ZERO) RATIO = ACTRED/PRERED ! ! UPDATE THE STEP BOUND. ! if (RATIO >= P1) go to 230 NCSUC = 0 NCFAIL = NCFAIL + 1 DELTA = P5*DELTA go to 240 230 CONTINUE NCFAIL = 0 NCSUC = NCSUC + 1 if (RATIO >= P5 .OR. NCSUC > 1) & DELTA = MAX(DELTA,PNORM/P5) if (ABS(RATIO-ONE) <= P1) DELTA = PNORM/P5 240 CONTINUE ! ! TEST FOR SUCCESSFUL ITERATION. ! if (RATIO < P0001) go to 260 ! ! SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. ! 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 ! ! DETERMINE THE PROGRESS OF THE ITERATION. ! NSLOW1 = NSLOW1 + 1 if (ACTRED >= P001) NSLOW1 = 0 if (JEVAL) NSLOW2 = NSLOW2 + 1 if (ACTRED >= P1) NSLOW2 = 0 ! ! TEST FOR CONVERGENCE. ! if (DELTA <= XTOL*XNORM .OR. FNORM == ZERO) INFO = 1 if (INFO /= 0) go to 300 ! ! TESTS FOR TERMINATION AND STRINGENT TOLERANCES. ! if (NFEV >= MAXFEV) INFO = 2 if (P1*MAX(P1*DELTA,PNORM) <= EPSMCH*XNORM) INFO = 3 if (NSLOW2 == 5) INFO = 4 if (NSLOW1 == 10) INFO = 5 if (INFO /= 0) go to 300 ! ! CRITERION FOR RECALCULATING JACOBIAN ! if (NCFAIL == 2) go to 290 ! ! CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN ! AND UPDATE QTF if NECESSARY. ! 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 >= P0001) QTF(J) = SUM 280 CONTINUE ! ! COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. ! 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) ! ! END OF THE INNER LOOP. ! JEVAL = .FALSE. go to 180 290 CONTINUE ! ! END OF THE OUTER LOOP. ! go to 30 300 CONTINUE ! ! TERMINATION, EITHER NORMAL OR USER IMPOSED. ! if (IFLAG < 0) INFO = IFLAG IFLAG = 0 if (NPRINT > 0) call FCN(N,X,FVEC,IFLAG) if (INFO < 0) call XERMSG ('SLATEC', 'SNSQ', & 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1) if (INFO == 0) call XERMSG ('SLATEC', 'SNSQ', & 'INVALID INPUT PARAMETER.', 2, 1) if (INFO == 2) call XERMSG ('SLATEC', 'SNSQ', & 'TOO MANY FUNCTION EVALUATIONS.', 9, 1) if (INFO == 3) call XERMSG ('SLATEC', 'SNSQ', & 'XTOL TOO SMALL. NO FURTHER IMPROVEMENT POSSIBLE.', 3, 1) if (INFO > 4) call XERMSG ('SLATEC', 'SNSQ', & 'ITERATION NOT MAKING GOOD PROGRESS.', 1, 1) return ! ! LAST CARD OF SUBROUTINE SNSQ. ! end subroutine SODS (A, X, B, NEQ, NUK, NRDA, IFLAG, WORK, IWORK) ! !! SODS solves an overdetermined linear system for BVSUP. ! !***SUBSIDIARY !***PURPOSE Subsidiary to BVSUP !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SODS-S) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! SODS solves the overdetermined system of linear equations A X = B, ! where A is NEQ by NUK and NEQ >= NUK. If rank A = NUK, ! X is the UNIQUE least squares solution vector. That is, ! R(1)**2 + ..... + R(NEQ)**2 = minimum ! where R is the residual vector R = B - A X. ! If rank A < NUK , the least squares solution of minimal ! length can be provided. ! SODS is an interfacing routine which calls subroutine LSSODS ! for the solution. LSSODS in turn calls subroutine ORTHOL and ! possibly subroutine OHTROR for the decomposition of A by ! orthogonal transformations. In the process, ORTHOL calls upon ! subroutine CSCALE for scaling. ! ! ********************************************************************** ! Input ! ********************************************************************** ! ! A -- Contains the matrix of NEQ equations in NUK unknowns and must ! be dimensioned NRDA by NUK. The original A is destroyed ! X -- Solution array of length at least NUK ! B -- Given constant vector of length NEQ, B is destroyed ! NEQ -- Number of equations, NEQ greater or equal to 1 ! NUK -- Number of columns in the matrix (which is also the number ! of unknowns), NUK not larger than NEQ ! NRDA -- Row dimension of A, NRDA greater or equal to NEQ ! IFLAG -- Status indicator ! =0 For the first call (and for each new problem defined by ! a new matrix A) when the matrix data is treated as exact ! =-K For the first call (and for each new problem defined by ! a new matrix A) when the matrix data is assumed to be ! accurate to about K digits ! =1 For subsequent calls whenever the matrix A has already ! been decomposed (problems with new vectors B but ! same matrix a can be handled efficiently) ! WORK(*),IWORK(*) -- Arrays for storage of internal information, ! WORK must be dimensioned at least 2 + 5*NUK ! IWORK must be dimensioned at least NUK+2 ! IWORK(2) -- Scaling indicator ! =-1 If the matrix A is to be pre-scaled by ! columns when appropriate ! If the scaling indicator is not equal to -1 ! no scaling will be attempted ! For most problems scaling will probably not be necessary ! ! ********************************************************************** ! OUTPUT ! ********************************************************************** ! ! IFLAG -- Status indicator ! =1 If solution was obtained ! =2 If improper input is detected ! =3 If rank of matrix is less than NUK ! If the minimal length least squares solution is ! desired, simply reset IFLAG=1 and call the code again ! X -- Least squares solution of A X = B ! A -- Contains the strictly upper triangular part of the reduced ! matrix and the transformation information ! WORK(*),IWORK(*) -- Contains information needed on subsequent ! Calls (IFLAG=1 case on input) which must not ! be altered ! WORK(1) contains the Euclidean norm of ! the residual vector ! WORK(2) contains the Euclidean norm of ! the solution vector ! IWORK(1) contains the numerically determined ! rank of the matrix A ! ! ********************************************************************** ! !***SEE ALSO BVSUP !***REFERENCES G. Golub, Numerical methods for solving linear least ! squares problems, Numerische Mathematik 7, (1965), ! pp. 206-216. ! P. Businger and G. Golub, Linear least squares ! solutions by Householder transformations, Numerische ! Mathematik 7, (1965), pp. 269-276. ! H. A. Watts, Solving linear least squares problems ! using SODS/SUDS/CODS, Sandia Report SAND77-0683, ! Sandia Laboratories, 1977. !***ROUTINES CALLED LSSODS !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SODS DIMENSION A(NRDA,*),X(*),B(*),WORK(*),IWORK(*) ! !***FIRST EXECUTABLE STATEMENT SODS ITER=0 IS=2 IP=3 KS=2 KD=3 KZ=KD+NUK KV=KZ+NUK KT=KV+NUK KC=KT+NUK ! call LSSODS(A,X,B,NEQ,NUK,NRDA,IFLAG,IWORK(1),IWORK(IS),A, & WORK(KD),IWORK(IP),ITER,WORK(1),WORK(KS), & WORK(KZ),B,WORK(KV),WORK(KT),WORK(KC)) ! return end subroutine SOMN (N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, & NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, AP, & EMAP, DZ, CSAV, RWORK, IWORK) ! !! SOMN is the Preconditioned Orthomin Sparse Iterative Ax=b Solver. ! ! Routine to solve a general linear system Ax = b using ! the Preconditioned Orthomin method. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SOMN-S, DOMN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, ! ORTHOMIN, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) ! REAL B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N) ! REAL P(N,0:NSAVE), AP(N,0:NSAVE), EMAP(N,0:NSAVE) ! REAL DZ(N), CSAV(NSAVE), RWORK(USER DEFINED) ! EXTERNAL MATVEC, MSOLVE ! ! call SOMN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ! $ NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, ! $ Z, P, AP, EMAP, DZ, CSAV, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays contain the matrix data structure for A. ! It could take any form. See "Description", below, for more ! details. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) ! Where N is the number of unknowns, Y is the product A*X ! upon return X is an input vector, NELT is the number of ! non-zeros in the SLAP IA, JA, A storage for the matrix A. ! ISYM is a flag which, if non-zero, denotest that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of a routine which solves a linear system MZ = R for ! Z given R with the preconditioning matrix M (M is supplied via ! RWORK and IWORK arrays). The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as above. RWORK is a real array that can ! be used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IWORK is an integer work array for ! the same purpose as RWORK. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize ! against. NSAVE >= 0. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Breakdown of method detected. ! (p,Ap) < epsilon**2. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! R :WORK Real R(N). ! Z :WORK Real Z(N). ! P :WORK Real P(N,0:NSAVE). ! AP :WORK Real AP(N,0:NSAVE). ! EMAP :WORK Real EMAP(N,0:NSAVE). ! DZ :WORK Real DZ(N). ! CSAV :WORK Real CSAV(NSAVE) ! Real arrays used for workspace. ! RWORK :WORK Real RWORK(USER DEFINED). ! Real array that can be used for workspace in MSOLVE. ! IWORK :WORK Integer IWORK(USER DEFINED). ! Integer array that can be used for workspace in MSOLVE. ! ! *Description ! This routine does not care what matrix data structure is ! used for A and M. It simply calls the MATVEC and MSOLVE ! routines, with the arguments as described above. The user ! could write any type of structure and the appropriate MATVEC ! and MSOLVE routines. It is assumed that A is stored in the ! IA, JA, A arrays in some fashion and that M (or INV(M)) is ! stored in IWORK and RWORK) in some fashion. The SLAP ! routines SSDOMN and SSLUOM are examples of this procedure. ! ! Two examples of matrix data structures are the: 1) SLAP ! Triad format and 2) SLAP Column format. ! ! =================== S L A P Triad format =================== ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the real array A. ! In other words, for each column in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have JA(N+1) ! = NELT+1, where N is the number of columns in the matrix and ! NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SSDOMN, SSLUOM, ISSOMN !***REFERENCES 1. Mark K. Seager, A SLAP for the Masses, in ! G. F. Carey, Ed., Parallel Supercomputing: Methods, ! Algorithms and Applications, Wiley, 1989, pp.135-155. !***ROUTINES CALLED ISSOMN, R1MACH, SAXPY, SCOPY, SDOT !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 891004 Added new reference. ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930326 Removed unused variable. (FNF) !***END PROLOGUE SOMN ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, N, NELT, NSAVE ! .. Array Arguments .. REAL A(NELT), AP(N,0:NSAVE), B(N), CSAV(NSAVE), DZ(N), & EMAP(N,0:NSAVE), P(N,0:NSAVE), R(N), RWORK(*), X(N), Z(N) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. REAL AK, AKDEN, AKNUM, BKL, BNRM, FUZZ, SOLNRM INTEGER I, IP, IPO, K, L, LMAX ! .. External Functions .. REAL R1MACH, SDOT INTEGER ISSOMN EXTERNAL R1MACH, SDOT, ISSOMN ! .. External Subroutines .. EXTERNAL SAXPY, SCOPY ! .. Intrinsic Functions .. INTRINSIC ABS, MIN, MOD !***FIRST EXECUTABLE STATEMENT SOMN ! ! Check some of the input data. ! ITER = 0 IERR = 0 if ( N < 1 ) THEN IERR = 3 return end if FUZZ = R1MACH(3) if ( TOL < 500*FUZZ ) THEN TOL = 500*FUZZ IERR = 4 end if FUZZ = FUZZ*FUZZ ! ! Calculate initial residual and pseudo-residual, and check ! stopping criterion. call MATVEC(N, X, R, NELT, IA, JA, A, ISYM) DO 10 I = 1, N R(I) = B(I) - R(I) 10 CONTINUE call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! if ( ISSOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & R, Z, P, AP, EMAP, DZ, CSAV, & RWORK, IWORK, AK, BNRM, SOLNRM) /= 0 ) go to 200 if ( IERR /= 0 ) RETURN ! ! ! ***** iteration loop ***** ! !VD$R NOVECTOR !VD$R NOCONCUR DO 100 K = 1, ITMAX ITER = K IP = MOD( ITER-1, NSAVE+1 ) ! ! calculate direction vector p, a*p, and (m-inv)*a*p, ! and save if desired. call SCOPY(N, Z, 1, P(1,IP), 1) call MATVEC(N, P(1,IP), AP(1,IP), NELT, IA, JA, A, ISYM) call MSOLVE(N, AP(1,IP), EMAP(1,IP), NELT, IA, JA, A, ISYM, & RWORK, IWORK) if ( NSAVE == 0 ) THEN AKDEN = SDOT(N, EMAP, 1, EMAP, 1) ELSE if ( ITER > 1 ) THEN LMAX = MIN( NSAVE, ITER-1 ) DO 20 L = 1, LMAX IPO = MOD(IP+(NSAVE+1-L),NSAVE+1) BKL = SDOT(N, EMAP(1,IP), 1, EMAP(1,IPO), 1) BKL = BKL*CSAV(L) call SAXPY(N, -BKL, P(1,IPO), 1, P(1,IP), 1) call SAXPY(N, -BKL, AP(1,IPO), 1, AP(1,IP), 1) call SAXPY(N, -BKL, EMAP(1,IPO), 1, EMAP(1,IP), 1) 20 CONTINUE if ( NSAVE > 1 ) THEN DO 30 L = NSAVE-1, 1, -1 CSAV(L+1) = CSAV(L) 30 CONTINUE ENDIF ENDIF AKDEN = SDOT(N, EMAP(1,IP), 1, EMAP(1,IP), 1) if ( ABS(AKDEN) < FUZZ ) THEN IERR = 6 return ENDIF CSAV(1) = 1.0E0/AKDEN ! ! calculate coefficient ak, new iterate x, new residual r, and ! new pseudo-residual z. ENDIF AKNUM = SDOT(N, Z, 1, EMAP(1,IP), 1) AK = AKNUM/AKDEN call SAXPY(N, AK, P(1,IP), 1, X, 1) call SAXPY(N, -AK, AP(1,IP), 1, R, 1) call SAXPY(N, -AK, EMAP(1,IP), 1, Z, 1) ! ! check stopping criterion. if ( ISSOMN(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, NSAVE, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & R, Z, P, AP, EMAP, DZ, CSAV, & RWORK, IWORK, AK, BNRM, SOLNRM) /= 0 ) go to 200 ! 100 CONTINUE ! ! ***** end of loop ***** ! ! Stopping criterion not satisfied. ITER = ITMAX + 1 IERR = 2 ! 200 return !------------- LAST LINE OF SOMN FOLLOWS ---------------------------- end subroutine SOPENM (IPAGE, LPAGE) ! !! SOPENM is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE ALL (SOPENM-A) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! 1. OPEN UNIT NUMBER IPAGEF AS A RANDOM ACCESS FILE. ! ! 2. THE RECORD LENGTH IS CONSTANT=LPG. ! !***SEE ALSO SPLP !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890605 Corrected references to XERRWV. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE SOPENM CHARACTER*8 XERN1 ! !***FIRST EXECUTABLE STATEMENT SOPENM IPAGEF=IPAGE LPG =LPAGE OPEN(UNIT=IPAGEF,IOSTAT=IOS,ERR=100,STATUS='UNKNOWN', & ACCESS='DIRECT',FORM='UNFORMATTED',RECL=LPG) return ! 100 WRITE (XERN1, '(I8)') IOS call XERMSG ('SLATEC', 'SOPENM', & 'IN SPLP, OPEN HAS ERROR FLAG = ' // XERN1, 100, 1) return end subroutine SORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) ! !! SORTH is an internal routine for SGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SORTH-S, DORTH-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine orthogonalizes the vector VNEW against the ! previous KMP vectors in the V array. It uses a modified ! Gram-Schmidt orthogonalization procedure with conditional ! reorthogonalization. ! ! *Usage: ! INTEGER N, LL, LDHES, KMP ! REAL VNEW(N), V(N,LL), HES(LDHES,LL), SNORMW ! ! call SORTH(VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) ! ! *Arguments: ! VNEW :INOUT Real VNEW(N) ! On input, the vector of length N containing a scaled ! product of the Jacobian and the vector V(*,LL). ! On output, the new vector orthogonal to V(*,i0) to V(*,LL), ! where i0 = max(1, LL-KMP+1). ! V :IN Real V(N,LL) ! The N x LL array containing the previous LL ! orthogonal vectors V(*,1) to V(*,LL). ! HES :INOUT Real HES(LDHES,LL) ! On input, an LL x LL upper Hessenberg matrix containing, ! in HES(I,K), K.lt.LL, the scaled inner products of ! A*V(*,K) and V(*,i). ! On return, column LL of HES is filled in with ! the scaled inner products of A*V(*,LL) and V(*,i). ! N :IN Integer ! The order of the matrix A, and the length of VNEW. ! LL :IN Integer ! The current order of the matrix HES. ! LDHES :IN Integer ! The leading dimension of the HES array. ! KMP :IN Integer ! The number of previous vectors the new vector VNEW ! must be made orthogonal to (KMP .le. MAXL). ! SNORMW :OUT REAL ! Scalar containing the l-2 norm of VNEW. ! !***SEE ALSO SGMRES !***ROUTINES CALLED SAXPY, SDOT, SNRM2 !***REVISION HISTORY (YYMMDD) ! 871001 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Made subsidiary to SGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE SORTH ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. REAL SNORMW INTEGER KMP, LDHES, LL, N ! .. Array Arguments .. REAL HES(LDHES,*), V(N,*), VNEW(*) ! .. Local Scalars .. REAL ARG, SUMDSQ, TEM, VNRM INTEGER I, I0 ! .. External Functions .. REAL SDOT, SNRM2 EXTERNAL SDOT, SNRM2 ! .. External Subroutines .. EXTERNAL SAXPY ! .. Intrinsic Functions .. INTRINSIC MAX, SQRT !***FIRST EXECUTABLE STATEMENT SORTH ! ! Get norm of unaltered VNEW for later use. ! VNRM = SNRM2(N, VNEW, 1) ! ------------------------------------------------------------------- ! Perform the modified Gram-Schmidt procedure on VNEW =A*V(LL). ! Scaled inner products give new column of HES. ! Projections of earlier vectors are subtracted from VNEW. ! ------------------------------------------------------------------- I0 = MAX(1,LL-KMP+1) DO 10 I = I0,LL HES(I,LL) = SDOT(N, V(1,I), 1, VNEW, 1) TEM = -HES(I,LL) call SAXPY(N, TEM, V(1,I), 1, VNEW, 1) 10 CONTINUE ! ------------------------------------------------------------------- ! Compute SNORMW = norm of VNEW. If VNEW is small compared ! to its input value (in norm), then reorthogonalize VNEW to ! V(*,1) through V(*,LL). Correct if relative correction ! exceeds 1000*(unit roundoff). Finally, correct SNORMW using ! the dot products involved. ! ------------------------------------------------------------------- SNORMW = SNRM2(N, VNEW, 1) if (VNRM + 0.001E0*SNORMW /= VNRM) RETURN SUMDSQ = 0 DO 30 I = I0,LL TEM = -SDOT(N, V(1,I), 1, VNEW, 1) if (HES(I,LL) + 0.001E0*TEM == HES(I,LL)) go to 30 HES(I,LL) = HES(I,LL) - TEM call SAXPY(N, TEM, V(1,I), 1, VNEW, 1) SUMDSQ = SUMDSQ + TEM**2 30 CONTINUE if (SUMDSQ == 0.0E0) RETURN ARG = MAX(0.0E0,SNORMW**2 - SUMDSQ) SNORMW = SQRT(ARG) ! return !------------- LAST LINE OF SORTH FOLLOWS ---------------------------- end subroutine SOSEQS (FNC, N, S, RTOLX, ATOLX, TOLF, IFLAG, MXIT, & NCJS, NSRRC, NSRI, IPRINT, FMAX, C, NC, B, P, TEMP, X, Y, FAC, & IS) ! !! SOSEQS is subsidiary to SOS. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SOSEQS-S, DSOSEQ-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! SOSEQS solves a system of N simultaneous nonlinear equations. ! See the comments in the interfacing routine SOS for a more ! detailed description of some of the items in the calling list. ! ! ******************************************************************** ! ! -INPUT- ! FNC -Function subprogram which evaluates the equations ! N -Number of equations ! S -Solution vector of initial guesses ! RTOLX-Relative error tolerance on solution components ! ATOLX-Absolute error tolerance on solution components ! TOLF-Residual error tolerance ! MXIT-Maximum number of allowable iterations. ! NCJS-Maximum number of consecutive iterative steps to perform ! using the same triangular Jacobian matrix approximation. ! NSRRC-Number of consecutive iterative steps for which the ! limiting precision accuracy test must be satisfied ! before the routine exits with IFLAG=4. ! NSRI-Number of consecutive iterative steps for which the ! diverging condition test must be satisfied before ! the routine exits with IFLAG=7. ! IPRINT-Internal printing parameter. You must set IPRINT=-1 if you ! want the intermediate solution iterates and a residual norm ! to be printed. ! C -Internal work array, dimensioned at least N*(N+1)/2. ! NC -Dimension of C array. NC >= N*(N+1)/2. ! B -Internal work array, dimensioned N. ! P -Internal work array, dimensioned N. ! TEMP-Internal work array, dimensioned N. ! X -Internal work array, dimensioned N. ! Y -Internal work array, dimensioned N. ! FAC -Internal work array, dimensioned N. ! IS -Internal work array, dimensioned N. ! ! -OUTPUT- ! S -Solution vector ! IFLAG-Status indicator flag ! MXIT-The actual number of iterations performed ! FMAX-Residual norm ! C -Upper unit triangular matrix which approximates the ! forward triangularization of the full Jacobian matrix. ! stored in a vector with dimension at least N*(N+1)/2. ! B -Contains the residuals (function values) divided ! by the corresponding components of the P vector ! P -Array used to store the partial derivatives. After ! each iteration P(K) contains the maximal derivative ! occurring in the K-th reduced equation. ! TEMP-Array used to store the previous solution iterate. ! X -Solution vector. Contains the values achieved on the ! last iteration loop upon exit from SOS. ! Y -Array containing the solution increments. ! FAC -Array containing factors used in computing numerical ! derivatives. ! IS -Records the pivotal information (column interchanges) ! ! ********************************************************************** ! *** Three machine dependent parameters appear in this subroutine. ! ! *** The smallest positive magnitude, zero, is defined by the function ! *** routine R1MACH(1). ! ! *** URO, The computer unit roundoff value, is defined by R1MACH(3) for ! *** machines that round or R1MACH(4) for machines that truncate. ! *** URO is the smallest positive number such that 1.+URO > 1. ! ! *** The output tape unit number, LOUN, is defined by the function ! *** I1MACH(2). ! ********************************************************************** ! !***SEE ALSO SOS !***ROUTINES CALLED I1MACH, R1MACH, SOSSOL !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SOSEQS ! ! DIMENSION S(*), C(NC), B(*), IS(*), P(*), TEMP(*), X(*), Y(*), & FAC(*) ! !***FIRST EXECUTABLE STATEMENT SOSEQS URO = R1MACH(4) LOUN = I1MACH(2) ZERO = R1MACH(1) RE = MAX(RTOLX,URO) SRURO = SQRT(URO) ! IFLAG = 0 NP1 = N + 1 ICR = 0 IC = 0 ITRY = NCJS YN1 = 0. YN2 = 0. YN3 = 0. YNS = 0. MIT = 0 FN1 = 0. FN2 = 0. FMXS = 0. ! ! INITIALIZE THE INTERCHANGE (PIVOTING) VECTOR AND ! SAVE THE CURRENT SOLUTION APPROXIMATION FOR FUTURE USE. ! DO 10 K=1,N IS(K) = K X(K) = S(K) TEMP(K) = X(K) 10 CONTINUE ! ! ! ***************************************** ! **** BEGIN PRINCIPAL ITERATION LOOP **** ! ***************************************** ! DO 330 M=1,MXIT ! DO 20 K=1,N FAC(K) = SRURO 20 CONTINUE ! 30 KN = 1 FMAX = 0. ! ! ! ******** BEGIN SUBITERATION LOOP DEFINING THE LINEARIZATION OF EACH ! ******** EQUATION WHICH RESULTS IN THE CONSTRUCTION OF AN UPPER ! ******** TRIANGULAR MATRIX APPROXIMATING THE FORWARD ! ******** TRIANGULARIZATION OF THE FULL JACOBIAN MATRIX ! DO 170 K=1,N KM1 = K - 1 ! ! BACK-SOLVE A TRIANGULAR LINEAR SYSTEM OBTAINING ! IMPROVED SOLUTION VALUES FOR K-1 OF THE VARIABLES ! FROM THE FIRST K-1 EQUATIONS. THESE VARIABLES ARE THEN ! ELIMINATED FROM THE K-TH EQUATION. ! if (KM1 == 0) go to 50 call SOSSOL(K, N, KM1, Y, C, B, KN) DO 40 J=1,KM1 JS = IS(J) X(JS) = TEMP(JS) + Y(J) 40 CONTINUE ! ! ! EVALUATE THE K-TH EQUATION AND THE INTERMEDIATE COMPUTATION ! FOR THE MAX NORM OF THE RESIDUAL VECTOR. ! 50 F = FNC(X,K) FMAX = MAX(FMAX,ABS(F)) ! ! if WE WISH TO PERFORM SEVERAL ITERATIONS USING A FIXED ! FACTORIZATION OF AN APPROXIMATE JACOBIAN,WE NEED ONLY ! UPDATE THE CONSTANT VECTOR. ! if (ITRY < NCJS) go to 160 ! ! IT = 0 ! ! COMPUTE PARTIAL DERIVATIVES THAT ARE REQUIRED IN THE LINEARIZATION ! OF THE K-TH REDUCED EQUATION ! DO 90 J=K,N ITEM = IS(J) HX = X(ITEM) H = FAC(ITEM)*HX if (ABS(H) <= ZERO) H = FAC(ITEM) X(ITEM) = HX + H if (KM1 == 0) go to 70 Y(J) = H call SOSSOL(K, N, J, Y, C, B, KN) DO 60 L=1,KM1 LS = IS(L) X(LS) = TEMP(LS) + Y(L) 60 CONTINUE 70 FP = FNC(X,K) X(ITEM) = HX FDIF = FP - F if (ABS(FDIF) > URO*ABS(F)) go to 80 FDIF = 0. IT = IT + 1 80 P(J) = FDIF/H 90 CONTINUE ! if (IT <= (N-K)) go to 110 ! ! ALL COMPUTED PARTIAL DERIVATIVES OF THE K-TH EQUATION ! ARE EFFECTIVELY ZERO.TRY LARGER PERTURBATIONS OF THE ! INDEPENDENT VARIABLES. ! DO 100 J=K,N ISJ = IS(J) FACT = 100.*FAC(ISJ) if (FACT > 1.E+10) go to 340 FAC(ISJ) = FACT 100 CONTINUE go to 30 ! 110 if (K == N) go to 160 ! ! ACHIEVE A PIVOTING EFFECT BY CHOOSING THE MAXIMAL DERIVATIVE ! ELEMENT ! PMAX = 0. DO 120 J=K,N TEST = ABS(P(J)) if (TEST <= PMAX) go to 120 PMAX = TEST ISV = J 120 CONTINUE if (PMAX == 0.) go to 340 ! ! SET UP THE COEFFICIENTS FOR THE K-TH ROW OF THE TRIANGULAR ! LINEAR SYSTEM AND SAVE THE PARTIAL DERIVATIVE OF ! LARGEST MAGNITUDE ! PMAX = P(ISV) KK = KN DO 140 J=K,N if (J == ISV) go to 130 C(KK) = -P(J)/PMAX 130 KK = KK + 1 140 CONTINUE P(K) = PMAX ! ! if (ISV == K) go to 160 ! ! INTERCHANGE THE TWO COLUMNS OF C DETERMINED BY THE ! PIVOTAL STRATEGY ! KSV = IS(K) IS(K) = IS(ISV) IS(ISV) = KSV ! KD = ISV - K KJ = K DO 150 J=1,K CSV = C(KJ) JK = KJ + KD C(KJ) = C(JK) C(JK) = CSV KJ = KJ + N - J 150 CONTINUE ! 160 KN = KN + NP1 - K ! ! STORE THE COMPONENTS FOR THE CONSTANT VECTOR ! B(K) = -F/P(K) ! 170 CONTINUE ! ! ******** ! ******** END OF LOOP CREATING THE TRIANGULAR LINEARIZATION MATRIX ! ******** ! ! ! SOLVE THE RESULTING TRIANGULAR SYSTEM FOR A NEW SOLUTION ! APPROXIMATION AND OBTAIN THE SOLUTION INCREMENT NORM. ! KN = KN - 1 Y(N) = B(N) if (N > 1) call SOSSOL(N, N, N, Y, C, B, KN) XNORM = 0. YNORM = 0. DO 180 J=1,N YJ = Y(J) YNORM = MAX(YNORM,ABS(YJ)) JS = IS(J) X(JS) = TEMP(JS) + YJ XNORM = MAX(XNORM,ABS(X(JS))) 180 CONTINUE ! ! ! PRINT INTERMEDIATE SOLUTION ITERATES AND RESIDUAL NORM if DESIRED ! if (IPRINT /= (-1)) go to 190 MM = M - 1 WRITE (LOUN,1234) FMAX, MM, (X(J),J=1,N) 1234 FORMAT ('0RESIDUAL NORM =', E9.2, /1X, 'SOLUTION ITERATE', & ' (', I3, ')', /(1X, 5E26.14)) 190 CONTINUE ! ! TEST FOR CONVERGENCE TO A SOLUTION (RELATIVE AND/OR ABSOLUTE ERROR ! COMPARISON ON SUCCESSIVE APPROXIMATIONS OF EACH SOLUTION VARIABLE) ! DO 200 J=1,N JS = IS(J) if (ABS(Y(J)) > RE*ABS(X(JS))+ATOLX) go to 210 200 CONTINUE if (FMAX <= FMXS) IFLAG = 1 ! ! TEST FOR CONVERGENCE TO A SOLUTION BASED ON RESIDUALS ! 210 if (FMAX > TOLF) go to 220 IFLAG = IFLAG + 2 220 if (IFLAG > 0) go to 360 ! ! if (M > 1) go to 230 FMIN = FMAX go to 280 ! ! SAVE SOLUTION HAVING MINIMUM RESIDUAL NORM. ! 230 if (FMAX >= FMIN) go to 250 MIT = M + 1 YN1 = YNORM YN2 = YNS FN1 = FMXS FMIN = FMAX DO 240 J=1,N S(J) = X(J) 240 CONTINUE IC = 0 ! ! TEST FOR LIMITING PRECISION CONVERGENCE. VERY SLOWLY CONVERGENT ! PROBLEMS MAY ALSO BE DETECTED. ! 250 if (YNORM > SRURO*XNORM) go to 260 if ((FMAX < 0.2*FMXS) .OR. (FMAX > 5.*FMXS)) go to 260 if ((YNORM < 0.2*YNS) .OR. (YNORM > 5.*YNS)) go to 260 ICR = ICR + 1 if (ICR < NSRRC) go to 270 IFLAG = 4 FMAX = FMIN go to 380 260 ICR = 0 ! ! TEST FOR DIVERGENCE OF THE ITERATIVE SCHEME. ! if ((YNORM <= 2.*YNS) .AND. (FMAX <= 2.*FMXS)) go to 270 IC = IC + 1 if (IC < NSRI) go to 280 IFLAG = 7 go to 360 270 IC = 0 ! ! CHECK TO SEE if NEXT ITERATION CAN USE THE OLD JACOBIAN ! FACTORIZATION ! 280 ITRY = ITRY - 1 if (ITRY == 0) go to 290 if (20.*YNORM > XNORM) go to 290 if (YNORM > 2.*YNS) go to 290 if (FMAX < 2.*FMXS) go to 300 290 ITRY = NCJS ! ! SAVE THE CURRENT SOLUTION APPROXIMATION AND THE RESIDUAL AND ! SOLUTION INCREMENT NORMS FOR USE IN THE NEXT ITERATION. ! 300 DO 310 J=1,N TEMP(J) = X(J) 310 CONTINUE if (M /= MIT) go to 320 FN2 = FMAX YN3 = YNORM 320 FMXS = FMAX YNS = YNORM ! ! 330 CONTINUE ! ! ***************************************** ! **** END OF PRINCIPAL ITERATION LOOP **** ! ***************************************** ! ! ! TOO MANY ITERATIONS, CONVERGENCE WAS NOT ACHIEVED. M = MXIT IFLAG = 5 if (YN1 > 10.0*YN2 .OR. YN3 > 10.0*YN1) IFLAG = 6 if (FN1 > 5.0*FMIN .OR. FN2 > 5.0*FMIN) IFLAG = 6 if (FMAX > 5.0*FMIN) IFLAG = 6 go to 360 ! ! ! A JACOBIAN-RELATED MATRIX IS EFFECTIVELY SINGULAR. 340 IFLAG = 8 DO 350 J=1,N S(J) = TEMP(J) 350 CONTINUE go to 380 ! ! 360 DO 370 J=1,N S(J) = X(J) 370 CONTINUE ! ! 380 MXIT = M return end subroutine SOS (FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, RW, LRW, & IW, LIW) ! !! SOS solves a square system of nonlinear equations. ! !***LIBRARY SLATEC !***CATEGORY F2A !***TYPE SINGLE PRECISION (SOS-S, DSOS-D) !***KEYWORDS BROWN'S METHOD, NEWTON'S METHOD, NONLINEAR EQUATIONS, ! ROOTS, SOLUTIONS !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! SOS solves a system of NEQ simultaneous nonlinear equations in ! NEQ unknowns. That is, it solves the problem F(X)=0 ! where X is a vector with components X(1),...,X(NEQ) and F ! is a vector of nonlinear functions. Each equation is of the form ! ! F (X(1),...,X(NEQ))=0 for K=1,...,NEQ. ! K ! ! The algorithm is based on an iterative method which is a ! variation of Newton's method using Gaussian elimination ! in a manner similar to the Gauss-Seidel process. Convergence ! is roughly quadratic. All partial derivatives required by ! the algorithm are approximated by first difference quotients. ! The convergence behavior of this code is affected by the ! ordering of the equations, and it is advantageous to place linear ! and mildly nonlinear equations first in the ordering. ! ! Actually, SOS is merely an interfacing routine for ! calling subroutine SOSEQS which embodies the solution ! algorithm. The purpose of this is to add greater ! flexibility and ease of use for the prospective user. ! ! SOSEQS calls the accompanying routine SOSSOL, which solves special ! triangular linear systems by back-substitution. ! ! The user must supply a function subprogram which evaluates the ! K-th equation only (K specified by SOSEQS) for each call ! to the subprogram. ! ! SOS represents an implementation of the mathematical algorithm ! described in the references below. It is a modification of the ! code SOSNLE written by H. A. Watts in 1973. ! ! ********************************************************************** ! -Input- ! ! FNC -Name of the function program which evaluates the equations. ! This name must be in an EXTERNAL statement in the calling ! program. The user must supply FNC in the form FNC(X,K), ! where X is the solution vector (which must be dimensioned ! in FNC) and FNC returns the value of the K-th function. ! ! NEQ -Number of equations to be solved. ! ! X -Solution vector. Initial guesses must be supplied. ! ! RTOLX -Relative error tolerance used in the convergence criteria. ! Each solution component X(I) is checked by an accuracy test ! of the form ABS(X(I)-XOLD(I)) <= RTOLX*ABS(X(I))+ATOLX, ! where XOLD(I) represents the previous iteration value. ! RTOLX must be non-negative. ! ! ATOLX -Absolute error tolerance used in the convergence criteria. ! ATOLX must be non-negative. If the user suspects some ! solution component may be zero, he should set ATOLX to an ! appropriate (depends on the scale of the remaining variables) ! positive value for better efficiency. ! ! TOLF -Residual error tolerance used in the convergence criteria. ! Convergence will be indicated if all residuals (values of the ! functions or equations) are not bigger than TOLF in ! magnitude. Note that extreme care must be given in assigning ! an appropriate value for TOLF because this convergence test ! is dependent on the scaling of the equations. An ! inappropriate value can cause premature termination of the ! iteration process. ! ! IFLAG -Optional input indicator. You must set IFLAG=-1 if you ! want to use any of the optional input items listed below. ! Otherwise set it to zero. ! ! RW -A REAL work array which is split apart by SOS and used ! internally by SOSEQS. ! ! LRW -Dimension of the RW array. LRW must be at least ! 1 + 6*NEQ + NEQ*(NEQ+1)/2 ! ! IW -An INTEGER work array which is split apart by SOS and used ! internally by SOSEQS. ! ! LIW -Dimension of the IW array. LIW must be at least 3 + NEQ. ! ! -Optional Input- ! ! IW(1) -Internal printing parameter. You must set IW(1)=-1 if ! you want the intermediate solution iterates to be printed. ! ! IW(2) -Iteration limit. The maximum number of allowable ! iterations can be specified, if desired. To override the ! default value of 50, set IW(2) to the number wanted. ! ! Remember, if you tell the code that you are using one of the ! options (by setting IFLAG=-1), you must supply values ! for both IW(1) and IW(2). ! ! ********************************************************************** ! -Output- ! ! X -Solution vector. ! ! IFLAG -Status indicator ! ! *** Convergence to a Solution *** ! ! 1 Means satisfactory convergence to a solution was achieved. ! Each solution component X(I) satisfies the error tolerance ! test ABS(X(I)-XOLD(I)) <= RTOLX*ABS(X(I))+ATOLX. ! ! 2 Means procedure converged to a solution such that all ! residuals are at most TOLF in magnitude, ! ABS(FNC(X,I)) <= TOLF. ! ! 3 Means that conditions for both IFLAG=1 and IFLAG=2 hold. ! ! 4 Means possible numerical convergence. Behavior indicates ! limiting precision calculations as a result of user asking ! for too much accuracy or else convergence is very slow. ! Residual norms and solution increment norms have ! remained roughly constant over several consecutive ! iterations. ! ! *** Task Interrupted *** ! ! 5 Means the allowable number of iterations has been met ! without obtaining a solution to the specified accuracy. ! Very slow convergence may be indicated. Examine the ! approximate solution returned and see if the error ! tolerances seem appropriate. ! ! 6 Means the allowable number of iterations has been met and ! the iterative process does not appear to be converging. ! A local minimum may have been encountered or there may be ! limiting precision difficulties. ! ! 7 Means that the iterative scheme appears to be diverging. ! Residual norms and solution increment norms have ! increased over several consecutive iterations. ! ! *** Task Cannot Be Continued *** ! ! 8 Means that a Jacobian-related matrix was singular. ! ! 9 Means improper input parameters. ! ! *** IFLAG should be examined after each call to *** ! *** SOS with the appropriate action being taken. *** ! ! ! RW(1) -Contains a norm of the residual. ! ! IW(3) -Contains the number of iterations used by the process. ! ! ********************************************************************** !***REFERENCES K. M. Brown, Solution of simultaneous nonlinear ! equations, Algorithm 316, Communications of the ! A.C.M. 10, (1967), pp. 728-729. ! K. M. Brown, A quadratically convergent Newton-like ! method based upon Gaussian elimination, SIAM Journal ! on Numerical Analysis 6, (1969), pp. 560-569. !***ROUTINES CALLED SOSEQS, XERMSG !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Convert XERRWV calls to XERMSG calls, changed Prologue ! comments to agree with DSOS. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SOS DIMENSION X(*), RW(*), IW(*) CHARACTER*8 XERN1 CHARACTER*16 XERN3, XERN4 EXTERNAL FNC !***FIRST EXECUTABLE STATEMENT SOS INPFLG = IFLAG ! ! CHECK FOR VALID INPUT ! if (NEQ <= 0) THEN WRITE (XERN1, '(I8)') NEQ call XERMSG ('SLATEC', 'SOS', 'THE NUMBER OF EQUATIONS ' // & 'MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // & 'CODE WITH NEQ = ' // XERN1, 1, 1) IFLAG = 9 end if ! if (RTOLX < 0.0D0 .OR. ATOLX < 0.0D0) THEN WRITE (XERN3, '(1PE15.6)') ATOLX WRITE (XERN4, '(1PE15.6)') RTOLX call XERMSG ('SLATEC', 'SOS', 'THE ERROR TOLERANCES FOR ' // & 'THE SOLUTION ITERATES CANNOT BE NEGATIVE. YOU HAVE ' // & 'CALLED THE CODE WITH RTOLX = ' // XERN3 // & ' AND ATOLX = ' // XERN4,2, 1) IFLAG = 9 end if ! if (TOLF < 0.0D0) THEN WRITE (XERN3, '(1PE15.6)') TOLF call XERMSG ('SLATEC', 'SOS', 'THE RESIDUAL ERROR ' // & 'TOLERANCE MUST BE NON-NEGATIVE. YOU HAVE CALLED THE ' // & 'CODE WITH TOLF = ' // XERN3, 3, 1) IFLAG = 9 end if ! IPRINT = 0 MXIT = 50 if (INPFLG == (-1)) THEN if (IW(1) == (-1)) IPRINT = -1 MXIT = IW(2) if (MXIT <= 0) THEN WRITE (XERN1, '(I8)') MXIT call XERMSG ('SLATEC', 'SOS', 'YOU HAVE TOLD THE CODE ' // & 'TO USE OPTIONAL IN PUT ITEMS BY SETTING IFLAG=-1. ' // & 'HOWEVER YOU HAVE CALLED THE CODE WITH THE MAXIMUM ' // & 'ALLOWABLE NUMBER OF ITERATIONS SET TO IW(2) = ' // & XERN1, 4, 1) IFLAG = 9 ENDIF end if ! NC = (NEQ*(NEQ+1))/2 if (LRW < 1 + 6*NEQ + NC) THEN WRITE (XERN1, '(I8)') LRW call XERMSG ('SLATEC', 'SOS', 'DIMENSION OF THE RW ARRAY ' // & 'MUST BE AT LEAST 1 + 6*NEQ + NEQ*(NEQ+1)/2 . YOU HAVE ' // & 'CALLED THE CODE WITH LRW = ' // XERN1, 5, 1) IFLAG = 9 end if ! if (LIW < 3 + NEQ) THEN WRITE (XERN1, '(I8)') LIW call XERMSG ('SLATEC', 'SOS', 'DIMENSION OF THE IW ARRAY ' // & 'MUST BE AT LEAST 3 + NEQ. YOU HAVE CALLED THE CODE ' // & 'WITH LIW = ' // XERN1, 6, 1) IFLAG = 9 end if ! if (IFLAG /= 9) THEN NCJS = 6 NSRRC = 4 NSRI = 5 ! K1 = NC + 2 K2 = K1 + NEQ K3 = K2 + NEQ K4 = K3 + NEQ K5 = K4 + NEQ K6 = K5 + NEQ ! call SOSEQS(FNC, NEQ, X, RTOLX, ATOLX, TOLF, IFLAG, MXIT, NCJS, & NSRRC, NSRI, IPRINT, RW(1), RW(2), NC, RW(K1), & RW(K2), RW(K3), RW(K4), RW(K5), RW(K6), IW(4)) ! IW(3) = MXIT end if return end subroutine SOSSOL (K, N, L, X, C, B, M) ! !! SOSSOL is subsidiary to SOS. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SOSSOL-S, DSOSSL-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! SOSSOL solves an upper triangular type of linear system by back ! substitution. ! ! The matrix C is upper trapezoidal and stored as a linear array by ! rows. The equations have been normalized so that the diagonal ! entries of C are understood to be unity. The off diagonal entries ! and the elements of the constant right hand side vector B have ! already been stored as the negatives of the corresponding equation ! values. ! with each call to SOSSOL a (K-1) by (K-1) triangular system is ! resolved. For L greater than K, column L of C is included in the ! right hand side vector. ! !***SEE ALSO SOS !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SOSSOL ! ! DIMENSION X(*), C(*), B(*) ! !***FIRST EXECUTABLE STATEMENT SOSSOL NP1 = N + 1 KM1 = K - 1 LK = KM1 if (L == K) LK = K KN = M ! ! DO 40 KJ=1,KM1 KMM1 = K - KJ KM = KMM1 + 1 XMAX = 0. KN = KN - NP1 + KMM1 if (KM > LK) go to 20 JKM = KN ! DO 10 J=KM,LK JKM = JKM + 1 XMAX = XMAX + C(JKM)*X(J) 10 CONTINUE ! 20 if (L <= K) go to 30 JKM = KN + L - KMM1 XMAX = XMAX + C(JKM)*X(L) 30 X(KMM1) = XMAX + B(KMM1) 40 CONTINUE ! return end subroutine SPBCO (ABD, LDA, N, M, RCOND, Z, INFO) ! !! SPBCO factors a real symmetric positive definite matrix stored in ... ! band form and estimate the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B2 !***TYPE SINGLE PRECISION (SPBCO-S, DPBCO-D, CPBCO-C) !***KEYWORDS BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPBCO factors a real symmetric positive definite matrix ! stored in band form and estimates the condition of the matrix. ! ! If RCOND is not needed, SPBFA is slightly faster. ! To solve A*X = B , follow SPBCO by SPBSL. ! To compute INVERSE(A)*C , follow SPBCO by SPBSL. ! To compute DETERMINANT(A) , follow SPBCO by SPBDI. ! ! On Entry ! ! ABD REAL(LDA, N) ! the matrix to be factored. The columns of the upper ! triangle are stored in the columns of ABD and the ! diagonals of the upper triangle are stored in the ! rows of ABD . See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= M + 1 . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! 0 <= M < N . ! ! On Return ! ! ABD an upper triangular matrix R , stored in band ! form, so that A = TRANS(R)*R . ! If INFO /= 0 , the factorization is not complete. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. If INFO /= 0 , RCOND is unchanged. ! ! Z REAL(N) ! a work vector whose contents are usually unimportant. ! If A is singular to working precision, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! If INFO /= 0 , Z is unchanged. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! ! Band Storage ! ! If A is a symmetric positive definite band matrix, ! the following program segment will set up the input. ! ! M = (band width above diagonal) ! DO 20 J = 1, N ! I1 = MAX(1, J-M) ! DO 10 I = I1, J ! K = I-J+M+1 ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! ! This uses M + 1 rows of A , except for the M by M ! upper left triangle, which is ignored. ! ! Example: If the original matrix is ! ! 111213 0 0 0 ! 12222324 0 0 ! 1323333435 0 ! 02434444546 ! 0 035455556 ! 0 0 0465666 ! ! then N = 6 , M = 2 and ABD should contain ! ! * * 13243546 ! * 1223344556 ! 112233445566 ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SASUM, SAXPY, SDOT, SPBFA, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPBCO INTEGER LDA,N,M,INFO REAL ABD(LDA,*),Z(*) REAL RCOND ! REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER I,J,J2,K,KB,KP1,L,LA,LB,LM,MU ! ! FIND NORM OF A ! !***FIRST EXECUTABLE STATEMENT SPBCO DO 30 J = 1, N L = MIN(J,M+1) MU = MAX(M+2-J,1) Z(J) = SASUM(L,ABD(MU,J),1) K = J - L if (M < MU) go to 20 DO 10 I = MU, M K = K + 1 Z(K) = Z(K) + ABS(ABD(I,J)) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,Z(J)) 40 CONTINUE ! ! FACTOR ! call SPBFA(ABD,LDA,N,M,INFO) if (INFO /= 0) go to 180 ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE TRANS(R)*W = E ! EK = 1.0E0 DO 50 J = 1, N Z(J) = 0.0E0 50 CONTINUE DO 110 K = 1, N if (Z(K) /= 0.0E0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= ABD(M+1,K)) go to 60 S = ABD(M+1,K)/ABS(EK-Z(K)) call SSCAL(N,S,Z,1) EK = S*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) WK = WK/ABD(M+1,K) WKM = WKM/ABD(M+1,K) KP1 = K + 1 J2 = MIN(K+M,N) I = M + 1 if (KP1 > J2) go to 100 DO 70 J = KP1, J2 I = I - 1 SM = SM + ABS(Z(J)+WKM*ABD(I,J)) Z(J) = Z(J) + WK*ABD(I,J) S = S + ABS(Z(J)) 70 CONTINUE if (S >= SM) go to 90 T = WKM - WK WK = WKM I = M + 1 DO 80 J = KP1, J2 I = I - 1 Z(J) = Z(J) + T*ABD(I,J) 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) ! ! SOLVE R*Y = W ! DO 130 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= ABD(M+1,K)) go to 120 S = ABD(M+1,K)/ABS(Z(K)) call SSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/ABD(M+1,K) LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM T = -Z(K) call SAXPY(LM,T,ABD(LA,K),1,Z(LB),1) 130 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE TRANS(R)*V = Y ! DO 150 K = 1, N LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM Z(K) = Z(K) - SDOT(LM,ABD(LA,K),1,Z(LB),1) if (ABS(Z(K)) <= ABD(M+1,K)) go to 140 S = ABD(M+1,K)/ABS(Z(K)) call SSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/ABD(M+1,K) 150 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE R*Z = W ! DO 170 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= ABD(M+1,K)) go to 160 S = ABD(M+1,K)/ABS(Z(K)) call SSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/ABD(M+1,K) LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM T = -Z(K) call SAXPY(LM,T,ABD(LA,K),1,Z(LB),1) 170 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 180 CONTINUE return end subroutine SPBDI (ABD, LDA, N, M, DET) ! !! SPBDI computes the determinant of a symmetric positive definite ... ! band matrix using the factors computed by SPBCO or SPBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D3B2 !***TYPE SINGLE PRECISION (SPBDI-S, DPBDI-D, CPBDI-C) !***KEYWORDS BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, ! MATRIX, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPBDI computes the determinant ! of a real symmetric positive definite band matrix ! using the factors computed by SPBCO or SPBFA. ! If the inverse is needed, use SPBSL N times. ! ! On Entry ! ! ABD REAL(LDA, N) ! the output from SPBCO or SPBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! ! On Return ! ! DET REAL(2) ! determinant of original matrix in the form ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= DET(1) < 10.0 ! or DET(1) == 0.0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPBDI INTEGER LDA,N,M REAL ABD(LDA,*) REAL DET(2) ! REAL S INTEGER I !***FIRST EXECUTABLE STATEMENT SPBDI ! ! COMPUTE DETERMINANT ! DET(1) = 1.0E0 DET(2) = 0.0E0 S = 10.0E0 DO 50 I = 1, N DET(1) = ABD(M+1,I)**2*DET(1) if (DET(1) == 0.0E0) go to 60 10 if (DET(1) >= 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) < S) go to 40 DET(1) = DET(1)/S DET(2) = DET(2) + 1.0E0 go to 30 40 CONTINUE 50 CONTINUE 60 CONTINUE return end subroutine SPBFA (ABD, LDA, N, M, INFO) ! !! SPBFA factors a real symmetric positive definite matrix stored in band form. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B2 !***TYPE SINGLE PRECISION (SPBFA-S, DPBFA-D, CPBFA-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPBFA factors a real symmetric positive definite matrix ! stored in band form. ! ! SPBFA is usually called by SPBCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! ! On Entry ! ! ABD REAL(LDA, N) ! the matrix to be factored. The columns of the upper ! triangle are stored in the columns of ABD and the ! diagonals of the upper triangle are stored in the ! rows of ABD . See the comments below for details. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! LDA must be >= M + 1 . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! 0 <= M < N . ! ! On Return ! ! ABD an upper triangular matrix R , stored in band ! form, so that A = TRANS(R)*R . ! ! INFO INTEGER ! = 0 for normal return. ! = K if the leading minor of order K is not ! positive definite. ! ! Band Storage ! ! If A is a symmetric positive definite band matrix, ! the following program segment will set up the input. ! ! M = (band width above diagonal) ! DO 20 J = 1, N ! I1 = MAX(1, J-M) ! DO 10 I = I1, J ! K = I-J+M+1 ! ABD(K,J) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPBFA INTEGER LDA,N,M,INFO REAL ABD(LDA,*) ! REAL SDOT,T REAL S INTEGER IK,J,JK,K,MU !***FIRST EXECUTABLE STATEMENT SPBFA DO 30 J = 1, N INFO = J S = 0.0E0 IK = M + 1 JK = MAX(J-M,1) MU = MAX(M+2-J,1) if (M < MU) go to 20 DO 10 K = MU, M T = ABD(K,J) - SDOT(K-MU,ABD(IK,JK),1,ABD(MU,J),1) T = T/ABD(M+1,JK) ABD(K,J) = T S = S + T*T IK = IK - 1 JK = JK + 1 10 CONTINUE 20 CONTINUE S = ABD(M+1,J) - S if (S <= 0.0E0) go to 40 ABD(M+1,J) = SQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE return end subroutine SPBSL (ABD, LDA, N, M, B) ! !! SPBSL solves a real symmetric positive definite band system using the ... ! factors computed by SPBCO or SPBFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B2 !***TYPE SINGLE PRECISION (SPBSL-S, DPBSL-D, CPBSL-C) !***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, ! POSITIVE DEFINITE, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPBSL solves the real symmetric positive definite band ! system A*X = B ! using the factors computed by SPBCO or SPBFA. ! ! On Entry ! ! ABD REAL(LDA, N) ! the output from SPBCO or SPBFA. ! ! LDA INTEGER ! the leading dimension of the array ABD . ! ! N INTEGER ! the order of the matrix A . ! ! M INTEGER ! the number of diagonals above the main diagonal. ! ! B REAL(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal. Technically, this indicates ! singularity, but it is usually caused by improper subroutine ! arguments. It will not occur if the subroutines are called ! correctly and INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call SPBCO(ABD,LDA,N,RCOND,Z,INFO) ! if (RCOND is too small .OR. INFO /= 0) go to ... ! DO 10 J = 1, P ! call SPBSL(ABD,LDA,N,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPBSL INTEGER LDA,N,M REAL ABD(LDA,*),B(*) ! REAL SDOT,T INTEGER K,KB,LA,LB,LM ! ! SOLVE TRANS(R)*Y = B ! !***FIRST EXECUTABLE STATEMENT SPBSL DO 10 K = 1, N LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM T = SDOT(LM,ABD(LA,K),1,B(LB),1) B(K) = (B(K) - T)/ABD(M+1,K) 10 CONTINUE ! ! SOLVE R*X = Y ! DO 20 KB = 1, N K = N + 1 - KB LM = MIN(K-1,M) LA = M + 1 - LM LB = K - LM B(K) = B(K)/ABD(M+1,K) T = -B(K) call SAXPY(LM,T,ABD(LA,K),1,B(LB),1) 20 CONTINUE return end subroutine SPELI4 (IORDER, A, B, M, MBDCND, BDA, ALPHA, BDB, BETA, & C, D, N, NBDCND, BDC, BDD, COFX, AN, BN, CN, DN, UN, ZN, AM, & BM, CM, DM, UM, ZM, GRHS, USOL, IDMN, W, PERTRB, IERROR) ! !! SPELI4 is subsidiary to SEPX4. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPELI4-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! SPELI4 sets up vectors and arrays for input to BLKTRI ! and computes a second order solution in USOL. A return jump to ! SEPX4 occurs if IORDER=2. If IORDER=4 a fourth order ! solution is generated in USOL. ! !***SEE ALSO SEPX4 !***ROUTINES CALLED CHKSN4, DEFE4, GENBUN, MINSO4, ORTHO4, TRIS4 !***COMMON BLOCKS SPL4 !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE SPELI4 ! DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , & W(*) DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) DIMENSION AN(*) ,BN(*) ,CN(*) ,DN(*) , & UN(*) ,ZN(*) DIMENSION AM(*) ,BM(*) ,CM(*) ,DM(*) , & UM(*) ,ZM(*) COMMON /SPL4/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 LOGICAL SINGLR EXTERNAL COFX !***FIRST EXECUTABLE STATEMENT SPELI4 KSWX = MBDCND+1 KSWY = NBDCND+1 K = M+1 L = N+1 AIT = A BIT = B CIT = C DIT = D DLY=(DIT-CIT)/N ! ! SET RIGHT HAND SIDE VALUES FROM GRHS IN USOL ON THE INTERIOR ! AND NON-SPECIFIED BOUNDARIES. ! DO 20 I=2,M DO 10 J=2,N USOL(I,J)=DLY**2*GRHS(I,J) 10 CONTINUE 20 CONTINUE if (KSWX == 2 .OR. KSWX == 3) go to 40 DO 30 J=2,N USOL(1,J)=DLY**2*GRHS(1,J) 30 CONTINUE 40 CONTINUE if (KSWX == 2 .OR. KSWX == 5) go to 60 DO 50 J=2,N USOL(K,J)=DLY**2*GRHS(K,J) 50 CONTINUE 60 CONTINUE if (KSWY == 2 .OR. KSWY == 3) go to 80 DO 70 I=2,M USOL(I,1)=DLY**2*GRHS(I,1) 70 CONTINUE 80 CONTINUE if (KSWY == 2 .OR. KSWY == 5) go to 100 DO 90 I=2,M USOL(I,L)=DLY**2*GRHS(I,L) 90 CONTINUE 100 CONTINUE if (KSWX /= 2 .AND. KSWX /= 3 .AND. KSWY /= 2 .AND. KSWY /= 3) & USOL(1,1)=DLY**2*GRHS(1,1) if (KSWX /= 2 .AND. KSWX /= 5 .AND. KSWY /= 2 .AND. KSWY /= 3) & USOL(K,1)=DLY**2*GRHS(K,1) if (KSWX /= 2 .AND. KSWX /= 3 .AND. KSWY /= 2 .AND. KSWY /= 5) & USOL(1,L)=DLY**2*GRHS(1,L) if (KSWX /= 2 .AND. KSWX /= 5 .AND. KSWY /= 2 .AND. KSWY /= 5) & USOL(K,L)=DLY**2*GRHS(K,L) ! ! SET SWITCHES FOR PERIODIC OR NON-PERIODIC BOUNDARIES ! MP=1 if ( KSWX == 1) MP=0 NP=NBDCND ! ! SET DLX,DLY AND SIZE OF BLOCK TRI-DIAGONAL SYSTEM GENERATED ! IN NINT,MINT ! DLX = (BIT-AIT)/M MIT = K-1 if (KSWX == 2) MIT = K-2 if (KSWX == 4) MIT = K DLY = (DIT-CIT)/N NIT = L-1 if (KSWY == 2) NIT = L-2 if (KSWY == 4) NIT = L TDLX3 = 2.0*DLX**3 DLX4 = DLX**4 TDLY3 = 2.0*DLY**3 DLY4 = DLY**4 ! ! SET SUBSCRIPT LIMITS FOR PORTION OF ARRAY TO INPUT TO BLKTRI ! IS = 1 JS = 1 if (KSWX == 2 .OR. KSWX == 3) IS = 2 if (KSWY == 2 .OR. KSWY == 3) JS = 2 NS = NIT+JS-1 MS = MIT+IS-1 ! ! SET X - DIRECTION ! DO 110 I=1,MIT XI = AIT+(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)=DLY**2*AXI BM(I)=DLY**2*BXI CM(I)=DLY**2*CXI 110 CONTINUE ! ! SET Y DIRECTION ! DO 120 J=1,NIT DYJ=1.0 EYJ=-2.0 FYJ=1.0 AN(J) = DYJ BN(J) = EYJ CN(J) = FYJ 120 CONTINUE ! ! ADJUST EDGES IN X DIRECTION UNLESS PERIODIC ! AX1 = AM(1) CXM = CM(MIT) go to (170,130,150,160,140),KSWX ! ! DIRICHLET-DIRICHLET IN X DIRECTION ! 130 AM(1) = 0.0 CM(MIT) = 0.0 go to 170 ! ! MIXED-DIRICHLET IN X DIRECTION ! 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 ! ! DIRICHLET-MIXED IN X DIRECTION ! 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 ! ! MIXED - MIXED IN X DIRECTION ! 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 ! ! ADJUST IN Y DIRECTION UNLESS PERIODIC ! DY1 = AN(1) FYN = CN(NIT) GAMA=0.0 XNU=0.0 go to (220,180,200,210,190),KSWY ! ! DIRICHLET-DIRICHLET IN Y DIRECTION ! 180 CONTINUE AN(1) = 0.0 CN(NIT) = 0.0 go to 220 ! ! MIXED-DIRICHLET IN Y DIRECTION ! 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 ! ! DIRICHLET-MIXED IN Y DIRECTION ! 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 ! ! MIXED - MIXED DIRECTION IN Y DIRECTION ! 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 == 1) go to 270 ! ! ADJUST USOL ALONG X EDGE ! DO 260 J=JS,NS if (KSWX /= 2 .AND. KSWX /= 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 /= 2 .AND. KSWX /= 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 == 1) go to 320 ! ! ADJUST USOL ALONG Y EDGE ! DO 310 I=IS,MS if (KSWY /= 2 .AND. KSWY /= 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 /= 2 .AND. KSWY /= 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 ! ! SAVE ADJUSTED EDGES IN GRHS if IORDER=4 ! if (IORDER /= 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 ! ! CHECK if OPERATOR IS SINGULAR ! call CHKSN4(MBDCND,NBDCND,ALPHA,BETA,COFX,SINGLR) ! ! COMPUTE NON-ZERO EIGENVECTOR IN NULL SPACE OF TRANSPOSE ! if SINGULAR ! if (SINGLR) call TRIS4 (MIT,AM,BM,CM,DM,UM,ZM) if (SINGLR) call TRIS4 (NIT,AN,BN,CN,DN,UN,ZN) ! ! ADJUST RIGHT HAND SIDE if NECESSARY ! 360 CONTINUE if (SINGLR) call ORTHO4 (USOL,IDMN,ZN,ZM,PERTRB) ! ! COMPUTE SOLUTION ! ! SAVE ADJUSTED RIGHT HAND SIDE IN GRHS DO 444 J=JS,NS DO 444 I=IS,MS GRHS(I,J)=USOL(I,J) 444 CONTINUE call GENBUN(NP,NIT,MP,MIT,AM,BM,CM,IDMN,USOL(IS,JS),IEROR,W) ! CHECK if ERROR DETECTED IN POIS ! THIS CAN ONLY CORRESPOND TO IERROR=12 if ( IEROR == 0) go to 224 ! SET ERROR FLAG if IMPROPER COEFFICIENTS INPUT TO POIS IERROR=12 return 224 CONTINUE if (IERROR /= 0) RETURN ! ! SET PERIODIC BOUNDARIES if NECESSARY ! if (KSWX /= 1) go to 380 DO 370 J=1,L USOL(K,J) = USOL(1,J) 370 CONTINUE 380 if (KSWY /= 1) go to 400 DO 390 I=1,K USOL(I,L) = USOL(I,1) 390 CONTINUE 400 CONTINUE ! ! MINIMIZE SOLUTION WITH RESPECT TO WEIGHTED LEAST SQUARES ! NORM if OPERATOR IS SINGULAR ! if (SINGLR) call MINSO4 (USOL,IDMN,ZN,ZM,PRTRB) ! ! return if DEFERRED CORRECTIONS AND A FOURTH ORDER SOLUTION ARE ! NOT FLAGGED ! if (IORD == 2) RETURN IORD = 2 ! ! COMPUTE NEW RIGHT HAND SIDE FOR FOURTH ORDER SOLUTION ! call DEFE4(COFX,IDMN,USOL,GRHS) go to 360 end subroutine SPELIP (INTL, IORDER, A, B, M, MBDCND, BDA, ALPHA, BDB, & BETA, C, D, N, NBDCND, BDC, GAMA, BDD, XNU, COFX, COFY, AN, BN, & CN, DN, UN, ZN, AM, BM, CM, DM, UM, ZM, GRHS, USOL, IDMN, W, & PERTRB, IERROR) ! !! SPELIP is subsidiary to SEPELI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPELIP-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! SPELIP sets up vectors and arrays for input to BLKTRI ! and computes a second order solution in USOL. A return jump to ! SEPELI occurs if IORDER=2. If IORDER=4 a fourth order ! solution is generated in USOL. ! !***SEE ALSO SEPELI !***ROUTINES CALLED BLKTRI, CHKSNG, DEFER, MINSOL, ORTHOG, TRISP !***COMMON BLOCKS SPLPCM !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE SPELIP ! DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , & W(*) DIMENSION GRHS(IDMN,*) ,USOL(IDMN,*) DIMENSION AN(*) ,BN(*) ,CN(*) ,DN(*) , & UN(*) ,ZN(*) DIMENSION AM(*) ,BM(*) ,CM(*) ,DM(*) , & UM(*) ,ZM(*) COMMON /SPLPCM/ KSWX ,KSWY ,K ,L , & AIT ,BIT ,CIT ,DIT , & MIT ,NIT ,IS ,MS , & JS ,NS ,DLX ,DLY , & TDLX3 ,TDLY3 ,DLX4 ,DLY4 LOGICAL SINGLR EXTERNAL COFX ,COFY !***FIRST EXECUTABLE STATEMENT SPELIP KSWX = MBDCND+1 KSWY = NBDCND+1 K = M+1 L = N+1 AIT = A BIT = B CIT = C DIT = D ! ! SET RIGHT HAND SIDE VALUES FROM GRHS IN USOL ON THE INTERIOR ! AND NON-SPECIFIED BOUNDARIES. ! DO 20 I=2,M DO 10 J=2,N USOL(I,J) = GRHS(I,J) 10 CONTINUE 20 CONTINUE if (KSWX == 2 .OR. KSWX == 3) go to 40 DO 30 J=2,N USOL(1,J) = GRHS(1,J) 30 CONTINUE 40 CONTINUE if (KSWX == 2 .OR. KSWX == 5) go to 60 DO 50 J=2,N USOL(K,J) = GRHS(K,J) 50 CONTINUE 60 CONTINUE if (KSWY == 2 .OR. KSWY == 3) go to 80 DO 70 I=2,M USOL(I,1) = GRHS(I,1) 70 CONTINUE 80 CONTINUE if (KSWY == 2 .OR. KSWY == 5) go to 100 DO 90 I=2,M USOL(I,L) = GRHS(I,L) 90 CONTINUE 100 CONTINUE if (KSWX /= 2 .AND. KSWX /= 3 .AND. KSWY /= 2 .AND. KSWY /= 3) & USOL(1,1) = GRHS(1,1) if (KSWX /= 2 .AND. KSWX /= 5 .AND. KSWY /= 2 .AND. KSWY /= 3) & USOL(K,1) = GRHS(K,1) if (KSWX /= 2 .AND. KSWX /= 3 .AND. KSWY /= 2 .AND. KSWY /= 5) & USOL(1,L) = GRHS(1,L) if (KSWX /= 2 .AND. KSWX /= 5 .AND. KSWY /= 2 .AND. KSWY /= 5) & USOL(K,L) = GRHS(K,L) I1 = 1 ! ! SET SWITCHES FOR PERIODIC OR NON-PERIODIC BOUNDARIES ! MP = 1 NP = 1 if (KSWX == 1) MP = 0 if (KSWY == 1) NP = 0 ! ! SET DLX,DLY AND SIZE OF BLOCK TRI-DIAGONAL SYSTEM GENERATED ! IN NINT,MINT ! DLX = (BIT-AIT)/M MIT = K-1 if (KSWX == 2) MIT = K-2 if (KSWX == 4) MIT = K DLY = (DIT-CIT)/N NIT = L-1 if (KSWY == 2) NIT = L-2 if (KSWY == 4) NIT = L TDLX3 = 2.0*DLX**3 DLX4 = DLX**4 TDLY3 = 2.0*DLY**3 DLY4 = DLY**4 ! ! SET SUBSCRIPT LIMITS FOR PORTION OF ARRAY TO INPUT TO BLKTRI ! IS = 1 JS = 1 if (KSWX == 2 .OR. KSWX == 3) IS = 2 if (KSWY == 2 .OR. KSWY == 3) JS = 2 NS = NIT+JS-1 MS = MIT+IS-1 ! ! SET X - DIRECTION ! DO 110 I=1,MIT XI = AIT+(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 ! ! SET Y DIRECTION ! DO 120 J=1,NIT YJ = CIT+(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 ! ! ADJUST EDGES IN X DIRECTION UNLESS PERIODIC ! AX1 = AM(1) CXM = CM(MIT) go to (170,130,150,160,140),KSWX ! ! DIRICHLET-DIRICHLET IN X DIRECTION ! 130 AM(1) = 0.0 CM(MIT) = 0.0 go to 170 ! ! MIXED-DIRICHLET IN X DIRECTION ! 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 ! ! DIRICHLET-MIXED IN X DIRECTION ! 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 ! ! MIXED - MIXED IN X DIRECTION ! 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 ! ! ADJUST IN Y DIRECTION UNLESS PERIODIC ! DY1 = AN(1) FYN = CN(NIT) go to (220,180,200,210,190),KSWY ! ! DIRICHLET-DIRICHLET IN Y DIRECTION ! 180 CONTINUE AN(1) = 0.0 CN(NIT) = 0.0 go to 220 ! ! MIXED-DIRICHLET IN Y DIRECTION ! 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 ! ! DIRICHLET-MIXED IN Y DIRECTION ! 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 ! ! MIXED - MIXED DIRECTION IN Y DIRECTION ! 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 == 1) go to 270 ! ! ADJUST USOL ALONG X EDGE ! DO 260 J=JS,NS if (KSWX /= 2 .AND. KSWX /= 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 /= 2 .AND. KSWX /= 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 == 1) go to 320 ! ! ADJUST USOL ALONG Y EDGE ! DO 310 I=IS,MS if (KSWY /= 2 .AND. KSWY /= 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 /= 2 .AND. KSWY /= 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 ! ! SAVE ADJUSTED EDGES IN GRHS if IORDER=4 ! if (IORDER /= 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 ! ! CHECK if OPERATOR IS SINGULAR ! call CHKSNG (MBDCND,NBDCND,ALPHA,BETA,GAMA,XNU,COFX,COFY,SINGLR) ! ! COMPUTE NON-ZERO EIGENVECTOR IN NULL SPACE OF TRANSPOSE ! if SINGULAR ! if (SINGLR) call TRISP (MIT,AM,BM,CM,DM,UM,ZM) if (SINGLR) call TRISP (NIT,AN,BN,CN,DN,UN,ZN) ! ! MAKE INITIALIZATION call TO BLKTRI ! if (INTL == 0) & call BLKTRI (INTL,NP,NIT,AN,BN,CN,MP,MIT,AM,BM,CM,IDMN, & USOL(IS,JS),IERROR,W) if (IERROR /= 0) RETURN ! ! ADJUST RIGHT HAND SIDE if NECESSARY ! 360 CONTINUE if (SINGLR) call ORTHOG (USOL,IDMN,ZN,ZM,PERTRB) ! ! COMPUTE SOLUTION ! call BLKTRI (I1,NP,NIT,AN,BN,CN,MP,MIT,AM,BM,CM,IDMN,USOL(IS,JS), & IERROR,W) if (IERROR /= 0) RETURN ! ! SET PERIODIC BOUNDARIES if NECESSARY ! if (KSWX /= 1) go to 380 DO 370 J=1,L USOL(K,J) = USOL(1,J) 370 CONTINUE 380 if (KSWY /= 1) go to 400 DO 390 I=1,K USOL(I,L) = USOL(I,1) 390 CONTINUE 400 CONTINUE ! ! MINIMIZE SOLUTION WITH RESPECT TO WEIGHTED LEAST SQUARES ! NORM if OPERATOR IS SINGULAR ! if (SINGLR) call MINSOL (USOL,IDMN,ZN,ZM,PRTRB) ! ! return if DEFERRED CORRECTIONS AND A FOURTH ORDER SOLUTION ARE ! NOT FLAGGED ! if (IORD == 2) RETURN IORD = 2 ! ! COMPUTE NEW RIGHT HAND SIDE FOR FOURTH ORDER SOLUTION ! call DEFER (COFX,COFY,IDMN,USOL,GRHS) go to 360 end function SPENC (X) ! !! SPENC computes a form of Spence's integral due to K. Mitchell. ! !***LIBRARY SLATEC (FNLIB) !***CATEGORY C5 !***TYPE SINGLE PRECISION (SPENC-S, DSPENC-D) !***KEYWORDS FNLIB, SPECIAL FUNCTIONS, SPENCE'S INTEGRAL !***AUTHOR Fullerton, W., (LANL) !***DESCRIPTION ! ! Evaluate a form of Spence's function defined by ! integral from 0 to X of -LOG(1-Y)/Y DY. ! For ABS(X) <= 1, the uniformly convergent expansion ! SPENC = sum K=1,infinity X**K / K**2 is valid. ! ! Spence's function can be used to evaluate much more general integral ! forms. For example, ! integral from 0 to Z of LOG(A*X+B)/(C*X+D) DX = ! LOG(ABS(B-A*D/C))*LOG(ABS(A*(C*X+D)/(A*D-B*C)))/C ! - SPENC (A*(C*Z+D)/(A*D-B*C)) / C. ! ! Ref -- K. Mitchell, Philosophical Magazine, 40, p. 351 (1949). ! Stegun and Abromowitz, AMS 55, p. 1004. ! ! ! Series for SPEN on the interval 0. to 5.00000D-01 ! with weighted error 6.82E-17 ! log weighted error 16.17 ! significant figures required 15.22 ! decimal places required 16.81 ! !***REFERENCES (NONE) !***ROUTINES CALLED CSEVL, INITS, R1MACH !***REVISION HISTORY (YYMMDD) ! 780201 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE SPENC DIMENSION SPENCS(19) LOGICAL FIRST SAVE SPENCS, PI26, NSPENC, XBIG, FIRST DATA SPENCS( 1) / .1527365598892406E0 / DATA SPENCS( 2) / .08169658058051014E0 / DATA SPENCS( 3) / .00581415714077873E0 / DATA SPENCS( 4) / .00053716198145415E0 / DATA SPENCS( 5) / .00005724704675185E0 / DATA SPENCS( 6) / .00000667454612164E0 / DATA SPENCS( 7) / .00000082764673397E0 / DATA SPENCS( 8) / .00000010733156730E0 / DATA SPENCS( 9) / .00000001440077294E0 / DATA SPENCS(10) / .00000000198444202E0 / DATA SPENCS(11) / .00000000027940058E0 / DATA SPENCS(12) / .00000000004003991E0 / DATA SPENCS(13) / .00000000000582346E0 / DATA SPENCS(14) / .00000000000085767E0 / DATA SPENCS(15) / .00000000000012768E0 / DATA SPENCS(16) / .00000000000001918E0 / DATA SPENCS(17) / .00000000000000290E0 / DATA SPENCS(18) / .00000000000000044E0 / DATA SPENCS(19) / .00000000000000006E0 / DATA PI26 / 1.644934066848226E0 / DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT SPENC if (FIRST) THEN NSPENC = INITS (SPENCS, 19, 0.1*R1MACH(3)) XBIG = 1.0/R1MACH(3) end if FIRST = .FALSE. ! if (X > 2.0) go to 60 if (X > 1.0) go to 50 if (X > 0.5) go to 40 if (X >= 0.0) go to 30 if (X > (-1.)) go to 20 ! ! HERE if X <= -1.0 ! ALN = LOG(1.0-X) SPENC = -PI26 - 0.5*ALN*(2.0*LOG(-X)-ALN) if (X > (-XBIG)) SPENC = SPENC & + (1.0 + CSEVL (4.0/(1.0-X)-1.0, SPENCS, NSPENC)) / (1.0-X) return ! ! -1.0 < X < 0.0 ! 20 SPENC = -0.5*LOG(1.0-X)**2 & - X*(1.0 + CSEVL (4.0*X/(X-1.0)-1.0, SPENCS, NSPENC)) / (X-1.0) return ! ! 0.0 <= X <= 0.5 ! 30 SPENC = X*(1.0 + CSEVL (4.0*X-1.0, SPENCS, NSPENC)) return ! ! 0.5 < X <= 1.0 ! 40 SPENC = PI26 if (X /= 1.0) SPENC = PI26 - LOG(X)*LOG(1.0-X) & - (1.0-X)*(1.0 + CSEVL (4.0*(1.0-X)-1.0, SPENCS, NSPENC)) return ! ! 1.0 < X <= 2.0 ! 50 SPENC = PI26 - 0.5*LOG(X)*LOG((X-1.0)**2/X) & + (X-1.)*(1.0 + CSEVL (4.0*(X-1.)/X-1.0, SPENCS, NSPENC))/X return ! ! X > 2.0 ! 60 SPENC = 2.0*PI26 - 0.5*LOG(X)**2 if (X < XBIG) SPENC = SPENC & - (1.0 + CSEVL (4.0/X-1.0, SPENCS, NSPENC))/X return ! end subroutine SPIGMR (N, R0, SR, SZ, JSCAL, MAXL, MAXLP1, KMP, NRSTS, & JPRE, MATVEC, MSOLVE, NMSL, Z, V, HES, Q, LGMR, RPAR, IPAR, WK, & DL, RHOL, NRMAX, B, BNRM, X, XL, ITOL, TOL, NELT, IA, JA, A, & ISYM, IUNIT, IFLAG, ERR) ! !! SPIGMR is an internal routine for SGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SPIGMR-S, DPIGMR-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine solves the linear system A * Z = R0 using a ! scaled preconditioned version of the generalized minimum ! residual method. An initial guess of Z = 0 is assumed. ! ! *Usage: ! INTEGER N, JSCAL, MAXL, MAXLP1, KMP, NRSTS, JPRE, NMSL, LGMR ! INTEGER IPAR(USER DEFINED), NRMAX, ITOL, NELT, IA(NELT), JA(NELT) ! INTEGER ISYM, IUNIT, IFLAG ! REAL R0(N), SR(N), SZ(N), Z(N), V(N,MAXLP1), HES(MAXLP1,MAXL), ! $ Q(2*MAXL), RPAR(USER DEFINED), WK(N), DL(N), RHOL, B(N), ! $ BNRM, X(N), XL(N), TOL, A(NELT), ERR ! EXTERNAL MATVEC, MSOLVE ! ! call SPIGMR(N, R0, SR, SZ, JSCAL, MAXL, MAXLP1, KMP, ! $ NRSTS, JPRE, MATVEC, MSOLVE, NMSL, Z, V, HES, Q, LGMR, ! $ RPAR, IPAR, WK, DL, RHOL, NRMAX, B, BNRM, X, XL, ! $ ITOL, TOL, NELT, IA, JA, A, ISYM, IUNIT, IFLAG, ERR) ! ! *Arguments: ! N :IN Integer ! The order of the matrix A, and the lengths ! of the vectors SR, SZ, R0 and Z. ! R0 :IN Real R0(N) ! R0 = the right hand side of the system A*Z = R0. ! R0 is also used as workspace when computing ! the final approximation. ! (R0 is the same as V(*,MAXL+1) in the call to SPIGMR.) ! SR :IN Real SR(N) ! SR is a vector of length N containing the non-zero ! elements of the diagonal scaling matrix for R0. ! SZ :IN Real SZ(N) ! SZ is a vector of length N containing the non-zero ! elements of the diagonal scaling matrix for Z. ! JSCAL :IN Integer ! A flag indicating whether arrays SR and SZ are used. ! JSCAL=0 means SR and SZ are not used and the ! algorithm will perform as if all ! SR(i) = 1 and SZ(i) = 1. ! JSCAL=1 means only SZ is used, and the algorithm ! performs as if all SR(i) = 1. ! JSCAL=2 means only SR is used, and the algorithm ! performs as if all SZ(i) = 1. ! JSCAL=3 means both SR and SZ are used. ! MAXL :IN Integer ! The maximum allowable order of the matrix H. ! MAXLP1 :IN Integer ! MAXPL1 = MAXL + 1, used for dynamic dimensioning of HES. ! KMP :IN Integer ! The number of previous vectors the new vector VNEW ! must be made orthogonal to. (KMP .le. MAXL) ! NRSTS :IN Integer ! Counter for the number of restarts on the current ! call to SGMRES. If NRSTS .gt. 0, then the residual ! R0 is already scaled, and so scaling of it is ! not necessary. ! JPRE :IN Integer ! Preconditioner type flag. ! MATVEC :EXT External. ! Name of a routine which performs the matrix vector multiply ! Y = A*X given A and X. The name of the MATVEC routine must ! be declared external in the calling program. The calling ! sequence to MATVEC is: ! call MATVEC(N, X, Y, NELT, IA, JA, A, ISYM) ! where N is the number of unknowns, Y is the product A*X ! upon return, X is an input vector, and NELT is the number of ! non-zeros in the SLAP IA, JA, A storage for the matrix A. ! ISYM is a flag which, if non-zero, denotes that A is ! symmetric and only the lower or upper triangle is stored. ! MSOLVE :EXT External. ! Name of the routine which solves a linear system Mz = r for ! z given r with the preconditioning matrix M (M is supplied via ! RPAR and IPAR arrays. The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as below. RPAR is a real array that can be ! used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IPAR is an integer work array for the ! same purpose as RPAR. ! NMSL :OUT Integer ! The number of calls to MSOLVE. ! Z :OUT Real Z(N) ! The final computed approximation to the solution ! of the system A*Z = R0. ! V :OUT Real V(N,MAXLP1) ! The N by (LGMR+1) array containing the LGMR ! orthogonal vectors V(*,1) to V(*,LGMR). ! HES :OUT Real HES(MAXLP1,MAXL) ! The upper triangular factor of the QR decomposition ! of the (LGMR+1) by LGMR upper Hessenberg matrix whose ! entries are the scaled inner-products of A*V(*,I) ! and V(*,K). ! Q :OUT Real Q(2*MAXL) ! A real array of length 2*MAXL containing the components ! of the Givens rotations used in the QR decomposition ! of HES. It is loaded in SHEQR and used in SHELS. ! LGMR :OUT Integer ! The number of iterations performed and ! the current order of the upper Hessenberg ! matrix HES. ! RPAR :IN Real RPAR(USER DEFINED) ! Real workspace passed directly to the MSOLVE routine. ! IPAR :IN Integer IPAR(USER DEFINED) ! Integer workspace passed directly to the MSOLVE routine. ! WK :IN Real WK(N) ! A real work array of length N used by routines MATVEC ! and MSOLVE. ! DL :INOUT Real DL(N) ! On input, a real work array of length N used for calculation ! of the residual norm RHO when the method is incomplete ! (KMP.lt.MAXL), and/or when using restarting. ! On output, the scaled residual vector RL. It is only loaded ! when performing restarts of the Krylov iteration. ! RHOL :OUT Real ! A real scalar containing the norm of the final residual. ! NRMAX :IN Integer ! The maximum number of restarts of the Krylov iteration. ! NRMAX .gt. 0 means restarting is active, while ! NRMAX = 0 means restarting is not being used. ! B :IN Real B(N) ! The right hand side of the linear system A*X = b. ! BNRM :IN Real ! The scaled norm of b. ! X :IN Real X(N) ! The current approximate solution as of the last ! restart. ! XL :IN Real XL(N) ! An array of length N used to hold the approximate ! solution X(L) when ITOL=11. ! ITOL :IN Integer ! A flag to indicate the type of convergence criterion ! used. See the driver for its description. ! TOL :IN Real ! The tolerance on residuals R0-A*Z in scaled norm. ! NELT :IN Integer ! The length of arrays IA, JA and A. ! IA :IN Integer IA(NELT) ! An integer array of length NELT containing matrix data. ! It is passed directly to the MATVEC and MSOLVE routines. ! JA :IN Integer JA(NELT) ! An integer array of length NELT containing matrix data. ! It is passed directly to the MATVEC and MSOLVE routines. ! A :IN Real A(NELT) ! A real array of length NELT containing matrix data. ! It is passed directly to the MATVEC and MSOLVE routines. ! ISYM :IN Integer ! A flag to indicate symmetric matrix storage. ! If ISYM=0, all non-zero entries of the matrix are ! stored. If ISYM=1, the matrix is symmetric and ! only the upper or lower triangular part is stored. ! IUNIT :IN Integer ! The i/o unit number for writing intermediate residual ! norm values. ! IFLAG :OUT Integer ! An integer error flag.. ! 0 means convergence in LGMR iterations, LGMR.le.MAXL. ! 1 means the convergence test did not pass in MAXL ! iterations, but the residual norm is .lt. norm(R0), ! and so Z is computed. ! 2 means the convergence test did not pass in MAXL ! iterations, residual .ge. norm(R0), and Z = 0. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SGMRES !***ROUTINES CALLED ISSGMR, SAXPY, SCOPY, SHELS, SHEQR, SNRM2, SORTH, ! SRLCAL, SSCAL !***REVISION HISTORY (YYMMDD) ! 871001 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to SGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE SPIGMR ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. REAL BNRM, ERR, RHOL, TOL INTEGER IFLAG, ISYM, ITOL, IUNIT, JPRE, JSCAL, KMP, LGMR, MAXL, & MAXLP1, N, NELT, NMSL, NRMAX, NRSTS ! .. Array Arguments .. REAL A(NELT), B(*), DL(*), HES(MAXLP1,*), Q(*), R0(*), RPAR(*), & SR(*), SZ(*), V(N,*), WK(*), X(*), XL(*), Z(*) INTEGER IA(NELT), IPAR(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MATVEC, MSOLVE ! .. Local Scalars .. REAL C, DLNRM, PROD, R0NRM, RHO, S, SNORMW, TEM INTEGER I, I2, INFO, IP1, ITER, ITMAX, J, K, LL, LLP1 ! .. External Functions .. REAL SNRM2 INTEGER ISSGMR EXTERNAL SNRM2, ISSGMR ! .. External Subroutines .. EXTERNAL SAXPY, SCOPY, SHELS, SHEQR, SORTH, SRLCAL, SSCAL ! .. Intrinsic Functions .. INTRINSIC ABS !***FIRST EXECUTABLE STATEMENT SPIGMR ! ! Zero out the Z array. ! DO 5 I = 1,N Z(I) = 0 5 CONTINUE ! IFLAG = 0 LGMR = 0 NMSL = 0 ! Load ITMAX, the maximum number of iterations. ITMAX =(NRMAX+1)*MAXL ! ------------------------------------------------------------------- ! The initial residual is the vector R0. ! Apply left precon. if JPRE < 0 and this is not a restart. ! Apply scaling to R0 if JSCAL = 2 or 3. ! ------------------------------------------------------------------- if ((JPRE < 0) .AND.(NRSTS == 0)) THEN call SCOPY(N, R0, 1, WK, 1) call MSOLVE(N, WK, R0, NELT, IA, JA, A, ISYM, RPAR, IPAR) NMSL = NMSL + 1 end if if (((JSCAL == 2) .OR.(JSCAL == 3)) .AND.(NRSTS == 0)) THEN DO 10 I = 1,N V(I,1) = R0(I)*SR(I) 10 CONTINUE ELSE DO 20 I = 1,N V(I,1) = R0(I) 20 CONTINUE end if R0NRM = SNRM2(N, V, 1) ITER = NRSTS*MAXL ! ! Call stopping routine ISSGMR. ! if (ISSGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, & NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, V(1,1), Z, WK, & RPAR, IPAR, R0NRM, BNRM, SR, SZ, JSCAL, & KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, & HES, JPRE) /= 0) RETURN TEM = 1.0E0/R0NRM call SSCAL(N, TEM, V(1,1), 1) ! ! Zero out the HES array. ! DO 50 J = 1,MAXL DO 40 I = 1,MAXLP1 HES(I,J) = 0 40 CONTINUE 50 CONTINUE ! ------------------------------------------------------------------- ! Main loop to compute the vectors V(*,2) to V(*,MAXL). ! The running product PROD is needed for the convergence test. ! ------------------------------------------------------------------- PROD = 1 DO 90 LL = 1,MAXL LGMR = LL ! ------------------------------------------------------------------- ! Unscale the current V(LL) and store in WK. Call routine ! MSOLVE to compute(M-inverse)*WK, where M is the ! preconditioner matrix. Save the answer in Z. Call routine ! MATVEC to compute VNEW = A*Z, where A is the the system ! matrix. save the answer in V(LL+1). Scale V(LL+1). Call ! routine SORTH to orthogonalize the new vector VNEW = ! V(*,LL+1). Call routine SHEQR to update the factors of HES. ! ------------------------------------------------------------------- if ((JSCAL == 1) .OR.(JSCAL == 3)) THEN DO 60 I = 1,N WK(I) = V(I,LL)/SZ(I) 60 CONTINUE ELSE call SCOPY(N, V(1,LL), 1, WK, 1) ENDIF if (JPRE > 0) THEN call MSOLVE(N, WK, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) NMSL = NMSL + 1 call MATVEC(N, Z, V(1,LL+1), NELT, IA, JA, A, ISYM) ELSE call MATVEC(N, WK, V(1,LL+1), NELT, IA, JA, A, ISYM) ENDIF if (JPRE < 0) THEN call SCOPY(N, V(1,LL+1), 1, WK, 1) call MSOLVE(N,WK,V(1,LL+1),NELT,IA,JA,A,ISYM,RPAR,IPAR) NMSL = NMSL + 1 ENDIF if ((JSCAL == 2) .OR.(JSCAL == 3)) THEN DO 65 I = 1,N V(I,LL+1) = V(I,LL+1)*SR(I) 65 CONTINUE ENDIF call SORTH(V(1,LL+1), V, HES, N, LL, MAXLP1, KMP, SNORMW) HES(LL+1,LL) = SNORMW call SHEQR(HES, MAXLP1, LL, Q, INFO, LL) if (INFO == LL) go to 120 ! ------------------------------------------------------------------- ! Update RHO, the estimate of the norm of the residual R0-A*ZL. ! If KMP < MAXL, then the vectors V(*,1),...,V(*,LL+1) are not ! necessarily orthogonal for LL > KMP. The vector DL must then ! be computed, and its norm used in the calculation of RHO. ! ------------------------------------------------------------------- PROD = PROD*Q(2*LL) RHO = ABS(PROD*R0NRM) if ((LL > KMP) .AND.(KMP < MAXL)) THEN if (LL == KMP+1) THEN call SCOPY(N, V(1,1), 1, DL, 1) DO 75 I = 1,KMP IP1 = I + 1 I2 = I*2 S = Q(I2) C = Q(I2-1) DO 70 K = 1,N DL(K) = S*DL(K) + C*V(K,IP1) 70 CONTINUE 75 CONTINUE ENDIF S = Q(2*LL) C = Q(2*LL-1)/SNORMW LLP1 = LL + 1 DO 80 K = 1,N DL(K) = S*DL(K) + C*V(K,LLP1) 80 CONTINUE DLNRM = SNRM2(N, DL, 1) RHO = RHO*DLNRM ENDIF RHOL = RHO ! ------------------------------------------------------------------- ! Test for convergence. If passed, compute approximation ZL. ! If failed and LL < MAXL, then continue iterating. ! ------------------------------------------------------------------- ITER = NRSTS*MAXL + LGMR if (ISSGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE, & NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, DL, Z, WK, & RPAR, IPAR, RHOL, BNRM, SR, SZ, JSCAL, & KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM, & HES, JPRE) /= 0) go to 200 if (LL == MAXL) go to 100 ! ------------------------------------------------------------------- ! Rescale so that the norm of V(1,LL+1) is one. ! ------------------------------------------------------------------- TEM = 1.0E0/SNORMW call SSCAL(N, TEM, V(1,LL+1), 1) 90 CONTINUE 100 CONTINUE if (RHO < R0NRM) go to 150 120 CONTINUE IFLAG = 2 ! ! Load approximate solution with zero. ! DO 130 I = 1,N Z(I) = 0 130 CONTINUE return 150 IFLAG = 1 ! ! Tolerance not met, but residual norm reduced. ! if (NRMAX > 0) THEN ! ! If performing restarting (NRMAX > 0) calculate the residual ! vector RL and store it in the DL array. If the incomplete ! version is being used (KMP < MAXL) then DL has already been ! calculated up to a scaling factor. Use SRLCAL to calculate ! the scaled residual vector. ! call SRLCAL(N, KMP, MAXL, MAXL, V, Q, DL, SNORMW, PROD, & R0NRM) end if ! ------------------------------------------------------------------- ! Compute the approximation ZL to the solution. Since the ! vector Z was used as workspace, and the initial guess ! of the linear iteration is zero, Z must be reset to zero. ! ------------------------------------------------------------------- 200 CONTINUE LL = LGMR LLP1 = LL + 1 DO 210 K = 1,LLP1 R0(K) = 0 210 CONTINUE R0(1) = R0NRM call SHELS(HES, MAXLP1, LL, Q, R0) DO 220 K = 1,N Z(K) = 0 220 CONTINUE DO 230 I = 1,LL call SAXPY(N, R0(I), V(1,I), 1, Z, 1) 230 CONTINUE if ((JSCAL == 1) .OR.(JSCAL == 3)) THEN DO 240 I = 1,N Z(I) = Z(I)/SZ(I) 240 CONTINUE end if if (JPRE > 0) THEN call SCOPY(N, Z, 1, WK, 1) call MSOLVE(N, WK, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) NMSL = NMSL + 1 end if return !------------- LAST LINE OF SPIGMR FOLLOWS ---------------------------- end subroutine SPINCW (MRELAS, NVARS, LMX, LBM, NPP, JSTRT, IBASIS, & IMAT, IBRC, IPR, IWR, IND, IBB, COSTSC, GG, ERDNRM, DULNRM, & AMAT, BASMAT, CSC, WR, WW, RZ, RG, COSTS, COLNRM, DUALS, & STPEDG) ! !! SPINCW is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPINCW-S, DPINCW-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/, ! REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/,/SDOT/DDOT/. ! ! THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE. ! IT IMPLEMENTS THE PROCEDURE (INITIALIZE REDUCED COSTS AND ! STEEPEST EDGE WEIGHTS). ! !***SEE ALSO SPLP !***ROUTINES CALLED IPLOC, LA05BS, PRWPGE, SCOPY, SDOT !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SPINCW INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) REAL AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),RZ(*),RG(*), & COSTS(*),COLNRM(*),DUALS(*),COSTSC,ERDNRM,DULNRM,GG,ONE,RZJ, & SCALR,ZERO,RCOST LOGICAL STPEDG,PAGEPL,TRANS !***FIRST EXECUTABLE STATEMENT SPINCW LPG=LMX-(NVARS+4) ZERO=0. ONE=1. ! ! FORM REDUCED COSTS, RZ(*), AND STEEPEST EDGE WEIGHTS, RG(*). PAGEPL=.TRUE. RZ(1)=ZERO call SCOPY(NVARS+MRELAS,RZ,0,RZ,1) RG(1)=ONE call SCOPY(NVARS+MRELAS,RG,0,RG,1) NNEGRC=0 J=JSTRT 20002 if (.NOT.(IBB(J) <= 0)) go to 20004 PAGEPL=.TRUE. go to 20005 ! ! THESE ARE NONBASIC INDEPENDENT VARIABLES. THE COLS. ARE IN SPARSE ! MATRIX FORMAT. 20004 if (.NOT.(J <= NVARS)) go to 20007 RZJ=COSTSC*COSTS(J) WW(1)=ZERO call SCOPY(MRELAS,WW,0,WW,1) if (.NOT.(J == 1)) go to 20010 ILOW=NVARS+5 go to 20011 20010 ILOW=IMAT(J+3)+1 20011 CONTINUE if (.NOT.(PAGEPL)) go to 20013 IL1=IPLOC(ILOW,AMAT,IMAT) if (.NOT.(IL1 >= LMX-1)) go to 20016 ILOW=ILOW+2 IL1=IPLOC(ILOW,AMAT,IMAT) 20016 CONTINUE IPAGE=ABS(IMAT(LMX-1)) go to 20014 20013 IL1=IHI+1 20014 CONTINUE IHI=IMAT(J+4)-(ILOW-IL1) 20019 IU1=MIN(LMX-2,IHI) if (.NOT.(IL1 > IU1)) go to 20021 go to 20020 20021 CONTINUE DO 60 I=IL1,IU1 RZJ=RZJ-AMAT(I)*DUALS(IMAT(I)) WW(IMAT(I))=AMAT(I)*CSC(J) 60 CONTINUE if (.NOT.(IHI <= LMX-2)) go to 20024 go to 20020 20024 CONTINUE IPAGE=IPAGE+1 KEY=1 call PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG go to 20019 20020 PAGEPL=IHI == (LMX-2) RZ(J)=RZJ*CSC(J) if (.NOT.(STPEDG)) go to 20027 TRANS=.FALSE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) RG(J)=SDOT(MRELAS,WW,1,WW,1)+ONE 20027 CONTINUE ! ! THESE ARE NONBASIC DEPENDENT VARIABLES. THE COLS. ARE IMPLICITLY ! DEFINED. go to 20008 20007 PAGEPL=.TRUE. WW(1)=ZERO call SCOPY(MRELAS,WW,0,WW,1) SCALR=-ONE if (IND(J) == 2) SCALR=ONE I=J-NVARS RZ(J)=-SCALR*DUALS(I) WW(I)=SCALR if (.NOT.(STPEDG)) go to 20030 TRANS=.FALSE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) RG(J)=SDOT(MRELAS,WW,1,WW,1)+ONE 20030 CONTINUE CONTINUE 20008 CONTINUE ! 20005 RCOST=RZ(J) if (MOD(IBB(J),2) == 0) RCOST=-RCOST if (IND(J) == 4) RCOST=-ABS(RCOST) CNORM=ONE if (J <= NVARS) CNORM=COLNRM(J) if (RCOST+ERDNRM*DULNRM*CNORM < ZERO) NNEGRC=NNEGRC+1 J=MOD(J,MRELAS+NVARS)+1 if (.NOT.(NNEGRC >= NPP .OR. J == JSTRT)) go to 20033 go to 20003 20033 go to 20002 20003 JSTRT=J return end subroutine SPINIT (MRELAS, NVARS, COSTS, BL, BU, IND, PRIMAL, & INFO, AMAT, CSC, COSTSC, COLNRM, XLAMDA, ANORM, RHS, RHSNRM, & IBASIS, IBB, IMAT, LOPT) ! !! SPINIT is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPINIT-S, DPINIT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/ ! REVISED 810519-0900 ! REVISED YYMMDD-HHMM ! ! INITIALIZATION SUBROUTINE FOR SPLP(*) PACKAGE. ! !***SEE ALSO SPLP !***ROUTINES CALLED PNNZRS, SASUM, SCOPY !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SPINIT REAL AIJ,AMAT(*),ANORM,BL(*),BU(*),CMAX, & COLNRM(*),COSTS(*),COSTSC,CSC(*),CSUM,ONE,PRIMAL(*), & RHS(*),RHSNRM,SCALR,TESTSC,XLAMDA,ZERO INTEGER IBASIS(*),IBB(*),IMAT(*),IND(*) LOGICAL CONTIN,USRBAS,COLSCP,CSTSCP,MINPRB,LOPT(8) ! !***FIRST EXECUTABLE STATEMENT SPINIT ZERO=0. ONE=1. CONTIN=LOPT(1) USRBAS=LOPT(2) COLSCP=LOPT(5) CSTSCP=LOPT(6) MINPRB=LOPT(7) ! ! SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS. go to 30001 ! ! INITIALIZE ACTIVE BASIS MATRIX. 20002 CONTINUE go to 30002 20003 RETURN ! ! PROCEDURE (SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS) ! ! DO COLUMN SCALING if NOT PROVIDED BY THE USER. 30001 if (.NOT.(.NOT. COLSCP)) go to 20004 J=1 N20007=NVARS go to 20008 20007 J=J+1 20008 if ((N20007-J) < 0) go to 20009 CMAX=ZERO I=0 20011 call PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I == 0)) go to 20013 go to 20012 20013 CONTINUE CMAX=MAX(CMAX,ABS(AIJ)) go to 20011 20012 if (.NOT.(CMAX == ZERO)) go to 20016 CSC(J)=ONE go to 20017 20016 CSC(J)=ONE/CMAX 20017 CONTINUE go to 20007 20009 CONTINUE ! ! FORM CHECK SUMS OF COLUMNS. COMPUTE MATRIX NORM OF SCALED MATRIX. 20004 ANORM = ZERO J=1 N20019=NVARS go to 20020 20019 J=J+1 20020 if ((N20019-J) < 0) go to 20021 PRIMAL(J)=ZERO CSUM = ZERO I=0 20023 call PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I <= 0)) go to 20025 go to 20024 20025 CONTINUE PRIMAL(J)=PRIMAL(J)+AIJ CSUM = CSUM+ABS(AIJ) go to 20023 20024 if (IND(J) == 2) CSC(J)=-CSC(J) PRIMAL(J)=PRIMAL(J)*CSC(J) COLNRM(J)=ABS(CSC(J)*CSUM) ANORM = MAX(ANORM,COLNRM(J)) go to 20019 ! ! if THE USER HAS NOT PROVIDED COST VECTOR SCALING THEN SCALE IT ! USING THE MAX. NORM OF THE TRANSFORMED COST VECTOR, if NONZERO. 20021 TESTSC=ZERO J=1 N20028=NVARS go to 20029 20028 J=J+1 20029 if ((N20028-J) < 0) go to 20030 TESTSC=MAX(TESTSC,ABS(CSC(J)*COSTS(J))) go to 20028 20030 if (.NOT.(.NOT.CSTSCP)) go to 20032 if (.NOT.(TESTSC > ZERO)) go to 20035 COSTSC=ONE/TESTSC go to 20036 20035 COSTSC=ONE 20036 CONTINUE CONTINUE 20032 XLAMDA=(COSTSC+COSTSC)*TESTSC if (XLAMDA == ZERO) XLAMDA=ONE ! ! if MAXIMIZATION PROBLEM, THEN CHANGE SIGN OF COSTSC AND LAMDA ! =WEIGHT FOR PENALTY-FEASIBILITY METHOD. if (.NOT.(.NOT.MINPRB)) go to 20038 COSTSC=-COSTSC 20038 go to 20002 !:CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (INITIALIZE RHS(*),IBASIS(*), AND IBB(*)) ! ! INITIALLY SET RIGHT-HAND SIDE VECTOR TO ZERO. 30002 call sinit ( MRELAS,ZERO,RHS,1) ! ! TRANSLATE RHS ACCORDING TO CLASSIFICATION OF INDEPENDENT VARIABLES J=1 N20041=NVARS go to 20042 20041 J=J+1 20042 if ((N20041-J) < 0) go to 20043 if (.NOT.(IND(J) == 1)) go to 20045 SCALR=-BL(J) go to 20046 20045 if (.NOT.(IND(J) == 2)) go to 10001 SCALR=-BU(J) go to 20046 10001 if (.NOT.(IND(J) == 3)) go to 10002 SCALR=-BL(J) go to 20046 10002 if (.NOT.(IND(J) == 4)) go to 10003 SCALR=ZERO 10003 CONTINUE 20046 CONTINUE if (.NOT.(SCALR /= ZERO)) go to 20048 I=0 20051 call PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I <= 0)) go to 20053 go to 20052 20053 CONTINUE RHS(I)=SCALR*AIJ+RHS(I) go to 20051 20052 CONTINUE 20048 CONTINUE go to 20041 ! ! TRANSLATE RHS ACCORDING TO CLASSIFICATION OF DEPENDENT VARIABLES. 20043 I=NVARS+1 N20056=NVARS+MRELAS go to 20057 20056 I=I+1 20057 if ((N20056-I) < 0) go to 20058 if (.NOT.(IND(I) == 1)) go to 20060 SCALR=BL(I) go to 20061 20060 if (.NOT.(IND(I) == 2)) go to 10004 SCALR=BU(I) go to 20061 10004 if (.NOT.(IND(I) == 3)) go to 10005 SCALR=BL(I) go to 20061 10005 if (.NOT.(IND(I) == 4)) go to 10006 SCALR=ZERO 10006 CONTINUE 20061 CONTINUE RHS(I-NVARS)=RHS(I-NVARS)+SCALR go to 20056 20058 RHSNRM=SASUM(MRELAS,RHS,1) ! ! if THIS IS NOT A CONTINUATION OR THE USER HAS NOT PROVIDED THE ! INITIAL BASIS, THEN THE INITIAL BASIS IS COMPRISED OF THE ! DEPENDENT VARIABLES. if (.NOT.(.NOT.(CONTIN .OR. USRBAS))) go to 20063 J=1 N20066=MRELAS go to 20067 20066 J=J+1 20067 if ((N20066-J) < 0) go to 20068 IBASIS(J)=NVARS+J go to 20066 20068 CONTINUE ! ! DEFINE THE ARRAY IBB(*) 20063 J=1 N20070=NVARS+MRELAS go to 20071 20070 J=J+1 20071 if ((N20070-J) < 0) go to 20072 IBB(J)=1 go to 20070 20072 J=1 N20074=MRELAS go to 20075 20074 J=J+1 20075 if ((N20074-J) < 0) go to 20076 IBB(IBASIS(J))=-1 go to 20074 ! ! DEFINE THE REST OF IBASIS(*) 20076 IP=MRELAS J=1 N20078=NVARS+MRELAS go to 20079 20078 J=J+1 20079 if ((N20078-J) < 0) go to 20080 if (.NOT.(IBB(J) > 0)) go to 20082 IP=IP+1 IBASIS(IP)=J 20082 go to 20078 20080 go to 20003 end subroutine SPLPCE (MRELAS, NVARS, LMX, LBM, ITLP, ITBRC, IBASIS, & IMAT, IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, TUNE, GG, AMAT, & BASMAT, CSC, WR, WW, PRIMAL, ERD, ERP, SINGLR, REDBAS) ! !! SPLPCE is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPLPCE-S, DPLPCE-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/, ! /SASUM/DASUM/,/SCOPY/,DCOPY/. ! ! REVISED 811219-1630 ! REVISED YYMMDD-HHMM ! ! THIS SUBPROGRAM IS FROM THE SPLP( ) PACKAGE. IT CALCULATES ! THE APPROXIMATE ERROR IN THE PRIMAL AND DUAL SYSTEMS. IT IS ! THE MAIN PART OF THE PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL ! SYSTEMS). ! !***SEE ALSO SPLP !***ROUTINES CALLED IPLOC, LA05BS, PRWPGE, SASUM, SCOPY !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SPLPCE INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) REAL AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),PRIMAL(*), & ERD(*),ERP(*),EPS,ERDNRM,FACTOR,GG,ONE,ZERO,TEN,TUNE LOGICAL SINGLR,REDBAS,TRANS,PAGEPL !***FIRST EXECUTABLE STATEMENT SPLPCE ZERO=0.E0 ONE=1.E0 TEN=10.E0 LPG=LMX-(NVARS+4) SINGLR=.FALSE. FACTOR=0.01 ! ! COPY COLSUMS IN WW(*), AND SOLVE TRANSPOSED SYSTEM. I=1 N20002=MRELAS go to 20003 20002 I=I+1 20003 if ((N20002-I) < 0) go to 20004 J=IBASIS(I) if (.NOT.(J <= NVARS)) go to 20006 WW(I) = PRIMAL(J) go to 20007 20006 if (.NOT.(IND(J) == 2)) go to 20009 WW(I)=ONE go to 20010 20009 WW(I)=-ONE 20010 CONTINUE 20007 CONTINUE go to 20002 ! ! PERTURB RIGHT-SIDE IN UNITS OF LAST BITS TO BETTER REFLECT ! ERRORS IN THE CHECK SUM SOLNS. 20004 I=1 N20012=MRELAS go to 20013 20012 I=I+1 20013 if ((N20012-I) < 0) go to 20014 WW(I)=WW(I)+TEN*EPS*WW(I) go to 20012 20014 TRANS = .TRUE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) I=1 N20016=MRELAS go to 20017 20016 I=I+1 20017 if ((N20016-I) < 0) go to 20018 ERD(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE ! ! SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS > FACTOR. ! THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED. SINGLR=SINGLR.OR.(ERD(I) >= FACTOR) go to 20016 20018 ERDNRM=SASUM(MRELAS,ERD,1) ! ! RECALCULATE ROW CHECK SUMS EVERY ITBRC ITERATIONS OR WHEN ! A REDECOMPOSITION HAS OCCURRED. if (.NOT.(MOD(ITLP,ITBRC) == 0 .OR. REDBAS)) go to 20020 ! ! COMPUTE ROW SUMS, STORE IN WW(*), SOLVE PRIMAL SYSTEM. WW(1)=ZERO call SCOPY(MRELAS,WW,0,WW,1) PAGEPL=.TRUE. J=1 N20023=NVARS go to 20024 20023 J=J+1 20024 if ((N20023-J) < 0) go to 20025 if (.NOT.(IBB(J) >= ZERO)) go to 20027 ! ! THE VARIABLE IS NON-BASIC. PAGEPL=.TRUE. go to 20023 20027 if (.NOT.(J == 1)) go to 20030 ILOW=NVARS+5 go to 20031 20030 ILOW=IMAT(J+3)+1 20031 if (.NOT.(PAGEPL)) go to 20033 IL1=IPLOC(ILOW,AMAT,IMAT) if (.NOT.(IL1 >= LMX-1)) go to 20036 ILOW=ILOW+2 IL1=IPLOC(ILOW,AMAT,IMAT) 20036 CONTINUE IPAGE=ABS(IMAT(LMX-1)) go to 20034 20033 IL1=IHI+1 20034 IHI=IMAT(J+4)-(ILOW-IL1) 20039 IU1=MIN(LMX-2,IHI) if (.NOT.(IL1 > IU1)) go to 20041 go to 20040 20041 CONTINUE DO 20 I=IL1,IU1 WW(IMAT(I))=WW(IMAT(I))+AMAT(I)*CSC(J) 20 CONTINUE if (.NOT.(IHI <= LMX-2)) go to 20044 go to 20040 20044 CONTINUE IPAGE=IPAGE+1 KEY=1 call PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG go to 20039 20040 PAGEPL=IHI == (LMX-2) go to 20023 20025 L=1 N20047=MRELAS go to 20048 20047 L=L+1 20048 if ((N20047-L) < 0) go to 20049 J=IBASIS(L) if (.NOT.(J > NVARS)) go to 20051 I=J-NVARS if (.NOT.(IND(J) == 2)) go to 20054 WW(I)=WW(I)+ONE go to 20055 20054 WW(I)=WW(I)-ONE 20055 CONTINUE 20051 CONTINUE go to 20047 ! ! PERTURB RIGHT-SIDE IN UNITS OF LAST BIT POSITIONS. 20049 I=1 N20057=MRELAS go to 20058 20057 I=I+1 20058 if ((N20057-I) < 0) go to 20059 WW(I)=WW(I)+TEN*EPS*WW(I) go to 20057 20059 TRANS = .FALSE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) I=1 N20061=MRELAS go to 20062 20061 I=I+1 20062 if ((N20061-I) < 0) go to 20063 ERP(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE ! ! SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS > FACTOR. ! THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED. SINGLR=SINGLR.OR.(ERP(I) >= FACTOR) go to 20061 20063 CONTINUE ! 20020 RETURN end subroutine SPLPDM (MRELAS, NVARS, LMX, LBM, NREDC, INFO, IOPT, & IBASIS, IMAT, IBRC, IPR, IWR, IND, IBB, ANORM, EPS, UU, GG, & AMAT, BASMAT, CSC, WR, SINGLR, REDBAS) ! !! SPLPDM is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPLPDM-S, DPLPDM-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS SUBPROGRAM IS FROM THE SPLP( ) PACKAGE. IT PERFORMS THE ! TASK OF DEFINING THE ENTRIES OF THE BASIS MATRIX AND ! DECOMPOSING IT USING THE LA05 PACKAGE. ! IT IS THE MAIN PART OF THE PROCEDURE (DECOMPOSE BASIS MATRIX). ! !***SEE ALSO SPLP !***ROUTINES CALLED LA05AS, PNNZRS, SASUM, XERMSG !***COMMON BLOCKS LA05DS !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890605 Corrected references to XERRWV. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls, changed do-it-yourself ! DO loops to DO loops. (RWC) !***END PROLOGUE SPLPDM INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) REAL AMAT(*),BASMAT(*),CSC(*),WR(*),ANORM,EPS,GG, & ONE,SMALL,UU,ZERO LOGICAL SINGLR,REDBAS CHARACTER*16 XERN3 ! ! COMMON BLOCK USED BY LA05 () PACKAGE.. COMMON /LA05DS/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL ! !***FIRST EXECUTABLE STATEMENT SPLPDM ZERO = 0.E0 ONE = 1.E0 ! ! DEFINE BASIS MATRIX BY COLUMNS FOR SPARSE MATRIX EQUATION SOLVER. ! THE LA05AS() SUBPROGRAM REQUIRES THE NONZERO ENTRIES OF THE MATRIX ! TOGETHER WITH THE ROW AND COLUMN INDICES. ! NZBM = 0 ! ! DEFINE DEPENDENT VARIABLE COLUMNS. THESE ARE ! COLS. OF THE IDENTITY MATRIX AND IMPLICITLY GENERATED. ! DO 20 K = 1,MRELAS J = IBASIS(K) if (J > NVARS) THEN NZBM = NZBM+1 if (IND(J) == 2) THEN BASMAT(NZBM) = ONE ELSE BASMAT(NZBM) = -ONE ENDIF IBRC(NZBM,1) = J-NVARS IBRC(NZBM,2) = K ELSE ! ! DEFINE THE INDEP. VARIABLE COLS. THIS REQUIRES RETRIEVING ! THE COLS. FROM THE SPARSE MATRIX DATA STRUCTURE. ! I = 0 10 call PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) if (I > 0) THEN NZBM = NZBM+1 BASMAT(NZBM) = AIJ*CSC(J) IBRC(NZBM,1) = I IBRC(NZBM,2) = K go to 10 ENDIF ENDIF 20 CONTINUE ! SINGLR = .FALSE. ! ! RECOMPUTE MATRIX NORM USING CRUDE NORM = SUM OF MAGNITUDES. ! ANORM = SASUM(NZBM,BASMAT,1) SMALL = EPS*ANORM ! ! GET AN L-U FACTORIZATION OF THE BASIS MATRIX. ! NREDC = NREDC+1 REDBAS = .TRUE. call LA05AS(BASMAT,IBRC,NZBM,LBM,MRELAS,IPR,IWR,WR,GG,UU) ! ! CHECK RETURN VALUE OF ERROR FLAG, GG. ! if (GG >= ZERO) RETURN if (GG == (-7.)) THEN call XERMSG ('SLATEC', 'SPLPDM', & 'IN SPLP, SHORT ON STORAGE FOR LA05AS. ' // & 'USE PRGOPT(*) TO GIVE MORE.', 28, IOPT) INFO = -28 ELSEIF (GG == (-5.)) THEN SINGLR = .TRUE. ELSE WRITE (XERN3, '(1PE15.6)') GG call XERMSG ('SLATEC', 'SPLPDM', & 'IN SPLP, LA05AS RETURNED ERROR FLAG = ' // XERN3, & 27, IOPT) INFO = -27 end if return end subroutine SPLP (USRMAT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, BL, & BU, IND, INFO, PRIMAL, DUALS, IBASIS, WORK, LW, IWORK, LIW) ! !! SPLP solves linear programming problems involving at most a few thousand ... ! constraints and variables. ! Takes advantage of sparsity in the constraint matrix. ! !***LIBRARY SLATEC !***CATEGORY G2A2 !***TYPE SINGLE PRECISION (SPLP-S, DSPLP-D) !***KEYWORDS LINEAR CONSTRAINTS, LINEAR OPTIMIZATION, ! LINEAR PROGRAMMING, LP, SPARSE CONSTRAINTS !***AUTHOR Hanson, R. J., (SNLA) ! Hiebert, K. L., (SNLA) !***DESCRIPTION ! ! These are the short usage instructions; for details about ! other features, options and methods for defining the matrix ! A, see the extended usage instructions which are contained in ! the Long Description section below. ! ! |------------| ! |Introduction| ! |------------| ! The subprogram SPLP( ) solves a linear optimization problem. ! The problem statement is as follows ! ! minimize (transpose of costs)*x ! subject to A*x=w. ! ! The entries of the unknowns x and w may have simple lower or ! upper bounds (or both), or be free to take on any value. By ! setting the bounds for x and w, the user is imposing the con- ! straints of the problem. The matrix A has MRELAS rows and ! NVARS columns. The vectors costs, x, and w respectively ! have NVARS, NVARS, and MRELAS number of entries. ! ! The input for the problem includes the problem dimensions, ! MRELAS and NVARS, the array COSTS(*), data for the matrix ! A, and the bound information for the unknowns x and w, BL(*), ! BU(*), and IND(*). Only the nonzero entries of the matrix A ! are passed to SPLP( ). ! ! The output from the problem (when output flag INFO=1) includes ! optimal values for x and w in PRIMAL(*), optimal values for ! dual variables of the equations A*x=w and the simple bounds ! on x in DUALS(*), and the indices of the basic columns, ! IBASIS(*). ! ! |------------------------------| ! |Fortran Declarations Required:| ! |------------------------------| ! ! DIMENSION COSTS(NVARS),PRGOPT(*),DATTRV(*), ! *BL(NVARS+MRELAS),BU(NVARS+MRELAS),IND(NVARS+MRELAS), ! *PRIMAL(NVARS+MRELAS),DUALS(MRELAS+NVARS),IBASIS(NVARS+MRELAS), ! *WORK(LW),IWORK(LIW) ! ! EXTERNAL USRMAT ! ! The dimensions of PRGOPT(*) and DATTRV(*) must be at least 1. ! The exact lengths will be determined by user-required options and ! data transferred to the subprogram USRMAT( ). ! ! The values of LW and LIW, the lengths of the arrays WORK(*) ! and IWORK(*), must satisfy the inequalities ! ! LW >= 4*NVARS+ 8*MRELAS+LAMAT+ LBM ! LIW >= NVARS+11*MRELAS+LAMAT+2*LBM ! ! It is an error if they do not both satisfy these inequalities. ! (The subprogram will inform the user of the required lengths ! if either LW or LIW is wrong.) The values of LAMAT and LBM ! nominally are ! ! LAMAT=4*NVARS+7 ! and LBM =8*MRELAS ! ! LAMAT determines the length of the sparse matrix storage area. ! The value of LBM determines the amount of storage available ! to decompose and update the active basis matrix. ! ! |------| ! |Input:| ! |------| ! ! MRELAS,NVARS ! ------------ ! These parameters are respectively the number of constraints (the ! linear relations A*x=w that the unknowns x and w are to satisfy) ! and the number of entries in the vector x. Both must be >= 1. ! Other values are errors. ! ! COSTS(*) ! -------- ! The NVARS entries of this array are the coefficients of the ! linear objective function. The value COSTS(J) is the ! multiplier for variable J of the unknown vector x. Each ! entry of this array must be defined. ! ! USRMAT ! ------ ! This is the name of a specific subprogram in the SPLP( ) package ! used to define the matrix A. In this usage mode of SPLP( ) ! the user places the nonzero entries of A in the ! array DATTRV(*) as given in the description of that parameter. ! The name USRMAT must appear in a Fortran EXTERNAL statement. ! ! DATTRV(*) ! --------- ! The array DATTRV(*) contains data for the matrix A as follows: ! Each column (numbered J) requires (floating point) data con- ! sisting of the value (-J) followed by pairs of values. Each pair ! consists of the row index immediately followed by the value ! of the matrix at that entry. A value of J=0 signals that there ! are no more columns. The required length of ! DATTRV(*) is 2*no. of nonzeros + NVARS + 1. ! ! BL(*),BU(*),IND(*) ! ------------------ ! The values of IND(*) are input parameters that define ! the form of the bounds for the unknowns x and w. The values for ! the bounds are found in the arrays BL(*) and BU(*) as follows. ! ! For values of J between 1 and NVARS, ! if IND(J)=1, then X(J) >= BL(J); BU(J) is not used. ! if IND(J)=2, then X(J) <= BU(J); BL(J) is not used. ! if IND(J)=3, then BL(J) <= X(J) <= BU(J),(BL(J)=BU(J) ok) ! if IND(J)=4, then X(J) is free to have any value, ! and BL(J), BU(J) are not used. ! ! For values of I between NVARS+1 and NVARS+MRELAS, ! if IND(I)=1, then W(I-NVARS) >= BL(I); BU(I) is not used. ! if IND(I)=2, then W(I-NVARS) <= BU(I); BL(I) is not used. ! if IND(I)=3, then BL(I) <= W(I-NVARS) <= BU(I), ! (BL(I)=BU(I) is ok). ! if IND(I)=4, then W(I-NVARS) is free to have any value, ! and BL(I), BU(I) are not used. ! ! A value of IND(*) not equal to 1,2,3 or 4 is an error. When ! IND(I)=3, BL(I) must be <= BU(I). The condition BL(I) > ! BU(I) indicates infeasibility and is an error. ! ! PRGOPT(*) ! --------- ! This array is used to redefine various parameters within SPLP( ). ! Frequently, perhaps most of the time, a user will be satisfied ! and obtain the solutions with no changes to any of these ! parameters. To try this, simply set PRGOPT(1)=1.E0. ! ! For users with more sophisticated needs, SPLP( ) provides several ! options that may be used to take advantage of more detailed ! knowledge of the problem or satisfy other utilitarian needs. ! The complete description of how to use this option array to ! utilize additional subprogram features is found under the ! heading of SPLP( ) Subprogram Options in the Extended ! Usage Instructions. ! ! Briefly, the user should note the following value of the parameter ! KEY and the corresponding task or feature desired before turning ! to that document. ! ! Value Brief Statement of Purpose for Option ! of KEY ! ------ ------------------------------------- ! 50 Change from a minimization problem to a ! maximization problem. ! 51 Change the amount of printed output. ! Normally, no printed output is obtained. ! 52 Redefine the line length and precision used ! for the printed output. ! 53 Redefine the values of LAMAT and LBM that ! were discussed above under the heading ! Fortran Declarations Required. ! 54 Redefine the unit number where pages of the sparse ! data matrix A are stored. Normally, the unit ! number is 1. ! 55 A computation, partially completed, is ! being continued. Read the up-to-date ! partial results from unit number 2. ! 56 Redefine the unit number where the partial results ! are stored. Normally, the unit number is 2. ! 57 Save partial results on unit 2 either after ! maximum iterations or at the optimum. ! 58 Redefine the value for the maximum number of ! iterations. Normally, the maximum number of ! iterations is 3*(NVARS+MRELAS). ! 59 Provide SPLP( ) with a starting (feasible) ! nonsingular basis. Normally, SPLP( ) starts ! with the identity matrix columns corresponding ! to the vector w. ! 60 The user has provided scale factors for the ! columns of A. Normally, SPLP( ) computes scale ! factors that are the reciprocals of the max. norm ! of each column. ! 61 The user has provided a scale factor ! for the vector costs. Normally, SPLP( ) computes ! a scale factor equal to the reciprocal of the ! max. norm of the vector costs after the column ! scaling for the data matrix has been applied. ! 62 Size parameters, namely the smallest and ! largest magnitudes of nonzero entries in ! the matrix A, are provided. Values noted ! outside this range are to be considered errors. ! 63 Redefine the tolerance required in ! evaluating residuals for feasibility. ! Normally, this value is set to RELPR, ! where RELPR = relative precision of the arithmetic. ! 64 Change the criterion for bringing new variables ! into the basis from the steepest edge (best ! local move) to the minimum reduced cost. ! 65 Redefine the value for the number of iterations ! between recalculating the error in the primal ! solution. Normally, this value is equal to ten. ! 66 Perform "partial pricing" on variable selection. ! Redefine the value for the number of negative ! reduced costs to compute (at most) when finding ! a variable to enter the basis. Normally this ! value is set to NVARS. This implies that no ! "partial pricing" is used. ! 67 Adjust the tuning factor (normally one) to apply ! to the primal and dual error estimates. ! 68 Pass information to the subprogram FULMAT(), ! provided with the SPLP() package, so that a Fortran ! two-dimensional array can be used as the argument ! DATTRV(*). ! 69 Pass an absolute tolerance to use for the feasibility ! test when the usual relative error test indicates ! infeasibility. The nominal value of this tolerance, ! TOLABS, is zero. ! ! ! |---------------| ! |Working Arrays:| ! |---------------| ! ! WORK(*),LW, ! IWORK(*),LIW ! ------------ ! The arrays WORK(*) and IWORK(*) are respectively floating point ! and type INTEGER working arrays for SPLP( ) and its ! subprograms. The lengths of these arrays are respectively ! LW and LIW. These parameters must satisfy the inequalities ! noted above under the heading "Fortran Declarations Required:" ! It is an error if either value is too small. ! ! |----------------------------| ! |Input/Output files required:| ! |----------------------------| ! ! Fortran unit 1 is used by SPLP( ) to store the sparse matrix A ! out of high-speed memory. A crude ! upper bound for the amount of information written on unit 1 ! is 6*nz, where nz is the number of nonzero entries in A. ! ! |-------| ! |Output:| ! |-------| ! ! INFO,PRIMAL(*),DUALS(*) ! ----------------------- ! The integer flag INFO indicates why SPLP( ) has returned to the ! user. If INFO=1 the solution has been computed. In this case ! X(J)=PRIMAL(J) and W(I)=PRIMAL(I+NVARS). The dual variables ! for the equations A*x=w are in the array DUALS(I)=dual for ! equation number I. The dual value for the component X(J) that ! has an upper or lower bound (or both) is returned in ! DUALS(J+MRELAS). The only other values for INFO are < 0. ! The meaning of these values can be found by reading ! the diagnostic message in the output file, or by looking for ! error number = (-INFO) in the Extended Usage Instructions ! under the heading: ! ! List of SPLP( ) Error and Diagnostic Messages. ! ! BL(*),BU(*),IND(*) ! ------------------ ! These arrays are output parameters only under the (unusual) ! circumstances where the stated problem is infeasible, has an ! unbounded optimum value, or both. These respective conditions ! correspond to INFO=-1,-2 or -3. See the Extended ! Usage Instructions for further details. ! ! IBASIS(I),I=1,...,MRELAS ! ------------------------ ! This array contains the indices of the variables that are ! in the active basis set at the solution (INFO=1). A value ! of IBASIS(I) between 1 and NVARS corresponds to the variable ! X(IBASIS(I)). A value of IBASIS(I) between NVARS+1 and NVARS+ ! MRELAS corresponds to the variable W(IBASIS(I)-NVARS). ! ! *Long Description: ! ! SUBROUTINE SPLP(USRMAT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, ! * BL,BU,IND,INFO,PRIMAL,DUALS,IBASIS,WORK,LW,IWORK,LIW) ! ! |------------| ! |Introduction| ! |------------| ! The subprogram SPLP( ) solves a linear optimization problem. ! The problem statement is as follows ! ! minimize (transpose of costs)*x ! subject to A*x=w. ! ! The entries of the unknowns x and w may have simple lower or ! upper bounds (or both), or be free to take on any value. By ! setting the bounds for x and w, the user is imposing the con- ! straints of the problem. ! ! (The problem may also be stated as a maximization ! problem. This is done by means of input in the option array ! PRGOPT(*).) The matrix A has MRELAS rows and NVARS columns. The ! vectors costs, x, and w respectively have NVARS, NVARS, and ! MRELAS number of entries. ! ! The input for the problem includes the problem dimensions, ! MRELAS and NVARS, the array COSTS(*), data for the matrix ! A, and the bound information for the unknowns x and w, BL(*), ! BU(*), and IND(*). ! ! The output from the problem (when output flag INFO=1) includes ! optimal values for x and w in PRIMAL(*), optimal values for ! dual variables of the equations A*x=w and the simple bounds ! on x in DUALS(*), and the indices of the basic columns in ! IBASIS(*). ! ! |------------------------------| ! |Fortran Declarations Required:| ! |------------------------------| ! ! DIMENSION COSTS(NVARS),PRGOPT(*),DATTRV(*), ! *BL(NVARS+MRELAS),BU(NVARS+MRELAS),IND(NVARS+MRELAS), ! *PRIMAL(NVARS+MRELAS),DUALS(MRELAS+NVARS),IBASIS(NVARS+MRELAS), ! *WORK(LW),IWORK(LIW) ! ! EXTERNAL USRMAT (or 'NAME', if user provides the subprogram) ! ! The dimensions of PRGOPT(*) and DATTRV(*) must be at least 1. ! The exact lengths will be determined by user-required options and ! data transferred to the subprogram USRMAT( ) ( or 'NAME'). ! ! The values of LW and LIW, the lengths of the arrays WORK(*) ! and IWORK(*), must satisfy the inequalities ! ! LW >= 4*NVARS+ 8*MRELAS+LAMAT+ LBM ! LIW >= NVARS+11*MRELAS+LAMAT+2*LBM ! ! It is an error if they do not both satisfy these inequalities. ! (The subprogram will inform the user of the required lengths ! if either LW or LIW is wrong.) The values of LAMAT and LBM ! nominally are ! ! LAMAT=4*NVARS+7 ! and LBM =8*MRELAS ! ! These values will be as shown unless the user changes them by ! means of input in the option array PRGOPT(*). The value of LAMAT ! determines the length of the sparse matrix "staging" area. ! For reasons of efficiency the user may want to increase the value ! of LAMAT. The value of LBM determines the amount of storage ! available to decompose and update the active basis matrix. ! Due to exhausting the working space because of fill-in, ! it may be necessary for the user to increase the value of LBM. ! (If this situation occurs an informative diagnostic is printed ! and a value of INFO=-28 is obtained as an output parameter.) ! ! |------| ! |Input:| ! |------| ! ! MRELAS,NVARS ! ------------ ! These parameters are respectively the number of constraints (the ! linear relations A*x=w that the unknowns x and w are to satisfy) ! and the number of entries in the vector x. Both must be >= 1. ! Other values are errors. ! ! COSTS(*) ! -------- ! The NVARS entries of this array are the coefficients of the ! linear objective function. The value COSTS(J) is the ! multiplier for variable J of the unknown vector x. Each ! entry of this array must be defined. This array can be changed ! by the user between restarts. See options with KEY=55,57 for ! details of checkpointing and restarting. ! ! USRMAT ! ------ ! This is the name of a specific subprogram in the SPLP( ) package ! that is used to define the matrix entries when this data is passed ! to SPLP( ) as a linear array. In this usage mode of SPLP( ) ! the user gives information about the nonzero entries of A ! in DATTRV(*) as given under the description of that parameter. ! The name USRMAT must appear in a Fortran EXTERNAL statement. ! Users who are passing the matrix data with USRMAT( ) can skip ! directly to the description of the input parameter DATTRV(*). ! Also see option 68 for passing the constraint matrix data using ! a standard Fortran two-dimensional array. ! ! If the user chooses to provide a subprogram 'NAME'( ) to ! define the matrix A, then DATTRV(*) may be used to pass floating ! point data from the user's program unit to the subprogram ! 'NAME'( ). The content of DATTRV(*) is not changed in any way. ! ! The subprogram 'NAME'( ) can be of the user's choice ! but it must meet Fortran standards and it must appear in a ! Fortran EXTERNAL statement. The first statement of the subprogram ! has the form ! ! SUBROUTINE 'NAME'(I,J,AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) ! ! The variables I,J, INDCAT, IFLAG(10) are type INTEGER, ! while AIJ, PRGOPT(*),DATTRV(*) are type REAL. ! ! The user interacts with the contents of IFLAG(*) to ! direct the appropriate action. The algorithmic steps are ! as follows. ! ! Test IFLAG(1). ! ! if ( IFLAG(1) == 1) THEN ! ! Initialize the necessary pointers and data ! for defining the matrix A. The contents ! of IFLAG(K), K=2,...,10, may be used for ! storage of the pointers. This array remains intact ! between calls to 'NAME'( ) by SPLP( ). ! return ! ! end if ! ! if ( IFLAG(1) == 2) THEN ! ! Define one set of values for I,J,AIJ, and INDCAT. ! Each nonzero entry of A must be defined this way. ! These values can be defined in any convenient order. ! (It is most efficient to define the data by ! columns in the order 1,...,NVARS; within each ! column define the entries in the order 1,...,MRELAS.) ! If this is the last matrix value to be ! defined or updated, then set IFLAG(1)=3. ! (When I and J are positive and respectively no larger ! than MRELAS and NVARS, the value of AIJ is used to ! define (or update) row I and column J of A.) ! return ! ! end if ! ! END ! ! Remarks: The values of I and J are the row and column ! indices for the nonzero entries of the matrix A. ! The value of this entry is AIJ. ! Set INDCAT=0 if this value defines that entry. ! Set INDCAT=1 if this entry is to be updated, ! new entry=old entry+AIJ. ! A value of I not between 1 and MRELAS, a value of J ! not between 1 and NVARS, or a value of INDCAT ! not equal to 0 or 1 are each errors. ! ! The contents of IFLAG(K), K=2,...,10, can be used to ! remember the status (of the process of defining the ! matrix entries) between calls to 'NAME'( ) by SPLP( ). ! On entry to 'NAME'( ), only the values 1 or 2 will be ! in IFLAG(1). More than 2*NVARS*MRELAS definitions of ! the matrix elements is considered an error because ! it suggests an infinite loop in the user-written ! subprogram 'NAME'( ). Any matrix element not ! provided by 'NAME'( ) is defined to be zero. ! ! The REAL arrays PRGOPT(*) and DATTRV(*) are passed as ! arguments directly from SPLP( ) to 'NAME'( ). ! The array PRGOPT(*) contains any user-defined program ! options. In this usage mode the array DATTRV(*) may ! now contain any (type REAL) data that the user needs ! to define the matrix A. Both arrays PRGOPT(*) and ! DATTRV(*) remain intact between calls to 'NAME'( ) ! by SPLP( ). ! Here is a subprogram that communicates the matrix values for A, ! as represented in DATTRV(*), to SPLP( ). This subprogram, ! called USRMAT( ), is included as part of the SPLP( ) package. ! This subprogram 'decodes' the array DATTRV(*) and defines the ! nonzero entries of the matrix A for SPLP( ) to store. This ! listing is presented here as a guide and example ! for the users who find it necessary to write their own subroutine ! for this purpose. The contents of DATTRV(*) are given below in ! the description of that parameter. ! ! SUBROUTINE USRMAT(I,J,AIJ, INDCAT,PRGOPT,DATTRV,IFLAG) ! DIMENSION PRGOPT(*),DATTRV(*),IFLAG(10) ! ! if ( IFLAG(1) == 1) THEN ! ! THIS IS THE INITIALIZATION STEP. THE VALUES OF IFLAG(K),K=2,3,4, ! ARE RESPECTIVELY THE COLUMN INDEX, THE ROW INDEX (OR THE NEXT COL. ! INDEX), AND THE POINTER TO THE MATRIX ENTRY'S VALUE WITHIN ! DATTRV(*). ALSO CHECK (DATTRV(1)=0.) SIGNIFYING NO DATA. ! if ( DATTRV(1) == 0.) THEN ! I = 0 ! J = 0 ! IFLAG(1) = 3 ! ELSE ! IFLAG(2)=-DATTRV(1) ! IFLAG(3)= DATTRV(2) ! IFLAG(4)= 3 ! end if ! ! return ! ELSE ! J=IFLAG(2) ! I=IFLAG(3) ! L=IFLAG(4) ! if ( I == 0) THEN ! ! SIGNAL THAT ALL OF THE NONZERO ENTRIES HAVE BEEN DEFINED. ! IFLAG(1)=3 ! return ! ELSE if ( I < 0) THEN ! ! SIGNAL THAT A SWITCH IS MADE TO A NEW COLUMN. ! J=-I ! I=DATTRV(L) ! L=L+1 ! end if ! ! AIJ=DATTRV(L) ! ! UPDATE THE INDICES AND POINTERS FOR THE NEXT ENTRY. ! IFLAG(2)=J ! IFLAG(3)=DATTRV(L+1) ! IFLAG(4)=L+2 ! ! INDCAT=0 DENOTES THAT ENTRIES OF THE MATRIX ARE ASSIGNED THE ! VALUES FROM DATTRV(*). NO ACCUMULATION IS PERFORMED. ! INDCAT=0 ! return ! end if ! END ! ! DATTRV(*) ! --------- ! If the user chooses to use the provided subprogram USRMAT( ) then ! the array DATTRV(*) contains data for the matrix A as follows: ! Each column (numbered J) requires (floating point) data con- ! sisting of the value (-J) followed by pairs of values. Each pair ! consists of the row index immediately followed by the value ! of the matrix at that entry. A value of J=0 signals that there ! are no more columns. (See "Example of SPLP( ) Usage," below.) ! The dimension of DATTRV(*) must be 2*no. of nonzeros ! + NVARS + 1 in this usage. No checking of the array ! length is done by the subprogram package. ! ! If the Save/Restore feature is in use (see options with ! KEY=55,57 for details of checkpointing and restarting) ! USRMAT( ) can be used to redefine entries of the matrix. ! The matrix entries are redefined or overwritten. No accum- ! ulation is performed. ! Any other nonzero entry of A, defined in a previous call to ! SPLP( ), remain intact. ! ! BL(*),BU(*),IND(*) ! ------------------ ! The values of IND(*) are input parameters that define ! the form of the bounds for the unknowns x and w. The values for ! the bounds are found in the arrays BL(*) and BU(*) as follows. ! ! For values of J between 1 and NVARS, ! if IND(J)=1, then X(J) >= BL(J); BU(J) is not used. ! if IND(J)=2, then X(J) <= BU(J); BL(J) is not used. ! if IND(J)=3, then BL(J) <= X(J) <= BU(J),(BL(J)=BU(J) ok) ! if IND(J)=4, then X(J) is free to have any value, ! and BL(J), BU(J) are not used. ! ! For values of I between NVARS+1 and NVARS+MRELAS, ! if IND(I)=1, then W(I-NVARS) >= BL(I); BU(I) is not used. ! if IND(I)=2, then W(I-NVARS) <= BU(I); BL(I) is not used. ! if IND(I)=3, then BL(I) <= W(I-NVARS) <= BU(I), ! (BL(I)=BU(I) is ok). ! if IND(I)=4, then W(I-NVARS) is free to have any value, ! and BL(I), BU(I) are not used. ! ! A value of IND(*) not equal to 1,2,3 or 4 is an error. When ! IND(I)=3, BL(I) must be <= BU(I). The condition BL(I) > ! BU(I) indicates infeasibility and is an error. These ! arrays can be changed by the user between restarts. See ! options with KEY=55,57 for details of checkpointing and ! restarting. ! ! PRGOPT(*) ! --------- ! This array is used to redefine various parameters within SPLP( ). ! Frequently, perhaps most of the time, a user will be satisfied ! and obtain the solutions with no changes to any of these ! parameters. To try this, simply set PRGOPT(1)=1.E0. ! ! For users with more sophisticated needs, SPLP( ) provides several ! options that may be used to take advantage of more detailed ! knowledge of the problem or satisfy other utilitarian needs. ! The complete description of how to use this option array to ! utilize additional subprogram features is found under the ! heading "Usage of SPLP( ) Subprogram Options." ! ! Briefly, the user should note the following value of the parameter ! KEY and the corresponding task or feature desired before turning ! to that section. ! ! Value Brief Statement of Purpose for Option ! of KEY ! ------ ------------------------------------- ! 50 Change from a minimization problem to a ! maximization problem. ! 51 Change the amount of printed output. ! Normally, no printed output is obtained. ! 52 Redefine the line length and precision used ! for the printed output. ! 53 Redefine the values of LAMAT and LBM that ! were discussed above under the heading ! Fortran Declarations Required. ! 54 Redefine the unit number where pages of the sparse ! data matrix A are stored. Normally, the unit ! number is 1. ! 55 A computation, partially completed, is ! being continued. Read the up-to-date ! partial results from unit number 2. ! 56 Redefine the unit number where the partial results ! are stored. Normally, the unit number is 2. ! 57 Save partial results on unit 2 either after ! maximum iterations or at the optimum. ! 58 Redefine the value for the maximum number of ! iterations. Normally, the maximum number of ! iterations is 3*(NVARS+MRELAS). ! 59 Provide SPLP( ) with a starting (feasible) ! nonsingular basis. Normally, SPLP( ) starts ! with the identity matrix columns corresponding ! to the vector w. ! 60 The user has provided scale factors for the ! columns of A. Normally, SPLP( ) computes scale ! factors that are the reciprocals of the max. norm ! of each column. ! 61 The user has provided a scale factor ! for the vector costs. Normally, SPLP( ) computes ! a scale factor equal to the reciprocal of the ! max. norm of the vector costs after the column ! scaling for the data matrix has been applied. ! 62 Size parameters, namely the smallest and ! largest magnitudes of nonzero entries in ! the matrix A, are provided. Values noted ! outside this range are to be considered errors. ! 63 Redefine the tolerance required in ! evaluating residuals for feasibility. ! Normally, this value is set to the value RELPR, ! where RELPR = relative precision of the arithmetic. ! 64 Change the criterion for bringing new variables ! into the basis from the steepest edge (best ! local move) to the minimum reduced cost. ! 65 Redefine the value for the number of iterations ! between recalculating the error in the primal ! solution. Normally, this value is equal to ten. ! 66 Perform "partial pricing" on variable selection. ! Redefine the value for the number of negative ! reduced costs to compute (at most) when finding ! a variable to enter the basis. Normally this ! value is set to NVARS. This implies that no ! "partial pricing" is used. ! 67 Adjust the tuning factor (normally one) to apply ! to the primal and dual error estimates. ! 68 Pass information to the subprogram FULMAT(), ! provided with the SPLP() package, so that a Fortran ! two-dimensional array can be used as the argument ! DATTRV(*). ! 69 Pass an absolute tolerance to use for the feasibility ! test when the usual relative error test indicates ! infeasibility. The nominal value of this tolerance, ! TOLABS, is zero. ! ! ! |---------------| ! |Working Arrays:| ! |---------------| ! ! WORK(*),LW, ! IWORK(*),LIW ! ------------ ! The arrays WORK(*) and IWORK(*) are respectively floating point ! and type INTEGER working arrays for SPLP( ) and its ! subprograms. The lengths of these arrays are respectively ! LW and LIW. These parameters must satisfy the inequalities ! noted above under the heading "Fortran Declarations Required." ! It is an error if either value is too small. ! ! |----------------------------| ! |Input/Output files required:| ! |----------------------------| ! ! Fortran unit 1 is used by SPLP( ) to store the sparse matrix A ! out of high-speed memory. This direct access file is opened ! within the package under the following two conditions. ! 1. When the Save/Restore feature is used. 2. When the ! constraint matrix is so large that storage out of high-speed ! memory is required. The user may need to close unit 1 ! (with deletion from the job step) in the main program unit ! when several calls are made to SPLP( ). A crude ! upper bound for the amount of information written on unit 1 ! is 6*nz, where nz is the number of nonzero entries in A. ! The unit number may be redefined to any other positive value ! by means of input in the option array PRGOPT(*). ! ! Fortran unit 2 is used by SPLP( ) only when the Save/Restore ! feature is desired. Normally this feature is not used. It is ! activated by means of input in the option array PRGOPT(*). ! On some computer systems the user may need to open unit ! 2 before executing a call to SPLP( ). This file is type ! sequential and is unformatted. ! ! Fortran unit=I1MACH(2) (check local setting) is used by SPLP( ) ! when the printed output feature (KEY=51) is used. Normally ! this feature is not used. It is activated by input in the ! options array PRGOPT(*). For many computer systems I1MACH(2)=6. ! ! |-------| ! |Output:| ! |-------| ! ! INFO,PRIMAL(*),DUALS(*) ! ----------------------- ! The integer flag INFO indicates why SPLP( ) has returned to the ! user. If INFO=1 the solution has been computed. In this case ! X(J)=PRIMAL(J) and W(I)=PRIMAL(I+NVARS). The dual variables ! for the equations A*x=w are in the array DUALS(I)=dual for ! equation number I. The dual value for the component X(J) that ! has an upper or lower bound (or both) is returned in ! DUALS(J+MRELAS). The only other values for INFO are < 0. ! The meaning of these values can be found by reading ! the diagnostic message in the output file, or by looking for ! error number = (-INFO) under the heading "List of SPLP( ) Error ! and Diagnostic Messages." ! The diagnostic messages are printed using the error processing ! subprogram XERMSG( ) with error category LEVEL=1. ! See the document "Brief Instr. for Using the Sandia Math. ! Subroutine Library," SAND79-2382, Nov., 1980, for further inform- ! ation about resetting the usual response to a diagnostic message. ! ! BL(*),BU(*),IND(*) ! ------------------ ! These arrays are output parameters only under the (unusual) ! circumstances where the stated problem is infeasible, has an ! unbounded optimum value, or both. These respective conditions ! correspond to INFO=-1,-2 or -3. For INFO=-1 or -3 certain comp- ! onents of the vectors x or w will not satisfy the input bounds. ! If component J of X or component I of W does not satisfy its input ! bound because of infeasibility, then IND(J)=-4 or IND(I+NVARS)=-4, ! respectively. For INFO=-2 or -3 certain ! components of the vector x could not be used as basic variables ! because the objective function would have become unbounded. ! In particular if component J of x corresponds to such a variable, ! then IND(J)=-3. Further, if the input value of IND(J) ! =1, then BU(J)=BL(J); ! =2, then BL(J)=BU(J); ! =4, then BL(J)=0.,BU(J)=0. ! ! (The J-th variable in x has been restricted to an appropriate ! feasible value.) ! The negative output value for IND(*) allows the user to identify ! those constraints that are not satisfied or those variables that ! would cause unbounded values of the objective function. Note ! that the absolute value of IND(*), together with BL(*) and BU(*), ! are valid input to SPLP( ). In the case of infeasibility the ! sum of magnitudes of the infeasible values is minimized. Thus ! one could reenter SPLP( ) with these components of x or w now ! fixed at their present values. This involves setting ! the appropriate components of IND(*) = 3, and BL(*) = BU(*). ! ! IBASIS(I),I=1,...,MRELAS ! ------------------------ ! This array contains the indices of the variables that are ! in the active basis set at the solution (INFO=1). A value ! of IBASIS(I) between 1 and NVARS corresponds to the variable ! X(IBASIS(I)). A value of IBASIS(I) between NVARS+1 and NVARS+ ! MRELAS corresponds to the variable W(IBASIS(I)-NVARS). ! ! Computing with the Matrix A after Calling SPLP( ) ! ------------------------------------------------- ! Following the return from SPLP( ), nonzero entries of the MRELAS ! by NVARS matrix A are available for usage by the user. The method ! for obtaining the next nonzero in column J with a row index ! strictly greater than I in value, is completed by executing ! ! call PNNZRS(I,AIJ,IPLACE,WORK,IWORK,J) ! ! The value of I is also an output parameter. If I <= 0 on output, ! then there are no more nonzeroes in column J. If I > 0, the ! output value for component number I of column J is in AIJ. The ! parameters WORK(*) and IWORK(*) are the same arguments as in the ! call to SPLP( ). The parameter IPLACE is a single INTEGER ! working variable. ! ! The data structure used for storage of the matrix A within SPLP( ) ! corresponds to sequential storage by columns as defined in ! SAND78-0785. Note that the names of the subprograms LNNZRS(), ! LCHNGS(),LINITM(),LLOC(),LRWPGE(), and LRWVIR() have been ! changed to PNNZRS(),PCHNGS(),PINITM(),IPLOC(),PRWPGE(), and ! PRWVIR() respectively. The error processing subprogram LERROR() ! is no longer used; XERMSG() is used instead. ! ! |-------------------------------| ! |Subprograms Required by SPLP( )| ! |-------------------------------| ! Called by SPLP() are SPLPMN(),SPLPUP(),SPINIT(),SPOPT(), ! SPLPDM(),SPLPCE(),SPINCW(),SPLPFL(), ! SPLPFE(),SPLPMU(). ! ! Error Processing Subprograms XERMSG(),I1MACH(),R1MACH() ! ! Sparse Matrix Subprograms PNNZRS(),PCHNGS(),PRWPGE(),PRWVIR(), ! PINITM(),IPLOC() ! ! Mass Storage File Subprograms SOPENM(),SCLOSM(),SREADP(),SWRITP() ! ! Basic Linear Algebra Subprograms SCOPY(),SASUM(),SDOT() ! ! Sparse Matrix Basis Handling Subprograms LA05AS(),LA05BS(), ! LA05CS(),LA05ED(),MC20AS() ! ! Vector Output Subprograms SVOUT(),IVOUT() ! ! Machine-sensitive Subprograms I1MACH( ),R1MACH( ), ! SOPENM(),SCLOSM(),SREADP(),SWRITP(). ! COMMON Block Used ! ----------------- ! /LA05DS/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL ! See the document AERE-R8269 for further details. ! |------------------------| ! |Example of SPLP( ) Usage| ! |------------------------| ! PROGRAM LPEX ! THE OPTIMIZATION PROBLEM IS TO FIND X1, X2, X3 THAT ! MINIMIZE X1 + X2 + X3, X1 >= 0, X2 >= 0, X3 UNCONSTRAINED. ! ! THE UNKNOWNS X1,X2,X3 ARE TO SATISFY CONSTRAINTS ! ! X1 -3*X2 +4*X3 = 5 ! X1 -2*X2 <= 3 ! 2*X2 - X3 >= 4 ! ! WE FIRST DEFINE THE DEPENDENT VARIABLES ! W1=X1 -3*X2 +4*X3 ! W2=X1- 2*X2 ! W3= 2*X2 -X3 ! ! WE NOW SHOW HOW TO USE SPLP( ) TO SOLVE THIS LINEAR OPTIMIZATION ! PROBLEM. EACH REQUIRED STEP WILL BE SHOWN IN THIS EXAMPLE. ! DIMENSION COSTS(03),PRGOPT(01),DATTRV(18),BL(06),BU(06),IND(06), ! *PRIMAL(06),DUALS(06),IBASIS(06),WORK(079),IWORK(103) ! ! EXTERNAL USRMAT ! MRELAS=3 ! NVARS=3 ! ! DEFINE THE ARRAY COSTS(*) FOR THE OBJECTIVE FUNCTION. ! COSTS(01)=1. ! COSTS(02)=1. ! COSTS(03)=1. ! ! PLACE THE NONZERO INFORMATION ABOUT THE MATRIX IN DATTRV(*). ! DEFINE COL. 1: ! DATTRV(01)=-1 ! DATTRV(02)=1 ! DATTRV(03)=1. ! DATTRV(04)=2 ! DATTRV(05)=1. ! ! DEFINE COL. 2: ! DATTRV(06)=-2 ! DATTRV(07)=1 ! DATTRV(08)=-3. ! DATTRV(09)=2 ! DATTRV(10)=-2. ! DATTRV(11)=3 ! DATTRV(12)=2. ! ! DEFINE COL. 3: ! DATTRV(13)=-3 ! DATTRV(14)=1 ! DATTRV(15)=4. ! DATTRV(16)=3 ! DATTRV(17)=-1. ! ! DATTRV(18)=0 ! ! CONSTRAIN X1,X2 TO BE NONNEGATIVE. LET X3 HAVE NO BOUNDS. ! BL(1)=0. ! IND(1)=1 ! BL(2)=0. ! IND(2)=1 ! IND(3)=4 ! ! CONSTRAIN W1=5,W2 <= 3, AND W3 >= 4. ! BL(4)=5. ! BU(4)=5. ! IND(4)=3 ! BU(5)=3. ! IND(5)=2 ! BL(6)=4. ! IND(6)=1 ! ! INDICATE THAT NO MODIFICATIONS TO OPTIONS ARE IN USE. ! PRGOPT(01)=1 ! ! DEFINE THE WORKING ARRAY LENGTHS. ! LW=079 ! LIW=103 ! call SPLP(USRMAT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, ! *BL,BU,IND,INFO,PRIMAL,DUALS,IBASIS,WORK,LW,IWORK,LIW) ! ! CALCULATE VAL, THE MINIMAL VALUE OF THE OBJECTIVE FUNCTION. ! VAL=SDOT(NVARS,COSTS,1,PRIMAL,1) ! ! STOP ! END ! |------------------------| ! |End of Example of Usage | ! |------------------------| ! ! |------------------------------------| ! |Usage of SPLP( ) Subprogram Options.| ! |------------------------------------| ! ! Users frequently have a large variety of requirements for linear ! optimization software. Allowing for these varied requirements ! is at cross purposes with the desire to keep the usage of SPLP( ) ! as simple as possible. One solution to this dilemma is as follows. ! (1) Provide a version of SPLP( ) that solves a wide class of ! problems and is easy to use. (2) Identify parameters within SPLP() ! that certain users may want to change. (3) Provide a means ! of changing any selected number of these parameters that does ! not require changing all of them. ! ! Changing selected parameters is done by requiring ! that the user provide an option array, PRGOPT(*), to SPLP( ). ! The contents of PRGOPT(*) inform SPLP( ) of just those options ! that are going to be modified within the total set of possible ! parameters that can be modified. The array PRGOPT(*) is a linked ! list consisting of groups of data of the following form ! ! LINK ! KEY ! SWITCH ! data set ! ! that describe the desired options. The parameters LINK, KEY and ! switch are each one word and are always required. The data set ! can be comprised of several words or can be empty. The number of ! words in the data set for each option depends on the value of ! the parameter KEY. ! ! The value of LINK points to the first entry of the next group ! of data within PRGOPT(*). The exception is when there are no more ! options to change. In that case, LINK=1 and the values for KEY, ! SWITCH and data set are not referenced. The general layout of ! PRGOPT(*) is as follows: ! ...PRGOPT(1)=LINK1 (link to first entry of next group) ! . PRGOPT(2)=KEY1 (KEY to the option change) ! . PRGOPT(3)=SWITCH1 (on/off switch for the option) ! . PRGOPT(4)=data value ! . . ! . . ! . . ! ...PRGOPT(LINK1)=LINK2 (link to first entry of next group) ! . PRGOPT(LINK1+1)=KEY2 (KEY to option change) ! . PRGOPT(LINK1+2)=SWITCH2 (on/off switch for the option) ! . PRGOPT(LINK1+3)=data value ! ... . ! . . ! . . ! ...PRGOPT(LINK)=1 (no more options to change) ! ! A value of LINK that is <= 0 or > 10000 is an error. ! In this case SPLP( ) returns with an error message, INFO=-14. ! This helps prevent using invalid but positive values of LINK that ! will probably extend beyond the program limits of PRGOPT(*). ! Unrecognized values of KEY are ignored. If the value of SWITCH is ! zero then the option is turned off. For any other value of SWITCH ! the option is turned on. This is used to allow easy changing of ! options without rewriting PRGOPT(*). The order of the options is ! arbitrary and any number of options can be changed with the ! following restriction. To prevent cycling in processing of the ! option array PRGOPT(*), a count of the number of options changed ! is maintained. Whenever this count exceeds 1000 an error message ! (INFO=-15) is printed and the subprogram returns. ! ! In the following description of the options, the value of ! LATP indicates the amount of additional storage that a particular ! option requires. The sum of all of these values (plus one) is ! the minimum dimension for the array PRGOPT(*). ! ! If a user is satisfied with the nominal form of SPLP( ), ! set PRGOPT(1)=1 (or PRGOPT(1)=1.E0). ! ! Options: ! ! -----KEY = 50. Change from a minimization problem to a maximization ! problem. ! If SWITCH=0 option is off; solve minimization problem. ! =1 option is on; solve maximization problem. ! data set =empty ! LATP=3 ! ! -----KEY = 51. Change the amount of printed output. The nominal form ! of SPLP( ) has no printed output. ! The first level of output (SWITCH=1) includes ! ! (1) Minimum dimensions for the arrays COSTS(*),BL(*),BU(*),IND(*), ! PRIMAL(*),DUALS(*),IBASIS(*), and PRGOPT(*). ! (2) Problem dimensions MRELAS,NVARS. ! (3) The types of and values for the bounds on x and w, ! and the values of the components of the vector costs. ! (4) Whether optimization problem is minimization or ! maximization. ! (5) Whether steepest edge or smallest reduced cost criteria used ! for exchanging variables in the revised simplex method. ! ! Whenever a solution has been found, (INFO=1), ! ! (6) the value of the objective function, ! (7) the values of the vectors x and w, ! (8) the dual variables for the constraints A*x=w and the ! bounded components of x, ! (9) the indices of the basic variables, ! (10) the number of revised simplex method iterations, ! (11) the number of full decompositions of the basis matrix. ! ! The second level of output (SWITCH=2) includes all for SWITCH=1 ! plus ! ! (12) the iteration number, ! (13) the column number to enter the basis, ! (14) the column number to leave the basis, ! (15) the length of the step taken. ! ! The third level of output (SWITCH=3) includes all for SWITCH=2 ! plus ! (16) critical quantities required in the revised simplex method. ! This output is rather voluminous. It is intended to be used ! as a diagnostic tool in case of a failure in SPLP( ). ! ! If SWITCH=0 option is off; no printed output. ! =1 summary output. ! =2 lots of output. ! =3 even more output. ! data set =empty ! LATP=3 ! ! -----KEY = 52. Redefine the parameter, IDIGIT, which determines the ! format and precision used for the printed output. In the printed ! output, at least ABS(IDIGIT) decimal digits per number is printed. ! If IDIGIT < 0, 72 printing columns are used. if IDIGIT > 0, 133 ! printing columns are used. ! If SWITCH=0 option is off; IDIGIT=-4. ! =1 option is on. ! data set =IDIGIT ! LATP=4 ! ! -----KEY = 53. Redefine LAMAT and LBM, the lengths of the portions of ! WORK(*) and IWORK(*) that are allocated to the sparse matrix ! storage and the sparse linear equation solver, respectively. ! LAMAT must be >= NVARS+7 and LBM must be positive. ! If SWITCH=0 option is off; LAMAT=4*NVARS+7 ! LBM =8*MRELAS. ! =1 option is on. ! data set =LAMAT ! LBM ! LATP=5 ! ! -----KEY = 54. Redefine IPAGEF, the file number where the pages of the ! sparse data matrix are stored. IPAGEF must be positive and ! different from ISAVE (see option 56). ! If SWITCH=0 option is off; IPAGEF=1. ! =1 option is on. ! data set =IPAGEF ! LATP=4 ! ! -----KEY = 55. Partial results have been computed and stored on unit ! number ISAVE (see option 56), during a previous run of ! SPLP( ). This is a continuation from these partial results. ! The arrays COSTS(*),BL(*),BU(*),IND(*) do not have to have ! the same values as they did when the checkpointing occurred. ! This feature makes it possible for the user to do certain ! types of parameter studies such as changing costs and varying ! the constraints of the problem. This file is rewound both be- ! fore and after reading the partial results. ! If SWITCH=0 option is off; start a new problem. ! =1 option is on; continue from partial results ! that are stored in file ISAVE. ! data set = empty ! LATP=3 ! ! -----KEY = 56. Redefine ISAVE, the file number where the partial ! results are stored (see option 57). ISAVE must be positive and ! different from IPAGEF (see option 54). ! If SWITCH=0 option is off; ISAVE=2. ! =1 option is on. ! data set =ISAVE ! LATP=4 ! ! -----KEY = 57. Save the partial results after maximum number of ! iterations, MAXITR, or at the optimum. When this option is on, ! data essential to continuing the calculation is saved on a file ! using a Fortran binary write operation. The data saved includes ! all the information about the sparse data matrix A. Also saved ! is information about the current basis. Nominally the partial ! results are saved on Fortran unit 2. This unit number can be ! redefined (see option 56). If the save option is on, ! this file must be opened (or declared) by the user prior to the ! call to SPLP( ). A crude upper bound for the number of words ! written to this file is 6*nz. Here nz= number of nonzeros in A. ! If SWITCH=0 option is off; do not save partial results. ! =1 option is on; save partial results. ! data set = empty ! LATP=3 ! ! -----KEY = 58. Redefine the maximum number of iterations, MAXITR, to ! be taken before returning to the user. ! If SWITCH=0 option is off; MAXITR=3*(NVARS+MRELAS). ! =1 option is on. ! data set =MAXITR ! LATP=4 ! ! -----KEY = 59. Provide SPLP( ) with exactly MRELAS indices which ! comprise a feasible, nonsingular basis. The basis must define a ! feasible point: values for x and w such that A*x=w and all the ! stated bounds on x and w are satisfied. The basis must also be ! nonsingular. The failure of either condition will cause an error ! message (INFO=-23 or =-24, respectively). Normally, SPLP( ) uses ! identity matrix columns which correspond to the components of w. ! This option would normally not be used when restarting from ! a previously saved run (KEY=57). ! In numbering the unknowns, ! the components of x are numbered (1-NVARS) and the components ! of w are numbered (NVARS+1)-(NVARS+MRELAS). A value for an ! index <= 0 or > (NVARS+MRELAS) is an error (INFO=-16). ! If SWITCH=0 option is off; SPLP( ) chooses the initial basis. ! =1 option is on; user provides the initial basis. ! data set =MRELAS indices of basis; order is arbitrary. ! LATP=MRELAS+3 ! ! -----KEY = 60. Provide the scale factors for the columns of the data ! matrix A. Normally, SPLP( ) computes the scale factors as the ! reciprocals of the max. norm of each column. ! If SWITCH=0 option is off; SPLP( ) computes the scale factors. ! =1 option is on; user provides the scale factors. ! data set =scaling for column J, J=1,NVARS; order is sequential. ! LATP=NVARS+3 ! ! -----KEY = 61. Provide a scale factor, COSTSC, for the vector of ! costs. Normally, SPLP( ) computes this scale factor to be the ! reciprocal of the max. norm of the vector costs after the column ! scaling has been applied. ! If SWITCH=0 option is off; SPLP( ) computes COSTSC. ! =1 option is on; user provides COSTSC. ! data set =COSTSC ! LATP=4 ! ! -----KEY = 62. Provide size parameters, ASMALL and ABIG, the smallest ! and largest magnitudes of nonzero entries in the data matrix A, ! respectively. When this option is on, SPLP( ) will check the ! nonzero entries of A to see if they are in the range of ASMALL and ! ABIG. If an entry of A is not within this range, SPLP( ) returns ! an error message, INFO=-22. Both ASMALL and ABIG must be positive ! with ASMALL <= ABIG. Otherwise, an error message is returned, ! INFO=-17. ! If SWITCH=0 option is off; no checking of the data matrix is done ! =1 option is on; checking is done. ! data set =ASMALL ! ABIG ! LATP=5 ! ! -----KEY = 63. Redefine the relative tolerance, TOLLS, used in ! checking if the residuals are feasible. Normally, ! TOLLS=RELPR, where RELPR is the machine precision. ! If SWITCH=0 option is off; TOLLS=RELPR. ! =1 option is on. ! data set =TOLLS ! LATP=4 ! ! -----KEY = 64. Use the minimum reduced cost pricing strategy to choose ! columns to enter the basis. Normally, SPLP( ) uses the steepest ! edge pricing strategy which is the best local move. The steepest ! edge pricing strategy generally uses fewer iterations than the ! minimum reduced cost pricing, but each iteration costs more in the ! number of calculations done. The steepest edge pricing is ! considered to be more efficient. However, this is very problem ! dependent. That is why SPLP( ) provides the option of either ! pricing strategy. ! If SWITCH=0 option is off; steepest option edge pricing is used. ! =1 option is on; minimum reduced cost pricing is used. ! data set =empty ! LATP=3 ! ! -----KEY = 65. Redefine MXITBR, the number of iterations between ! recalculating the error in the primal solution. Normally, MXITBR ! is set to 10. The error in the primal solution is used to monitor ! the error in solving the linear system. This is an expensive ! calculation and every tenth iteration is generally often enough. ! If SWITCH=0 option is off; MXITBR=10. ! =1 option is on. ! data set =MXITBR ! LATP=4 ! ! -----KEY = 66. Redefine NPP, the number of negative reduced costs ! (at most) to be found at each iteration of choosing ! a variable to enter the basis. Normally NPP is set ! to NVARS which implies that all of the reduced costs ! are computed at each such step. This "partial ! pricing" may very well increase the total number ! of iterations required. However it decreases the ! number of calculations at each iteration. ! therefore the effect on overall efficiency is quite ! problem-dependent. ! ! if SWITCH=0 option is off; NPP=NVARS ! =1 option is on. ! data set =NPP ! LATP=4 ! ! -----KEY = 67. Redefine the tuning factor (PHI) used to scale the ! error estimates for the primal and dual linear algebraic systems ! of equations. Normally, PHI = 1.E0, but in some environments it ! may be necessary to reset PHI to the range 0.001-0.01. This is ! particularly important for machines with short word lengths. ! ! if SWITCH = 0 option is off; PHI=1.E0. ! = 1 option is on. ! Data Set = PHI ! LATP=4 ! ! -----KEY = 68. Used together with the subprogram FULMAT(), provided ! with the SPLP() package, for passing a standard Fortran two- ! dimensional array containing the constraint matrix. Thus the sub- ! program FULMAT must be declared in a Fortran EXTERNAL statement. ! The two-dimensional array is passed as the argument DATTRV. ! The information about the array and problem dimensions are passed ! in the option array PRGOPT(*). It is an error if FULMAT() is ! used and this information is not passed in PRGOPT(*). ! ! if SWITCH = 0 option is off; this is an error is FULMAT() is ! used. ! = 1 option is on. ! Data Set = IA = row dimension of two-dimensional array. ! MRELAS = number of constraint equations. ! NVARS = number of dependent variables. ! LATP = 6 ! -----KEY = 69. Normally a relative tolerance (TOLLS, see option 63) ! is used to decide if the problem is feasible. If this test fails ! an absolute test will be applied using the value TOLABS. ! Nominally TOLABS = zero. ! If SWITCH = 0 option is off; TOLABS = zero. ! = 1 option is on. ! Data set = TOLABS ! LATP = 4 ! ! |-----------------------------| ! |Example of Option array Usage| ! |-----------------------------| ! To illustrate the usage of the option array, let us suppose that ! the user has the following nonstandard requirements: ! ! a) Wants to change from minimization to maximization problem. ! b) Wants to limit the number of simplex steps to 100. ! c) Wants to save the partial results after 100 steps on ! Fortran unit 2. ! ! After these 100 steps are completed the user wants to continue the ! problem (until completed) using the partial results saved on ! Fortran unit 2. Here are the entries of the array PRGOPT(*) ! that accomplish these tasks. (The definitions of the other ! required input parameters are not shown.) ! ! CHANGE TO A MAXIMIZATION PROBLEM; KEY=50. ! PRGOPT(01)=4 ! PRGOPT(02)=50 ! PRGOPT(03)=1 ! ! LIMIT THE NUMBER OF SIMPLEX STEPS TO 100; KEY=58. ! PRGOPT(04)=8 ! PRGOPT(05)=58 ! PRGOPT(06)=1 ! PRGOPT(07)=100 ! ! SAVE THE PARTIAL RESULTS, AFTER 100 STEPS, ON FORTRAN ! UNIT 2; KEY=57. ! PRGOPT(08)=11 ! PRGOPT(09)=57 ! PRGOPT(10)=1 ! ! NO MORE OPTIONS TO CHANGE. ! PRGOPT(11)=1 ! The user makes the call statement for SPLP( ) at this point. ! Now to restart, using the partial results after 100 steps, define ! new values for the array PRGOPT(*): ! ! AGAIN INFORM SPLP( ) THAT THIS IS A MAXIMIZATION PROBLEM. ! PRGOPT(01)=4 ! PRGOPT(02)=50 ! PRGOPT(03)=1 ! ! RESTART, USING SAVED PARTIAL RESULTS; KEY=55. ! PRGOPT(04)=7 ! PRGOPT(05)=55 ! PRGOPT(06)=1 ! ! NO MORE OPTIONS TO CHANGE. THE SUBPROGRAM SPLP( ) IS NO LONGER ! LIMITED TO 100 SIMPLEX STEPS BUT WILL RUN UNTIL COMPLETION OR ! MAX.=3*(MRELAS+NVARS) ITERATIONS. ! PRGOPT(07)=1 ! The user now makes a call to subprogram SPLP( ) to compute the ! solution. ! |-------------------------------------------| ! |End of Usage of SPLP( ) Subprogram Options.| ! |-------------------------------------------| ! ! |----------------------------------------------| ! |List of SPLP( ) Error and Diagnostic Messages.| ! |----------------------------------------------| ! This section may be required to understand the meanings of the ! error flag =-INFO that may be returned from SPLP( ). ! ! -----1. There is no set of values for x and w that satisfy A*x=w and ! the stated bounds. The problem can be made feasible by ident- ! ifying components of w that are now infeasible and then rede- ! signating them as free variables. Subprogram SPLP( ) only ! identifies an infeasible problem; it takes no other action to ! change this condition. Message: ! SPLP( ). THE PROBLEM APPEARS TO BE INFEASIBLE. ! ERROR NUMBER = 1 ! ! 2. One of the variables in either the vector x or w was con- ! strained at a bound. Otherwise the objective function value, ! (transpose of costs)*x, would not have a finite optimum. ! Message: ! SPLP( ). THE PROBLEM APPEARS TO HAVE NO FINITE SOLN. ! ERROR NUMBER = 2 ! ! 3. Both of the conditions of 1. and 2. above have occurred. ! Message: ! SPLP( ). THE PROBLEM APPEARS TO BE INFEASIBLE AND TO ! HAVE NO FINITE SOLN. ! ERROR NUMBER = 3 ! ! -----4. The REAL and INTEGER working arrays, WORK(*) and IWORK(*), ! are not long enough. The values (I1) and (I2) in the message ! below will give you the minimum length required. Also redefine ! LW and LIW, the lengths of these arrays. Message: ! SPLP( ). WORK OR IWORK IS NOT LONG ENOUGH. LW MUST BE (I1) ! AND LIW MUST BE (I2). ! IN ABOVE MESSAGE, I1= 0 ! IN ABOVE MESSAGE, I2= 0 ! ERROR NUMBER = 4 ! ! -----5. and 6. These error messages often mean that one or more ! arguments were left out of the call statement to SPLP( ) or ! that the values of MRELAS and NVARS have been over-written ! by garbage. Messages: ! SPLP( ). VALUE OF MRELAS MUST BE > 0. NOW=(I1). ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 5 ! ! SPLP( ). VALUE OF NVARS MUST BE > 0. NOW=(I1). ! IN ABOVE MESSAGE, I1= 0 ! ERROR NUMBER = 6 ! ! -----7.,8., and 9. These error messages can occur as the data matrix ! is being defined by either USRMAT( ) or the user-supplied sub- ! program, 'NAME'( ). They would indicate a mistake in the contents ! of DATTRV(*), the user-written subprogram or that data has been ! over-written. ! Messages: ! SPLP( ). MORE THAN 2*NVARS*MRELAS ITERS. DEFINING OR UPDATING ! MATRIX DATA. ! ERROR NUMBER = 7 ! ! SPLP( ). ROW INDEX (I1) OR COLUMN INDEX (I2) IS OUT OF RANGE. ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, I2= 12 ! ERROR NUMBER = 8 ! ! SPLP( ). INDICATION FLAG (I1) FOR MATRIX DATA MUST BE ! EITHER 0 OR 1. ! IN ABOVE MESSAGE, I1= 12 ! ERROR NUMBER = 9 ! ! -----10. and 11. The type of bound (even no bound) and the bounds ! must be specified for each independent variable. If an independent ! variable has both an upper and lower bound, the bounds must be ! consistent. The lower bound must be <= the upper bound. ! Messages: ! SPLP( ). INDEPENDENT VARIABLE (I1) IS NOT DEFINED. ! IN ABOVE MESSAGE, I1= 1 ! ERROR NUMBER = 10 ! ! SPLP( ). LOWER BOUND (R1) AND UPPER BOUND (R2) FOR INDEP. ! VARIABLE (I1) ARE NOT CONSISTENT. ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, R1= 0. ! IN ABOVE MESSAGE, R2= -.1000000000E+01 ! ERROR NUMBER = 11 ! ! -----12. and 13. The type of bound (even no bound) and the bounds ! must be specified for each dependent variable. If a dependent ! variable has both an upper and lower bound, the bounds must be ! consistent. The lower bound must be <= the upper bound. ! Messages: ! SPLP( ). DEPENDENT VARIABLE (I1) IS NOT DEFINED. ! IN ABOVE MESSAGE, I1= 1 ! ERROR NUMBER = 12 ! ! SPLP( ). LOWER BOUND (R1) AND UPPER BOUND (R2) FOR DEP. ! VARIABLE (I1) ARE NOT CONSISTENT. ! IN ABOVE MESSAGE, I1= 1 ! IN ABOVE MESSAGE, R1= 0. ! IN ABOVE MESSAGE, R2= -.1000000000E+01 ! ERROR NUMBER = 13 ! ! -----14. - 21. These error messages can occur when processing the ! option array, PRGOPT(*), supplied by the user. They would ! indicate a mistake in defining PRGOPT(*) or that data has been ! over-written. See heading Usage of SPLP( ) ! Subprogram Options, for details on how to define PRGOPT(*). ! Messages: ! SPLP( ). THE USER OPTION ARRAY HAS UNDEFINED DATA. ! ERROR NUMBER = 14 ! ! SPLP( ). OPTION ARRAY PROCESSING IS CYCLING. ! ERROR NUMBER = 15 ! ! SPLP( ). AN INDEX OF USER-SUPPLIED BASIS IS OUT OF RANGE. ! ERROR NUMBER = 16 ! ! SPLP( ). SIZE PARAMETERS FOR MATRIX MUST BE SMALLEST AND LARGEST ! MAGNITUDES OF NONZERO ENTRIES. ! ERROR NUMBER = 17 ! ! SPLP( ). THE NUMBER OF REVISED SIMPLEX STEPS BETWEEN CHECK-POINTS ! MUST BE POSITIVE. ! ERROR NUMBER = 18 ! ! SPLP( ). FILE NUMBERS FOR SAVED DATA AND MATRIX PAGES MUST BE ! POSITIVE AND NOT EQUAL. ! ERROR NUMBER = 19 ! ! SPLP( ). USER-DEFINED VALUE OF LAMAT (I1) ! MUST BE >= NVARS+7. ! IN ABOVE MESSAGE, I1= 1 ! ERROR NUMBER = 20 ! ! SPLP( ). USER-DEFINED VALUE OF LBM MUST BE >= 0. ! ERROR NUMBER = 21 ! ! -----22. The user-option, number 62, to check the size of the matrix ! data has been used. An element of the matrix does not lie within ! the range of ASMALL and ABIG, parameters provided by the user. ! (See the heading: Usage of SPLP( ) Subprogram Options, ! for details about this feature.) Message: ! SPLP( ). A MATRIX ELEMENT'S SIZE IS OUT OF THE SPECIFIED RANGE. ! ERROR NUMBER = 22 ! ! -----23. The user has provided an initial basis that is singular. ! In this case, the user can remedy this problem by letting ! subprogram SPLP( ) choose its own initial basis. Message: ! SPLP( ). A SINGULAR INITIAL BASIS WAS ENCOUNTERED. ! ERROR NUMBER = 23 ! ! -----24. The user has provided an initial basis which is infeasible. ! The x and w values it defines do not satisfy A*x=w and the stated ! bounds. In this case, the user can let subprogram SPLP( ) ! choose its own initial basis. Message: ! SPLP( ). AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED. ! ERROR NUMBER = 24 ! ! -----25. Subprogram SPLP( ) has completed the maximum specified number ! of iterations. (The nominal maximum number is 3*(MRELAS+NVARS).) ! The results, necessary to continue on from ! this point, can be saved on Fortran unit 2 by activating option ! KEY=57. If the user anticipates continuing the calculation, then ! the contents of Fortran unit 2 must be retained intact. This ! is not done by subprogram SPLP( ), so the user needs to save unit ! 2 by using the appropriate system commands. Message: ! SPLP( ). MAX. ITERS. (I1) TAKEN. UP-TO-DATE RESULTS ! SAVED ON FILE (I2). if ( I2)=0, NO SAVE. ! IN ABOVE MESSAGE, I1= 500 ! IN ABOVE MESSAGE, I2= 2 ! ERROR NUMBER = 25 ! ! -----26. This error should never happen. Message: ! SPLP( ). MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN. ! ERROR NUMBER = 26 ! ! -----27. The subprogram LA05A( ), which decomposes the basis matrix, ! has returned with an error flag (R1). (See the document, ! "Fortran subprograms for handling sparse linear programming ! bases", AERE-R8269, J.K. Reid, Jan., 1976, H.M. Stationery Office, ! for an explanation of this error.) Message: ! SPLP( ). LA05A( ) RETURNED ERROR FLAG (R1) BELOW. ! IN ABOVE MESSAGE, R1= -.5000000000E+01 ! ERROR NUMBER = 27 ! ! -----28. The sparse linear solver package, LA05*( ), requires more ! space. The value of LBM must be increased. See the companion ! document, Usage of SPLP( ) Subprogram Options, for details on how ! to increase the value of LBM. Message: ! SPLP( ). SHORT ON STORAGE FOR LA05*( ) PACKAGE. USE PRGOPT(*) ! TO GIVE MORE. ! ERROR NUMBER = 28 ! ! -----29. The row dimension of the two-dimensional Fortran array, ! the number of constraint equations (MRELAS), and the number ! of variables (NVARS), were not passed to the subprogram ! FULMAT(). See KEY = 68 for details. Message: ! FULMAT() OF SPLP() PACKAGE. ROW DIM., MRELAS, NVARS ARE ! MISSING FROM PRGOPT(*). ! ERROR NUMBER = 29 ! ! |------------------------------------------------------| ! |End of List of SPLP( ) Error and Diagnostic Messages. | ! |------------------------------------------------------| !***REFERENCES R. J. Hanson and K. L. Hiebert, A sparse linear ! programming subprogram, Report SAND81-0297, Sandia ! National Laboratories, 1981. !***ROUTINES CALLED SPLPMN, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890605 Corrected references to XERRWV. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 890605 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPLP REAL BL(*),BU(*),COSTS(*),DATTRV(*),DUALS(*), & PRGOPT(*),PRIMAL(*),WORK(*),ZERO ! INTEGER IBASIS(*),IND(*),IWORK(*) CHARACTER*8 XERN1, XERN2 ! EXTERNAL USRMAT ! !***FIRST EXECUTABLE STATEMENT SPLP ZERO=0.E0 IOPT=1 ! ! VERIFY THAT MRELAS, NVARS > 0. ! if (MRELAS <= 0) THEN WRITE (XERN1, '(I8)') MRELAS call XERMSG ('SLATEC', 'SPLP', 'VALUE OF MRELAS MUST BE ' // & ' > 0. NOW = ' // XERN1, 5, 1) INFO = -5 return end if ! if (NVARS <= 0) THEN WRITE (XERN1, '(I8)') NVARS call XERMSG ('SLATEC', 'SPLP', 'VALUE OF NVARS MUST BE ' // & ' > 0. NOW = ' // XERN1, 6, 1) INFO = -6 return end if ! LMX=4*NVARS+7 LBM=8*MRELAS LAST = 1 IADBIG=10000 ICTMAX=1000 ICTOPT= 0 ! ! LOOK IN OPTION ARRAY FOR CHANGES TO WORK ARRAY LENGTHS. 20008 NEXT=PRGOPT(LAST) if (.NOT.(NEXT <= 0 .OR. NEXT > IADBIG)) go to 20010 ! ! THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT ! WORKING WITH UNDEFINED DATA. NERR=14 call XERMSG ('SLATEC', 'SPLP', & 'THE USER OPTION ARRAY HAS UNDEFINED DATA.', NERR, IOPT) INFO=-NERR return 20010 if (.NOT.(NEXT == 1)) go to 10001 go to 20009 10001 if (.NOT.(ICTOPT > ICTMAX)) go to 10002 NERR=15 call XERMSG ('SLATEC', 'SPLP', & 'OPTION ARRAY PROCESSING IS CYCLING.', NERR, IOPT) INFO=-NERR return 10002 CONTINUE KEY = PRGOPT(LAST+1) ! ! if KEY = 53, USER MAY SPECIFY LENGTHS OF PORTIONS ! OF WORK(*) AND IWORK(*) THAT ARE ALLOCATED TO THE ! SPARSE MATRIX STORAGE AND SPARSE LINEAR EQUATION ! SOLVING. if (.NOT.(KEY == 53)) go to 20013 if (.NOT.(PRGOPT(LAST+2) /= ZERO)) go to 20016 LMX=PRGOPT(LAST+3) LBM=PRGOPT(LAST+4) 20016 CONTINUE 20013 ICTOPT = ICTOPT+1 LAST = NEXT go to 20008 ! ! CHECK LENGTH VALIDITY OF SPARSE MATRIX STAGING AREA. ! 20009 if (LMX < NVARS+7) THEN WRITE (XERN1, '(I8)') LMX call XERMSG ('SLATEC', 'SPLP', 'USER-DEFINED VALUE OF ' // & 'LAMAT = ' // XERN1 // ' MUST BE >= NVARS+7.', 20, 1) INFO = -20 return end if ! ! TRIVIAL CHECK ON LENGTH OF LA05*() MATRIX AREA. if (.NOT.(LBM < 0)) go to 20022 NERR=21 call XERMSG ('SLATEC', 'SPLP', & 'USER-DEFINED VALUE OF LBM MUST BE >= 0.', NERR, IOPT) INFO=-NERR return 20022 CONTINUE ! ! DEFINE POINTERS FOR STARTS OF SUBARRAYS USED IN WORK(*) ! AND IWORK(*) IN OTHER SUBPROGRAMS OF THE PACKAGE. LAMAT=1 LCSC=LAMAT+LMX LCOLNR=LCSC+NVARS LERD=LCOLNR+NVARS LERP=LERD+MRELAS LBASMA=LERP+MRELAS LWR=LBASMA+LBM LRZ=LWR+MRELAS LRG=LRZ+NVARS+MRELAS LRPRIM=LRG+NVARS+MRELAS LRHS=LRPRIM+MRELAS LWW=LRHS+MRELAS LWORK=LWW+MRELAS-1 LIMAT=1 LIBB=LIMAT+LMX LIBRC=LIBB+NVARS+MRELAS LIPR=LIBRC+2*LBM LIWR=LIPR+2*MRELAS LIWORK=LIWR+8*MRELAS-1 ! ! CHECK ARRAY LENGTH VALIDITY OF WORK(*), IWORK(*). ! if (LW < LWORK .OR. LIW < LIWORK) THEN WRITE (XERN1, '(I8)') LWORK WRITE (XERN2, '(I8)') LIWORK call XERMSG ('SLATEC', 'SPLP', 'WORK OR IWORK IS NOT LONG ' // & 'ENOUGH. LW MUST BE = ' // XERN1 // ' AND LIW MUST BE = ' // & XERN2, 4, 1) INFO = -4 return end if ! call SPLPMN(USRMAT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, & BL,BU,IND,INFO,PRIMAL,DUALS,WORK(LAMAT), & WORK(LCSC),WORK(LCOLNR),WORK(LERD),WORK(LERP),WORK(LBASMA), & WORK(LWR),WORK(LRZ),WORK(LRG),WORK(LRPRIM),WORK(LRHS), & WORK(LWW),LMX,LBM,IBASIS,IWORK(LIBB),IWORK(LIMAT), & IWORK(LIBRC),IWORK(LIPR),IWORK(LIWR)) ! ! call SPLPMN(USRMAT,MRELAS,NVARS,COSTS,PRGOPT,DATTRV, ! 1 BL,BU,IND,INFO,PRIMAL,DUALS,AMAT, ! 2 CSC,COLNRM,ERD,ERP,BASMAT, ! 3 WR,RZ,RG,RPRIM,RHS, ! 4 WW,LMX,LBM,IBASIS,IBB,IMAT, ! 5 IBRC,IPR,IWR) ! return end subroutine SPLPFE (MRELAS, NVARS, LMX, LBM, IENTER, IBASIS, IMAT, & IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, GG, DULNRM, DIRNRM, & AMAT, BASMAT, CSC, WR, WW, BL, BU, RZ, RG, COLNRM, DUALS, & FOUND) ! !! SPLPFE is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPLPFE-S, DPLPFE-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/,/SASUM/DASUM/, ! /SCOPY/DCOPY/. ! ! THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE. ! IT IMPLEMENTS THE PROCEDURE (FIND VARIABLE TO ENTER BASIS ! AND GET SEARCH DIRECTION). ! REVISED 811130-1100 ! REVISED YYMMDD-HHMM ! !***SEE ALSO SPLP !***ROUTINES CALLED IPLOC, LA05BS, PRWPGE, SASUM, SCOPY !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SPLPFE INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) REAL AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),BL(*),BU(*), & RZ(*),RG(*),COLNRM(*),DUALS(*),CNORM,DIRNRM,DULNRM,EPS,ERDNRM,GG, & ONE,RATIO,RCOST,RMAX,ZERO LOGICAL FOUND,TRANS !***FIRST EXECUTABLE STATEMENT SPLPFE LPG=LMX-(NVARS+4) ZERO=0.E0 ONE=1.E0 RMAX=ZERO FOUND=.FALSE. I=MRELAS+1 N20002=MRELAS+NVARS go to 20003 20002 I=I+1 20003 if ((N20002-I) < 0) go to 20004 J=IBASIS(I) ! ! if J=IBASIS(I) < 0 THEN THE VARIABLE LEFT AT A ZERO LEVEL ! AND IS NOT CONSIDERED AS A CANDIDATE TO ENTER. if (.NOT.(J > 0)) go to 20006 ! ! DO NOT CONSIDER VARIABLES CORRESPONDING TO UNBOUNDED STEP LENGTHS. if (.NOT.(IBB(J) == 0)) go to 20009 go to 20002 20009 CONTINUE ! ! if A VARIABLE CORRESPONDS TO AN EQUATION(IND=3 AND BL=BU), ! THEN DO NOT CONSIDER IT AS A CANDIDATE TO ENTER. if (.NOT.(IND(J) == 3)) go to 20012 if (.NOT.((BU(J)-BL(J)) <= EPS*(ABS(BL(J))+ABS(BU(J))))) go to 20015 go to 20002 20015 CONTINUE 20012 CONTINUE RCOST=RZ(J) ! ! if VARIABLE IS AT UPPER BOUND IT CAN ONLY DECREASE. THIS ! ACCOUNTS FOR THE POSSIBLE CHANGE OF SIGN. if ( MOD(IBB(J),2) == 0) RCOST=-RCOST ! ! if THE VARIABLE IS FREE, USE THE NEGATIVE MAGNITUDE OF THE ! REDUCED COST FOR THAT VARIABLE. if ( IND(J) == 4) RCOST=-ABS(RCOST) CNORM=ONE if ( J <= NVARS)CNORM=COLNRM(J) ! ! TEST FOR NEGATIVITY OF REDUCED COSTS. if (.NOT.(RCOST+ERDNRM*DULNRM*CNORM < ZERO)) go to 20018 FOUND=.TRUE. RATIO=RCOST**2/RG(J) if (.NOT.(RATIO > RMAX)) go to 20021 RMAX=RATIO IENTER=I 20021 CONTINUE 20018 CONTINUE 20006 go to 20002 ! ! USE COL. CHOSEN TO COMPUTE SEARCH DIRECTION. 20004 if (.NOT.(FOUND)) go to 20024 J=IBASIS(IENTER) WW(1)=ZERO call SCOPY(MRELAS,WW,0,WW,1) if (.NOT.(J <= NVARS)) go to 20027 if (.NOT.(J == 1)) go to 20030 ILOW=NVARS+5 go to 20031 20030 ILOW=IMAT(J+3)+1 20031 CONTINUE IL1=IPLOC(ILOW,AMAT,IMAT) if (.NOT.(IL1 >= LMX-1)) go to 20033 ILOW=ILOW+2 IL1=IPLOC(ILOW,AMAT,IMAT) 20033 CONTINUE IPAGE=ABS(IMAT(LMX-1)) IHI=IMAT(J+4)-(ILOW-IL1) 20036 IU1=MIN(LMX-2,IHI) if (.NOT.(IL1 > IU1)) go to 20038 go to 20037 20038 CONTINUE DO 30 I=IL1,IU1 WW(IMAT(I))=AMAT(I)*CSC(J) 30 CONTINUE if (.NOT.(IHI <= LMX-2)) go to 20041 go to 20037 20041 CONTINUE IPAGE=IPAGE+1 KEY=1 call PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG go to 20036 20037 go to 20028 20027 if (.NOT.(IND(J) == 2)) go to 20044 WW(J-NVARS)=ONE go to 20045 20044 WW(J-NVARS)=-ONE 20045 CONTINUE CONTINUE ! ! COMPUTE SEARCH DIRECTION. 20028 TRANS=.FALSE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) ! ! THE SEARCH DIRECTION REQUIRES THE FOLLOWING SIGN CHANGE if EITHER ! VARIABLE ENTERING IS AT ITS UPPER BOUND OR IS FREE AND HAS ! POSITIVE REDUCED COST. if (.NOT.(MOD(IBB(J),2) == 0.OR.(IND(J) == 4 .AND. RZ(J) > ZERO)) & ) go to 20047 I=1 N20050=MRELAS go to 20051 20050 I=I+1 20051 if ((N20050-I) < 0) go to 20052 WW(I)=-WW(I) go to 20050 20052 CONTINUE 20047 DIRNRM=SASUM(MRELAS,WW,1) ! ! COPY CONTENTS OF WR(*) TO DUALS(*) FOR USE IN ! ADD-DROP (EXCHANGE) STEP, LA05CS( ). call SCOPY(MRELAS,WR,1,DUALS,1) 20024 RETURN end subroutine SPLPFL (MRELAS, NVARS, IENTER, ILEAVE, IBASIS, IND, & IBB, THETA, DIRNRM, RPRNRM, CSC, WW, BL, BU, ERP, RPRIM, & PRIMAL, FINITE, ZEROLV) ! !! SPLPFL is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPLPFL-S, DPLPFL-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/. ! ! THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE. ! IT IMPLEMENTS THE PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS). ! REVISED 811130-1045 ! REVISED YYMMDD-HHMM ! !***SEE ALSO SPLP !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SPLPFL INTEGER IBASIS(*),IND(*),IBB(*) REAL CSC(*),WW(*),BL(*),BU(*),ERP(*),RPRIM(*), & PRIMAL(*),BOUND,DIRNRM,RATIO,RPRNRM,THETA,ZERO LOGICAL FINITE,ZEROLV !***FIRST EXECUTABLE STATEMENT SPLPFL ZERO=0.E0 ! ! SEE if THE ENTERING VARIABLE IS RESTRICTING THE STEP LENGTH ! BECAUSE OF AN UPPER BOUND. FINITE=.FALSE. J=IBASIS(IENTER) if (.NOT.(IND(J) == 3)) go to 20002 THETA=BU(J)-BL(J) if ( J <= NVARS)THETA=THETA/CSC(J) FINITE=.TRUE. ILEAVE=IENTER ! ! NOW USE THE BASIC VARIABLES TO POSSIBLY RESTRICT THE STEP ! LENGTH EVEN FURTHER. 20002 I=1 N20005=MRELAS go to 20006 20005 I=I+1 20006 if ((N20005-I) < 0) go to 20007 J=IBASIS(I) ! ! if THIS IS A FREE VARIABLE, DO NOT USE IT TO ! RESTRICT THE STEP LENGTH. if (.NOT.(IND(J) == 4)) go to 20009 go to 20005 ! ! if DIRECTION COMPONENT IS ABOUT ZERO, IGNORE IT FOR COMPUTING ! THE STEP LENGTH. 20009 if (.NOT.(ABS(WW(I)) <= DIRNRM*ERP(I))) go to 20012 go to 20005 20012 if (.NOT.(WW(I) > ZERO)) go to 20015 ! ! if RPRIM(I) IS ESSENTIALLY ZERO, SET RATIO TO ZERO AND EXIT LOOP. if (.NOT.(ABS(RPRIM(I)) <= RPRNRM*ERP(I))) go to 20018 THETA=ZERO ILEAVE=I FINITE=.TRUE. go to 20008 ! ! THE VALUE OF RPRIM(I) WILL DECREASE ONLY TO ITS LOWER BOUND OR ! ONLY TO ITS UPPER BOUND. if IT DECREASES TO ITS ! UPPER BOUND, THEN RPRIM(I) HAS ALREADY BEEN TRANSLATED ! TO ITS UPPER BOUND AND NOTHING NEEDS TO BE DONE TO IBB(J). 20018 if (.NOT.(RPRIM(I) > ZERO)) go to 10001 RATIO=RPRIM(I)/WW(I) if (.NOT.(.NOT.FINITE)) go to 20021 ILEAVE=I THETA=RATIO FINITE=.TRUE. go to 20022 20021 if (.NOT.(RATIO < THETA)) go to 10002 ILEAVE=I THETA=RATIO 10002 CONTINUE 20022 CONTINUE go to 20019 ! ! THE VALUE RPRIM(I) < ZERO WILL NOT RESTRICT THE STEP. 10001 CONTINUE ! ! THE DIRECTION COMPONENT IS NEGATIVE, THEREFORE THE VARIABLE WILL ! INCREASE. 20019 go to 20016 ! ! if THE VARIABLE IS LESS THAN ITS LOWER BOUND, IT CAN ! INCREASE ONLY TO ITS LOWER BOUND. 20015 if (.NOT.(PRIMAL(I+NVARS) < ZERO)) go to 20024 RATIO=RPRIM(I)/WW(I) if (RATIO < ZERO) RATIO=ZERO if (.NOT.(.NOT.FINITE)) go to 20027 ILEAVE=I THETA=RATIO FINITE=.TRUE. go to 20028 20027 if (.NOT.(RATIO < THETA)) go to 10003 ILEAVE=I THETA=RATIO 10003 CONTINUE 20028 CONTINUE ! ! if THE BASIC VARIABLE IS FEASIBLE AND IS NOT AT ITS UPPER BOUND, ! THEN IT CAN INCREASE TO ITS UPPER BOUND. go to 20025 20024 if (.NOT.(IND(J) == 3 .AND. PRIMAL(I+NVARS) == ZERO)) go to 10004 BOUND=BU(J)-BL(J) if ( J <= NVARS) BOUND=BOUND/CSC(J) RATIO=(BOUND-RPRIM(I))/(-WW(I)) if (.NOT.(.NOT.FINITE)) go to 20030 ILEAVE=-I THETA=RATIO FINITE=.TRUE. go to 20031 20030 if (.NOT.(RATIO < THETA)) go to 10005 ILEAVE=-I THETA=RATIO 10005 CONTINUE 20031 CONTINUE CONTINUE 10004 CONTINUE 20025 CONTINUE 20016 go to 20005 20007 CONTINUE ! ! if STEP LENGTH IS FINITE, SEE IF STEP LENGTH IS ABOUT ZERO. 20008 if (.NOT.(FINITE)) go to 20033 ZEROLV=.TRUE. I=1 N20036=MRELAS go to 20037 20036 I=I+1 20037 if ((N20036-I) < 0) go to 20038 ZEROLV=ZEROLV.AND. ABS(THETA*WW(I)) <= ERP(I)*RPRNRM if (.NOT.(.NOT. ZEROLV)) go to 20040 go to 20039 20040 go to 20036 20038 CONTINUE 20039 CONTINUE 20033 CONTINUE return end subroutine SPLPMN (USRMAT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, & BL, BU, IND, INFO, PRIMAL, DUALS, AMAT, CSC, COLNRM, ERD, ERP, & BASMAT, WR, RZ, RG, RPRIM, RHS, WW, LMX, LBM, IBASIS, IBB, & IMAT, IBRC, IPR, IWR) ! !! SPLPMN is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPLPMN-S, DPLPMN-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT. ! THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR. ! ! MAIN SUBROUTINE FOR SPLP PACKAGE. ! !***SEE ALSO SPLP !***ROUTINES CALLED IVOUT, LA05BS, PINITM, PNNZRS, PRWPGE, SASUM, ! SCLOSM, SCOPY, SDOT, SPINCW, SPINIT, SPLPCE, ! SPLPDM, SPLPFE, SPLPFL, SPLPMU, SPLPUP, SPOPT, ! SVOUT, XERMSG !***COMMON BLOCKS LA05DS !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Corrected references to XERRWV. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE SPLPMN REAL ABIG,AIJ,AMAT(*),ANORM,ASMALL,BASMAT(*), & BL(*),BU(*),COLNRM(*),COSTS(*),COSTSC,CSC(*),DATTRV(*), & DIRNRM,DUALS(*),DULNRM,EPS,TUNE,ERD(*),ERDNRM,ERP(*),FACTOR,GG, & ONE,PRGOPT(*),PRIMAL(*),RESNRM,RG(*),RHS(*),RHSNRM,ROPT(07), & RPRIM(*),RPRNRM,RZ(*),RZJ,SCALR,SCOSTS,SIZE,SMALL,THETA, & TOLLS,UPBND,UU,WR(*),WW(*),XLAMDA,XVAL,ZERO,RDUM(01),TOLABS ! INTEGER IBASIS(*),IBB(*),IBRC(LBM,2),IMAT(*),IND(*), & IPR(*),IWR(*),INTOPT(08),IDUM(01) ! ! ARRAY LOCAL VARIABLES ! NAME(LENGTH) DESCRIPTION ! ! COSTS(NVARS) COST COEFFICIENTS ! PRGOPT( ) OPTION VECTOR ! DATTRV( ) DATA TRANSFER VECTOR ! PRIMAL(NVARS+MRELAS) AS OUTPUT IT IS PRIMAL SOLUTION OF LP. ! INTERNALLY, THE FIRST NVARS POSITIONS HOLD ! THE COLUMN CHECK SUMS. THE NEXT MRELAS ! POSITIONS HOLD THE CLASSIFICATION FOR THE ! BASIC VARIABLES -1 VIOLATES LOWER ! BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND ! DUALS(MRELAS+NVARS) DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE ! AS FIRST MRELAS ENTRIES. ! AMAT(LMX) SPARSE FORM OF DATA MATRIX ! IMAT(LMX) SPARSE FORM OF DATA MATRIX ! BL(NVARS+MRELAS) LOWER BOUNDS FOR VARIABLES ! BU(NVARS+MRELAS) UPPER BOUNDS FOR VARIABLES ! IND(NVARS+MRELAS) INDICATOR FOR VARIABLES ! CSC(NVARS) COLUMN SCALING ! IBASIS(NVARS+MRELAS) COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC ! IBB(NVARS+MRELAS) INDICATOR FOR NON-BASIC VARS., POLARITY OF ! VARS., AND POTENTIALLY INFINITE VARS. ! if IBB(J) < 0, VARIABLE J IS BASIC ! if IBB(J) > 0, VARIABLE J IS NON-BASIC ! if IBB(J) == 0, VARIABLE J HAS TO BE IGNORED ! BECAUSE IT WOULD CAUSE UNBOUNDED SOLN. ! WHEN MOD(IBB(J),2) == 0, VARIABLE IS AT ITS ! UPPER BOUND, OTHERWISE IT IS AT ITS LOWER ! BOUND ! COLNRM(NVARS) NORM OF COLUMNS ! ERD(MRELAS) ERRORS IN DUAL VARIABLES ! ERP(MRELAS) ERRORS IN PRIMAL VARIABLES ! BASMAT(LBM) BASIS MATRIX FOR HARWELL SPARSE CODE ! IBRC(LBM,2) ROW AND COLUMN POINTERS FOR BASMAT(*) ! IPR(2*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE ! IWR(8*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE ! WR(MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE ! RZ(NVARS+MRELAS) REDUCED COSTS ! RPRIM(MRELAS) INTERNAL PRIMAL SOLUTION ! RG(NVARS+MRELAS) COLUMN WEIGHTS ! WW(MRELAS) WORK ARRAY ! RHS(MRELAS) HOLDS TRANSLATED RIGHT HAND SIDE ! ! SCALAR LOCAL VARIABLES ! NAME TYPE DESCRIPTION ! ! LMX INTEGER LENGTH OF AMAT(*) ! LPG INTEGER LENGTH OF PAGE FOR AMAT(*) ! EPS REAL MACHINE PRECISION ! TUNE REAL PARAMETER TO SCALE ERROR ESTIMATES ! TOLLS REAL RELATIVE TOLERANCE FOR SMALL RESIDUALS ! TOLABS REAL ABSOLUTE TOLERANCE FOR SMALL RESIDUALS. ! USED if RELATIVE ERROR TEST FAILS. ! IN CONSTRAINT EQUATIONS ! FACTOR REAL .01--DETERMINES if BASIS IS SINGULAR ! OR COMPONENT IS FEASIBLE. MAY NEED TO ! BE INCREASED TO 1.E0 ON SHORT WORD ! LENGTH MACHINES. ! ASMALL REAL LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*) ! ABIG REAL UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*) ! MXITLP INTEGER MAXIMUM NUMBER OF ITERATIONS FOR LP ! ITLP INTEGER ITERATION COUNTER FOR TOTAL LP ITERS ! COSTSC REAL COSTS(*) SCALING ! SCOSTS REAL TEMP LOC. FOR COSTSC. ! XLAMDA REAL WEIGHT PARAMETER FOR PEN. METHOD. ! ANORM REAL NORM OF DATA MATRIX AMAT(*) ! RPRNRM REAL NORM OF THE SOLUTION ! DULNRM REAL NORM OF THE DUALS ! ERDNRM REAL NORM OF ERROR IN DUAL VARIABLES ! DIRNRM REAL NORM OF THE DIRECTION VECTOR ! RHSNRM REAL NORM OF TRANSLATED RIGHT HAND SIDE VECTOR ! RESNRM REAL NORM OF RESIDUAL VECTOR FOR CHECKING ! FEASIBILITY ! NZBM INTEGER NUMBER OF NON-ZEROS IN BASMAT(*) ! LBM INTEGER LENGTH OF BASMAT(*) ! SMALL REAL EPS*ANORM USED IN HARWELL SPARSE CODE ! LP INTEGER USED IN HARWELL LA05*() PACK AS OUTPUT ! FILE NUMBER. SET=I1MACH(4) NOW. ! UU REAL 0.1--USED IN HARWELL SPARSE CODE ! FOR RELATIVE PIVOTING TOLERANCE. ! GG REAL OUTPUT INFO FLAG IN HARWELL SPARSE CODE ! IPLACE INTEGER INTEGER USED BY SPARSE MATRIX CODES ! IENTER INTEGER NEXT COLUMN TO ENTER BASIS ! NREDC INTEGER NO. OF FULL REDECOMPOSITIONS ! KPRINT INTEGER LEVEL OF OUTPUT, =0-3 ! IDG INTEGER FORMAT AND PRECISION OF OUTPUT ! ITBRC INTEGER NO. OF ITERS. BETWEEN RECALCULATING ! THE ERROR IN THE PRIMAL SOLUTION. ! NPP INTEGER NO. OF NEGATIVE REDUCED COSTS REQUIRED ! IN PARTIAL PRICING ! JSTRT INTEGER STARTING PLACE FOR PARTIAL PRICING. ! LOGICAL COLSCP,SAVEDT,CONTIN,CSTSCP,UNBND, & FEAS,FINITE,FOUND,MINPRB,REDBAS, & SINGLR,SIZEUP,STPEDG,TRANS,USRBAS,ZEROLV,LOPT(08) CHARACTER*8 XERN1, XERN2 EQUIVALENCE (CONTIN,LOPT(1)),(USRBAS,LOPT(2)), & (SIZEUP,LOPT(3)),(SAVEDT,LOPT(4)),(COLSCP,LOPT(5)), & (CSTSCP,LOPT(6)),(MINPRB,LOPT(7)),(STPEDG,LOPT(8)), & (IDG,INTOPT(1)),(IPAGEF,INTOPT(2)),(ISAVE,INTOPT(3)), & (MXITLP,INTOPT(4)),(KPRINT,INTOPT(5)),(ITBRC,INTOPT(6)), & (NPP,INTOPT(7)),(LPRG,INTOPT(8)),(EPS,ROPT(1)),(ASMALL,ROPT(2)), & (ABIG,ROPT(3)),(COSTSC,ROPT(4)),(TOLLS,ROPT(5)),(TUNE,ROPT(6)), & (TOLABS,ROPT(7)) ! ! COMMON BLOCK USED BY LA05 () PACKAGE.. COMMON /LA05DS/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL EXTERNAL USRMAT ! ! SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE. !***FIRST EXECUTABLE STATEMENT SPLPMN LP=0 ! ! THE VALUES ZERO AND ONE. ZERO=0.E0 ONE=1.E0 FACTOR=0.01E0 LPG=LMX-(NVARS+4) IOPT=1 INFO=0 UNBND=.FALSE. JSTRT=1 ! ! PROCESS USER OPTIONS IN PRGOPT(*). ! CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED. call SPOPT(PRGOPT,MRELAS,NVARS,INFO,CSC,IBASIS,ROPT,INTOPT,LOPT) if (.NOT.(INFO < 0)) go to 20002 go to 30001 20002 if (.NOT.(CONTIN)) go to 20003 go to 30002 20006 go to 20004 ! ! INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*). 20003 call PINITM(MRELAS,NVARS,AMAT,IMAT,LMX,IPAGEF) ! ! UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY. 20004 call SPLPUP(USRMAT,MRELAS,NVARS,PRGOPT,DATTRV, & BL,BU,IND,INFO,AMAT,IMAT,SIZEUP,ASMALL,ABIG) if (.NOT.(INFO < 0)) go to 20007 go to 30001 ! !++ CODE FOR OUTPUT=YES IS ACTIVE 20007 if (.NOT.(KPRINT >= 1)) go to 20008 go to 30003 20011 CONTINUE !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END ! ! INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN ! CHECK SUMS, AND FORM INITIAL BASIS MATRIX. 20008 call SPINIT(MRELAS,NVARS,COSTS,BL,BU,IND,PRIMAL,INFO, & AMAT,CSC,COSTSC,COLNRM,XLAMDA,ANORM,RHS,RHSNRM, & IBASIS,IBB,IMAT,LOPT) if (.NOT.(INFO < 0)) go to 20012 go to 30001 ! 20012 NREDC=0 ASSIGN 20013 TO NPR004 go to 30004 20013 if (.NOT.(SINGLR)) go to 20014 NERR=23 call XERMSG ('SLATEC', 'SPLPMN', & 'IN SPLP, A SINGULAR INITIAL BASIS WAS ENCOUNTERED.', NERR, & IOPT) INFO=-NERR go to 30001 20014 ASSIGN 20018 TO NPR005 go to 30005 20018 ASSIGN 20019 TO NPR006 go to 30006 20019 ASSIGN 20020 TO NPR007 go to 30007 20020 if (.NOT.(USRBAS)) go to 20021 ASSIGN 20024 TO NPR008 go to 30008 20024 if (.NOT.(.NOT.FEAS)) go to 20025 NERR=24 call XERMSG ('SLATEC', 'SPLPMN', & 'IN SPLP, AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.', NERR, & IOPT) INFO=-NERR go to 30001 20025 CONTINUE 20021 ITLP=0 ! ! LAMDA HAS BEEN SET TO A CONSTANT, PERFORM PENALTY METHOD. ASSIGN 20029 TO NPR009 go to 30009 20029 ASSIGN 20030 TO NPR010 go to 30010 20030 ASSIGN 20031 TO NPR006 go to 30006 20031 ASSIGN 20032 TO NPR008 go to 30008 20032 if (.NOT.(.NOT.FEAS)) go to 20033 ! ! SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF ! COSTSC) AND PERFORM STANDARD PHASE-1. if ( KPRINT >= 2)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-1'')', & IDG) SCOSTS=COSTSC COSTSC=ZERO ASSIGN 20036 TO NPR007 go to 30007 20036 ASSIGN 20037 TO NPR009 go to 30009 20037 ASSIGN 20038 TO NPR010 go to 30010 20038 ASSIGN 20039 TO NPR006 go to 30006 20039 ASSIGN 20040 TO NPR008 go to 30008 20040 if (.NOT.(FEAS)) go to 20041 ! ! SET LAMDA TO ZERO, COSTSC=SCOSTS, PERFORM STANDARD PHASE-2. if ( KPRINT > 1)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-2'')', & IDG) XLAMDA=ZERO COSTSC=SCOSTS ASSIGN 20044 TO NPR009 go to 30009 20044 CONTINUE 20041 go to 20034 ! CHECK if ANY BASIC VARIABLES ARE STILL CLASSIFIED AS ! INFEASIBLE. if ANY ARE, THEN THIS MAY NOT YET BE AN ! OPTIMAL POINT. THEREFORE SET LAMDA TO ZERO AND TRY ! TO PERFORM MORE SIMPLEX STEPS. 20033 I=1 N20046=MRELAS go to 20047 20046 I=I+1 20047 if ((N20046-I) < 0) go to 20048 if (PRIMAL(I+NVARS) /= ZERO) go to 20045 go to 20046 20048 go to 20035 20045 XLAMDA=ZERO ASSIGN 20050 TO NPR009 go to 30009 20050 CONTINUE 20034 CONTINUE ! 20035 ASSIGN 20051 TO NPR011 go to 30011 20051 if (.NOT.(FEAS.AND.(.NOT.UNBND))) go to 20052 INFO=1 go to 20053 20052 if (.NOT.((.NOT.FEAS).AND.(.NOT.UNBND))) go to 10001 NERR=1 call XERMSG ('SLATEC', 'SPLPMN', & 'IN SPLP, THE PROBLEM APPEARS TO BE INFEASIBLE', NERR, IOPT) INFO=-NERR go to 20053 10001 if (.NOT.(FEAS .AND. UNBND)) go to 10002 NERR=2 call XERMSG ('SLATEC', 'SPLPMN', & 'IN SPLP, THE PROBLEM APPEARS TO HAVE NO FINITE SOLUTION.', & NERR, IOPT) INFO=-NERR go to 20053 10002 if (.NOT.((.NOT.FEAS).AND.UNBND)) go to 10003 NERR=3 call XERMSG ('SLATEC', 'SPLPMN', & 'IN SPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO HAVE ' // & 'NO FINITE SOLUTION.', NERR, IOPT) INFO=-NERR 10003 CONTINUE 20053 CONTINUE ! if (.NOT.(INFO == (-1) .OR. INFO == (-3))) go to 20055 SIZE=SASUM(NVARS,PRIMAL,1)*ANORM SIZE=SIZE/SASUM(NVARS,CSC,1) SIZE=SIZE+SASUM(MRELAS,PRIMAL(NVARS+1),1) I=1 N20058=NVARS+MRELAS go to 20059 20058 I=I+1 20059 if ((N20058-I) < 0) go to 20060 NX0066=IND(I) if (NX0066 < 1.OR.NX0066 > 4) go to 20066 go to (20062,20063,20064,20065), NX0066 20062 if (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR == SIZE)) go to 20068 go to 20058 20068 if (.NOT.(PRIMAL(I) > BL(I))) go to 10004 go to 20058 10004 IND(I)=-4 go to 20067 20063 if (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR == SIZE)) go to 20071 go to 20058 20071 if (.NOT.(PRIMAL(I) < BU(I))) go to 10005 go to 20058 10005 IND(I)=-4 go to 20067 20064 if (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR == SIZE)) go to 20074 go to 20058 20074 if (.NOT.(PRIMAL(I) < BL(I))) go to 10006 IND(I)=-4 go to 20075 10006 if (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR == SIZE)) go to 10007 go to 20058 10007 if (.NOT.(PRIMAL(I) > BU(I))) go to 10008 IND(I)=-4 go to 20075 10008 go to 20058 20075 go to 20067 20065 go to 20058 20066 CONTINUE 20067 go to 20058 20060 CONTINUE 20055 CONTINUE ! if (.NOT.(INFO == (-2) .OR. INFO == (-3))) go to 20077 J=1 N20080=NVARS go to 20081 20080 J=J+1 20081 if ((N20080-J) < 0) go to 20082 if (.NOT.(IBB(J) == 0)) go to 20084 NX0091=IND(J) if (NX0091 < 1.OR.NX0091 > 4) go to 20091 go to (20087,20088,20089,20090), NX0091 20087 BU(J)=BL(J) IND(J)=-3 go to 20092 20088 BL(J)=BU(J) IND(J)=-3 go to 20092 20089 go to 20080 20090 BL(J)=ZERO BU(J)=ZERO IND(J)=-3 20091 CONTINUE 20092 CONTINUE 20084 go to 20080 20082 CONTINUE 20077 CONTINUE !++ CODE FOR OUTPUT=YES IS ACTIVE if (.NOT.(KPRINT >= 1)) go to 20093 ASSIGN 20096 TO NPR012 go to 30012 20096 CONTINUE 20093 CONTINUE !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END go to 30001 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (COMPUTE RIGHT HAND SIDE) 30010 RHS(1)=ZERO call SCOPY(MRELAS,RHS,0,RHS,1) J=1 N20098=NVARS+MRELAS go to 20099 20098 J=J+1 20099 if ((N20098-J) < 0) go to 20100 NX0106=IND(J) if (NX0106 < 1.OR.NX0106 > 4) go to 20106 go to (20102,20103,20104,20105), NX0106 20102 SCALR=-BL(J) go to 20107 20103 SCALR=-BU(J) go to 20107 20104 SCALR=-BL(J) go to 20107 20105 SCALR=ZERO 20106 CONTINUE 20107 if (.NOT.(SCALR /= ZERO)) go to 20108 if (.NOT.(J <= NVARS)) go to 20111 I=0 20114 call PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I <= 0)) go to 20116 go to 20115 20116 RHS(I)=RHS(I)+AIJ*SCALR go to 20114 20115 go to 20112 20111 RHS(J-NVARS)=RHS(J-NVARS)-SCALR 20112 CONTINUE 20108 go to 20098 20100 J=1 N20119=NVARS+MRELAS go to 20120 20119 J=J+1 20120 if ((N20119-J) < 0) go to 20121 SCALR=ZERO if ( IND(J) == 3.AND.MOD(IBB(J),2) == 0) SCALR=BU(J)-BL(J) if (.NOT.(SCALR /= ZERO)) go to 20123 if (.NOT.(J <= NVARS)) go to 20126 I=0 20129 call PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I <= 0)) go to 20131 go to 20130 20131 RHS(I)=RHS(I)-AIJ*SCALR go to 20129 20130 go to 20127 20126 RHS(J-NVARS)=RHS(J-NVARS)+SCALR 20127 CONTINUE 20123 go to 20119 20121 CONTINUE go to NPR010, (20030,20038) ! PROCEDURE (PERFORM SIMPLEX STEPS) 30009 ASSIGN 20134 TO NPR013 go to 30013 20134 ASSIGN 20135 TO NPR014 go to 30014 20135 if (.NOT.(KPRINT > 2)) go to 20136 call SVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG) call SVOUT(NVARS+MRELAS,RZ,'('' REDUCED COSTS'')',IDG) 20136 CONTINUE 20139 ASSIGN 20141 TO NPR015 go to 30015 20141 if (.NOT.(.NOT. FOUND)) go to 20142 go to 30016 20145 CONTINUE 20142 if (.NOT.(FOUND)) go to 20146 if (KPRINT >= 3) call SVOUT(MRELAS,WW,'('' SEARCH DIRECTION'')', & IDG) go to 30017 20149 if (.NOT.(FINITE)) go to 20150 go to 30018 20153 ASSIGN 20154 TO NPR005 go to 30005 20154 go to 20151 20150 UNBND=.TRUE. IBB(IBASIS(IENTER))=0 20151 go to 20147 20146 go to 20140 20147 ITLP=ITLP+1 go to 30019 20155 go to 20139 20140 CONTINUE go to NPR009, (20029,20037,20044,20050) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE) 30002 LPR=NVARS+4 REWIND ISAVE READ(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR) KEY=2 IPAGE=1 go to 20157 20156 if (NP < 0) go to 20158 20157 LPR1=LPR+1 READ(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX) call PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) NP=IMAT(LMX-1) IPAGE=IPAGE+1 go to 20156 20158 NPARM=NVARS+MRELAS READ(ISAVE) (IBASIS(I),I=1,NPARM) REWIND ISAVE go to 20006 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (SAVE DATA ON FILE ISAVE) ! ! SOME PAGES MAY NOT BE WRITTEN YET. 30020 if (.NOT.(AMAT(LMX) == ONE)) go to 20159 AMAT(LMX)=ZERO KEY=2 IPAGE=ABS(IMAT(LMX-1)) call PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) ! ! FORCE PAGE FILE TO BE OPENED ON RESTARTS. 20159 KEY=AMAT(4) AMAT(4)=ZERO LPR=NVARS+4 WRITE(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR) AMAT(4)=KEY IPAGE=1 KEY=1 go to 20163 20162 if (NP < 0) go to 20164 20163 call PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) LPR1=LPR+1 WRITE(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX) NP=IMAT(LMX-1) IPAGE=IPAGE+1 go to 20162 20164 NPARM=NVARS+MRELAS WRITE(ISAVE) (IBASIS(I),I=1,NPARM) endFILE ISAVE ! ! CLOSE FILE, IPAGEF, WHERE PAGES ARE STORED. THIS IS NEEDED SO THAT ! THE PAGES MAY BE RESTORED AT A CONTINUATION OF SPLP(). go to 20317 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (DECOMPOSE BASIS MATRIX) !++ CODE FOR OUTPUT=YES IS ACTIVE 30004 if (.NOT.(KPRINT >= 2)) go to 20165 call IVOUT(MRELAS,IBASIS, & '('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')', & IDG) !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END ! ! SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE. 20165 UU=0.1 call SPLPDM( & MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & ANORM,EPS,UU,GG, & AMAT,BASMAT,CSC,WR, & SINGLR,REDBAS) if (.NOT.(INFO < 0)) go to 20168 go to 30001 20168 CONTINUE go to NPR004, (20013,20204,20242) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (CLASSIFY VARIABLES) ! ! DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES ! -1 VIOLATES LOWER BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND. ! (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS)) ! TRANSLATE VARIABLE TO ITS UPPER BOUND, if > UPPER BOUND 30007 PRIMAL(NVARS+1)=ZERO call SCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1) I=1 N20172=MRELAS go to 20173 20172 I=I+1 20173 if ((N20172-I) < 0) go to 20174 J=IBASIS(I) if (.NOT.(IND(J) /= 4)) go to 20176 if (.NOT.(RPRIM(I) < ZERO)) go to 20179 PRIMAL(I+NVARS)=-ONE go to 20180 20179 if (.NOT.(IND(J) == 3)) go to 10009 UPBND=BU(J)-BL(J) if (J <= NVARS) UPBND=UPBND/CSC(J) if (.NOT.(RPRIM(I) > UPBND)) go to 20182 RPRIM(I)=RPRIM(I)-UPBND if (.NOT.(J <= NVARS)) go to 20185 K=0 20188 call PNNZRS(K,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(K <= 0)) go to 20190 go to 20189 20190 RHS(K)=RHS(K)-UPBND*AIJ*CSC(J) go to 20188 20189 go to 20186 20185 RHS(J-NVARS)=RHS(J-NVARS)+UPBND 20186 PRIMAL(I+NVARS)=ONE 20182 CONTINUE CONTINUE 10009 CONTINUE 20180 CONTINUE 20176 go to 20172 20174 CONTINUE go to NPR007, (20020,20036) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS) 30005 NTRIES=1 go to 20195 20194 NTRIES=NTRIES+1 20195 if ((2-NTRIES) < 0) go to 20196 call SPLPCE( & MRELAS,NVARS,LMX,LBM,ITLP,ITBRC, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & ERDNRM,EPS,TUNE,GG, & AMAT,BASMAT,CSC,WR,WW,PRIMAL,ERD,ERP, & SINGLR,REDBAS) if (.NOT.(.NOT. SINGLR)) go to 20198 !++ CODE FOR OUTPUT=YES IS ACTIVE if (.NOT.(KPRINT >= 3)) go to 20201 call SVOUT(MRELAS,ERP,'('' EST. ERROR IN PRIMAL COMPS.'')',IDG) call SVOUT(MRELAS,ERD,'('' EST. ERROR IN DUAL COMPS.'')',IDG) 20201 CONTINUE !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END go to 20193 20198 if (NTRIES == 2) go to 20197 ASSIGN 20204 TO NPR004 go to 30004 20204 CONTINUE go to 20194 20196 CONTINUE 20197 NERR=26 call XERMSG ('SLATEC', 'SPLPMN', & 'IN SPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.', & NERR, IOPT) INFO=-NERR go to 30001 20193 CONTINUE go to NPR005, (20018,20154,20243) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (CHECK FEASIBILITY) ! ! SEE if NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT ! EQUATIONS. ! ! COPY RHS INTO WW(*), THEN UPDATE WW(*). 30008 call SCOPY(MRELAS,RHS,1,WW,1) J=1 N20206=MRELAS go to 20207 20206 J=J+1 20207 if ((N20206-J) < 0) go to 20208 IBAS=IBASIS(J) XVAL=RPRIM(J) ! ! ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND. if (IND(IBAS) <= 3) XVAL=MAX(ZERO,XVAL) ! ! if THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND. if (.NOT.(IND(IBAS) == 3)) go to 20210 UPBND=BU(IBAS)-BL(IBAS) if (IBAS <= NVARS) UPBND=UPBND/CSC(IBAS) XVAL=MIN(UPBND,XVAL) 20210 CONTINUE ! ! SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*) if (.NOT.(XVAL /= ZERO)) go to 20213 if (.NOT.(IBAS <= NVARS)) go to 20216 I=0 20219 call PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,IBAS) if (.NOT.(I <= 0)) go to 20221 go to 20220 20221 WW(I)=WW(I)-XVAL*AIJ*CSC(IBAS) go to 20219 20220 go to 20217 20216 if (.NOT.(IND(IBAS) == 2)) go to 20224 WW(IBAS-NVARS)=WW(IBAS-NVARS)-XVAL go to 20225 20224 WW(IBAS-NVARS)=WW(IBAS-NVARS)+XVAL 20225 CONTINUE 20217 CONTINUE 20213 CONTINUE go to 20206 ! ! COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY. 20208 RESNRM=SASUM(MRELAS,WW,1) FEAS=RESNRM <= TOLLS*(RPRNRM*ANORM+RHSNRM) ! ! TRY AN ABSOLUTE ERROR TEST if THE RELATIVE TEST FAILS. if ( .NOT. FEAS)FEAS=RESNRM <= TOLABS if (.NOT.(FEAS)) go to 20227 PRIMAL(NVARS+1)=ZERO call SCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1) 20227 CONTINUE go to NPR008, (20024,20032,20040) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS) 30014 call SPINCW( & MRELAS,NVARS,LMX,LBM,NPP,JSTRT, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & COSTSC,GG,ERDNRM,DULNRM, & AMAT,BASMAT,CSC,WR,WW,RZ,RG,COSTS,COLNRM,DUALS, & STPEDG) ! go to NPR014, (20135,20246) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS) 30019 if (.NOT.(ITLP > MXITLP)) go to 20230 NERR=25 ASSIGN 20233 TO NPR011 go to 30011 !++ CODE FOR OUTPUT=YES IS ACTIVE 20233 if (.NOT.(KPRINT >= 1)) go to 20234 ASSIGN 20237 TO NPR012 go to 30012 20237 CONTINUE 20234 CONTINUE !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END IDUM(1)=0 if ( SAVEDT) IDUM(1)=ISAVE WRITE (XERN1, '(I8)') MXITLP WRITE (XERN2, '(I8)') IDUM(1) call XERMSG ('SLATEC', 'SPLPMN', & 'IN SPLP, MAX ITERATIONS = ' // XERN1 // & ' TAKEN. UP-TO-DATE RESULTS SAVED ON FILE NO. ' // XERN2 // & '. if FILE NO. = 0, NO SAVE.', NERR, IOPT) INFO=-NERR go to 30001 20230 CONTINUE go to 20155 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN) 30016 if (.NOT.(.NOT.REDBAS)) go to 20239 ASSIGN 20242 TO NPR004 go to 30004 20242 ASSIGN 20243 TO NPR005 go to 30005 20243 ASSIGN 20244 TO NPR006 go to 30006 20244 ASSIGN 20245 TO NPR013 go to 30013 20245 ASSIGN 20246 TO NPR014 go to 30014 20246 CONTINUE ! ! ERASE NON-CYCLING MARKERS NEAR COMPLETION. 20239 I=MRELAS+1 N20247=MRELAS+NVARS go to 20248 20247 I=I+1 20248 if ((N20247-I) < 0) go to 20249 IBASIS(I)=ABS(IBASIS(I)) go to 20247 20249 ASSIGN 20251 TO NPR015 go to 30015 20251 CONTINUE go to 20145 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (COMPUTE NEW PRIMAL) ! ! COPY RHS INTO WW(*), SOLVE SYSTEM. 30006 call SCOPY(MRELAS,RHS,1,WW,1) TRANS = .FALSE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) call SCOPY(MRELAS,WW,1,RPRIM,1) RPRNRM=SASUM(MRELAS,RPRIM,1) go to NPR006, (20019,20031,20039,20244,20275) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (COMPUTE NEW DUALS) ! ! SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*). 30013 I=1 N20252=MRELAS go to 20253 20252 I=I+1 20253 if ((N20252-I) < 0) go to 20254 J=IBASIS(I) if (.NOT.(J <= NVARS)) go to 20256 DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS) go to 20257 20256 DUALS(I)=XLAMDA*PRIMAL(I+NVARS) 20257 CONTINUE go to 20252 ! 20254 TRANS=.TRUE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS) DULNRM=SASUM(MRELAS,DUALS,1) go to NPR013, (20134,20245,20267) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION) 30015 call SPLPFE( & MRELAS,NVARS,LMX,LBM,IENTER, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & ERDNRM,EPS,GG,DULNRM,DIRNRM, & AMAT,BASMAT,CSC,WR,WW,BL,BU,RZ,RG,COLNRM,DUALS, & FOUND) go to NPR015, (20141,20251) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS) 30017 call SPLPFL( & MRELAS,NVARS,IENTER,ILEAVE, & IBASIS,IND,IBB, & THETA,DIRNRM,RPRNRM, & CSC,WW,BL,BU,ERP,RPRIM,PRIMAL, & FINITE,ZEROLV) go to 20149 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (MAKE MOVE AND UPDATE) 30018 call SPLPMU( & MRELAS,NVARS,LMX,LBM,NREDC,INFO,IENTER,ILEAVE,IOPT,NPP,JSTRT, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & ANORM,EPS,UU,GG,RPRNRM,ERDNRM,DULNRM,THETA,COSTSC,XLAMDA,RHSNRM, & AMAT,BASMAT,CSC,WR,RPRIM,WW,BU,BL,RHS,ERD,ERP,RZ,RG,COLNRM,COSTS, & PRIMAL,DUALS,SINGLR,REDBAS,ZEROLV,STPEDG) if (.NOT.(INFO == (-26))) go to 20259 go to 30001 !++ CODE FOR OUTPUT=YES IS ACTIVE 20259 if (.NOT.(KPRINT >= 2)) go to 20263 go to 30021 20266 CONTINUE !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END 20263 CONTINUE go to 20153 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE(RESCALE AND REARRANGE VARIABLES) ! ! RESCALE THE DUAL VARIABLES. 30011 ASSIGN 20267 TO NPR013 go to 30013 20267 if (.NOT.(COSTSC /= ZERO)) go to 20268 I=1 N20271=MRELAS go to 20272 20271 I=I+1 20272 if ((N20271-I) < 0) go to 20273 DUALS(I)=DUALS(I)/COSTSC go to 20271 20273 CONTINUE 20268 ASSIGN 20275 TO NPR006 go to 30006 ! ! REAPPLY COLUMN SCALING TO PRIMAL. 20275 I=1 N20276=MRELAS go to 20277 20276 I=I+1 20277 if ((N20276-I) < 0) go to 20278 J=IBASIS(I) if (.NOT.(J <= NVARS)) go to 20280 SCALR=CSC(J) if ( IND(J) == 2)SCALR=-SCALR RPRIM(I)=RPRIM(I)*SCALR 20280 go to 20276 ! ! REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*) 20278 PRIMAL(1)=ZERO call SCOPY(NVARS+MRELAS,PRIMAL,0,PRIMAL,1) J=1 N20283=NVARS+MRELAS go to 20284 20283 J=J+1 20284 if ((N20283-J) < 0) go to 20285 IBAS=ABS(IBASIS(J)) XVAL=ZERO if (J <= MRELAS) XVAL=RPRIM(J) if (IND(IBAS) == 1) XVAL=XVAL+BL(IBAS) if (IND(IBAS) == 2) XVAL=BU(IBAS)-XVAL if (.NOT.(IND(IBAS) == 3)) go to 20287 if (MOD(IBB(IBAS),2) == 0) XVAL=BU(IBAS)-BL(IBAS)-XVAL XVAL = XVAL+BL(IBAS) 20287 PRIMAL(IBAS)=XVAL go to 20283 ! ! COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS. ! OTHER ENTRIES ARE ZERO. 20285 J=1 N20290=NVARS go to 20291 20290 J=J+1 20291 if ((N20290-J) < 0) go to 20292 RZJ=ZERO if (.NOT.(IBB(J) > ZERO .AND. IND(J) /= 4)) go to 20294 RZJ=COSTS(J) I=0 20297 call PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J) if (.NOT.(I <= 0)) go to 20299 go to 20298 20299 CONTINUE RZJ=RZJ-AIJ*DUALS(I) go to 20297 20298 CONTINUE 20294 DUALS(MRELAS+J)=RZJ go to 20290 20292 CONTINUE go to NPR011, (20051,20233) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC !++ CODE FOR OUTPUT=YES IS ACTIVE ! PROCEDURE (PRINT PROLOGUE) 30003 IDUM(1)=MRELAS call IVOUT(1,IDUM,'(''1NUM. OF DEPENDENT VARS., MRELAS'')',IDG) IDUM(1)=NVARS call IVOUT(1,IDUM,'('' NUM. OF INDEPENDENT VARS., NVARS'')',IDG) call IVOUT(1,IDUM,'('' DIMENSION OF COSTS(*)='')',IDG) IDUM(1)=NVARS+MRELAS call IVOUT(1,IDUM, '('' DIMENSIONS OF BL(*),BU(*),IND(*)'' & & // '' PRIMAL(*),DUALS(*) ='')',IDG) call IVOUT(1,IDUM,'('' DIMENSION OF IBASIS(*)='')',IDG) IDUM(1)=LPRG+1 call IVOUT(1,IDUM,'('' DIMENSION OF PRGOPT(*)='')',IDG) call IVOUT(0,IDUM, & '('' 1-NVARS=INDEPENDENT VARIABLE INDICES.''// & & '' (NVARS+1)-(NVARS+MRELAS)=DEPENDENT VARIABLE INDICES.''// & & '' CONSTRAINT INDICATORS ARE 1-4 AND MEAN'')',IDG) call IVOUT(0,IDUM, & '('' 1=VARIABLE HAS ONLY LOWER BOUND.''// & & '' 2=VARIABLE HAS ONLY UPPER BOUND.''// & & '' 3=VARIABLE HAS BOTH BOUNDS.''// & & '' 4=VARIABLE HAS NO BOUNDS, IT IS FREE.'')',IDG) call SVOUT(NVARS,COSTS,'('' ARRAY OF COSTS'')',IDG) call IVOUT(NVARS+MRELAS,IND, & '('' CONSTRAINT INDICATORS'')',IDG) call SVOUT(NVARS+MRELAS,BL, & '('' LOWER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG) call SVOUT(NVARS+MRELAS,BU, & '('' UPPER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG) if (.NOT.(KPRINT >= 2)) go to 20302 call IVOUT(0,IDUM, & '(''0NON-BASIC INDICES THAT ARE NEGATIVE SHOW VARIABLES'' // & & '' EXCHANGED AT A ZERO STEP LENGTH'')',IDG) call IVOUT(0,IDUM, & '('' WHEN COL. NO. LEAVING=COL. NO. ENTERING, THE ENTERING '' & & ''VARIABLE MOVED TO ITS BOUND. IT REMAINS NON-BASIC.''/ & & '' WHEN COL. NO. OF BASIS EXCHANGED IS NEGATIVE, THE LEAVING''/ & & '' VARIABLE IS AT ITS UPPER BOUND.'')',IDG) 20302 CONTINUE go to 20011 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (PRINT SUMMARY) 30012 IDUM(1)=INFO call IVOUT(1,IDUM,'('' THE OUTPUT VALUE OF INFO IS'')',IDG) if (.NOT.(MINPRB)) go to 20305 call IVOUT(0,IDUM,'('' THIS IS A MINIMIZATION PROBLEM.'')',IDG) go to 20306 20305 call IVOUT(0,IDUM,'('' THIS IS A MAXIMIZATION PROBLEM.'')',IDG) 20306 if (.NOT.(STPEDG)) go to 20308 call IVOUT(0,IDUM,'('' STEEPEST EDGE PRICING WAS USED.'')',IDG) go to 20309 20308 call IVOUT(0,IDUM,'('' MINIMUM REDUCED COST PRICING WAS USED.'')', & IDG) 20309 RDUM(1)=SDOT(NVARS,COSTS,1,PRIMAL,1) call SVOUT(1,RDUM, & '('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',IDG) call SVOUT(NVARS+MRELAS,PRIMAL, & '('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',IDG) call SVOUT(MRELAS+NVARS,DUALS, & '('' THE OUTPUT DUAL VARIABLES'')',IDG) call IVOUT(NVARS+MRELAS,IBASIS, & '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG) IDUM(1)=ITLP call IVOUT(1,IDUM,'('' NO. OF ITERATIONS'')',IDG) IDUM(1)=NREDC call IVOUT(1,IDUM,'('' NO. OF FULL REDECOMPS'')',IDG) go to NPR012, (20096,20237) ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (PRINT ITERATION SUMMARY) 30021 IDUM(1)=ITLP+1 call IVOUT(1,IDUM,'(''0ITERATION NUMBER'')',IDG) IDUM(1)=IBASIS(ABS(ILEAVE)) call IVOUT(1,IDUM, & '('' INDEX OF VARIABLE ENTERING THE BASIS'')',IDG) IDUM(1)=ILEAVE call IVOUT(1,IDUM,'('' COLUMN OF THE BASIS EXCHANGED'')',IDG) IDUM(1)=IBASIS(IENTER) call IVOUT(1,IDUM, & '('' INDEX OF VARIABLE LEAVING THE BASIS'')',IDG) RDUM(1)=THETA call SVOUT(1,RDUM,'('' LENGTH OF THE EXCHANGE STEP'')',IDG) if (.NOT.(KPRINT >= 3)) go to 20311 call SVOUT(MRELAS,RPRIM,'('' BASIC (INTERNAL) PRIMAL SOLN.'')', & IDG) call IVOUT(NVARS+MRELAS,IBASIS, & '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG) call IVOUT(NVARS+MRELAS,IBB,'('' IBB ARRAY'')',IDG) call SVOUT(MRELAS,RHS,'('' TRANSLATED RHS'')',IDG) call SVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG) 20311 CONTINUE go to 20266 !++ CODE FOR OUTPUT=NO IS INACTIVE !++ END ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! PROCEDURE (RETURN TO USER) 30001 if (.NOT.(SAVEDT)) go to 20314 go to 30020 20317 CONTINUE 20314 if ( IMAT(LMX-1) /= (-1)) call SCLOSM(IPAGEF) ! ! THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN ! COMPILERS. return end subroutine SPLPMU (MRELAS, NVARS, LMX, LBM, NREDC, INFO, IENTER, & ILEAVE, IOPT, NPP, JSTRT, IBASIS, IMAT, IBRC, IPR, IWR, IND, & IBB, ANORM, EPS, UU, GG, RPRNRM, ERDNRM, DULNRM, THETA, COSTSC, & XLAMDA, RHSNRM, AMAT, BASMAT, CSC, WR, RPRIM, WW, BU, BL, RHS, & ERD, ERP, RZ, RG, COLNRM, COSTS, PRIMAL, DUALS, SINGLR, REDBAS, & ZEROLV, STPEDG) ! !! SPLPMU is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPLPMU-S, DPLPMU-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/, ! /SASUM/DASUM/,/SCOPY/DCOPY/,/SDOT/DDOT/, ! /.E0/.D0/ ! ! THIS SUBPROGRAM IS FROM THE SPLP( ) PACKAGE. IT PERFORMS THE ! TASKS OF UPDATING THE PRIMAL SOLUTION, EDGE WEIGHTS, REDUCED ! COSTS, AND MATRIX DECOMPOSITION. ! IT IS THE MAIN PART OF THE PROCEDURE (MAKE MOVE AND UPDATE). ! ! REVISED 821122-1100 ! REVISED YYMMDD ! !***SEE ALSO SPLP !***ROUTINES CALLED IPLOC, LA05BS, LA05CS, PNNZRS, PRWPGE, SASUM, ! SCOPY, SDOT, SPLPDM, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 890606 Removed unused COMMON block LA05DS. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SPLPMU INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) REAL AIJ,ALPHA,ANORM,COSTSC,ERDNRM,DULNRM,EPS,GAMMA, & GG,GQ,ONE,RPRNRM,RZJ,SCALR,THETA,TWO,UU,WP,XLAMDA,RHSNRM, & ZERO,AMAT(*),BASMAT(*),CSC(*),WR(*),RPRIM(*),WW(*),BU(*),BL(*), & RHS(*),ERD(*),ERP(*),RZ(*),RG(*),COSTS(*),PRIMAL(*),DUALS(*), & COLNRM(*),RCOST,SASUM,SDOT LOGICAL SINGLR,REDBAS,PAGEPL,TRANS,ZEROLV,STPEDG ! !***FIRST EXECUTABLE STATEMENT SPLPMU ZERO=0.E0 ONE=1.E0 TWO=2.E0 LPG=LMX-(NVARS+4) ! ! UPDATE THE PRIMAL SOLUTION WITH A MULTIPLE OF THE SEARCH ! DIRECTION. I=1 N20002=MRELAS go to 20003 20002 I=I+1 20003 if ((N20002-I) < 0) go to 20004 RPRIM(I)=RPRIM(I)-THETA*WW(I) go to 20002 ! ! if EJECTED VARIABLE IS LEAVING AT AN UPPER BOUND, THEN ! TRANSLATE RIGHT HAND SIDE. 20004 if (.NOT.(ILEAVE < 0)) go to 20006 IBAS=IBASIS(ABS(ILEAVE)) SCALR=RPRIM(ABS(ILEAVE)) ASSIGN 20009 TO NPR001 go to 30001 20009 IBB(IBAS)=ABS(IBB(IBAS))+1 ! ! if ENTERING VARIABLE IS RESTRICTED TO ITS UPPER BOUND, TRANSLATE ! RIGHT HAND SIDE. if THE VARIABLE DECREASED FROM ITS UPPER ! BOUND, A SIGN CHANGE IS REQUIRED IN THE TRANSLATION. 20006 if (.NOT.(IENTER == ILEAVE)) go to 20010 IBAS=IBASIS(IENTER) SCALR=THETA if (MOD(IBB(IBAS),2) == 0) SCALR=-SCALR ASSIGN 20013 TO NPR001 go to 30001 20013 IBB(IBAS)=IBB(IBAS)+1 go to 20011 20010 IBAS=IBASIS(IENTER) ! ! if ENTERING VARIABLE IS DECREASING FROM ITS UPPER BOUND, ! COMPLEMENT ITS PRIMAL VALUE. if (.NOT.(IND(IBAS) == 3.AND.MOD(IBB(IBAS),2) == 0)) go to 20014 SCALR=-(BU(IBAS)-BL(IBAS)) if (IBAS <= NVARS) SCALR=SCALR/CSC(IBAS) ASSIGN 20017 TO NPR001 go to 30001 20017 THETA=-SCALR-THETA IBB(IBAS)=IBB(IBAS)+1 20014 CONTINUE RPRIM(ABS(ILEAVE))=THETA IBB(IBAS)=-ABS(IBB(IBAS)) I=IBASIS(ABS(ILEAVE)) IBB(I)=ABS(IBB(I)) if ( PRIMAL(ABS(ILEAVE)+NVARS) > ZERO) IBB(I)=IBB(I)+1 ! ! INTERCHANGE COLUMN POINTERS TO NOTE EXCHANGE OF COLUMNS. 20011 IBAS=IBASIS(IENTER) IBASIS(IENTER)=IBASIS(ABS(ILEAVE)) IBASIS(ABS(ILEAVE))=IBAS ! ! if VARIABLE WAS EXCHANGED AT A ZERO LEVEL, MARK IT SO THAT ! IT CAN'T BE BROUGHT BACK IN. THIS IS TO HELP PREVENT CYCLING. if ( ZEROLV) IBASIS(IENTER)=-ABS(IBASIS(IENTER)) RPRNRM=MAX(RPRNRM,SASUM(MRELAS,RPRIM,1)) K=1 N20018=MRELAS go to 20019 20018 K=K+1 20019 if ((N20018-K) < 0) go to 20020 ! ! SEE if VARIABLES THAT WERE CLASSIFIED AS INFEASIBLE HAVE NOW ! BECOME FEASIBLE. THIS MAY REQUIRED TRANSLATING UPPER BOUNDED ! VARIABLES. if (.NOT.(PRIMAL(K+NVARS) /= ZERO .AND. & ABS(RPRIM(K)) <= RPRNRM*ERP(K))) go to 20022 if (.NOT.(PRIMAL(K+NVARS) > ZERO)) go to 20025 IBAS=IBASIS(K) SCALR=-(BU(IBAS)-BL(IBAS)) if ( IBAS <= NVARS)SCALR=SCALR/CSC(IBAS) ASSIGN 20028 TO NPR001 go to 30001 20028 RPRIM(K)=-SCALR RPRNRM=RPRNRM-SCALR 20025 PRIMAL(K+NVARS)=ZERO 20022 CONTINUE go to 20018 ! ! UPDATE REDUCED COSTS, EDGE WEIGHTS, AND MATRIX DECOMPOSITION. 20020 if (.NOT.(IENTER /= ILEAVE)) go to 20029 ! ! THE INCOMING VARIABLE IS ALWAYS CLASSIFIED AS FEASIBLE. PRIMAL(ABS(ILEAVE)+NVARS)=ZERO ! WP=WW(ABS(ILEAVE)) GQ=SDOT(MRELAS,WW,1,WW,1)+ONE ! ! COMPUTE INVERSE (TRANSPOSE) TIMES SEARCH DIRECTION. TRANS=.TRUE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) ! ! UPDATE THE MATRIX DECOMPOSITION. COL. ABS(ILEAVE) IS LEAVING. ! THE ARRAY DUALS(*) CONTAINS INTERMEDIATE RESULTS FOR THE ! INCOMING COLUMN. call LA05CS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,DUALS,GG,UU, & ABS(ILEAVE)) REDBAS=.FALSE. if (.NOT.(GG < ZERO)) go to 20032 ! ! REDECOMPOSE BASIS MATRIX WHEN AN ERROR RETURN FROM ! LA05CS( ) IS NOTED. THIS WILL PROBABLY BE DUE TO ! SPACE BEING EXHAUSTED, GG=-7. call SPLPDM( & MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT, & IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB, & ANORM,EPS,UU,GG, & AMAT,BASMAT,CSC,WR, & SINGLR,REDBAS) if (.NOT.(SINGLR)) go to 20035 NERR=26 call XERMSG ('SLATEC', 'SPLPMU', & 'IN SPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.', & NERR, IOPT) INFO=-NERR return 20035 CONTINUE go to 30002 20038 CONTINUE 20032 CONTINUE ! ! if STEEPEST EDGE PRICING IS USED, UPDATE REDUCED COSTS ! AND EDGE WEIGHTS. if (.NOT.(STPEDG)) go to 20039 ! ! COMPUTE COL. ABS(ILEAVE) OF THE NEW INVERSE (TRANSPOSE) MATRIX ! HERE ABS(ILEAVE) POINTS TO THE EJECTED COLUMN. ! USE ERD(*) FOR TEMP. STORAGE. call sinit ( MRELAS,ZERO,ERD,1) ERD(ABS(ILEAVE))=ONE TRANS=.TRUE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,ERD,TRANS) ! ! COMPUTE UPDATED DUAL VARIABLES IN DUALS(*). ASSIGN 20042 TO NPR003 go to 30003 ! ! COMPUTE THE DOT PRODUCT OF COL. J OF THE NEW INVERSE (TRANSPOSE) ! WITH EACH NON-BASIC COLUMN. ALSO COMPUTE THE DOT PRODUCT OF THE ! INVERSE (TRANSPOSE) OF NON-UPDATED MATRIX (TIMES) THE ! SEARCH DIRECTION WITH EACH NON-BASIC COLUMN. ! RECOMPUTE REDUCED COSTS. 20042 PAGEPL=.TRUE. call sinit ( NVARS+MRELAS,ZERO,RZ,1) NNEGRC=0 J=JSTRT 20043 if (.NOT.(IBB(J) <= 0)) go to 20045 PAGEPL=.TRUE. RG(J)=ONE go to 20046 ! ! NONBASIC INDEPENDENT VARIABLES (COLUMN IN SPARSE MATRIX STORAGE) 20045 if (.NOT.(J <= NVARS)) go to 20048 RZJ=COSTS(J)*COSTSC ALPHA=ZERO GAMMA=ZERO ! ! COMPUTE THE DOT PRODUCT OF THE SPARSE MATRIX NONBASIC COLUMNS ! WITH THREE VECTORS INVOLVED IN THE UPDATING STEP. if (.NOT.(J == 1)) go to 20051 ILOW=NVARS+5 go to 20052 20051 ILOW=IMAT(J+3)+1 20052 if (.NOT.(PAGEPL)) go to 20054 IL1=IPLOC(ILOW,AMAT,IMAT) if (.NOT.(IL1 >= LMX-1)) go to 20057 ILOW=ILOW+2 IL1=IPLOC(ILOW,AMAT,IMAT) 20057 CONTINUE IPAGE=ABS(IMAT(LMX-1)) go to 20055 20054 IL1=IHI+1 20055 IHI=IMAT(J+4)-(ILOW-IL1) 20060 IU1=MIN(LMX-2,IHI) if (.NOT.(IL1 > IU1)) go to 20062 go to 20061 20062 CONTINUE DO 10 I=IL1,IU1 RZJ=RZJ-AMAT(I)*DUALS(IMAT(I)) ALPHA=ALPHA+AMAT(I)*ERD(IMAT(I)) GAMMA=GAMMA+AMAT(I)*WW(IMAT(I)) 10 CONTINUE if (.NOT.(IHI <= LMX-2)) go to 20065 go to 20061 20065 CONTINUE IPAGE=IPAGE+1 KEY=1 call PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG go to 20060 20061 PAGEPL=IHI == (LMX-2) RZ(J)=RZJ*CSC(J) ALPHA=ALPHA*CSC(J) GAMMA=GAMMA*CSC(J) RG(J)=MAX(RG(J)-TWO*ALPHA*GAMMA+ALPHA**2*GQ,ONE+ALPHA**2) ! ! NONBASIC DEPENDENT VARIABLES (COLUMNS DEFINED IMPLICITLY) go to 20049 20048 PAGEPL=.TRUE. SCALR=-ONE if ( IND(J) == 2) SCALR=ONE I=J-NVARS ALPHA=SCALR*ERD(I) RZ(J)=-SCALR*DUALS(I) GAMMA=SCALR*WW(I) RG(J)=MAX(RG(J)-TWO*ALPHA*GAMMA+ALPHA**2*GQ,ONE+ALPHA**2) 20049 CONTINUE 20046 CONTINUE ! RCOST=RZ(J) if (MOD(IBB(J),2) == 0) RCOST=-RCOST if (.NOT.(IND(J) == 3)) go to 20068 if ( BU(J) == BL(J)) RCOST=ZERO 20068 CONTINUE if (IND(J) == 4) RCOST=-ABS(RCOST) CNORM=ONE if (J <= NVARS) CNORM=COLNRM(J) if (RCOST+ERDNRM*DULNRM*CNORM < ZERO) NNEGRC=NNEGRC+1 J=MOD(J,MRELAS+NVARS)+1 if (.NOT.(NNEGRC >= NPP .OR. J == JSTRT)) go to 20071 go to 20044 20071 CONTINUE go to 20043 20044 JSTRT=J ! ! UPDATE THE EDGE WEIGHT FOR THE EJECTED VARIABLE. RG(ABS(IBASIS(IENTER)))= GQ/WP**2 ! ! if MINIMUM REDUCED COST (DANTZIG) PRICING IS USED, ! CALCULATE THE NEW REDUCED COSTS. go to 20040 ! ! COMPUTE THE UPDATED DUALS IN DUALS(*). 20039 ASSIGN 20074 TO NPR003 go to 30003 20074 call sinit ( NVARS+MRELAS,ZERO,RZ,1) NNEGRC=0 J=JSTRT PAGEPL=.TRUE. ! 20075 if (.NOT.(IBB(J) <= 0)) go to 20077 PAGEPL=.TRUE. go to 20078 ! ! NONBASIC INDEPENDENT VARIABLE (COLUMN IN SPARSE MATRIX STORAGE) 20077 if (.NOT.(J <= NVARS)) go to 20080 RZ(J)=COSTS(J)*COSTSC if (.NOT.(J == 1)) go to 20083 ILOW=NVARS+5 go to 20084 20083 ILOW=IMAT(J+3)+1 20084 CONTINUE if (.NOT.(PAGEPL)) go to 20086 IL1=IPLOC(ILOW,AMAT,IMAT) if (.NOT.(IL1 >= LMX-1)) go to 20089 ILOW=ILOW+2 IL1=IPLOC(ILOW,AMAT,IMAT) 20089 CONTINUE IPAGE=ABS(IMAT(LMX-1)) go to 20087 20086 IL1=IHI+1 20087 CONTINUE IHI=IMAT(J+4)-(ILOW-IL1) 20092 IU1=MIN(LMX-2,IHI) if (.NOT.(IU1 >= IL1 .AND.MOD(IU1-IL1,2) == 0)) go to 20094 RZ(J)=RZ(J)-AMAT(IL1)*DUALS(IMAT(IL1)) IL1=IL1+1 20094 CONTINUE if (.NOT.(IL1 > IU1)) go to 20097 go to 20093 20097 CONTINUE ! ! UNROLL THE DOT PRODUCT LOOP TO A DEPTH OF TWO. (THIS IS DONE ! FOR INCREASED EFFICIENCY). DO 40 I=IL1,IU1,2 RZ(J)=RZ(J)-AMAT(I)*DUALS(IMAT(I))-AMAT(I+1)*DUALS(IMAT(I+1)) 40 CONTINUE if (.NOT.(IHI <= LMX-2)) go to 20100 go to 20093 20100 CONTINUE IPAGE=IPAGE+1 KEY=1 call PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG go to 20092 20093 PAGEPL=IHI == (LMX-2) RZ(J)=RZ(J)*CSC(J) ! ! NONBASIC DEPENDENT VARIABLES (COLUMNS DEFINED IMPLICITLY) go to 20081 20080 PAGEPL=.TRUE. SCALR=-ONE if ( IND(J) == 2) SCALR=ONE I=J-NVARS RZ(J)=-SCALR*DUALS(I) 20081 CONTINUE 20078 CONTINUE ! RCOST=RZ(J) if (MOD(IBB(J),2) == 0) RCOST=-RCOST if (.NOT.(IND(J) == 3)) go to 20103 if ( BU(J) == BL(J)) RCOST=ZERO 20103 CONTINUE if (IND(J) == 4) RCOST=-ABS(RCOST) CNORM=ONE if (J <= NVARS) CNORM=COLNRM(J) if (RCOST+ERDNRM*DULNRM*CNORM < ZERO) NNEGRC=NNEGRC+1 J=MOD(J,MRELAS+NVARS)+1 if (.NOT.(NNEGRC >= NPP .OR. J == JSTRT)) go to 20106 go to 20076 20106 CONTINUE go to 20075 20076 JSTRT=J 20040 CONTINUE go to 20030 ! ! THIS IS NECESSARY ONLY FOR PRINTING OF INTERMEDIATE RESULTS. 20029 ASSIGN 20109 TO NPR003 go to 30003 20109 CONTINUE 20030 RETURN ! PROCEDURE (TRANSLATE RIGHT HAND SIDE) ! ! PERFORM THE TRANSLATION ON THE RIGHT-HAND SIDE. 30001 if (.NOT.(IBAS <= NVARS)) go to 20110 I=0 20113 call PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,IBAS) if (.NOT.(I <= 0)) go to 20115 go to 20114 20115 CONTINUE RHS(I)=RHS(I)-SCALR*AIJ*CSC(IBAS) go to 20113 20114 go to 20111 20110 I=IBAS-NVARS if (.NOT.(IND(IBAS) == 2)) go to 20118 RHS(I)=RHS(I)-SCALR go to 20119 20118 RHS(I)=RHS(I)+SCALR 20119 CONTINUE 20111 CONTINUE RHSNRM=MAX(RHSNRM,SASUM(MRELAS,RHS,1)) go to NPR001, (20009,20013,20017,20028) ! PROCEDURE (COMPUTE NEW PRIMAL) ! ! COPY RHS INTO WW(*), SOLVE SYSTEM. 30002 call SCOPY(MRELAS,RHS,1,WW,1) TRANS = .FALSE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) call SCOPY(MRELAS,WW,1,RPRIM,1) RPRNRM=SASUM(MRELAS,RPRIM,1) go to 20038 ! PROCEDURE (COMPUTE NEW DUALS) ! ! SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*). 30003 I=1 N20121=MRELAS go to 20122 20121 I=I+1 20122 if ((N20121-I) < 0) go to 20123 J=IBASIS(I) if (.NOT.(J <= NVARS)) go to 20125 DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS) go to 20126 20125 DUALS(I)=XLAMDA*PRIMAL(I+NVARS) 20126 CONTINUE go to 20121 ! 20123 TRANS=.TRUE. call LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS) DULNRM=SASUM(MRELAS,DUALS,1) go to NPR003, (20042,20074,20109) end subroutine SPLPUP (USRMAT, MRELAS, NVARS, PRGOPT, DATTRV, BL, BU, & IND, INFO, AMAT, IMAT, SIZEUP, ASMALL, ABIG) ! !! SPLPUP is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPLPUP-S, DPLPUP-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/. ! ! REVISED 810613-1130 ! REVISED YYMMDD-HHMM ! ! THIS SUBROUTINE COLLECTS INFORMATION ABOUT THE BOUNDS AND MATRIX ! FROM THE USER. IT IS PART OF THE SPLP( ) PACKAGE. ! !***SEE ALSO SPLP !***ROUTINES CALLED PCHNGS, PNNZRS, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Corrected references to XERRWV. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891009 Removed unreferenced variables. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls, changed do-it-yourself ! DO loops to DO loops. (RWC) ! 900602 Get rid of ASSIGNed GOTOs. (RWC) !***END PROLOGUE SPLPUP REAL ABIG,AIJ,AMAT(*),AMN,AMX,ASMALL,BL(*), & BU(*),DATTRV(*),PRGOPT(*),XVAL,ZERO INTEGER IFLAG(10),IMAT(*),IND(*) LOGICAL SIZEUP,FIRST CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 ! !***FIRST EXECUTABLE STATEMENT SPLPUP ZERO = 0.E0 ! ! CHECK USER-SUPPLIED BOUNDS ! ! CHECK THAT IND(*) VALUES ARE 1,2,3 OR 4. ! ALSO CHECK CONSISTENCY OF UPPER AND LOWER BOUNDS. ! DO 10 J=1,NVARS if (IND(J) < 1 .OR. IND(J) > 4) THEN WRITE (XERN1, '(I8)') J call XERMSG ('SLATEC', 'SPLPUP', & 'IN SPLP, INDEPENDENT VARIABLE = ' // XERN1 // & ' IS NOT DEFINED.', 10, 1) INFO = -10 return ENDIF ! if (IND(J) == 3) THEN if (BL(J) > BU(J)) THEN WRITE (XERN1, '(I8)') J WRITE (XERN3, '(1PE15.6)') BL(J) WRITE (XERN4, '(1PE15.6)') BU(J) call XERMSG ('SLATEC', 'SPLPUP', & 'IN SPLP, LOWER BOUND = ' // XERN3 // & ' AND UPPER BOUND = ' // XERN4 // & ' FOR INDEPENDENT VARIABLE = ' // XERN1 // & ' ARE NOT CONSISTENT.', 11, 1) return ENDIF ENDIF 10 CONTINUE ! DO 20 I=NVARS+1,NVARS+MRELAS if (IND(I) < 1 .OR. IND(I) > 4) THEN WRITE (XERN1, '(I8)') I-NVARS call XERMSG ('SLATEC', 'SPLPUP', & 'IN SPLP, DEPENDENT VARIABLE = ' // XERN1 // & ' IS NOT DEFINED.', 12, 1) INFO = -12 return ENDIF ! if (IND(I) == 3) THEN if (BL(I) > BU(I)) THEN WRITE (XERN1, '(I8)') I WRITE (XERN3, '(1PE15.6)') BL(I) WRITE (XERN4, '(1PE15.6)') BU(I) call XERMSG ('SLATEC', 'SPLPUP', & 'IN SPLP, LOWER BOUND = ' // XERN3 // & ' AND UPPER BOUND = ' // XERN4 // & ' FOR DEPENDANT VARIABLE = ' // XERN1 // & ' ARE NOT CONSISTENT.',13,1) INFO = -13 return ENDIF ENDIF 20 CONTINUE ! ! GET UPDATES OR DATA FOR MATRIX FROM THE USER ! ! GET THE ELEMENTS OF THE MATRIX FROM THE USER. IT WILL BE STORED ! BY COLUMNS USING THE SPARSE STORAGE CODES OF RJ HANSON AND ! JA WISNIEWSKI. ! IFLAG(1) = 1 ! ! KEEP ACCEPTING ELEMENTS UNTIL THE USER IS FINISHED GIVING THEM. ! LIMIT THIS LOOP TO 2*NVARS*MRELAS ITERATIONS. ! ITMAX = 2*NVARS*MRELAS+1 ITCNT = 0 FIRST = .TRUE. ! ! CHECK ON THE ITERATION COUNT. ! 30 ITCNT = ITCNT+1 if (ITCNT > ITMAX) THEN call XERMSG ('SLATEC', 'SPLPUP', & 'IN SPLP, MORE THAN 2*NVARS*MRELAS ITERATIONS DEFINING ' // & 'OR UPDATING MATRIX DATA.', 7, 1) INFO = -7 return end if ! AIJ = ZERO call USRMAT(I,J,AIJ,INDCAT,PRGOPT,DATTRV,IFLAG) if (IFLAG(1) == 1) THEN IFLAG(1) = 2 go to 30 end if ! ! CHECK TO SEE THAT THE SUBSCRIPTS I AND J ARE VALID. ! if (I < 1 .OR. I > MRELAS .OR. J < 1 .OR. J > NVARS) THEN ! ! CHECK ON SIZE OF MATRIX DATA ! RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS. ! if (IFLAG(1) == 3) THEN if (SIZEUP .AND. ABS(AIJ) /= ZERO) THEN if (FIRST) THEN AMX = ABS(AIJ) AMN = ABS(AIJ) FIRST = .FALSE. ELSEIF (ABS(AIJ) > AMX) THEN AMX = ABS(AIJ) ELSEIF (ABS(AIJ) < AMN) THEN AMN = ABS(AIJ) ENDIF ENDIF go to 40 ENDIF ! WRITE (XERN1, '(I8)') I WRITE (XERN2, '(I8)') J call XERMSG ('SLATEC', 'SPLPUP', & 'IN SPLP, ROW INDEX = ' // XERN1 // ' OR COLUMN INDEX = ' & // XERN2 // ' IS OUT OF RANGE.', 8, 1) INFO = -8 return end if ! ! if INDCAT=0 THEN SET A(I,J)=AIJ. ! if INDCAT=1 THEN ACCUMULATE ELEMENT, A(I,J)=A(I,J)+AIJ. ! if (INDCAT == 0) THEN call PCHNGS(I,AIJ,IPLACE,AMAT,IMAT,J) ELSEIF (INDCAT == 1) THEN INDEX = -(I-1) call PNNZRS(INDEX,XVAL,IPLACE,AMAT,IMAT,J) if (INDEX == I) AIJ=AIJ+XVAL call PCHNGS(I,AIJ,IPLACE,AMAT,IMAT,J) ELSE WRITE (XERN1, '(I8)') INDCAT call XERMSG ('SLATEC', 'SPLPUP', & 'IN SPLP, INDICATION FLAG = ' // XERN1 // & ' FOR MATRIX DATA MUST BE EITHER 0 OR 1.', 9, 1) INFO = -9 return end if ! ! CHECK ON SIZE OF MATRIX DATA ! RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS. ! if (SIZEUP .AND. ABS(AIJ) /= ZERO) THEN if (FIRST) THEN AMX = ABS(AIJ) AMN = ABS(AIJ) FIRST = .FALSE. ELSEIF (ABS(AIJ) > AMX) THEN AMX = ABS(AIJ) ELSEIF (ABS(AIJ) < AMN) THEN AMN = ABS(AIJ) ENDIF end if if (IFLAG(1) /= 3) go to 30 40 if (SIZEUP .AND. .NOT. FIRST) THEN if (AMN < ASMALL .OR. AMX > ABIG) THEN call XERMSG ('SLATEC', 'SPLPUP', & 'IN SPLP, A MATRIX ELEMENT''S SIZE IS OUT OF THE ' // & 'SPECIFIED RANGE.', 22, 1) INFO = -22 return ENDIF end if return end subroutine SPOCO (A, LDA, N, RCOND, Z, INFO) ! !! SPOCO factors a real symmetric positive definite matrix ... ! and estimate the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE SINGLE PRECISION (SPOCO-S, DPOCO-D, CPOCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPOCO factors a real symmetric positive definite matrix ! and estimates the condition of the matrix. ! ! If RCOND is not needed, SPOFA is slightly faster. ! To solve A*X = B , follow SPOCO by SPOSL. ! To compute INVERSE(A)*C , follow SPOCO by SPOSL. ! To compute DETERMINANT(A) , follow SPOCO by SPODI. ! To compute INVERSE(A) , follow SPOCO by SPODI. ! ! On Entry ! ! A REAL(LDA, N) ! the symmetric matrix to be factored. Only the ! diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix R so that A = TRANS(R)*R ! where TRANS(R) is the transpose. ! The strict lower triangle is unaltered. ! If INFO /= 0 , the factorization is not complete. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. If INFO /= 0 , RCOND is unchanged. ! ! Z REAL(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! If INFO /= 0 , Z is unchanged. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SASUM, SAXPY, SDOT, SPOFA, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPOCO INTEGER LDA,N,INFO REAL A(LDA,*),Z(*) REAL RCOND ! REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER I,J,JM1,K,KB,KP1 ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT SPOCO DO 30 J = 1, N Z(J) = SASUM(J,A(1,J),1) JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 Z(I) = Z(I) + ABS(A(I,J)) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,Z(J)) 40 CONTINUE ! ! FACTOR ! call SPOFA(A,LDA,N,INFO) if (INFO /= 0) go to 180 ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE TRANS(R)*W = E ! EK = 1.0E0 DO 50 J = 1, N Z(J) = 0.0E0 50 CONTINUE DO 110 K = 1, N if (Z(K) /= 0.0E0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= A(K,K)) go to 60 S = A(K,K)/ABS(EK-Z(K)) call SSCAL(N,S,Z,1) EK = S*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) WK = WK/A(K,K) WKM = WKM/A(K,K) KP1 = K + 1 if (KP1 > N) go to 100 DO 70 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)) 70 CONTINUE if (S >= SM) go to 90 T = WKM - WK WK = WKM DO 80 J = KP1, N Z(J) = Z(J) + T*A(K,J) 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) ! ! SOLVE R*Y = W ! DO 130 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= A(K,K)) go to 120 S = A(K,K)/ABS(Z(K)) call SSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) call SAXPY(K-1,T,A(1,K),1,Z(1),1) 130 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE TRANS(R)*V = Y ! DO 150 K = 1, N Z(K) = Z(K) - SDOT(K-1,A(1,K),1,Z(1),1) if (ABS(Z(K)) <= A(K,K)) go to 140 S = A(K,K)/ABS(Z(K)) call SSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/A(K,K) 150 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE R*Z = V ! DO 170 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= A(K,K)) go to 160 S = A(K,K)/ABS(Z(K)) call SSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) call SAXPY(K-1,T,A(1,K),1,Z(1),1) 170 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 180 CONTINUE return end subroutine SPODI (A, LDA, N, DET, JOB) ! !! SPODI computes the determinant and inverse of a certain real symmetric ... ! positive definite matrix using the factors ! computed by SPOCO, SPOFA or SQRDC. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B, D3B1B !***TYPE SINGLE PRECISION (SPODI-S, DPODI-D, CPODI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPODI computes the determinant and inverse of a certain ! real symmetric positive definite matrix (see below) ! using the factors computed by SPOCO, SPOFA or SQRDC. ! ! On Entry ! ! A REAL(LDA, N) ! the output A from SPOCO or SPOFA ! or the output X from SQRDC. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! JOB INTEGER ! = 11 both determinant and inverse. ! = 01 inverse only. ! = 10 determinant only. ! ! On Return ! ! A If SPOCO or SPOFA was used to factor A , then ! SPODI produces the upper half of INVERSE(A) . ! If SQRDC was used to decompose X , then ! SPODI produces the upper half of INVERSE(TRANS(X)*X), ! where TRANS(X) is the transpose. ! Elements of A below the diagonal are unchanged. ! If the units digit of JOB is zero, A is unchanged. ! ! DET REAL(2) ! determinant of A or of TRANS(X)*X if requested. ! Otherwise not referenced. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= DET(1) < 10.0 ! or DET(1) == 0.0 . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal and the inverse is requested. ! It will not occur if the subroutines are called correctly ! and if SPOCO or SPOFA has set INFO == 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPODI INTEGER LDA,N,JOB REAL A(LDA,*) REAL DET(2) ! REAL T REAL S INTEGER I,J,JM1,K,KP1 !***FIRST EXECUTABLE STATEMENT SPODI ! ! COMPUTE DETERMINANT ! if (JOB/10 == 0) go to 70 DET(1) = 1.0E0 DET(2) = 0.0E0 S = 10.0E0 DO 50 I = 1, N DET(1) = A(I,I)**2*DET(1) if (DET(1) == 0.0E0) go to 60 10 if (DET(1) >= 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) < 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 ! ! COMPUTE INVERSE(R) ! if (MOD(JOB,10) == 0) go to 140 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 < 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 ! ! FORM INVERSE(R) * TRANS(INVERSE(R)) ! DO 130 J = 1, N JM1 = J - 1 if (JM1 < 1) go to 120 DO 110 K = 1, JM1 T = A(K,J) call SAXPY(K,T,A(1,J),1,A(1,K),1) 110 CONTINUE 120 CONTINUE T = A(J,J) call SSCAL(J,T,A(1,J),1) 130 CONTINUE 140 CONTINUE return end subroutine SPOFA (A, LDA, N, INFO) ! !! SPOFA factors a real symmetric positive definite matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE SINGLE PRECISION (SPOFA-S, DPOFA-D, CPOFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPOFA factors a real symmetric positive definite matrix. ! ! SPOFA is usually called by SPOCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! (Time for SPOCO) = (1 + 18/N)*(Time for SPOFA) . ! ! On Entry ! ! A REAL(LDA, N) ! the symmetric matrix to be factored. Only the ! diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A an upper triangular matrix R so that A = TRANS(R)*R ! where TRANS(R) is the transpose. ! The strict lower triangle is unaltered. ! If INFO /= 0 , the factorization is not complete. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPOFA INTEGER LDA,N,INFO REAL A(LDA,*) ! REAL SDOT,T REAL S INTEGER J,JM1,K !***FIRST EXECUTABLE STATEMENT SPOFA DO 30 J = 1, N INFO = J S = 0.0E0 JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 K = 1, JM1 T = A(K,J) - SDOT(K-1,A(1,K),1,A(1,J),1) T = T/A(K,K) A(K,J) = T S = S + T*T 10 CONTINUE 20 CONTINUE S = A(J,J) - S if (S <= 0.0E0) go to 40 A(J,J) = SQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE return end subroutine SPOFS (A, LDA, N, V, ITASK, IND, WORK) ! !! SPOFS solves a positive definite symmetric system of linear equations. ! !***LIBRARY SLATEC !***CATEGORY D2B1B !***TYPE SINGLE PRECISION (SPOFS-S, DPOFS-D, CPOFS-C) !***KEYWORDS HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine SPOFS solves a real positive definite symmetric ! NxN system of single precision linear equations using ! LINPACK subroutines SPOCO and SPOSL. That is, if A is an ! NxN real positive definite symmetric matrix and if X and B ! are real N-vectors, then SPOFS solves the equation ! ! A*X=B. ! ! The matrix A is first factored into upper and lower tri- ! angular matrices R and R-TRANSPOSE. These factors are used to ! find the solution vector X. An approximate condition number is ! calculated to provide a rough estimate of the number of ! digits of accuracy in the computed solution. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to solve only (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, and N must not have been altered by the user following ! factorization (ITASK=1). IND will not be changed by SPOFS ! in this case. ! ! Argument Description *** ! ! A REAL(LDA,N) ! on entry, the doubly subscripted array with dimension ! (LDA,N) which contains the coefficient matrix. Only ! the upper triangle, including the diagonal, of the ! coefficient matrix need be entered and will subse- ! quently be referenced and changed by the routine. ! on return, contains in its upper triangle an upper ! triangular matrix R such that A = (R-TRANSPOSE) * R . ! LDA INTEGER ! the leading dimension of the array A. LDA must be great- ! er than or equal to N. (Terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. N must be greater ! than or equal to 1. (Terminal error message IND=-2) ! V REAL(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! If ITASK = 1, the matrix A is factored and then the ! linear equation is solved. ! If ITASK > 1, the equation is solved using the existing ! factored matrix A. ! If ITASK < 1, then terminal error message IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. ! LT. 0 see error message corresponding to IND below. ! WORK REAL(N) ! a singly subscripted array of dimension at least N. ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than 1. ! IND=-3 terminal ITASK is less than 1. ! IND=-4 Terminal The matrix A is computationally singular or ! is not positive definite. A solution ! has not been computed. ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the ! matrix A may be poorly scaled. ! ! Note- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED R1MACH, SPOCO, SPOSL, XERMSG !***REVISION HISTORY (YYMMDD) ! 800509 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPOFS ! INTEGER LDA,N,ITASK,IND,INFO REAL A(LDA,*),V(*),WORK(*),R1MACH REAL RCOND CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT SPOFS if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'SPOFS', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'SPOFS', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'SPOFS', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ITASK == 1) THEN ! ! FACTOR MATRIX A INTO R ! call SPOCO(A,LDA,N,RCOND,WORK,INFO) ! ! CHECK FOR POSITIVE DEFINITE MATRIX ! if (INFO /= 0) THEN IND = -4 call XERMSG ('SLATEC', 'SPOFS', & 'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1) return ENDIF ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(R1MACH(4)/RCOND) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'SPOFS', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) ENDIF end if ! ! SOLVE AFTER FACTORING ! call SPOSL(A,LDA,N,V) return end subroutine SPOIR (A, LDA, N, V, ITASK, IND, WORK) ! !! SPOIR solves a positive definite symmetric system of linear equations. ! Iterative refinement is used to obtain an error estimate. ! !***LIBRARY SLATEC !***CATEGORY D2B1B !***TYPE SINGLE PRECISION (SPOIR-S, CPOIR-C) !***KEYWORDS HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! Subroutine SPOIR solves a real positive definite symmetric ! NxN system of single precision linear equations using LINPACK ! subroutines SPOFA and SPOSL. One pass of iterative refine- ! ment is used only to obtain an estimate of the accuracy. That ! is, if A is an NxN real positive definite symmetric matrix ! and if X and B are real N-vectors, then SPOIR solves the ! equation ! ! A*X=B. ! ! The matrix A is first factored into upper and lower ! triangular matrices R and R-TRANSPOSE. These ! factors are used to calculate the solution, X. ! Then the residual vector is found and used ! to calculate an estimate of the relative error, IND. ! IND estimates the accuracy of the solution only when the ! input matrix and the right hand side are represented ! exactly in the computer and does not take into account ! any errors in the input data. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK > 1) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N, and WORK must not have been altered by the user ! following factorization (ITASK=1). IND will not be changed ! by SPOIR in this case. ! ! Argument Description *** ! A REAL(LDA,N) ! the doubly subscripted array with dimension (LDA,N) ! which contains the coefficient matrix. Only the ! upper triangle, including the diagonal, of the ! coefficient matrix need be entered. A is not ! altered by the routine. ! LDA INTEGER ! the leading dimension of the array A. LDA must be great- ! er than or equal to N. (Terminal error message IND=-1) ! N INTEGER ! the order of the matrix A. N must be greater than ! or equal to one. (Terminal error message IND=-2) ! V REAL(N) ! on entry, the singly subscripted array(vector) of di- ! mension N which contains the right hand side B of a ! system of simultaneous linear equations A*X=B. ! on return, V contains the solution vector, X . ! ITASK INTEGER ! If ITASK = 1, the matrix A is factored and then the ! linear equation is solved. ! If ITASK > 1, the equation is solved using the existing ! factored matrix A (stored in WORK). ! If ITASK < 1, then terminal terminal error IND=-3 is ! printed. ! IND INTEGER ! GT. 0 IND is a rough estimate of the number of digits ! of accuracy in the solution, X. IND=75 means ! that the solution vector X is zero. ! LT. 0 See error message corresponding to IND below. ! WORK REAL(N*(N+1)) ! a singly subscripted array of dimension at least N*(N+1). ! ! Error Messages Printed *** ! ! IND=-1 terminal N is greater than LDA. ! IND=-2 terminal N is less than one. ! IND=-3 terminal ITASK is less than one. ! IND=-4 Terminal The matrix A is computationally singular ! or is not positive definite. ! A solution has not been computed. ! IND=-10 warning The solution has no apparent significance. ! The solution may be inaccurate or the matrix ! A may be poorly scaled. ! ! Note- The above terminal(*fatal*) error messages are ! designed to be handled by XERMSG in which ! LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 ! for warning error messages from XERMSG. Unless ! the user provides otherwise, an error message ! will be printed followed by an abort. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED DSDOT, R1MACH, SASUM, SCOPY, SPOFA, SPOSL, XERMSG !***REVISION HISTORY (YYMMDD) ! 800528 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPOIR ! INTEGER LDA,N,ITASK,IND,INFO,J REAL A(LDA,*),V(*),WORK(N,*),SASUM,XNORM,DNORM,R1MACH DOUBLE PRECISION DSDOT CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT SPOIR if (LDA < N) THEN IND = -1 WRITE (XERN1, '(I8)') LDA WRITE (XERN2, '(I8)') N call XERMSG ('SLATEC', 'SPOIR', 'LDA = ' // XERN1 // & ' IS LESS THAN N = ' // XERN2, -1, 1) return end if ! if (N <= 0) THEN IND = -2 WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'SPOIR', 'N = ' // XERN1 // & ' IS LESS THAN 1', -2, 1) return end if ! if (ITASK < 1) THEN IND = -3 WRITE (XERN1, '(I8)') ITASK call XERMSG ('SLATEC', 'SPOIR', 'ITASK = ' // XERN1 // & ' IS LESS THAN 1', -3, 1) return end if ! if (ITASK == 1) THEN ! ! MOVE MATRIX A TO WORK ! DO 10 J=1,N call SCOPY(N,A(1,J),1,WORK(1,J),1) 10 CONTINUE ! ! FACTOR MATRIX A INTO R call SPOFA(WORK,N,N,INFO) ! ! CHECK FOR SINGULAR OR NOT POS.DEF. MATRIX if (INFO /= 0) THEN IND = -4 call XERMSG ('SLATEC', 'SPOIR', & 'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1) return ENDIF end if ! ! SOLVE AFTER FACTORING ! MOVE VECTOR B TO WORK ! call SCOPY(N,V(1),1,WORK(1,N+1),1) call SPOSL(WORK,N,N,V) ! ! FORM NORM OF X0 ! XNORM = SASUM(N,V(1),1) if (XNORM == 0.0) THEN IND = 75 return end if ! ! COMPUTE RESIDUAL ! DO 40 J=1,N WORK(J,N+1) = -WORK(J,N+1) & +DSDOT(J-1,A(1,J),1,V(1),1) & +DSDOT(N-J+1,A(J,J),LDA,V(J),1) 40 CONTINUE ! ! SOLVE A*DELTA=R ! call SPOSL(WORK,N,N,WORK(1,N+1)) ! ! FORM NORM OF DELTA ! DNORM = SASUM(N,WORK(1,N+1),1) ! ! COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) ! AND CHECK FOR IND GREATER THAN ZERO ! IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM)) if (IND <= 0) THEN IND = -10 call XERMSG ('SLATEC', 'SPOIR', & 'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0) end IF return end subroutine SPOPT (PRGOPT, MRELAS, NVARS, INFO, CSC, IBASIS, ROPT, & INTOPT, LOPT) ! !! SPOPT is subsidiary to SPLP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPOPT-S, DPOPT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO ! DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. ! ! USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. ! /REAL (12 BLANKS)/DOUBLE PRECISION/, ! /R1MACH/D1MACH/,/E0/D0/ ! ! REVISED 821122-1045 ! REVISED YYMMDD-HHMM ! ! THIS SUBROUTINE PROCESSES THE OPTION VECTOR, PRGOPT(*), ! AND VALIDATES ANY MODIFIED DATA. ! !***SEE ALSO SPLP !***ROUTINES CALLED R1MACH, XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890605 Removed unreferenced labels. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SPOPT REAL ABIG,ASMALL,COSTSC,CSC(*),EPS,ONE,PRGOPT(*), & ROPT(07),TOLLS,TUNE,ZERO,R1MACH,TOLABS INTEGER IBASIS(*),INTOPT(08) LOGICAL CONTIN,USRBAS,SIZEUP,SAVEDT,COLSCP,CSTSCP,MINPRB, & STPEDG,LOPT(8) ! !***FIRST EXECUTABLE STATEMENT SPOPT IOPT=1 ZERO=0.E0 ONE=1.E0 go to 30001 20002 CONTINUE go to 30002 ! 20003 LOPT(1)=CONTIN LOPT(2)=USRBAS LOPT(3)=SIZEUP LOPT(4)=SAVEDT LOPT(5)=COLSCP LOPT(6)=CSTSCP LOPT(7)=MINPRB LOPT(8)=STPEDG ! INTOPT(1)=IDG INTOPT(2)=IPAGEF INTOPT(3)=ISAVE INTOPT(4)=MXITLP INTOPT(5)=KPRINT INTOPT(6)=ITBRC INTOPT(7)=NPP INTOPT(8)=LPRG ! ROPT(1)=EPS ROPT(2)=ASMALL ROPT(3)=ABIG ROPT(4)=COSTSC ROPT(5)=TOLLS ROPT(6)=TUNE ROPT(7)=TOLABS return ! ! ! PROCEDURE (INITIALIZE PARAMETERS AND PROCESS USER OPTIONS) 30001 CONTIN = .FALSE. USRBAS = .FALSE. SIZEUP = .FALSE. SAVEDT = .FALSE. COLSCP = .FALSE. CSTSCP = .FALSE. MINPRB = .TRUE. STPEDG = .TRUE. ! ! GET THE MACHINE REL. FLOATING POINT ACCURACY VALUE FROM THE ! LIBRARY SUBPROGRAM, R1MACH( ). EPS=R1MACH(4) TOLLS=R1MACH(4) TUNE=ONE TOLABS=ZERO ! ! DEFINE NOMINAL FILE NUMBERS FOR MATRIX PAGES AND DATA SAVING. IPAGEF=1 ISAVE=2 ITBRC=10 MXITLP=3*(NVARS+MRELAS) KPRINT=0 IDG=-4 NPP=NVARS LPRG=0 ! LAST = 1 IADBIG=10000 ICTMAX=1000 ICTOPT= 0 20004 NEXT=PRGOPT(LAST) if (.NOT.(NEXT <= 0 .OR. NEXT > IADBIG)) go to 20006 ! ! THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT ! WORKING WITH UNDEFINED DATA. NERR=14 call XERMSG ('SLATEC', 'SPOPT', & 'IN SPLP, THE USER OPTION ARRAY HAS UNDEFINED DATA.', NERR, & IOPT) INFO=-NERR return 20006 if (.NOT.(NEXT == 1)) go to 10001 go to 20005 10001 if (.NOT.(ICTOPT > ICTMAX)) go to 10002 NERR=15 call XERMSG ('SLATEC', 'SPOPT', & 'IN SPLP, OPTION ARRAY PROCESSING IS CYCLING.', NERR, IOPT) INFO=-NERR return 10002 CONTINUE KEY = PRGOPT(LAST+1) ! ! if KEY = 50, THIS IS TO BE A MAXIMIZATION PROBLEM ! INSTEAD OF A MINIMIZATION PROBLEM. if (.NOT.(KEY == 50)) go to 20010 MINPRB = PRGOPT(LAST+2) == ZERO LDS=3 go to 20009 20010 CONTINUE ! ! if KEY = 51, THE LEVEL OF OUTPUT IS BEING MODIFIED. ! KPRINT = 0, NO OUTPUT ! = 1, SUMMARY OUTPUT ! = 2, LOTS OF OUTPUT ! = 3, EVEN MORE OUTPUT if (.NOT.(KEY == 51)) go to 20013 KPRINT=PRGOPT(LAST+2) LDS=3 go to 20009 20013 CONTINUE ! ! if KEY = 52, REDEFINE THE FORMAT AND PRECISION USED ! IN THE OUTPUT. if (.NOT.(KEY == 52)) go to 20016 if (PRGOPT(LAST+2) /= ZERO) IDG=PRGOPT(LAST+3) LDS=4 go to 20009 20016 CONTINUE ! ! if KEY = 53, THE ALLOTTED SPACE FOR THE SPARSE MATRIX ! STORAGE AND/OR SPARSE EQUATION SOLVING HAS BEEN CHANGED. ! (PROCESSED IN SPLP(). THIS IS TO COMPUTE THE LENGTH OF PRGOPT(*).) if (.NOT.(KEY == 53)) go to 20019 LDS=5 go to 20009 20019 CONTINUE ! ! if KEY = 54, REDEFINE THE FILE NUMBER WHERE THE PAGES ! FOR THE SPARSE MATRIX ARE STORED. if (.NOT.(KEY == 54)) go to 20022 if ( PRGOPT(LAST+2) /= ZERO) IPAGEF = PRGOPT(LAST+3) LDS=4 go to 20009 20022 CONTINUE ! ! if KEY = 55, A CONTINUATION FOR A PROBLEM MAY BE REQUESTED. if (.NOT.(KEY == 55)) go to 20025 CONTIN = PRGOPT(LAST+2) /= ZERO LDS=3 go to 20009 20025 CONTINUE ! ! if KEY = 56, REDEFINE THE FILE NUMBER WHERE THE SAVED DATA ! WILL BE STORED. if (.NOT.(KEY == 56)) go to 20028 if ( PRGOPT(LAST+2) /= ZERO) ISAVE = PRGOPT(LAST+3) LDS=4 go to 20009 20028 CONTINUE ! ! if KEY = 57, SAVE DATA (ON EXTERNAL FILE) AT MXITLP ITERATIONS OR ! THE OPTIMUM, WHICHEVER COMES FIRST. if (.NOT.(KEY == 57)) go to 20031 SAVEDT=PRGOPT(LAST+2) /= ZERO LDS=3 go to 20009 20031 CONTINUE ! ! if KEY = 58, SEE IF PROBLEM IS TO RUN ONLY A GIVEN ! NUMBER OF ITERATIONS. if (.NOT.(KEY == 58)) go to 20034 if (PRGOPT(LAST+2) /= ZERO) MXITLP = PRGOPT(LAST+3) LDS=4 go to 20009 20034 CONTINUE ! ! if KEY = 59, SEE IF USER PROVIDES THE BASIS INDICES. if (.NOT.(KEY == 59)) go to 20037 USRBAS = PRGOPT(LAST+2) /= ZERO if (.NOT.(USRBAS)) go to 20040 I=1 N20043=MRELAS go to 20044 20043 I=I+1 20044 if ((N20043-I) < 0) go to 20045 IBASIS(I) = PRGOPT(LAST+2+I) go to 20043 20045 CONTINUE 20040 CONTINUE LDS=MRELAS+3 go to 20009 20037 CONTINUE ! ! if KEY = 60, SEE IF USER HAS PROVIDED SCALING OF COLUMNS. if (.NOT.(KEY == 60)) go to 20047 COLSCP = PRGOPT(LAST+2) /= ZERO if (.NOT.(COLSCP)) go to 20050 J=1 N20053=NVARS go to 20054 20053 J=J+1 20054 if ((N20053-J) < 0) go to 20055 CSC(J)=ABS(PRGOPT(LAST+2+J)) go to 20053 20055 CONTINUE 20050 CONTINUE LDS=NVARS+3 go to 20009 20047 CONTINUE ! ! if KEY = 61, SEE IF USER HAS PROVIDED SCALING OF COSTS. if (.NOT.(KEY == 61)) go to 20057 CSTSCP = PRGOPT(LAST+2) /= ZERO if (CSTSCP) COSTSC = PRGOPT(LAST+3) LDS=4 go to 20009 20057 CONTINUE ! ! if KEY = 62, SEE IF SIZE PARAMETERS ARE PROVIDED WITH THE DATA. ! THESE WILL BE CHECKED AGAINST THE MATRIX ELEMENT SIZES LATER. if (.NOT.(KEY == 62)) go to 20060 SIZEUP = PRGOPT(LAST+2) /= ZERO if (.NOT.(SIZEUP)) go to 20063 ASMALL = PRGOPT(LAST+3) ABIG = PRGOPT(LAST+4) 20063 CONTINUE LDS=5 go to 20009 20060 CONTINUE ! ! if KEY = 63, SEE IF TOLERANCE FOR LINEAR SYSTEM RESIDUAL ERROR IS ! PROVIDED. if (.NOT.(KEY == 63)) go to 20066 if (PRGOPT(LAST+2) /= ZERO) TOLLS = MAX(EPS,PRGOPT(LAST+3)) LDS=4 go to 20009 20066 CONTINUE ! ! if KEY = 64, SEE IF MINIMUM REDUCED COST OR STEEPEST EDGE ! DESCENT IS TO BE USED FOR SELECTING VARIABLES TO ENTER BASIS. if (.NOT.(KEY == 64)) go to 20069 STPEDG = PRGOPT(LAST+2) == ZERO LDS=3 go to 20009 20069 CONTINUE ! ! if KEY = 65, SET THE NUMBER OF ITERATIONS BETWEEN RECALCULATING ! THE ERROR IN THE PRIMAL SOLUTION. if (.NOT.(KEY == 65)) go to 20072 if (PRGOPT(LAST+2) /= ZERO) ITBRC=MAX(ONE,PRGOPT(LAST+3)) LDS=4 go to 20009 20072 CONTINUE ! ! if KEY = 66, SET THE NUMBER OF NEGATIVE REDUCED COSTS TO BE FOUND ! IN THE PARTIAL PRICING STRATEGY. if (.NOT.(KEY == 66)) go to 20075 if (.NOT.(PRGOPT(LAST+2) /= ZERO)) go to 20078 NPP=MAX(PRGOPT(LAST+3),ONE) NPP=MIN(NPP,NVARS) 20078 CONTINUE LDS=4 go to 20009 20075 CONTINUE ! if KEY = 67, CHANGE THE TUNING PARAMETER TO APPLY TO THE ERROR ! ESTIMATES FOR THE PRIMAL AND DUAL SYSTEMS. if (.NOT.(KEY == 67)) go to 20081 if (.NOT.(PRGOPT(LAST+2) /= ZERO)) go to 20084 TUNE=ABS(PRGOPT(LAST+3)) 20084 CONTINUE LDS=4 go to 20009 20081 CONTINUE if (.NOT.(KEY == 68)) go to 20087 LDS=6 go to 20009 20087 CONTINUE ! ! RESET THE ABSOLUTE TOLERANCE TO BE USED ON THE FEASIBILITY ! DECISION PROVIDED THE RELATIVE ERROR TEST FAILED. if (.NOT.(KEY == 69)) go to 20090 if ( PRGOPT(LAST+2) /= ZERO)TOLABS=PRGOPT(LAST+3) LDS=4 go to 20009 20090 CONTINUE CONTINUE ! 20009 ICTOPT = ICTOPT+1 LAST = NEXT LPRG=LPRG+LDS go to 20004 20005 CONTINUE go to 20002 ! ! PROCEDURE (VALIDATE OPTIONALLY MODIFIED DATA) ! ! if USER HAS DEFINED THE BASIS, CHECK FOR VALIDITY OF INDICES. 30002 if (.NOT.(USRBAS)) go to 20093 I=1 N20096=MRELAS go to 20097 20096 I=I+1 20097 if ((N20096-I) < 0) go to 20098 ITEST=IBASIS(I) if (.NOT.(ITEST <= 0 .OR.ITEST > (NVARS+MRELAS))) go to 20100 NERR=16 call XERMSG ('SLATEC', 'SPOPT', & 'IN SPLP, AN INDEX OF USER-SUPPLIED BASIS IS OUT OF RANGE.', & NERR, IOPT) INFO=-NERR return 20100 CONTINUE go to 20096 20098 CONTINUE 20093 CONTINUE ! ! if USER HAS PROVIDED SIZE PARAMETERS, MAKE SURE THEY ARE ORDERED ! AND POSITIVE. if (.NOT.(SIZEUP)) go to 20103 if (.NOT.(ASMALL <= ZERO .OR. ABIG < ASMALL)) go to 20106 NERR=17 call XERMSG ('SLATEC', 'SPOPT', & 'IN SPLP, SIZE PARAMETERS FOR MATRIX MUST BE SMALLEST AND ' // & 'LARGEST MAGNITUDES OF NONZERO ENTRIES.', NERR, IOPT) INFO=-NERR return 20106 CONTINUE 20103 CONTINUE ! ! THE NUMBER OF ITERATIONS OF REV. SIMPLEX STEPS MUST BE POSITIVE. if (.NOT.(MXITLP <= 0)) go to 20109 NERR=18 call XERMSG ('SLATEC', 'SPOPT', & 'IN SPLP, THE NUMBER OF REVISED SIMPLEX STEPS BETWEEN ' // & 'CHECK-POINTS MUST BE POSITIVE.', NERR, IOPT) INFO=-NERR return 20109 CONTINUE ! ! CHECK THAT SAVE AND PAGE FILE NUMBERS ARE DEFINED AND NOT EQUAL. ! if (.NOT.(ISAVE <= 0.OR.IPAGEF <= 0.OR.(ISAVE == IPAGEF))) go to 20112 NERR=19 call XERMSG ('SLATEC', 'SPOPT', & 'IN SPLP, FILE NUMBERS FOR SAVED DATA AND MATRIX PAGES ' // & 'MUST BE POSITIVE AND NOT EQUAL.', NERR, IOPT) INFO=-NERR return 20112 CONTINUE CONTINUE go to 20003 end subroutine SPOSL (A, LDA, N, B) ! !! SPOSL solves the real symmetric positive definite linear system ... ! using the factors computed by SPOCO or SPOFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE SINGLE PRECISION (SPOSL-S, DPOSL-D, CPOSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPOSL solves the real symmetric positive definite system ! A * X = B ! using the factors computed by SPOCO or SPOFA. ! ! On Entry ! ! A REAL(LDA, N) ! the output from SPOCO or SPOFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! B REAL(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal. Technically, this indicates ! singularity, but it is usually caused by improper subroutine ! arguments. It will not occur if the subroutines are called ! correctly and INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call SPOCO(A,LDA,N,RCOND,Z,INFO) ! if (RCOND is too small .OR. INFO /= 0) go to ... ! DO 10 J = 1, P ! call SPOSL(A,LDA,N,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPOSL INTEGER LDA,N REAL A(LDA,*),B(*) ! REAL SDOT,T INTEGER K,KB ! ! SOLVE TRANS(R)*Y = B ! !***FIRST EXECUTABLE STATEMENT SPOSL DO 10 K = 1, N T = SDOT(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) 10 CONTINUE ! ! SOLVE R*X = Y ! DO 20 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) 20 CONTINUE return end subroutine SPPCO (AP, N, RCOND, Z, INFO) ! !! SPPCO factors a symmetric positive definite matrix stored in packed form ... ! and estimates the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE SINGLE PRECISION (SPPCO-S, DPPCO-D, CPPCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, PACKED, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPPCO factors a real symmetric positive definite matrix ! stored in packed form ! and estimates the condition of the matrix. ! ! If RCOND is not needed, SPPFA is slightly faster. ! To solve A*X = B , follow SPPCO by SPPSL. ! To compute INVERSE(A)*C , follow SPPCO by SPPSL. ! To compute DETERMINANT(A) , follow SPPCO by SPPDI. ! To compute INVERSE(A) , follow SPPCO by SPPDI. ! ! On Entry ! ! AP REAL (N*(N+1)/2) ! the packed form of a symmetric matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! AP an upper triangular matrix R , stored in packed ! form, so that A = TRANS(R)*R . ! If INFO /= 0 , the factorization is not complete. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. If INFO /= 0 , RCOND is unchanged. ! ! Z REAL(N) ! a work vector whose contents are usually unimportant. ! If A is singular to working precision, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! If INFO /= 0 , Z is unchanged. ! ! INFO INTEGER ! = 0 for normal return. ! = K signals an error condition. The leading minor ! of order K is not positive definite. ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a symmetric matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SASUM, SAXPY, SDOT, SPPFA, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPPCO INTEGER N,INFO REAL AP(*),Z(*) REAL RCOND ! REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER I,IJ,J,JM1,J1,K,KB,KJ,KK,KP1 ! ! FIND NORM OF A ! !***FIRST EXECUTABLE STATEMENT SPPCO J1 = 1 DO 30 J = 1, N Z(J) = SASUM(J,AP(J1),1) IJ = J1 J1 = J1 + J JM1 = J - 1 if (JM1 < 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 = MAX(ANORM,Z(J)) 40 CONTINUE ! ! FACTOR ! call SPPFA(AP,N,INFO) if (INFO /= 0) go to 180 ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE TRANS(R)*W = E ! EK = 1.0E0 DO 50 J = 1, N Z(J) = 0.0E0 50 CONTINUE KK = 0 DO 110 K = 1, N KK = KK + K if (Z(K) /= 0.0E0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= AP(KK)) go to 60 S = AP(KK)/ABS(EK-Z(K)) call SSCAL(N,S,Z,1) EK = S*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) WK = WK/AP(KK) WKM = WKM/AP(KK) KP1 = K + 1 KJ = KK + K if (KP1 > N) go to 100 DO 70 J = KP1, N SM = SM + ABS(Z(J)+WKM*AP(KJ)) Z(J) = Z(J) + WK*AP(KJ) S = S + ABS(Z(J)) KJ = KJ + J 70 CONTINUE if (S >= SM) go to 90 T = WKM - WK WK = WKM KJ = KK + K DO 80 J = KP1, N Z(J) = Z(J) + T*AP(KJ) KJ = KJ + J 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) ! ! SOLVE R*Y = W ! DO 130 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= AP(KK)) go to 120 S = AP(KK)/ABS(Z(K)) call SSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/AP(KK) KK = KK - K T = -Z(K) call SAXPY(K-1,T,AP(KK+1),1,Z(1),1) 130 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE TRANS(R)*V = Y ! DO 150 K = 1, N Z(K) = Z(K) - SDOT(K-1,AP(KK+1),1,Z(1),1) KK = KK + K if (ABS(Z(K)) <= AP(KK)) go to 140 S = AP(KK)/ABS(Z(K)) call SSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/AP(KK) 150 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE R*Z = V ! DO 170 KB = 1, N K = N + 1 - KB if (ABS(Z(K)) <= AP(KK)) go to 160 S = AP(KK)/ABS(Z(K)) call SSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/AP(KK) KK = KK - K T = -Z(K) call SAXPY(K-1,T,AP(KK+1),1,Z(1),1) 170 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 180 CONTINUE return end subroutine SPPDI (AP, N, DET, JOB) ! !! SPPDI computes the determinant and inverse of a real symmetric ... ! positive definite matrix using factors from SPPCO or SPPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B, D3B1B !***TYPE SINGLE PRECISION (SPPDI-S, DPPDI-D, CPPDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! PACKED, POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPPDI computes the determinant and inverse ! of a real symmetric positive definite matrix ! using the factors computed by SPPCO or SPPFA . ! ! On Entry ! ! AP REAL (N*(N+1)/2) ! the output from SPPCO or SPPFA. ! ! N INTEGER ! the order of the matrix A . ! ! JOB INTEGER ! = 11 both determinant and inverse. ! = 01 inverse only. ! = 10 determinant only. ! ! On Return ! ! AP the upper triangular half of the inverse . ! The strict lower triangle is unaltered. ! ! DET REAL(2) ! determinant of original matrix if requested. ! Otherwise not referenced. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= DET(1) < 10.0 ! or DET(1) == 0.0 . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal and the inverse is requested. ! It will not occur if the subroutines are called correctly ! and if SPOCO or SPOFA has set INFO == 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPPDI INTEGER N,JOB REAL AP(*) REAL DET(2) ! REAL T REAL S INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1 !***FIRST EXECUTABLE STATEMENT SPPDI ! ! COMPUTE DETERMINANT ! if (JOB/10 == 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) if (DET(1) == 0.0E0) go to 60 10 if (DET(1) >= 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) < 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 ! ! COMPUTE INVERSE(R) ! if (MOD(JOB,10) == 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 < 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 ! ! FORM INVERSE(R) * TRANS(INVERSE(R)) ! JJ = 0 DO 130 J = 1, N J1 = JJ + 1 JJ = JJ + J JM1 = J - 1 K1 = 1 KJ = J1 if (JM1 < 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 SPPERM (X, N, IPERM, IER) ! !! SPPERM rearranges a given array according to a prescribed permutation vector. ! !***LIBRARY SLATEC !***CATEGORY N8 !***TYPE SINGLE PRECISION (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H) !***KEYWORDS APPLICATION OF PERMUTATION TO DATA VECTOR !***AUTHOR McClain, M. A., (NIST) ! Rhoads, G. S., (NBS) !***DESCRIPTION ! ! SPPERM rearranges the data vector X according to the ! permutation IPERM: X(I) <--- X(IPERM(I)). IPERM could come ! from one of the sorting routines IPSORT, SPSORT, DPSORT or ! HPSORT. ! ! Description of Parameters ! X - input/output -- real array of values to be rearranged. ! N - input -- number of values in real array X. ! IPERM - input -- permutation vector. ! IER - output -- error indicator: ! = 0 if no error, ! = 1 if N is zero or negative, ! = 2 if IPERM is not a valid permutation. ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 901004 DATE WRITTEN ! 920507 Modified by M. McClain to revise prologue text. !***END PROLOGUE SPPERM INTEGER N, IPERM(*), I, IER, INDX, INDX0, ISTRT REAL X(*), TEMP !***FIRST EXECUTABLE STATEMENT SPPERM IER=0 if ( N < 1)THEN IER=1 call XERMSG ('SLATEC', 'SPPERM', & 'The number of values to be rearranged, N, is not positive.', & IER, 1) return end if ! ! CHECK WHETHER IPERM IS A VALID PERMUTATION ! DO 100 I=1,N INDX=ABS(IPERM(I)) if ( (INDX >= 1).AND.(INDX <= N))THEN if ( IPERM(INDX) > 0)THEN IPERM(INDX)=-IPERM(INDX) GOTO 100 ENDIF ENDIF IER=2 call XERMSG ('SLATEC', 'SPPERM', & 'The permutation vector, IPERM, is not valid.', IER, 1) return 100 CONTINUE ! ! REARRANGE THE VALUES OF X ! ! USE THE IPERM VECTOR AS A FLAG. ! if IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION ! DO 330 ISTRT = 1 , N if (IPERM(ISTRT) > 0) GOTO 330 INDX = ISTRT INDX0 = INDX TEMP = X(ISTRT) 320 CONTINUE if (IPERM(INDX) >= 0) GOTO 325 X(INDX) = X(-IPERM(INDX)) INDX0 = INDX IPERM(INDX) = -IPERM(INDX) INDX = IPERM(INDX) GOTO 320 325 CONTINUE X(INDX0) = TEMP 330 CONTINUE ! return end subroutine SPPFA (AP, N, INFO) ! !! SPPFA factors a real symmetric positive definite matrix in packed form. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE SINGLE PRECISION (SPPFA-S, DPPFA-D, CPPFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, ! POSITIVE DEFINITE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPPFA factors a real symmetric positive definite matrix ! stored in packed form. ! ! SPPFA is usually called by SPPCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! (Time for SPPCO) = (1 + 18/N)*(Time for SPPFA) . ! ! On Entry ! ! AP REAL (N*(N+1)/2) ! the packed form of a symmetric matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! AP an upper triangular matrix R , stored in packed ! form, so that A = TRANS(R)*R . ! ! INFO INTEGER ! = 0 for normal return. ! = K if the leading minor of order K is not ! positive definite. ! ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a symmetric matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPPFA INTEGER N,INFO REAL AP(*) ! REAL SDOT,T REAL S INTEGER J,JJ,JM1,K,KJ,KK !***FIRST EXECUTABLE STATEMENT SPPFA JJ = 0 DO 30 J = 1, N INFO = J S = 0.0E0 JM1 = J - 1 KJ = JJ KK = 0 if (JM1 < 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 if (S <= 0.0E0) go to 40 AP(JJ) = SQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE return end subroutine SPPSL (AP, N, B) ! !! SPPSL solves the real symmetric positive definite system using factors ... ! computed by SPPCO or SPPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1B !***TYPE SINGLE PRECISION (SPPSL-S, DPPSL-D, CPPSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, ! POSITIVE DEFINITE, SOLVE !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SPPSL solves the real symmetric positive definite system ! A * X = B ! using the factors computed by SPPCO or SPPFA. ! ! On Entry ! ! AP REAL (N*(N+1)/2) ! the output from SPPCO or SPPFA. ! ! N INTEGER ! the order of the matrix A . ! ! B REAL(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero will occur if the input factor contains ! a zero on the diagonal. Technically, this indicates ! singularity, but it is usually caused by improper subroutine ! arguments. It will not occur if the subroutines are called ! correctly and INFO == 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call SPPCO(AP,N,RCOND,Z,INFO) ! if (RCOND is too small .OR. INFO /= 0) go to ... ! DO 10 J = 1, P ! call SPPSL(AP,N,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPPSL INTEGER N REAL AP(*),B(*) ! REAL SDOT,T INTEGER K,KB,KK !***FIRST EXECUTABLE STATEMENT SPPSL 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 SPSORT (X, N, IPERM, KFLAG, IER) ! !! SPSORT returns the permutation vector generated by sorting a given array ... ! and, optionally, rearrange the elements of the array. ! The array may be sorted in increasing or decreasing order. ! A slightly modified quicksort algorithm is used. ! !***LIBRARY SLATEC !***CATEGORY N6A1B, N6A2B !***TYPE SINGLE PRECISION (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H) !***KEYWORDS NUMBER SORTING, PASSIVE SORTING, SINGLETON QUICKSORT, SORT !***AUTHOR Jones, R. E., (SNLA) ! Rhoads, G. S., (NBS) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! SPSORT returns the permutation vector IPERM generated by sorting ! the array X and, optionally, rearranges the values in X. X may ! be sorted in increasing or decreasing order. A slightly modified ! quicksort algorithm is used. ! ! IPERM is such that X(IPERM(I)) is the Ith value in the rearrangement ! of X. IPERM may be applied to another array by calling IPPERM, ! SPPERM, DPPERM or HPPERM. ! ! The main difference between SPSORT and its active sorting equivalent ! SSORT is that the data are referenced indirectly rather than ! directly. Therefore, SPSORT should require approximately twice as ! long to execute as SSORT. However, SPSORT is more general. ! ! Description of Parameters ! X - input/output -- real array of values to be sorted. ! If ABS(KFLAG) = 2, then the values in X will be ! rearranged on output; otherwise, they are unchanged. ! N - input -- number of values in array X to be sorted. ! IPERM - output -- permutation array such that IPERM(I) is the ! index of the value in the original order of the ! X array that is in the Ith location in the sorted ! order. ! KFLAG - input -- control parameter: ! = 2 means return the permutation vector resulting from ! sorting X in increasing order and sort X also. ! = 1 means return the permutation vector resulting from ! sorting X in increasing order and do not sort X. ! = -1 means return the permutation vector resulting from ! sorting X in decreasing order and do not sort X. ! = -2 means return the permutation vector resulting from ! sorting X in decreasing order and sort X also. ! IER - output -- error indicator: ! = 0 if no error, ! = 1 if N is zero or negative, ! = 2 if KFLAG is not 2, 1, -1, or -2. !***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm ! for sorting with minimal storage, Communications of ! the ACM, 12, 3 (1969), pp. 185-187. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 761101 DATE WRITTEN ! 761118 Modified by John A. Wisniewski to use the Singleton ! quicksort algorithm. ! 870423 Modified by Gregory S. Rhoads for passive sorting with the ! option for the rearrangement of the original data. ! 890620 Algorithm for rearranging the data vector corrected by R. ! Boisvert. ! 890622 Prologue upgraded to Version 4.0 style by D. Lozier. ! 891128 Error when KFLAG < 0 and N=1 corrected by R. Boisvert. ! 920507 Modified by M. McClain to revise prologue text. ! 920818 Declarations section rebuilt and code restructured to use ! IF-THEN-ELSE-ENDIF. (SMR, WRB) !***END PROLOGUE SPSORT ! .. Scalar Arguments .. INTEGER IER, KFLAG, N ! .. Array Arguments .. REAL X(*) INTEGER IPERM(*) ! .. Local Scalars .. REAL R, TEMP INTEGER I, IJ, INDX, INDX0, ISTRT, J, K, KK, L, LM, LMT, M, NN ! .. Local Arrays .. INTEGER IL(21), IU(21) ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, INT !***FIRST EXECUTABLE STATEMENT SPSORT IER = 0 NN = N if (NN < 1) THEN IER = 1 call XERMSG ('SLATEC', 'SPSORT', & 'The number of values to be sorted, N, is not positive.', & IER, 1) return end if KK = ABS(KFLAG) if (KK /= 1 .AND. KK /= 2) THEN IER = 2 call XERMSG ('SLATEC', 'SPSORT', & 'The sort control parameter, KFLAG, is not 2, 1, -1, or -2.', & IER, 1) return end if ! ! Initialize permutation vector ! DO 10 I=1,NN IPERM(I) = I 10 CONTINUE ! ! Return if only one value is to be sorted ! if (NN == 1) RETURN ! ! Alter array X to get decreasing order if needed ! if (KFLAG <= -1) THEN DO 20 I=1,NN X(I) = -X(I) 20 CONTINUE end if ! ! Sort X only ! M = 1 I = 1 J = NN R = .375E0 ! 30 if (I == J) go to 80 if (R <= 0.5898437E0) THEN R = R+3.90625E-2 ELSE R = R-0.21875E0 end if ! 40 K = I ! ! Select a central element of the array and save it in location L ! IJ = I + INT((J-I)*R) LM = IPERM(IJ) ! ! If first element of array is greater than LM, interchange with LM ! if (X(IPERM(I)) > X(LM)) THEN IPERM(IJ) = IPERM(I) IPERM(I) = LM LM = IPERM(IJ) end if L = J ! ! If last element of array is less than LM, interchange with LM ! if (X(IPERM(J)) < X(LM)) THEN IPERM(IJ) = IPERM(J) IPERM(J) = LM LM = IPERM(IJ) ! ! If first element of array is greater than LM, interchange ! with LM ! if (X(IPERM(I)) > X(LM)) THEN IPERM(IJ) = IPERM(I) IPERM(I) = LM LM = IPERM(IJ) ENDIF end if go to 60 50 LMT = IPERM(L) IPERM(L) = IPERM(K) IPERM(K) = LMT ! ! Find an element in the second half of the array which is smaller ! than LM ! 60 L = L-1 if (X(IPERM(L)) > X(LM)) go to 60 ! ! Find an element in the first half of the array which is greater ! than LM ! 70 K = K+1 if (X(IPERM(K)) < X(LM)) go to 70 ! ! Interchange these elements ! if (K <= L) go to 50 ! ! Save upper and lower subscripts of the array yet to be sorted ! if (L-I > J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 90 ! ! Begin again on another portion of the unsorted array ! 80 M = M-1 if (M == 0) go to 120 I = IL(M) J = IU(M) ! 90 if (J-I >= 1) go to 40 if (I == 1) go to 30 I = I-1 ! 100 I = I+1 if (I == J) go to 80 LM = IPERM(I+1) if (X(IPERM(I)) <= X(LM)) go to 100 K = I ! 110 IPERM(K+1) = IPERM(K) K = K-1 ! if (X(LM) < X(IPERM(K))) go to 110 IPERM(K+1) = LM go to 100 ! ! Clean up ! 120 if (KFLAG <= -1) THEN DO 130 I=1,NN X(I) = -X(I) 130 CONTINUE end if ! ! Rearrange the values of X if desired ! if (KK == 2) THEN ! ! Use the IPERM vector as a flag. ! If IPERM(I) < 0, then the I-th value is in correct location ! DO 150 ISTRT=1,NN if (IPERM(ISTRT) >= 0) THEN INDX = ISTRT INDX0 = INDX TEMP = X(ISTRT) 140 if (IPERM(INDX) > 0) THEN X(INDX) = X(IPERM(INDX)) INDX0 = INDX IPERM(INDX) = -IPERM(INDX) INDX = ABS(IPERM(INDX)) go to 140 ENDIF X(INDX0) = TEMP ENDIF 150 CONTINUE ! ! Revert the signs of the IPERM values ! DO 160 I=1,NN IPERM(I) = -IPERM(I) 160 CONTINUE ! end if ! return end subroutine SPTSL (N, D, E, B) ! !! SPTSL solves a positive definite tridiagonal linear system. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B2A !***TYPE SINGLE PRECISION (SPTSL-S, DPTSL-D, CPTSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE, ! TRIDIAGONAL !***AUTHOR Dongarra, J., (ANL) !***DESCRIPTION ! ! SPTSL given a positive definite tridiagonal matrix and a right ! hand side will find the solution. ! ! On Entry ! ! N INTEGER ! is the order of the tridiagonal matrix. ! ! D REAL(N) ! is the diagonal of the tridiagonal matrix. ! On output, D is destroyed. ! ! E REAL(N) ! is the offdiagonal of the tridiagonal matrix. ! E(1) through E(N-1) should contain the ! offdiagonal. ! ! B REAL(N) ! is the right hand side vector. ! ! On Return ! ! B contains the solution. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890505 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SPTSL INTEGER N REAL D(*),E(*),B(*) ! INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2 REAL T1,T2 ! ! CHECK FOR 1 X 1 CASE ! !***FIRST EXECUTABLE STATEMENT SPTSL if (N /= 1) go to 10 B(1) = B(1)/D(1) go to 70 10 CONTINUE NM1 = N - 1 NM1D2 = NM1/2 if (N == 2) go to 30 KBM1 = N - 1 ! ! ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF ! SUPERDIAGONAL ! DO 20 K = 1, NM1D2 T1 = E(K)/D(K) D(K+1) = D(K+1) - T1*E(K) B(K+1) = B(K+1) - T1*B(K) T2 = E(KBM1)/D(KBM1+1) D(KBM1) = D(KBM1) - T2*E(KBM1) B(KBM1) = B(KBM1) - T2*B(KBM1+1) KBM1 = KBM1 - 1 20 CONTINUE 30 CONTINUE KP1 = NM1D2 + 1 ! ! CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER ! if (MOD(N,2) /= 0) go to 40 T1 = E(KP1)/D(KP1) D(KP1+1) = D(KP1+1) - T1*E(KP1) B(KP1+1) = B(KP1+1) - T1*B(KP1) KP1 = KP1 + 1 40 CONTINUE ! ! BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP ! AND BOTTOM ! B(KP1) = B(KP1)/D(KP1) if (N == 2) go to 60 K = KP1 - 1 KE = KP1 + NM1D2 - 1 DO 50 KF = KP1, KE B(K) = (B(K) - E(K)*B(K+1))/D(K) B(KF+1) = (B(KF+1) - E(KF)*B(KF))/D(KF+1) K = K - 1 50 CONTINUE 60 CONTINUE if (MOD(N,2) == 0) B(1) = (B(1) - E(1)*B(2))/D(1) 70 CONTINUE return end subroutine SQRDC (X, LDX, N, P, QRAUX, JPVT, WORK, JOB) ! !! SQRDC computes the QR factorization of an N by P matrix. ! Column pivoting is a ! users option. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D5 !***TYPE SINGLE PRECISION (SQRDC-S, DQRDC-D, CQRDC-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, ! QR DECOMPOSITION !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! SQRDC uses Householder transformations to compute the QR ! factorization of an N by P matrix X. Column pivoting ! based on the 2-norms of the reduced columns may be ! performed at the user's option. ! ! On Entry ! ! X REAL(LDX,P), where LDX >= N. ! X contains the matrix whose decomposition is to be ! computed. ! ! LDX INTEGER. ! LDX is the leading dimension of the array X. ! ! N INTEGER. ! N is the number of rows of the matrix X. ! ! P INTEGER. ! P is the number of columns of the matrix X. ! ! JPVT INTEGER(P). ! JPVT contains integers that control the selection ! of the pivot columns. The K-th column X(K) of X ! is placed in one of three classes according to the ! value of JPVT(K). ! ! If JPVT(K) > 0, then X(K) is an initial ! column. ! ! If JPVT(K) == 0, then X(K) is a free column. ! ! If JPVT(K) < 0, then X(K) is a final column. ! ! Before the decomposition is computed, initial columns ! are moved to the beginning of the array X and final ! columns to the end. Both initial and final columns ! are frozen in place during the computation and only ! free columns are moved. At the K-th stage of the ! reduction, if X(K) is occupied by a free column, ! it is interchanged with the free column of largest ! reduced norm. JPVT is not referenced if ! JOB == 0. ! ! WORK REAL(P). ! WORK is a work array. WORK is not referenced if ! JOB == 0. ! ! JOB INTEGER. ! JOB is an integer that initiates column pivoting. ! If JOB == 0, no pivoting is done. ! If JOB /= 0, pivoting is done. ! ! On Return ! ! X X contains in its upper triangle the upper ! triangular matrix R of the QR factorization. ! Below its diagonal X contains information from ! which the orthogonal part of the decomposition ! can be recovered. Note that if pivoting has ! been requested, the decomposition is not that ! of the original matrix X but that of X ! with its columns permuted as described by JPVT. ! ! QRAUX REAL(P). ! QRAUX contains further information required to recover ! the orthogonal part of the decomposition. ! ! JPVT JPVT(K) contains the index of the column of the ! original matrix that has been interchanged into ! the K-th column, if pivoting was requested. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT, SNRM2, SSCAL, SSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SQRDC INTEGER LDX,N,P,JOB INTEGER JPVT(*) REAL X(LDX,*),QRAUX(*),WORK(*) ! INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU REAL MAXNRM,SNRM2,TT REAL SDOT,NRMXL,T LOGICAL NEGJ,SWAPJ ! !***FIRST EXECUTABLE STATEMENT SQRDC PL = 1 PU = 0 if (JOB == 0) go to 60 ! ! PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS ! ACCORDING TO JPVT. ! DO 20 J = 1, P SWAPJ = JPVT(J) > 0 NEGJ = JPVT(J) < 0 JPVT(J) = J if (NEGJ) JPVT(J) = -J if (.NOT.SWAPJ) go to 10 if (J /= PL) call SSWAP(N,X(1,PL),1,X(1,J),1) JPVT(J) = JPVT(PL) JPVT(PL) = J PL = PL + 1 10 CONTINUE 20 CONTINUE PU = P DO 50 JJ = 1, P J = P - JJ + 1 if (JPVT(J) >= 0) go to 40 JPVT(J) = -JPVT(J) if (J == PU) go to 30 call SSWAP(N,X(1,PU),1,X(1,J),1) JP = JPVT(PU) JPVT(PU) = JPVT(J) JPVT(J) = JP 30 CONTINUE PU = PU - 1 40 CONTINUE 50 CONTINUE 60 CONTINUE ! ! COMPUTE THE NORMS OF THE FREE COLUMNS. ! if (PU < PL) go to 80 DO 70 J = PL, PU QRAUX(J) = SNRM2(N,X(1,J),1) WORK(J) = QRAUX(J) 70 CONTINUE 80 CONTINUE ! ! PERFORM THE HOUSEHOLDER REDUCTION OF X. ! LUP = MIN(N,P) DO 200 L = 1, LUP if (L < PL .OR. L >= PU) go to 120 ! ! LOCATE THE COLUMN OF LARGEST NORM AND BRING IT ! INTO THE PIVOT POSITION. ! MAXNRM = 0.0E0 MAXJ = L DO 100 J = L, PU if (QRAUX(J) <= MAXNRM) go to 90 MAXNRM = QRAUX(J) MAXJ = J 90 CONTINUE 100 CONTINUE if (MAXJ == L) go to 110 call SSWAP(N,X(1,L),1,X(1,MAXJ),1) QRAUX(MAXJ) = QRAUX(L) WORK(MAXJ) = WORK(L) JP = JPVT(MAXJ) JPVT(MAXJ) = JPVT(L) JPVT(L) = JP 110 CONTINUE 120 CONTINUE QRAUX(L) = 0.0E0 if (L == N) go to 190 ! ! COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. ! NRMXL = SNRM2(N-L+1,X(L,L),1) if (NRMXL == 0.0E0) go to 180 if (X(L,L) /= 0.0E0) NRMXL = SIGN(NRMXL,X(L,L)) call SSCAL(N-L+1,1.0E0/NRMXL,X(L,L),1) X(L,L) = 1.0E0 + X(L,L) ! ! APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, ! UPDATING THE NORMS. ! LP1 = L + 1 if (P < LP1) go to 170 DO 160 J = LP1, P 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) if (J < PL .OR. J > PU) go to 150 if (QRAUX(J) == 0.0E0) go to 150 TT = 1.0E0 - (ABS(X(L,J))/QRAUX(J))**2 TT = MAX(TT,0.0E0) T = TT TT = 1.0E0 + 0.05E0*TT*(QRAUX(J)/WORK(J))**2 if (TT == 1.0E0) go to 130 QRAUX(J) = QRAUX(J)*SQRT(T) go to 140 130 CONTINUE QRAUX(J) = SNRM2(N-L,X(L+1,J),1) WORK(J) = QRAUX(J) 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE ! ! SAVE THE TRANSFORMATION. ! QRAUX(L) = X(L,L) X(L,L) = -NRMXL 180 CONTINUE 190 CONTINUE 200 CONTINUE return end subroutine SQRSL (X, LDX, N, K, QRAUX, Y, QY, QTY, B, RSD, XB, & JOB, INFO) ! !! SQRSL applies the output of SQRDC to compute coordinate transformations, ... ! projections, and least squares solutions. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D9, D2A1 !***TYPE SINGLE PRECISION (SQRSL-S, DQRSL-D, CQRSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR, ! SOLVE !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! SQRSL applies the output of SQRDC to compute coordinate ! transformations, projections, and least squares solutions. ! For K <= MIN(N,P), let XK be the matrix ! ! XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) ! ! formed from columns JPVT(1), ... ,JPVT(K) of the original ! N x P matrix X that was input to SQRDC (if no pivoting was ! done, XK consists of the first K columns of X in their ! original order). SQRDC produces a factored orthogonal matrix Q ! and an upper triangular matrix R such that ! ! XK = Q * (R) ! (0) ! ! This information is contained in coded form in the arrays ! X and QRAUX. ! ! On Entry ! ! X REAL(LDX,P) ! X contains the output of SQRDC. ! ! LDX INTEGER ! LDX is the leading dimension of the array X. ! ! N INTEGER ! N is the number of rows of the matrix XK. It must ! have the same value as N in SQRDC. ! ! K INTEGER ! K is the number of columns of the matrix XK. K ! must not be greater than MIN(N,P), where P is the ! same as in the calling sequence to SQRDC. ! ! QRAUX REAL(P) ! QRAUX contains the auxiliary output from SQRDC. ! ! Y REAL(N) ! Y contains an N-vector that is to be manipulated ! by SQRSL. ! ! JOB INTEGER ! JOB specifies what is to be computed. JOB has ! the decimal expansion ABCDE, with the following ! meaning. ! ! If A /= 0, compute QY. ! If B,C,D, or E /= 0, compute QTY. ! If C /= 0, compute B. ! If D /= 0, compute RSD. ! If E /= 0, compute XB. ! ! Note that a request to compute B, RSD, or XB ! automatically triggers the computation of QTY, for ! which an array must be provided in the calling ! sequence. ! ! On Return ! ! QY REAL(N). ! QY contains Q*Y, if its computation has been ! requested. ! ! QTY REAL(N). ! QTY contains TRANS(Q)*Y, if its computation has ! been requested. Here TRANS(Q) is the ! transpose of the matrix Q. ! ! B REAL(K) ! B contains the solution of the least squares problem ! ! minimize norm2(Y - XK*B), ! ! if its computation has been requested. (Note that ! if pivoting was requested in SQRDC, the J-th ! component of B will be associated with column JPVT(J) ! of the original matrix X that was input into SQRDC.) ! ! RSD REAL(N). ! RSD contains the least squares residual Y - XK*B, ! if its computation has been requested. RSD is ! also the orthogonal projection of Y onto the ! orthogonal complement of the column space of XK. ! ! XB REAL(N). ! XB contains the least squares approximation XK*B, ! if its computation has been requested. XB is also ! the orthogonal projection of Y onto the column space ! of X. ! ! INFO INTEGER. ! INFO is zero unless the computation of B has ! been requested and R is exactly singular. In ! this case, INFO is the index of the first zero ! diagonal element of R and B is left unaltered. ! ! The parameters QY, QTY, B, RSD, and XB are not referenced ! if their computation is not requested and in this case ! can be replaced by dummy variables in the calling program. ! To save storage, the user may in some cases use the same ! array for different parameters in the calling sequence. A ! frequently occurring example is when one wishes to compute ! any of B, RSD, or XB and does not need Y or QTY. In this ! case one may identify Y, QTY, and one of B, RSD, or XB, while ! providing separate arrays for anything else that is to be ! computed. Thus the calling sequence ! ! call SQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) ! ! will result in the computation of B and RSD, with RSD ! overwriting Y. More generally, each item in the following ! list contains groups of permissible identifications for ! a single calling sequence. ! ! 1. (Y,QTY,B) (RSD) (XB) (QY) ! ! 2. (Y,QTY,RSD) (B) (XB) (QY) ! ! 3. (Y,QTY,XB) (B) (RSD) (QY) ! ! 4. (Y,QY) (QTY,B) (RSD) (XB) ! ! 5. (Y,QY) (QTY,RSD) (B) (XB) ! ! 6. (Y,QY) (QTY,XB) (B) (RSD) ! ! In any group the value returned in the array allocated to ! the group corresponds to the last member of the group. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SCOPY, SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SQRSL INTEGER LDX,N,K,JOB,INFO REAL X(LDX,*),QRAUX(*),Y(*),QY(*),QTY(*),B(*),RSD(*),XB(*) ! INTEGER I,J,JJ,JU,KP1 REAL SDOT,T,TEMP LOGICAL CB,CQY,CQTY,CR,CXB !***FIRST EXECUTABLE STATEMENT SQRSL ! ! SET INFO FLAG. ! INFO = 0 ! ! DETERMINE WHAT IS TO BE COMPUTED. ! CQY = JOB/10000 /= 0 CQTY = MOD(JOB,10000) /= 0 CB = MOD(JOB,1000)/100 /= 0 CR = MOD(JOB,100)/10 /= 0 CXB = MOD(JOB,10) /= 0 JU = MIN(K,N-1) ! ! SPECIAL ACTION WHEN N=1. ! if (JU /= 0) go to 40 if (CQY) QY(1) = Y(1) if (CQTY) QTY(1) = Y(1) if (CXB) XB(1) = Y(1) if (.NOT.CB) go to 30 if (X(1,1) /= 0.0E0) go to 10 INFO = 1 go to 20 10 CONTINUE B(1) = Y(1)/X(1,1) 20 CONTINUE 30 CONTINUE if (CR) RSD(1) = 0.0E0 go to 250 40 CONTINUE ! ! SET UP TO COMPUTE QY OR QTY. ! if (CQY) call SCOPY(N,Y,1,QY,1) if (CQTY) call SCOPY(N,Y,1,QTY,1) if (.NOT.CQY) go to 70 ! ! COMPUTE QY. ! DO 60 JJ = 1, JU J = JU - JJ + 1 if (QRAUX(J) == 0.0E0) go to 50 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -SDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) call SAXPY(N-J+1,T,X(J,J),1,QY(J),1) X(J,J) = TEMP 50 CONTINUE 60 CONTINUE 70 CONTINUE if (.NOT.CQTY) go to 100 ! ! COMPUTE TRANS(Q)*Y. ! DO 90 J = 1, JU if (QRAUX(J) == 0.0E0) go to 80 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -SDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) call SAXPY(N-J+1,T,X(J,J),1,QTY(J),1) X(J,J) = TEMP 80 CONTINUE 90 CONTINUE 100 CONTINUE ! ! SET UP TO COMPUTE B, RSD, OR XB. ! if (CB) call SCOPY(K,QTY,1,B,1) KP1 = K + 1 if (CXB) call SCOPY(K,QTY,1,XB,1) if (CR .AND. K < N) call SCOPY(N-K,QTY(KP1),1,RSD(KP1),1) if (.NOT.CXB .OR. KP1 > N) go to 120 DO 110 I = KP1, N XB(I) = 0.0E0 110 CONTINUE 120 CONTINUE if (.NOT.CR) go to 140 DO 130 I = 1, K RSD(I) = 0.0E0 130 CONTINUE 140 CONTINUE if (.NOT.CB) go to 190 ! ! COMPUTE B. ! DO 170 JJ = 1, K J = K - JJ + 1 if (X(J,J) /= 0.0E0) go to 150 INFO = J go to 180 150 CONTINUE B(J) = B(J)/X(J,J) if (J == 1) go to 160 T = -B(J) call SAXPY(J-1,T,X(1,J),1,B,1) 160 CONTINUE 170 CONTINUE 180 CONTINUE 190 CONTINUE if (.NOT.CR .AND. .NOT.CXB) go to 240 ! ! COMPUTE RSD OR XB AS REQUIRED. ! DO 230 JJ = 1, JU J = JU - JJ + 1 if (QRAUX(J) == 0.0E0) go to 220 TEMP = X(J,J) X(J,J) = QRAUX(J) if (.NOT.CR) go to 200 T = -SDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) call SAXPY(N-J+1,T,X(J,J),1,RSD(J),1) 200 CONTINUE if (.NOT.CXB) go to 210 T = -SDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) call SAXPY(N-J+1,T,X(J,J),1,XB(J),1) 210 CONTINUE X(J,J) = TEMP 220 CONTINUE 230 CONTINUE 240 CONTINUE 250 CONTINUE return end subroutine SREADP (IPAGE, LIST, RLIST, LPAGE, IREC) ! !! SREADP reads a record for a file for SPLP. ! !***SUBSIDIARY !***PURPOSE Subsidiary to SPLP !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SREADP-S, DREADP-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! READ RECORD NUMBER IRECN, OF LENGTH LPG, FROM UNIT ! NUMBER IPAGEF INTO THE STORAGE ARRAY, LIST(*). ! READ RECORD IRECN+1, OF LENGTH LPG, FROM UNIT NUMBER ! IPAGEF INTO THE STORAGE ARRAY RLIST(*). ! ! TO CONVERT THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE ! /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/. ! !***SEE ALSO SPLP !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890605 Corrected references to XERRWV. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE SREADP INTEGER LIST(*) REAL RLIST(*) CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT SREADP IPAGEF=IPAGE LPG =LPAGE IRECN=IREC READ(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG) READ(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG) return ! 100 WRITE (XERN1, '(I8)') LPG WRITE (XERN2, '(I8)') IRECN call XERMSG ('SLATEC', 'SREADP', 'IN SPLP, LPG = ' // XERN1 // & ' IRECN = ' // XERN2, 100, 1) return end subroutine SRLCAL (N, KMP, LL, MAXL, V, Q, RL, SNORMW, PROD, & R0NRM) ! !! SRLCAL is an internal routine for SGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SRLCAL-S, DRLCAL-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine calculates the scaled residual RL from the ! V(I)'s. ! *Usage: ! INTEGER N, KMP, LL, MAXL ! REAL V(N,LL), Q(2*MAXL), RL(N), SNORMW, PROD, R0NORM ! ! call SRLCAL(N, KMP, LL, MAXL, V, Q, RL, SNORMW, PROD, R0NRM) ! ! *Arguments: ! N :IN Integer ! The order of the matrix A, and the lengths ! of the vectors SR, SZ, R0 and Z. ! KMP :IN Integer ! The number of previous V vectors the new vector VNEW ! must be made orthogonal to. (KMP .le. MAXL) ! LL :IN Integer ! The current dimension of the Krylov subspace. ! MAXL :IN Integer ! The maximum dimension of the Krylov subspace. ! V :IN Real V(N,LL) ! The N x LL array containing the orthogonal vectors ! V(*,1) to V(*,LL). ! Q :IN Real Q(2*MAXL) ! A real array of length 2*MAXL containing the components ! of the Givens rotations used in the QR decomposition ! of HES. It is loaded in SHEQR and used in SHELS. ! RL :OUT Real RL(N) ! The residual vector RL. This is either SB*(B-A*XL) if ! not preconditioning or preconditioning on the right, ! or SB*(M-inverse)*(B-A*XL) if preconditioning on the ! left. ! SNORMW :IN Real ! Scale factor. ! PROD :IN Real ! The product s1*s2*...*sl = the product of the sines of the ! Givens rotations used in the QR factorization of ! the Hessenberg matrix HES. ! R0NRM :IN Real ! The scaled norm of initial residual R0. ! !***SEE ALSO SGMRES !***ROUTINES CALLED SCOPY, SSCAL !***REVISION HISTORY (YYMMDD) ! 871001 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Made subsidiary to SGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE SRLCAL ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. REAL PROD, R0NRM, SNORMW INTEGER KMP, LL, MAXL, N ! .. Array Arguments .. REAL Q(*), RL(N), V(N,*) ! .. Local Scalars .. REAL C, S, TEM INTEGER I, I2, IP1, K, LLM1, LLP1 ! .. External Subroutines .. EXTERNAL SCOPY, SSCAL !***FIRST EXECUTABLE STATEMENT SRLCAL if (KMP == MAXL) THEN ! ! calculate RL. Start by copying V(*,1) into RL. ! call SCOPY(N, V(1,1), 1, RL, 1) LLM1 = LL - 1 DO 20 I = 1,LLM1 IP1 = I + 1 I2 = I*2 S = Q(I2) C = Q(I2-1) DO 10 K = 1,N RL(K) = S*RL(K) + C*V(K,IP1) 10 CONTINUE 20 CONTINUE S = Q(2*LL) C = Q(2*LL-1)/SNORMW LLP1 = LL + 1 DO 30 K = 1,N RL(K) = S*RL(K) + C*V(K,LLP1) 30 CONTINUE end if ! ! When KMP < MAXL, RL vector already partially calculated. ! Scale RL by R0NRM*PROD to obtain the residual RL. ! TEM = R0NRM*PROD call SSCAL(N, TEM, RL, 1) return !------------- LAST LINE OF SRLCAL FOLLOWS ---------------------------- end subroutine SROT (N, SX, INCX, SY, INCY, SC, SS) ! !! SROT applies a plane Givens rotation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A8 !***TYPE SINGLE PRECISION (SROT-S, DROT-D, CSROT-C) !***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, ! LINEAR ALGEBRA, PLANE ROTATION, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! SY single precision vector with N elements ! INCY storage spacing between elements of SY ! SC element of rotation matrix ! SS element of rotation matrix ! ! --Output-- ! SX rotated vector SX (unchanged if N <= 0) ! SY rotated vector SY (unchanged if N <= 0) ! ! Multiply the 2 x 2 matrix ( SC SS) times the 2 x N matrix (SX**T) ! (-SS SC) (SY**T) ! where **T indicates transpose. The elements of SX are in ! SX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX >= 0, else ! LX = 1+(1-N)*INCX, and similarly for SY using LY and INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SROT REAL SX, SY, SC, SS, ZERO, ONE, W, Z DIMENSION SX(*), SY(*) SAVE ZERO, ONE DATA ZERO, ONE /0.0E0, 1.0E0/ !***FIRST EXECUTABLE STATEMENT SROT if (N <= 0 .OR. (SS == ZERO .AND. SC == ONE)) go to 40 if (.NOT. (INCX == INCY .AND. INCX > 0)) go to 20 ! ! Code for equal and positive increments. ! NSTEPS=INCX*N DO 10 I = 1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=SC*W+SS*Z SY(I)=-SS*W+SC*Z 10 CONTINUE go to 40 ! ! Code for unequal or nonpositive increments. ! 20 CONTINUE KX=1 KY=1 ! if (INCX < 0) KX = 1-(N-1)*INCX if (INCY < 0) KY = 1-(N-1)*INCY ! DO 30 I = 1,N W=SX(KX) Z=SY(KY) SX(KX)=SC*W+SS*Z SY(KY)=-SS*W+SC*Z KX=KX+INCX KY=KY+INCY 30 CONTINUE 40 CONTINUE ! return end subroutine SROTG (SA, SB, SC, SS) ! !! SROTG constructs a plane Givens rotation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B10 !***TYPE SINGLE PRECISION (SROTG-S, DROTG-D, CROTG-C) !***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, ! LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! SA single precision scalar ! SB single precision scalar ! ! --Output-- ! SA single precision result R ! SB single precision result Z ! SC single precision result ! SS single precision result ! ! Construct the Givens transformation ! ! ( SC SS ) ! G = ( ) , SC**2 + SS**2 = 1 , ! (-SS SC ) ! ! which zeros the second entry of the 2-vector (SA,SB)**T. ! ! The quantity R = (+/-)SQRT(SA**2 + SB**2) overwrites SA in ! storage. The value of SB is overwritten by a value Z which ! allows SC and SS to be recovered by the following algorithm: ! ! If Z=1 set SC=0.0 and SS=1.0 ! If ABS(Z) < 1 set SC=SQRT(1-Z**2) and SS=Z ! If ABS(Z) > 1 set SC=1/Z and SS=SQRT(1-SC**2) ! ! Normally, the subprogram SROT(N,SX,INCX,SY,INCY,SC,SS) will ! next be called to apply the transformation to a 2 by N matrix. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SROTG !***FIRST EXECUTABLE STATEMENT SROTG if (ABS(SA) <= ABS(SB)) go to 10 ! ! *** HERE ABS(SA) > ABS(SB) *** ! U = SA + SA V = SB / U ! ! NOTE THAT U AND R HAVE THE SIGN OF SA ! R = SQRT(0.25E0 + V**2) * U ! ! NOTE THAT SC IS POSITIVE ! SC = SA / R SS = V * (SC + SC) SB = SS SA = R return ! ! *** HERE ABS(SA) <= ABS(SB) *** ! 10 if (SB == 0.0E0) go to 20 U = SB + SB V = SA / U ! ! NOTE THAT U AND R HAVE THE SIGN OF SB ! (R IS IMMEDIATELY STORED IN SA) ! SA = SQRT(0.25E0 + V**2) * U ! ! NOTE THAT SS IS POSITIVE ! SS = SB / SA SC = V * (SS + SS) if (SC == 0.0E0) go to 15 SB = 1.0E0 / SC return 15 SB = 1.0E0 return ! ! *** HERE SA = SB = 0.0 *** ! 20 SC = 1.0E0 SS = 0.0E0 return ! end subroutine SROTM (N, SX, INCX, SY, INCY, SPARAM) ! !! SROTM applies a modified Givens transformation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A8 !***TYPE SINGLE PRECISION (SROTM-S, DROTM-D) !***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! SY single precision vector with N elements ! INCY storage spacing between elements of SY ! SPARAM 5-element vector. SPARAM(1) is SFLAG described below. ! Locations 2-5 of SPARAM contain elements of the ! transformation matrix H described below. ! ! --Output-- ! SX rotated vector (unchanged if N <= 0) ! SY rotated vector (unchanged if N <= 0) ! ! Apply the modified Givens transformation, H, to the 2 by N matrix ! (SX**T) ! (SY**T) , where **T indicates transpose. The elements of SX are ! in SX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX >= 0, else ! LX = 1+(1-N)*INCX, and similarly for SY using LY and INCY. ! ! With SPARAM(1)=SFLAG, H has one of the following forms: ! ! SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 ! ! (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) ! H=( ) ( ) ( ) ( ) ! (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). ! ! See SROTMG for a description of data storage in SPARAM. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SROTM DIMENSION SX(*), SY(*), SPARAM(5) SAVE ZERO, TWO DATA ZERO, TWO /0.0E0, 2.0E0/ !***FIRST EXECUTABLE STATEMENT SROTM SFLAG=SPARAM(1) if (N <= 0 .OR. (SFLAG+TWO == ZERO)) go to 140 if (.NOT.(INCX == INCY.AND. INCX > 0)) go to 70 ! NSTEPS=N*INCX if (SFLAG) 50,10,30 10 CONTINUE SH12=SPARAM(4) SH21=SPARAM(3) 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) SH12=SPARAM(4) SH21=SPARAM(3) 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 < 0) KX = 1+(1-N)*INCX if (INCY < 0) KY = 1+(1-N)*INCY ! if (SFLAG) 120,80,100 80 CONTINUE SH12=SPARAM(4) SH21=SPARAM(3) 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) SH12=SPARAM(4) SH21=SPARAM(3) 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 SROTMG (SD1, SD2, SX1, SY1, SPARAM) ! !! SROTMG constructs a modified Givens transformation. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B10 !***TYPE SINGLE PRECISION (SROTMG-S, DROTMG-D) !***KEYWORDS BLAS, LINEAR ALGEBRA, MODIFIED GIVENS ROTATION, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! SD1 single precision scalar ! SD2 single precision scalar ! SX1 single precision scalar ! SY2 single precision scalar ! SPARAM S.P. 5-vector. SPARAM(1)=SFLAG defined below. ! Locations 2-5 contain the rotation matrix. ! ! --Output-- ! SD1 changed to represent the effect of the transformation ! SD2 changed to represent the effect of the transformation ! SX1 changed to represent the effect of the transformation ! SY2 unchanged ! ! Construct the modified Givens transformation matrix H which zeros ! the second component of the 2-vector (SQRT(SD1)*SX1,SQRT(SD2)* ! SY2)**T. ! With SPARAM(1)=SFLAG, H has one of the following forms: ! ! SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 ! ! (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) ! H=( ) ( ) ( ) ( ) ! (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). ! ! Locations 2-5 of SPARAM contain SH11, SH21, SH12, and SH22, ! respectively. (Values of 1.E0, -1.E0, or 0.E0 implied by the ! value of SPARAM(1) are not stored in SPARAM.) ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 780301 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920316 Prologue corrected. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SROTMG DIMENSION SPARAM(5) SAVE ZERO, ONE, TWO, GAM, GAMSQ, RGAMSQ DATA ZERO, ONE, TWO /0.0E0, 1.0E0, 2.0E0/ DATA GAM, GAMSQ, RGAMSQ /4096.0E0, 1.67772E7, 5.96046E-8/ !***FIRST EXECUTABLE STATEMENT SROTMG if (.NOT. SD1 < ZERO) go to 10 ! GO ZERO-H-D-AND-SX1.. go to 60 10 CONTINUE ! CASE-SD1-NONNEGATIVE SP2=SD2*SY1 if (.NOT. SP2 == ZERO) go to 20 SFLAG=-TWO go to 260 ! REGULAR-CASE.. 20 CONTINUE SP1=SD1*SX1 SQ2=SP2*SY1 SQ1=SP1*SX1 ! if (.NOT. ABS(SQ1) > ABS(SQ2)) go to 40 SH21=-SY1/SX1 SH12=SP2/SP1 ! SU=ONE-SH12*SH21 ! if (.NOT. SU <= ZERO) go to 30 ! GO ZERO-H-D-AND-SX1.. go to 60 30 CONTINUE SFLAG=ZERO SD1=SD1/SU SD2=SD2/SU SX1=SX1*SU ! GO SCALE-CHECK.. go to 100 40 CONTINUE if (.NOT. SQ2 < ZERO) go to 50 ! GO ZERO-H-D-AND-SX1.. go to 60 50 CONTINUE SFLAG=ONE SH11=SP1/SP2 SH22=SX1/SY1 SU=ONE+SH11*SH22 STEMP=SD2/SU SD2=SD1/SU SD1=STEMP SX1=SY1*SU ! GO SCALE-CHECK go to 100 ! PROCEDURE..ZERO-H-D-AND-SX1.. 60 CONTINUE SFLAG=-ONE SH11=ZERO SH12=ZERO SH21=ZERO SH22=ZERO ! SD1=ZERO SD2=ZERO SX1=ZERO ! return.. go to 220 ! PROCEDURE..FIX-H.. 70 CONTINUE if (.NOT. SFLAG >= ZERO) go to 90 ! if (.NOT. SFLAG == ZERO) go to 80 SH11=ONE SH22=ONE SFLAG=-ONE go to 90 80 CONTINUE SH21=-ONE SH12=ONE SFLAG=-ONE 90 CONTINUE go to IGO,(120,150,180,210) ! PROCEDURE..SCALE-CHECK 100 CONTINUE 110 CONTINUE if (.NOT. SD1 <= RGAMSQ) go to 130 if (SD1 == ZERO) go to 160 ASSIGN 120 TO IGO ! FIX-H.. go to 70 120 CONTINUE SD1=SD1*GAM**2 SX1=SX1/GAM SH11=SH11/GAM SH12=SH12/GAM go to 110 130 CONTINUE 140 CONTINUE if (.NOT. SD1 >= GAMSQ) go to 160 ASSIGN 150 TO IGO ! FIX-H.. go to 70 150 CONTINUE SD1=SD1/GAM**2 SX1=SX1*GAM SH11=SH11*GAM SH12=SH12*GAM go to 140 160 CONTINUE 170 CONTINUE if (.NOT. ABS(SD2) <= RGAMSQ) go to 190 if (SD2 == ZERO) go to 220 ASSIGN 180 TO IGO ! FIX-H.. go to 70 180 CONTINUE SD2=SD2*GAM**2 SH21=SH21/GAM SH22=SH22/GAM go to 170 190 CONTINUE 200 CONTINUE if (.NOT. ABS(SD2) >= GAMSQ) go to 220 ASSIGN 210 TO IGO ! FIX-H.. go to 70 210 CONTINUE SD2=SD2/GAM**2 SH21=SH21*GAM SH22=SH22*GAM go to 200 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 SS2LT (N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL) ! !! SS2LT is the Lower Triangle Preconditioner SLAP Set Up. ! ! Routine to store the lower triangle of a matrix stored ! in the SLAP Column format. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SS2LT-S, DS2LT-D) !***KEYWORDS LINEAR SYSTEM, LOWER TRIANGLE, SLAP SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! INTEGER NEL, IEL(NEL), JEL(NEL) ! REAL A(NELT), EL(NEL) ! ! call SS2LT( N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of non-zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! NEL :OUT Integer. ! Number of non-zeros in the lower triangle of A. Also ! corresponds to the length of the IEL, JEL, EL arrays. ! IEL :OUT Integer IEL(NEL). ! JEL :OUT Integer JEL(NEL). ! EL :OUT Real EL(NEL). ! IEL, JEL, EL contain the lower triangle of the A matrix ! stored in SLAP Column format. See "Description", below, ! for more details bout the SLAP Column format. ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SS2LT ! .. Scalar Arguments .. INTEGER ISYM, N, NEL, NELT ! .. Array Arguments .. REAL A(NELT), EL(NELT) INTEGER IA(NELT), IEL(NEL), JA(NELT), JEL(NEL) ! .. Local Scalars .. INTEGER I, ICOL, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT SS2LT if ( ISYM == 0 ) THEN ! ! The matrix is stored non-symmetricly. Pick out the lower ! triangle. ! NEL = 0 DO 20 ICOL = 1, N JEL(ICOL) = NEL+1 JBGN = JA(ICOL) JEND = JA(ICOL+1)-1 !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) >= ICOL ) THEN NEL = NEL + 1 IEL(NEL) = IA(J) EL(NEL) = A(J) ENDIF 10 CONTINUE 20 CONTINUE JEL(N+1) = NEL+1 ELSE ! ! The matrix is symmetric and only the lower triangle is ! stored. Copy it to IEL, JEL, EL. ! NEL = NELT DO 30 I = 1, NELT IEL(I) = IA(I) EL(I) = A(I) 30 CONTINUE DO 40 I = 1, N+1 JEL(I) = JA(I) 40 CONTINUE end if return !------------- LAST LINE OF SS2LT FOLLOWS ---------------------------- end subroutine SS2Y (N, NELT, IA, JA, A, ISYM) ! !! SS2Y is the SLAP Triad to SLAP Column Format Converter. ! ! Routine to convert from the SLAP Triad to SLAP Column ! format. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D1B9 !***TYPE SINGLE PRECISION (SS2Y-S, DS2Y-D) !***KEYWORDS LINEAR SYSTEM, SLAP SPARSE !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! REAL A(NELT) ! ! call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of non-zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is used, this format is ! translated to the SLAP Column format by this routine. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! ! *Description: ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures. If the SLAP Triad format is give ! as input then this routine transforms it into SLAP Column ! format. The way this routine tells which format is given as ! input is to look at JA(N+1). If JA(N+1) = NELT+1 then we ! have the SLAP Column format. If that equality does not hold ! then it is assumed that the IA, JA, A arrays contain the ! SLAP Triad format. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! !***REFERENCES (NONE) !***ROUTINES CALLED QS2I1R !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Corrected C***FIRST EXECUTABLE STATEMENT line. (FNF) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SS2Y ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(NELT) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. REAL TEMP INTEGER I, IBGN, ICOL, IEND, ITEMP, J ! .. External Subroutines .. EXTERNAL QS2I1R !***FIRST EXECUTABLE STATEMENT SS2Y ! ! Check to see if the (IA,JA,A) arrays are in SLAP Column ! format. If it's not then transform from SLAP Triad. ! if ( JA(N+1) == NELT+1 ) RETURN ! ! Sort into ascending order by COLUMN (on the ja array). ! This will line up the columns. ! call QS2I1R( JA, IA, A, NELT, 1 ) ! ! Loop over each column to see where the column indices change ! in the column index array ja. This marks the beginning of the ! next column. ! !VD$R NOVECTOR JA(1) = 1 DO 20 ICOL = 1, N-1 DO 10 J = JA(ICOL)+1, NELT if ( JA(J) /= ICOL ) THEN JA(ICOL+1) = J GOTO 20 ENDIF 10 CONTINUE 20 CONTINUE JA(N+1) = NELT+1 ! ! Mark the n+2 element so that future calls to a SLAP routine ! utilizing the YSMP-Column storage format will be able to tell. ! JA(N+2) = 0 ! ! Now loop through the IA array making sure that the diagonal ! matrix element appears first in the column. Then sort the ! rest of the column in ascending order. ! DO 70 ICOL = 1, N IBGN = JA(ICOL) IEND = JA(ICOL+1)-1 DO 30 I = IBGN, IEND if ( IA(I) == ICOL ) THEN ! ! Swap the diagonal element with the first element in the ! column. ! ITEMP = IA(I) IA(I) = IA(IBGN) IA(IBGN) = ITEMP TEMP = A(I) A(I) = A(IBGN) A(IBGN) = TEMP GOTO 40 ENDIF 30 CONTINUE 40 IBGN = IBGN + 1 if ( IBGN < IEND ) THEN DO 60 I = IBGN, IEND DO 50 J = I+1, IEND if ( IA(I) > IA(J) ) THEN ITEMP = IA(I) IA(I) = IA(J) IA(J) = ITEMP TEMP = A(I) A(I) = A(J) A(J) = TEMP ENDIF 50 CONTINUE 60 CONTINUE ENDIF 70 CONTINUE return !------------- LAST LINE OF SS2Y FOLLOWS ---------------------------- end subroutine SSBMV (UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, & INCY) ! !! SSBMV multiplies a real vector by a real symmetric band matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SSBMV-S, DSBMV-D, CSBMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! SSBMV performs the matrix-vector operation ! ! y := alpha*A*x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! A is an n by n symmetric band matrix, with k super-diagonals. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the band matrix A is being supplied as ! follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! being supplied. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! being supplied. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry, K specifies the number of super-diagonals of the ! matrix A. K must satisfy 0 .le. K. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) ! by n part of the array A must contain the upper triangular ! band part of the symmetric matrix, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. The top left k by k triangle ! of the array A is not referenced. ! The following program segment will transfer the upper ! triangular part of a symmetric band matrix from conventional ! full matrix storage to band storage: ! ! DO 20, J = 1, N ! M = K + 1 - J ! DO 10, I = MAX( 1, J - K ), J ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) ! by n part of the array A must contain the lower triangular ! band part of the symmetric matrix, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. The bottom right k by k triangle of the ! array A is not referenced. ! The following program segment will transfer the lower ! triangular part of a symmetric band matrix from conventional ! full matrix storage to band storage: ! ! DO 20, J = 1, N ! M = 1 - J ! DO 10, I = J, MIN( N, J + K ) ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( k + 1 ). ! Unchanged on exit. ! ! X - REAL array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the ! vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! Y - REAL array of DIMENSION at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the ! vector y. On exit, Y is overwritten by the updated vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SSBMV ! .. Scalar Arguments .. REAL ALPHA, BETA INTEGER INCX, INCY, K, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX, MIN !***FIRST EXECUTABLE STATEMENT SSBMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( K < 0 )THEN INFO = 3 ELSE if ( LDA < ( K + 1 ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 ELSE if ( INCY == 0 )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'SSBMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set up the start points in X and Y. ! if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if ! ! Start the operations. In this version the elements of the array A ! are accessed sequentially with one pass through A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return if ( LSAME( UPLO, 'U' ) )THEN ! ! Form y when upper triangle of A is stored. ! KPLUS1 = K + 1 if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO L = KPLUS1 - J DO 50, I = MAX( 1, J - K ), J - 1 Y( I ) = Y( I ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + A( L + I, J )*X( I ) 50 CONTINUE Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY L = KPLUS1 - J DO 70, I = MAX( 1, J - K ), J - 1 Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + A( L + I, J )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY if ( J > K )THEN KX = KX + INCX KY = KY + INCY end if 80 CONTINUE end if ELSE ! ! Form y when lower triangle of A is stored. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*A( 1, J ) L = 1 - J DO 90, I = J + 1, MIN( N, J + K ) Y( I ) = Y( I ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + A( L + I, J )*X( I ) 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) L = 1 - J IX = JX IY = JY DO 110, I = J + 1, MIN( N, J + K ) IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) TEMP2 = TEMP2 + A( L + I, J )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE end if end if ! return ! ! End of SSBMV . ! end subroutine SSCAL (N, SA, SX, INCX) ! !! SSCAL multiplies a vector by a constant. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A6 !***TYPE SINGLE PRECISION (SSCAL-S, DSCAL-D, CSCAL-C) !***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SA single precision scale factor ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! ! --Output-- ! SX single precision result (unchanged if N <= 0) ! ! Replace single precision SX by single precision SA*SX. ! For I = 0 to N-1, replace SX(IX+I*INCX) with SA * SX(IX+I*INCX), ! where IX = 1 if INCX >= 0, else IX = 1+(1-N)*INCX. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900821 Modified to correct problem with a negative increment. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSCAL REAL SA, SX(*) INTEGER I, INCX, IX, M, MP1, N !***FIRST EXECUTABLE STATEMENT SSCAL if (N <= 0) RETURN if (INCX == 1) GOTO 20 ! ! Code for increment not equal to 1. ! IX = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N SX(IX) = SA*SX(IX) IX = IX + INCX 10 CONTINUE return ! ! Code for increment equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 5. ! 20 M = MOD(N,5) if (M == 0) GOTO 40 DO 30 I = 1,M SX(I) = SA*SX(I) 30 CONTINUE if (N < 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 SSD2S (N, NELT, IA, JA, A, ISYM, DINV) ! !! SSD2S is the Diagonal Scaling Preconditioner SLAP Normal Eqns Set Up. ! ! Routine to compute the inverse of the diagonal of the ! matrix A*A', where A is stored in SLAP-Column format. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSD2S-S, DSD2S-D) !***KEYWORDS DIAGONAL, SLAP SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! REAL A(NELT), DINV(N) ! ! call SSD2S( N, NELT, IA, JA, A, ISYM, DINV ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of elements in arrays IA, JA, and A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! DINV :OUT Real DINV(N). ! Upon return this array holds 1./DIAG(A*A'). ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format all of the "inner loops" of this ! routine should vectorize on machines with hardware support ! for vector gather/scatter operations. Your compiler may ! require a compiler directive to convince it that there are ! no implicit vector dependencies. Compiler directives for ! the Alliant FX/Fortran and CRI CFT/CFT77 compilers are ! supplied with the standard SLAP distribution. ! ! ! *Cautions: ! This routine assumes that the diagonal of A is all non-zero ! and that the operation DINV = 1.0/DIAG(A*A') will not under- ! flow or overflow. This is done so that the loop vectorizes. ! Matrices with zero or near zero or very large entries will ! have numerical difficulties and must be fixed before this ! routine is called. ! !***SEE ALSO SSDCGN !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSD2S ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(NELT), DINV(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER I, K, KBGN, KEND !***FIRST EXECUTABLE STATEMENT SSD2S DO 10 I = 1, N DINV(I) = 0 10 CONTINUE ! ! Loop over each column. !VD$R NOCONCUR DO 40 I = 1, N KBGN = JA(I) KEND = JA(I+1) - 1 ! ! Add in the contributions for each row that has a non-zero ! in this column. !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 20 K = KBGN, KEND DINV(IA(K)) = DINV(IA(K)) + A(K)**2 20 CONTINUE if ( ISYM == 1 ) THEN ! ! Lower triangle stored by columns => upper triangle stored by ! rows with Diagonal being the first entry. Loop across the ! rest of the row. KBGN = KBGN + 1 if ( KBGN <= KEND ) THEN DO 30 K = KBGN, KEND DINV(I) = DINV(I) + A(K)**2 30 CONTINUE ENDIF ENDIF 40 CONTINUE DO 50 I=1,N DINV(I) = 1.0E0/DINV(I) 50 CONTINUE ! return !------------- LAST LINE OF SSD2S FOLLOWS ---------------------------- end subroutine SSDBCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSDBCG is the Diagonally Scaled BiConjugate Gradient Sparse Ax=b Solver. ! ! Routine to solve a linear system Ax = b using the ! BiConjugate Gradient method with diagonal scaling. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSDBCG-S, DSDBCG-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, ! SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) ! ! call SSDBCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= 8*N. ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the RWORK array. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! ! *Description: ! This routine performs preconditioned BiConjugate gradient ! method on the Non-Symmetric positive definite linear system ! Ax=b. The preconditioner is M = DIAG(A), the diagonal of the ! matrix A. This is the simplest of preconditioners and ! vectorizes very well. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SBCG, SLUBCG !***REFERENCES (NONE) !***ROUTINES CALLED SBCG, SCHKW, SS2Y, SSDI, SSDS, SSMTV, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SSDBCG ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(N), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCDZ, LOCIW, LOCP, LOCPP, LOCR, LOCRR, LOCW, & LOCZ, LOCZZ ! .. External Subroutines .. EXTERNAL SBCG, SCHKW, SS2Y, SSDI, SSDS, SSMTV, SSMV !***FIRST EXECUTABLE STATEMENT SSDBCG ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the workspace. LOCIW = LOCIB ! LOCDIN = LOCRB LOCR = LOCDIN + N LOCZ = LOCR + N LOCP = LOCZ + N LOCRR = LOCP + N LOCZZ = LOCRR + N LOCPP = LOCZZ + N LOCDZ = LOCPP + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call SCHKW( 'SSDBCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCDIN IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the inverse of the diagonal of the matrix. call SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) ! ! Perform the Diagonally Scaled BiConjugate gradient algorithm. call SBCG(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSMTV, & SSDI, SSDI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), & RWORK(LOCRR), RWORK(LOCZZ), RWORK(LOCPP), & RWORK(LOCDZ), RWORK(1), IWORK(1)) return !------------- LAST LINE OF SSDBCG FOLLOWS ---------------------------- end subroutine SSDCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSDCG is the Diagonally Scaled Conjugate Gradient Sparse Ax=b Solver. ! ! Routine to solve a symmetric positive definite linear ! system Ax = b using the Preconditioned Conjugate ! Gradient method. The preconditioner is diagonal scaling. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2B4 !***TYPE SINGLE PRECISION (SSDCG-S, DSDCG-D) !***KEYWORDS ITERATIVE PRECONDITION, SLAP, SPARSE, ! SYMMETRIC LINEAR SYSTEM !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(5*N) ! ! call SSDCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= 5*N. ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the real workspace, RWORK. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! ! *Description: ! This routine performs preconditioned conjugate gradient ! method on the symmetric positive definite linear system ! Ax=b. The preconditioner is M = DIAG(A), the diagonal of ! the matrix A. This is the simplest of preconditioners and ! vectorizes very well. This routine is simply a driver for ! the SCG routine. It calls the SSDS routine to set up the ! preconditioning and then calls SCG with the appropriate ! MATVEC and MSOLVE routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SCG, SSICCG !***REFERENCES 1. Louis Hageman and David Young, Applied Iterative ! Methods, Academic Press, New York, 1981. ! 2. Concus, Golub and O'Leary, A Generalized Conjugate ! Gradient Method for the Numerical Solution of ! Elliptic Partial Differential Equations, in Sparse ! Matrix Computations, Bunch and Rose, Eds., Academic ! Press, New York, 1979. !***ROUTINES CALLED SCG, SCHKW, SS2Y, SSDI, SSDS, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) !***END PROLOGUE SSDCG ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCD, LOCDZ, LOCIW, LOCP, LOCR, LOCW, LOCZ ! .. External Subroutines .. EXTERNAL SCG, SCHKW, SS2Y, SSDI, SSDS, SSMV !***FIRST EXECUTABLE STATEMENT SSDCG ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Modify the SLAP matrix data structure to YSMP-Column. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the work arrays. LOCIW = LOCIB ! LOCD = LOCRB LOCR = LOCD + N LOCZ = LOCR + N LOCP = LOCZ + N LOCDZ = LOCP + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call SCHKW( 'SSDCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCD IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the inverse of the diagonal of the matrix. This ! will be used as the preconditioner. call SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCD)) ! ! Do the Preconditioned Conjugate Gradient. call SCG(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSDI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCP), RWORK(LOCDZ), RWORK, IWORK) return !------------- LAST LINE OF SSDCG FOLLOWS ----------------------------- end subroutine SSDCGN (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSDCGN is the Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's. ! ! Routine to solve a general linear system Ax = b using ! diagonal scaling with the Conjugate Gradient method ! applied to the the normal equations, viz., AA'y = b, ! where x = A'y. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSDCGN-S, DSDCGN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) ! ! call SSDCGN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= 8*N. ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the RWORK array. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! ! *Description: ! This routine is simply a driver for the SCGN routine. It ! calls the SSD2S routine to set up the preconditioning and ! then calls SCGN with the appropriate MATVEC and MSOLVE ! routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SCGN, SSD2S, SSMV, SSMTV, SSDI !***REFERENCES (NONE) !***ROUTINES CALLED SCGN, SCHKW, SS2Y, SSD2S, SSDI, SSMTV, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SSDCGN ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCATD, LOCATP, LOCATZ, LOCD, LOCDZ, LOCIW, LOCP, LOCR, & LOCW, LOCZ ! .. External Subroutines .. EXTERNAL SCGN, SCHKW, SS2Y, SSD2S, SSDI, SSMTV, SSMV !***FIRST EXECUTABLE STATEMENT SSDCGN ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Modify the SLAP matrix data structure to YSMP-Column. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the work arrays. LOCIW = LOCIB ! LOCD = LOCRB LOCR = LOCD + N LOCZ = LOCR + N LOCP = LOCZ + N LOCATP = LOCP + N LOCATZ = LOCATP + N LOCDZ = LOCATZ + N LOCATD = LOCDZ + N LOCW = LOCATD + N ! ! Check the workspace allocations. call SCHKW( 'SSDCGN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCD IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the inverse of the diagonal of AA'. This will be ! used as the preconditioner. call SSD2S(N, NELT, IA, JA, A, ISYM, RWORK(1)) ! ! Perform Conjugate Gradient algorithm on the normal equations. call SCGN( N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSMTV, SSDI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCP), RWORK(LOCATP), RWORK(LOCATZ), & RWORK(LOCDZ), RWORK(LOCATD), RWORK, IWORK ) ! if ( ITER > ITMAX ) IERR = 2 return !------------- LAST LINE OF SSDCGN FOLLOWS ---------------------------- end subroutine SSDCGS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSDCGS is the Diagonally Scaled CGS Sparse Ax=b Solver. ! ! Routine to solve a linear system Ax = b using the ! BiConjugate Gradient Squared method with diagonal scaling. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSDCGS-S, DSDCGS-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, SLAP, ! SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N) ! ! call SSDCGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! This routine must calculate the residual from R = A*X - B. ! This is unnatural and hence expensive for this type of iter- ! ative method. ITOL=2 is *STRONGLY* recommended. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv time a vector is the pre- ! conditioning step. This is the *NATURAL* stopping for this ! iterative method and is *STRONGLY* recommended. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Breakdown of the method detected. ! (r0,r) approximately 0. ! IERR = 6 => Stagnation of the method detected. ! (r0,v) approximately 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= 8*N. ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the RWORK array. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! ! *Description: ! This routine performs preconditioned BiConjugate gradient ! method on the Non-Symmetric positive definite linear system ! Ax=b. The preconditioner is M = DIAG(A), the diagonal of the ! matrix A. This is the simplest of preconditioners and ! vectorizes very well. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SCGS, SLUBCG !***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver ! for nonsymmetric linear systems, Delft University ! of Technology Report 84-16, Department of Mathe- ! matics and Informatics, Delft, The Netherlands. ! 2. E. F. Kaasschieter, The solution of non-symmetric ! linear systems by biconjugate gradients or conjugate ! gradients squared, Delft University of Technology ! Report 86-21, Department of Mathematics and Informa- ! tics, Delft, The Netherlands. !***ROUTINES CALLED SCGS, SCHKW, SS2Y, SSDI, SSDS, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SSDCGS ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(N), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCIW, LOCP, LOCQ, LOCR, LOCR0, LOCU, LOCV1, & LOCV2, LOCW ! .. External Subroutines .. EXTERNAL SCGS, SCHKW, SS2Y, SSDI, SSDS, SSMV !***FIRST EXECUTABLE STATEMENT SSDCGS ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the workspace. LOCIW = LOCIB ! LOCDIN = LOCRB LOCR = LOCDIN + N LOCR0 = LOCR + N LOCP = LOCR0 + N LOCQ = LOCP + N LOCU = LOCQ + N LOCV1 = LOCU + N LOCV2 = LOCV1 + N LOCW = LOCV2 + N ! ! Check the workspace allocations. call SCHKW( 'SSDCGS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCDIN IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the inverse of the diagonal of the matrix. call SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) ! ! Perform the Diagonally Scaled ! BiConjugate Gradient Squared algorithm. call SCGS(N, B, X, NELT, IA, JA, A, ISYM, SSMV, & SSDI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCR0), RWORK(LOCP), & RWORK(LOCQ), RWORK(LOCU), RWORK(LOCV1), & RWORK(LOCV2), RWORK(1), IWORK(1)) return !------------- LAST LINE OF SSDCGS FOLLOWS ---------------------------- end subroutine SSDGMR (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSDGMR is the Diagonally Scaled GMRES Iterative Sparse Ax=b Solver. ! ! This routine uses the generalized minimum residual ! (GMRES) method with diagonal scaling to solve possibly ! non-symmetric linear systems of the form: Ax = b. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSDGMR-S, DSDGMR-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL ! INTEGER ITMAX, ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) ! ! call SSDGMR(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ! $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, ! $ RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize against. ! Must be greater than 1. ! ITOL :IN Integer. ! Flag to indicate the type of convergence criterion used. ! ITOL=0 Means the iteration stops when the test described ! below on the residual RL is satisfied. This is ! the "Natural Stopping Criteria" for this routine. ! Other values of ITOL cause extra, otherwise ! unnecessary, computation per iteration and are ! therefore much less efficient. See ISSGMR (the ! stop test routine) for more information. ! ITOL=1 Means the iteration stops when the first test ! described below on the residual RL is satisfied, ! and there is either right or no preconditioning ! being used. ! ITOL=2 Implies that the user is using left ! preconditioning, and the second stopping criterion ! below is used. ! ITOL=3 Means the iteration stops when the third test ! described below on Minv*Residual is satisfied, and ! there is either left or no preconditioning begin ! used. ! ITOL=11 is often useful for checking and comparing ! different routines. For this case, the user must ! supply the "exact" solution or a very accurate ! approximation (one with an error much less than ! TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the ! difference between the iterative approximation and ! the user-supplied solution divided by the 2-norm ! of the user-supplied solution is less than TOL. ! Note that this requires the user to set up the ! "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling ! routine. The routine with this declaration should ! be loaded before the stop test so that the correct ! length is used by the loader. This procedure is ! not standard Fortran and may not work correctly on ! your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 ! then this common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described below. If TOL is set ! to zero on input, then a default value of 500*(the smallest ! positive magnitude, machine epsilon) is used. ! ITMAX :IN Integer. ! Maximum number of iterations. This routine uses the default ! of NRMAX = ITMAX/NSAVE to determine when each restart ! should occur. See the description of NRMAX and MAXL in ! SGMRES for a full and frightfully interesting discussion of ! this topic. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. Letting norm() denote the Euclidean ! norm, ERR is defined as follows... ! If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! for right or no preconditioning, and ! ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! for left preconditioning. ! If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! since right or no preconditioning ! being used. ! If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! since left preconditioning is being ! used. ! If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| ! i=1,n ! If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient storage allocated for ! RGWK or IGWK. ! IERR = 2 => Routine SPIGMR failed to reduce the norm ! of the current residual on its last call, ! and so the iteration has stalled. In ! this case, X equals the last computed ! approximation. The user must either ! increase MAXL, or choose a different ! initial guess. ! IERR =-1 => Insufficient length for RGWK array. ! IGWK(6) contains the required minimum ! length of the RGWK array. ! IERR =-2 => Inconsistent ITOL and JPRE values. ! For IERR <= 2, RGWK(1) = RHOL, which is the norm on the ! left-hand-side of the relevant stopping test defined ! below associated with the residual for the current ! approximation X(L). ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array of size LENW. ! LENW :IN Integer. ! Length of the real workspace, RWORK. ! LENW >= 1 + N*(NSAVE+7) + NSAVE*(NSAVE+3). ! For the recommended values of NSAVE (10), RWORK has size at ! least 131 + 17*N. ! IWORK :INOUT Integer IWORK(USER DEFINED >= 30). ! Used to hold pointers into the RWORK array. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace IWORK. LENIW >= 30. ! ! *Description: ! SSDGMR solves a linear system A*X = B rewritten in the form: ! ! (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, ! ! with right preconditioning, or ! ! (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, ! ! with left preconditioning, where A is an n-by-n real matrix, ! X and B are N-vectors, SB and SX are diagonal scaling ! matrices, and M is the diagonal of A. It uses ! preconditioned Krylov subpace methods based on the ! generalized minimum residual method (GMRES). This routine ! is a driver routine which assumes a SLAP matrix data ! structure and sets up the necessary information to do ! diagonal preconditioning and calls the main GMRES routine ! SGMRES for the solution of the linear system. SGMRES ! optionally performs either the full orthogonalization ! version of the GMRES algorithm or an incomplete variant of ! it. Both versions use restarting of the linear iteration by ! default, although the user can disable this feature. ! ! The GMRES algorithm generates a sequence of approximations ! X(L) to the true solution of the above linear system. The ! convergence criteria for stopping the iteration is based on ! the size of the scaled norm of the residual R(L) = B - ! A*X(L). The actual stopping test is either: ! ! norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), ! ! for right preconditioning, or ! ! norm(SB*(M-inverse)*(B-A*X(L))) .le. ! TOL*norm(SB*(M-inverse)*B), ! ! for left preconditioning, where norm() denotes the Euclidean ! norm, and TOL is a positive scalar less than one input by ! the user. If TOL equals zero when SSDGMR is called, then a ! default value of 500*(the smallest positive magnitude, ! machine epsilon) is used. If the scaling arrays SB and SX ! are used, then ideally they should be chosen so that the ! vectors SX*X(or SX*M*X) and SB*B have all their components ! approximately equal to one in magnitude. If one wants to ! use the same scaling in X and B, then SB and SX can be the ! same array in the calling program. ! ! The following is a list of the other routines and their ! functions used by GMRES: ! SGMRES Contains the matrix structure independent driver ! routine for GMRES. ! SPIGMR Contains the main iteration loop for GMRES. ! SORTH Orthogonalizes a new vector against older basis vectors. ! SHEQR Computes a QR decomposition of a Hessenberg matrix. ! SHELS Solves a Hessenberg least-squares system, using QR ! factors. ! RLCALC Computes the scaled residual RL. ! XLCALC Computes the solution XL. ! ISSGMR User-replaceable stopping routine. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage ! Matrix Methods in Stiff ODE Systems, Lawrence Liver- ! more National Laboratory Report UCRL-95088, Rev. 1, ! Livermore, California, June 1987. !***ROUTINES CALLED SCHKW, SGMRES, SS2Y, SSDI, SSDS, SSMV !***REVISION HISTORY (YYMMDD) ! 880615 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) !***END PROLOGUE SSDGMR ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, & NELT, NSAVE ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCIGW, LOCIW, LOCRGW, LOCW, MYITOL ! .. External Subroutines .. EXTERNAL SCHKW, SGMRES, SS2Y, SSDI, SSDS, SSMV !***FIRST EXECUTABLE STATEMENT SSDGMR ! IERR = 0 ERR = 0 if ( NSAVE <= 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the workspace. We assume MAXL=KMP=NSAVE. LOCIGW = LOCIB LOCIW = LOCIGW + 20 ! LOCDIN = LOCRB LOCRGW = LOCDIN + N LOCW = LOCRGW + 1+N*(NSAVE+6)+NSAVE*(NSAVE+3) ! IWORK(4) = LOCDIN IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Check the workspace allocations. call SCHKW( 'SSDGMR', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! ! Compute the inverse of the diagonal of the matrix. call SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) ! ! Perform the Diagonally Scaled Generalized Minimum ! Residual iteration algorithm. The following SGMRES ! defaults are used MAXL = KMP = NSAVE, JSCAL = 0, ! JPRE = -1, NRMAX = ITMAX/NSAVE IWORK(LOCIGW ) = NSAVE IWORK(LOCIGW+1) = NSAVE IWORK(LOCIGW+2) = 0 IWORK(LOCIGW+3) = -1 IWORK(LOCIGW+4) = ITMAX/NSAVE MYITOL = 0 ! call SGMRES( N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSDI, & MYITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, RWORK, & RWORK(LOCRGW), LENW-LOCRGW, IWORK(LOCIGW), 20, & RWORK, IWORK ) ! if ( ITER > ITMAX ) IERR = 2 return !------------- LAST LINE OF SSDGMR FOLLOWS ---------------------------- end subroutine SSDI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! SSDI is the Diagonal Matrix Vector Multiply. ! ! Routine to calculate the product X = DIAG*B, where DIAG ! is a diagonal matrix. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SSDI-S, DSDI-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IWORK(10) ! REAL B(N), X(N), A(NELT), RWORK(USER DEFINED) ! ! call SSDI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Vector to multiply the diagonal by. ! X :OUT Real X(N). ! Result of DIAG*B. ! NELT :DUMMY Integer. ! IA :DUMMY Integer IA(NELT). ! JA :DUMMY Integer JA(NELT). ! A :DUMMY Real A(NELT). ! ISYM :DUMMY Integer. ! These are for compatibility with SLAP MSOLVE calling sequence. ! RWORK :IN Real RWORK(USER DEFINED). ! Work array holding the diagonal of some matrix to scale ! B by. This array must be set by the user or by a call ! to the SLAP routine SSDS or SSD2S. The length of RWORK ! must be >= IWORK(4)+N. ! IWORK :IN Integer IWORK(10). ! IWORK(4) holds the offset into RWORK for the diagonal matrix ! to scale B by. This is usually set up by the SLAP pre- ! conditioner setup routines SSDS or SSD2S. ! ! *Description: ! This routine is supplied with the SLAP package to perform ! the MSOLVE operation for iterative drivers that require ! diagonal Scaling (e.g., SSDCG, SSDBCG). It conforms ! to the SLAP MSOLVE CALLING CONVENTION and hence does not ! require an interface routine as do some of the other pre- ! conditioners supplied with SLAP. ! !***SEE ALSO SSDS, SSD2S !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSDI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER LOCD !***FIRST EXECUTABLE STATEMENT SSDI ! ! Determine where the inverse of the diagonal ! is in the work array and then scale by it. ! LOCD = IWORK(4) - 1 X(1:n) = RWORK(LOCD+1:locd+n)*B(1:n) return end subroutine SSDOMN (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSDOMN is the Diagonally Scaled Orthomin Sparse Iterative Ax=b Solver. ! ! Routine to solve a general linear system Ax = b using ! the Orthomin method with diagonal scaling. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSDOMN-S, DSDOMN-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(10), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR ! REAL RWORK(7*N+3*N*NSAVE+NSAVE) ! ! call SSDOMN(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen, it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize against. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Breakdown of method detected. ! (p,Ap) < epsilon**2. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. ! LENW >= 7*N+NSAVE*(3*N+1). ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the RWORK array. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! ! *Description: ! This routine is simply a driver for the SOMN routine. It ! calls the SSDS routine to set up the preconditioning and ! then calls SOMN with the appropriate MATVEC and MSOLVE ! routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! In this format only the non-zeros are stored. They may ! appear in *ANY* order. The user supplies three arrays of ! length NELT, where NELT is the number of non-zeros in the ! matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero ! the user puts the row and column index of that matrix ! element in the IA and JA arrays. The value of the non-zero ! matrix element is placed in the corresponding location of ! the A array. This is an extremely easy data structure to ! generate. On the other hand it is not too efficient on ! vector computers for the iterative solution of linear ! systems. Hence, SLAP changes this input data structure to ! the SLAP Column format for the iteration (but does not ! change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! In this format the non-zeros are stored counting down ! columns (except for the diagonal entry, which must appear ! first in each "column") and are stored in the real array A. ! In other words, for each column in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have JA(N+1) ! = NELT+1, where N is the number of columns in the matrix and ! NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SOMN, SSLUOM !***REFERENCES (NONE) !***ROUTINES CALLED SCHKW, SOMN, SS2Y, SSDI, SSDS, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SSDOMN ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, & NELT, NSAVE ! .. Array Arguments .. REAL A(N), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCAP, LOCCSA, LOCDIN, LOCDZ, LOCEMA, LOCIW, LOCP, LOCR, & LOCW, LOCZ ! .. External Subroutines .. EXTERNAL SCHKW, SOMN, SS2Y, SSDI, SSDS, SSMV !***FIRST EXECUTABLE STATEMENT SSDOMN ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Set up the workspace. LOCIW = LOCIB ! LOCDIN = LOCRB LOCR = LOCDIN + N LOCZ = LOCR + N LOCP = LOCZ + N LOCAP = LOCP + N*(NSAVE+1) LOCEMA = LOCAP + N*(NSAVE+1) LOCDZ = LOCEMA + N*(NSAVE+1) LOCCSA = LOCDZ + N LOCW = LOCCSA + NSAVE ! ! Check the workspace allocations. call SCHKW( 'SSDOMN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCDIN IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the inverse of the diagonal of the matrix. call SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCDIN)) ! ! Perform the Diagonally Scaled Orthomin iteration algorithm. call SOMN(N, B, X, NELT, IA, JA, A, ISYM, SSMV, & SSDI, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), RWORK(LOCAP), & RWORK(LOCEMA), RWORK(LOCDZ), RWORK(LOCCSA), & RWORK, IWORK ) return !------------- LAST LINE OF SSDOMN FOLLOWS ---------------------------- end subroutine SSDSCL (N, NELT, IA, JA, A, ISYM, X, B, DINV, JOB, ITOL) ! !! SSDSCL is the Diagonal Scaling of system Ax = b. ! ! This routine scales (and unscales) the system Ax = b ! by symmetric diagonal scaling. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSDSCL-S, DSDSCL-D) !***KEYWORDS DIAGONAL, SLAP SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! This routine scales (and unscales) the system Ax = b by symmetric ! diagonal scaling. The new system is: ! -1/2 -1/2 1/2 -1/2 ! D AD (D x) = D b ! when scaling is selected with the JOB parameter. When unscaling ! is selected this process is reversed. The true solution is also ! scaled or unscaled if ITOL is set appropriately, see below. ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, JOB, ITOL ! REAL A(NELT), X(N), B(N), DINV(N) ! ! call SSDSCL( N, NELT, IA, JA, A, ISYM, X, B, DINV, JOB, ITOL ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of elements in arrays IA, JA, and A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! X :INOUT Real X(N). ! Initial guess that will be later used in the iterative ! solution. ! of the scaled system. ! B :INOUT Real B(N). ! Right hand side vector. ! DINV :INOUT Real DINV(N). ! Upon return this array holds 1./DIAG(A). ! This is an input if JOB = 0. ! JOB :IN Integer. ! Flag indicating whether to scale or not. ! JOB non-zero means do scaling. ! JOB = 0 means do unscaling. ! ITOL :IN Integer. ! Flag indicating what type of error estimation to do in the ! iterative method. When ITOL = 11 the exact solution from ! common block SSLBLK will be used. When the system is scaled ! then the true solution must also be scaled. If ITOL is not ! 11 then this vector is not referenced. ! ! *Common Blocks: ! SOLN :INOUT Real SOLN(N). COMMON BLOCK /SSLBLK/ ! The true solution, SOLN, is scaled (or unscaled) if ITOL is ! set to 11, see above. ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format all of the "inner loops" of this ! routine should vectorize on machines with hardware support ! for vector gather/scatter operations. Your compiler may ! require a compiler directive to convince it that there are ! no implicit vector dependencies. Compiler directives for ! the Alliant FX/Fortran and CRI CFT/CFT77 compilers are ! supplied with the standard SLAP distribution. ! ! ! *Cautions: ! This routine assumes that the diagonal of A is all non-zero ! and that the operation DINV = 1.0/DIAG(A) will not under- ! flow or overflow. This is done so that the loop vectorizes. ! Matrices with zero or near zero or very large entries will ! have numerical difficulties and must be fixed before this ! routine is called. ! !***SEE ALSO SSDCG !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SSLBLK !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Added C***FIRST EXECUTABLE STATEMENT line. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSDSCL ! .. Scalar Arguments .. INTEGER ISYM, ITOL, JOB, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), DINV(N), X(N) INTEGER IA(NELT), JA(NELT) ! .. Arrays in Common .. REAL SOLN(1) ! .. Local Scalars .. REAL DI INTEGER ICOL, J, JBGN, JEND ! .. Intrinsic Functions .. INTRINSIC SQRT ! .. Common blocks .. COMMON /SSLBLK/ SOLN !***FIRST EXECUTABLE STATEMENT SSDSCL ! ! SCALING... ! if ( JOB /= 0 ) THEN DO 10 ICOL = 1, N DINV(ICOL) = 1.0E0/SQRT( A(JA(ICOL)) ) 10 CONTINUE ELSE ! ! UNSCALING... ! DO 15 ICOL = 1, N DINV(ICOL) = 1.0E0/DINV(ICOL) 15 CONTINUE end if ! DO 30 ICOL = 1, N JBGN = JA(ICOL) JEND = JA(ICOL+1)-1 DI = DINV(ICOL) DO 20 J = JBGN, JEND A(J) = DINV(IA(J))*A(J)*DI 20 CONTINUE 30 CONTINUE ! DO 40 ICOL = 1, N B(ICOL) = B(ICOL)*DINV(ICOL) X(ICOL) = X(ICOL)/DINV(ICOL) 40 CONTINUE ! ! Check to see if we need to scale the "true solution" as well. ! if ( ITOL == 11 ) THEN DO 50 ICOL = 1, N SOLN(ICOL) = SOLN(ICOL)/DINV(ICOL) 50 CONTINUE end if ! return end subroutine SSDS (N, NELT, IA, JA, A, ISYM, DINV) ! !! SSDS is the Diagonal Scaling Preconditioner SLAP Set Up. ! ! Routine to compute the inverse of the diagonal of a matrix ! stored in the SLAP Column format. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSDS-S, DSDS-D) !***KEYWORDS DIAGONAL, SLAP SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! REAL A(NELT), DINV(N) ! ! call SSDS( N, NELT, IA, JA, A, ISYM, DINV ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! NELT :IN Integer. ! Number of elements in arrays IA, JA, and A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! DINV :OUT Real DINV(N). ! Upon return this array holds 1./DIAG(A). ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format all of the "inner loops" of this ! routine should vectorize on machines with hardware support ! for vector gather/scatter operations. Your compiler may ! require a compiler directive to convince it that there are ! no implicit vector dependencies. Compiler directives for ! the Alliant FX/Fortran and CRI CFT/CFT77 compilers are ! supplied with the standard SLAP distribution. ! ! ! *Cautions: ! This routine assumes that the diagonal of A is all non-zero ! and that the operation DINV = 1.0/DIAG(A) will not underflow ! or overflow. This is done so that the loop vectorizes. ! Matrices with zero or near zero or very large entries will ! have numerical difficulties and must be fixed before this ! routine is called. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSDS ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(NELT), DINV(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER ICOL !***FIRST EXECUTABLE STATEMENT SSDS ! ! Assume the Diagonal elements are the first in each column. ! This loop should *VECTORIZE*. If it does not you may have ! to add a compiler directive. We do not check for a zero ! (or near zero) diagonal element since this would interfere ! with vectorization. If this makes you nervous put a check ! in! It will run much slower. ! DO 10 ICOL = 1, N DINV(ICOL) = 1.0E0/A(JA(ICOL)) 10 CONTINUE ! return !------------- LAST LINE OF SSDS FOLLOWS ---------------------------- end subroutine SSGS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ITMAX, & ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSGS is the Gauss-Seidel Method Iterative Sparse Ax = b Solver. ! ! Routine to solve a general linear system Ax = b using ! Gauss-Seidel iteration. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSGS-S, DSGS-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+2*N+1), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+3*N) ! ! call SSGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= NL+3*N. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= NL+N+11. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! ! *Description ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SSJAC, SIR !***REFERENCES (NONE) !***ROUTINES CALLED SCHKW, SIR, SS2LT, SS2Y, SSLI, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921019 Corrected NEL to NL. (FNF) !***END PROLOGUE SSGS ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(N), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCDZ, LOCEL, LOCIEL, LOCIW, LOCJEL, & LOCR, LOCW, LOCZ, NL ! .. External Subroutines .. EXTERNAL SCHKW, SIR, SS2LT, SS2Y, SSLI, SSMV !***FIRST EXECUTABLE STATEMENT SSGS ! if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Modify the SLAP matrix data structure to YSMP-Column. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of elements in lower triangle of the matrix. if ( ISYM == 0 ) THEN NL = 0 DO 20 ICOL = 1, N JBGN = JA(ICOL) JEND = JA(ICOL+1)-1 DO 10 J = JBGN, JEND if ( IA(J) >= ICOL ) NL = NL + 1 10 CONTINUE 20 CONTINUE ELSE NL = JA(N+1)-1 end if ! ! Set up the work arrays. Then store the lower triangle of ! the matrix. ! LOCJEL = LOCIB LOCIEL = LOCJEL + N+1 LOCIW = LOCIEL + NL ! LOCEL = LOCRB LOCR = LOCEL + NL LOCZ = LOCR + N LOCDZ = LOCZ + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call SCHKW( 'SSGS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = NL IWORK(2) = LOCIEL IWORK(3) = LOCJEL IWORK(4) = LOCEL IWORK(9) = LOCIW IWORK(10) = LOCW ! call SS2LT( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIEL), & IWORK(LOCJEL), RWORK(LOCEL) ) ! ! Call iterative refinement routine. call SIR(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSLI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCDZ), RWORK, IWORK ) ! ! Set the amount of Integer and Real Workspace used. IWORK(9) = LOCIW+N+NELT IWORK(10) = LOCW+NELT return end subroutine SSICCG (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSICCG is the Incomplete Cholesky Conjugate Gradient Sparse Ax=b Solver. ! ! Routine to solve a symmetric positive definite linear ! system Ax = b using the incomplete Cholesky ! Preconditioned Conjugate Gradient method. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2B4 !***TYPE SINGLE PRECISION (SSICCG-S, DSICCG-D) !***KEYWORDS INCOMPLETE CHOLESKY, ITERATIVE PRECONDITION, SLAP, SPARSE, ! SYMMETRIC LINEAR SYSTEM !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+2*N+1), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+5*N) ! ! call SSICCG(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= NL+5*N. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= NL+N+11. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! ! *Description: ! This routine performs preconditioned conjugate gradient ! method on the symmetric positive definite linear system ! Ax=b. The preconditioner is the incomplete Cholesky (IC) ! factorization of the matrix A. See SSICS for details about ! the incomplete factorization algorithm. One should note ! here however, that the IC factorization is a slow process ! and that one should save factorizations for reuse, if ! possible. The MSOLVE operation (handled in SSLLTI) does ! vectorize on machines with hardware gather/scatter and is ! quite fast. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SCG, SSLLTI !***REFERENCES 1. Louis Hageman and David Young, Applied Iterative ! Methods, Academic Press, New York, 1981. ! 2. Concus, Golub and O'Leary, A Generalized Conjugate ! Gradient Method for the Numerical Solution of ! Elliptic Partial Differential Equations, in Sparse ! Matrix Computations, Bunch and Rose, Eds., Academic ! Press, New York, 1979. !***ROUTINES CALLED SCG, SCHKW, SS2Y, SSICS, SSLLTI, SSMV, XERMSG !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 900805 Changed XERRWV calls to calls to XERMSG. (RWC) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Corrected NEL to NL. (FNF) !***END PROLOGUE SSICCG ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCDZ, LOCEL, LOCIEL, LOCIW, LOCJEL, LOCP, LOCR, & LOCW, LOCZ, NL CHARACTER XERN1*8 ! .. External Subroutines .. EXTERNAL SCG, SCHKW, SS2Y, SSICS, SSLLTI, SSMV, XERMSG !***FIRST EXECUTABLE STATEMENT SSICCG ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of elements in lower triangle of the matrix. ! Then set up the work arrays. if ( ISYM == 0 ) THEN NL = (NELT + N)/2 ELSE NL = NELT end if ! LOCJEL = LOCIB LOCIEL = LOCJEL + NL LOCIW = LOCIEL + N + 1 ! LOCEL = LOCRB LOCDIN = LOCEL + NL LOCR = LOCDIN + N LOCZ = LOCR + N LOCP = LOCZ + N LOCDZ = LOCP + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call SCHKW( 'SSICCG', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = NL IWORK(2) = LOCJEL IWORK(3) = LOCIEL IWORK(4) = LOCEL IWORK(5) = LOCDIN IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete Cholesky decomposition. ! call SSICS(N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIEL), & IWORK(LOCJEL), RWORK(LOCEL), RWORK(LOCDIN), & RWORK(LOCR), IERR ) if ( IERR /= 0 ) THEN WRITE (XERN1, '(I8)') IERR call XERMSG ('SLATEC', 'SSICCG', & 'IC factorization broke down on step ' // XERN1 // & '. Diagonal was set to unity and factorization proceeded.', & 1, 1) IERR = 7 end if ! ! Do the Preconditioned Conjugate Gradient. call SCG(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSLLTI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCP), RWORK(LOCDZ), RWORK(1), & IWORK(1)) return end subroutine SSICO (A, LDA, N, KPVT, RCOND, Z) ! !! SSICO factors a symmetric matrix by elimination with symmetric pivoting ... ! and estimates the condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE SINGLE PRECISION (SSICO-S, DSICO-D, CHICO-C, CSICO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, SYMMETRIC !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SSICO factors a real symmetric matrix by elimination with ! symmetric pivoting and estimates the condition of the matrix. ! ! If RCOND is not needed, SSIFA is slightly faster. ! To solve A*X = B , follow SSICO by SSISL. ! To compute INVERSE(A)*C , follow SSICO by SSISL. ! To compute INVERSE(A) , follow SSICO by SSIDI. ! To compute DETERMINANT(A) , follow SSICO by SSIDI. ! To compute INERTIA(A), follow SSICO by SSIDI. ! ! On Entry ! ! A REAL(LDA, N) ! the symmetric matrix to be factored. ! Only the diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! Output ! ! A a block diagonal matrix and the multipliers which ! were used to obtain it. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z REAL(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SASUM, SAXPY, SDOT, SSCAL, SSIFA !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSICO INTEGER LDA,N,KPVT(*) REAL A(LDA,*),Z(*) REAL RCOND ! REAL AK,AKM1,BK,BKM1,SDOT,DENOM,EK,T REAL ANORM,S,SASUM,YNORM INTEGER I,INFO,J,JM1,K,KP,KPS,KS ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT SSICO DO 30 J = 1, N Z(J) = SASUM(J,A(1,J),1) JM1 = J - 1 if (JM1 < 1) go to 20 DO 10 I = 1, JM1 Z(I) = Z(I) + ABS(A(I,J)) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,Z(J)) 40 CONTINUE ! ! FACTOR ! call SSIFA(A,LDA,N,KPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE U*D*W = E ! EK = 1.0E0 DO 50 J = 1, N Z(J) = 0.0E0 50 CONTINUE K = N 60 if (K == 0) go to 120 KS = 1 if (KPVT(K) < 0) KS = 2 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE if (Z(K) /= 0.0E0) EK = SIGN(EK,Z(K)) Z(K) = Z(K) + EK call SAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) if (KS == 1) go to 80 if (Z(K-1) /= 0.0E0) EK = SIGN(EK,Z(K-1)) Z(K-1) = Z(K-1) + EK call SAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) 80 CONTINUE if (KS == 2) go to 100 if (ABS(Z(K)) <= ABS(A(K,K))) go to 90 S = ABS(A(K,K))/ABS(Z(K)) call SSCAL(N,S,Z,1) EK = S*EK 90 CONTINUE if (A(K,K) /= 0.0E0) Z(K) = Z(K)/A(K,K) if (A(K,K) == 0.0E0) Z(K) = 1.0E0 go to 110 100 CONTINUE AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = Z(K)/A(K-1,K) BKM1 = Z(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0E0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 110 CONTINUE K = K - KS go to 60 120 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) ! ! SOLVE TRANS(U)*Y = W ! K = 1 130 if (K > N) go to 160 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 150 Z(K) = Z(K) + SDOT(K-1,A(1,K),1,Z(1),1) if (KS == 2) & Z(K+1) = Z(K+1) + SDOT(K-1,A(1,K+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE K = K + KS go to 130 160 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) ! YNORM = 1.0E0 ! ! SOLVE U*D*V = Y ! K = N 170 if (K == 0) go to 230 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == KS) go to 190 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 180 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 180 CONTINUE call SAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) if (KS == 2) call SAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) 190 CONTINUE if (KS == 2) go to 210 if (ABS(Z(K)) <= ABS(A(K,K))) go to 200 S = ABS(A(K,K))/ABS(Z(K)) call SSCAL(N,S,Z,1) YNORM = S*YNORM 200 CONTINUE if (A(K,K) /= 0.0E0) Z(K) = Z(K)/A(K,K) if (A(K,K) == 0.0E0) Z(K) = 1.0E0 go to 220 210 CONTINUE AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = Z(K)/A(K-1,K) BKM1 = Z(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0E0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 220 CONTINUE K = K - KS go to 170 230 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! ! SOLVE TRANS(U)*Z = V ! K = 1 240 if (K > N) go to 270 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 260 Z(K) = Z(K) + SDOT(K-1,A(1,K),1,Z(1),1) if (KS == 2) & Z(K+1) = Z(K+1) + SDOT(K-1,A(1,K+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE K = K + KS go to 240 270 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine SSICS (N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D, & R, IWARN) ! !! SSICS is the Incomplete Cholesky Decomposition Preconditioner SLAP Set Up. ! ! Routine to generate the Incomplete Cholesky decomposition, ! L*D*L-trans, of a symmetric positive definite matrix, A, ! which is stored in SLAP Column format. The unit lower ! triangular matrix L is stored by rows, and the inverse of ! the diagonal matrix D is stored. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSICS-S, DSICS-D) !***KEYWORDS INCOMPLETE CHOLESKY FACTORIZATION, ! ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! INTEGER NEL, IEL(NEL), JEL(NEL), IWARN ! REAL A(NELT), EL(NEL), D(N), R(N) ! ! call SSICS( N, NELT, IA, JA, A, ISYM, NEL, IEL, JEL, EL, D, R, ! $ IWARN ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! NELT :IN Integer. ! Number of elements in arrays IA, JA, and A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! NEL :OUT Integer. ! Number of non-zeros in the lower triangle of A. Also ! corresponds to the length of the IEL, JEL, EL arrays. ! IEL :OUT Integer IEL(NEL). ! JEL :OUT Integer JEL(NEL). ! EL :OUT Real EL(NEL). ! IEL, JEL, EL contain the unit lower triangular factor of the ! incomplete decomposition of the A matrix stored in SLAP ! Row format. The Diagonal of ones *IS* stored. See ! "Description", below for more details about the SLAP Row fmt. ! D :OUT Real D(N) ! Upon return this array holds D(I) = 1./DIAG(A). ! R :WORK Real R(N). ! Temporary real workspace needed for the factorization. ! IWARN :OUT Integer. ! This is a warning variable and is zero if the IC factoriza- ! tion goes well. It is set to the row index corresponding to ! the last zero pivot found. See "Description", below. ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the real ! array A. In other words, for each row in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going across the row (except the diagonal) in ! order. The JA array holds the column index for each ! non-zero. The IA array holds the offsets into the JA, A ! arrays for the beginning of each row. That is, ! JA(IA(IROW)), A(IA(IROW)) points to the beginning of the ! IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! points to the end of the IROW-th row. Note that we always ! have IA(N+1) = NELT+1, where N is the number of rows in ! the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format some of the "inner loops" of this ! routine should vectorize on machines with hardware support ! for vector gather/scatter operations. Your compiler may ! require a compiler directive to convince it that there are ! no implicit vector dependencies. Compiler directives for ! the Alliant FX/Fortran and CRI CFT/CFT77 compilers are ! supplied with the standard SLAP distribution. ! ! The IC factorization does not always exist for SPD matrices. ! In the event that a zero pivot is found it is set to be 1.0 ! and the factorization proceeds. The integer variable IWARN ! is set to the last row where the Diagonal was fudged. This ! eventuality hardly ever occurs in practice. ! !***SEE ALSO SCG, SSICCG !***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, ! Johns Hopkins University Press, Baltimore, Maryland, ! 1983. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 900805 Changed XERRWV calls to calls to XERMSG. (RWC) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSICS ! .. Scalar Arguments .. INTEGER ISYM, IWARN, N, NEL, NELT ! .. Array Arguments .. REAL A(NELT), D(N), EL(NEL), R(N) INTEGER IA(NELT), IEL(NEL), JA(NELT), JEL(NEL) ! .. Local Scalars .. REAL ELTMP INTEGER I, IBGN, IC, ICBGN, ICEND, ICOL, IEND, IR, IRBGN, IREND, & IROW, IRR, J, JBGN, JELTMP, JEND CHARACTER XERN1*8 ! .. External Subroutines .. EXTERNAL XERMSG !***FIRST EXECUTABLE STATEMENT SSICS ! ! Set the lower triangle in IEL, JEL, EL ! IWARN = 0 ! ! All matrix elements stored in IA, JA, A. Pick out the lower ! triangle (making sure that the Diagonal of EL is one) and ! store by rows. ! NEL = 1 IEL(1) = 1 JEL(1) = 1 EL(1) = 1 D(1) = A(1) !VD$R NOCONCUR DO 30 IROW = 2, N ! Put in the Diagonal. NEL = NEL + 1 IEL(IROW) = NEL JEL(NEL) = IROW EL(NEL) = 1 D(IROW) = A(JA(IROW)) ! ! Look in all the lower triangle columns for a matching row. ! Since the matrix is symmetric, we can look across the ! ITOW-th row by looking down the IROW-th column (if it is ! stored ISYM=0)... if ( ISYM == 0 ) THEN ICBGN = JA(IROW) ICEND = JA(IROW+1)-1 ELSE ICBGN = 1 ICEND = IROW-1 ENDIF DO 20 IC = ICBGN, ICEND if ( ISYM == 0 ) THEN ICOL = IA(IC) if ( ICOL >= IROW ) GOTO 20 ELSE ICOL = IC ENDIF JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND .AND. IA(JEND) >= IROW ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) == IROW ) THEN NEL = NEL + 1 JEL(NEL) = ICOL EL(NEL) = A(J) GOTO 20 ENDIF 10 CONTINUE ENDIF 20 CONTINUE 30 CONTINUE IEL(N+1) = NEL+1 ! ! Sort ROWS of lower triangle into descending order (count out ! along rows out from Diagonal). ! DO 60 IROW = 2, N IBGN = IEL(IROW)+1 IEND = IEL(IROW+1)-1 if ( IBGN < IEND ) THEN DO 50 I = IBGN, IEND-1 !VD$ NOVECTOR DO 40 J = I+1, IEND if ( JEL(I) > JEL(J) ) THEN JELTMP = JEL(J) JEL(J) = JEL(I) JEL(I) = JELTMP ELTMP = EL(J) EL(J) = EL(I) EL(I) = ELTMP ENDIF 40 CONTINUE 50 CONTINUE ENDIF 60 CONTINUE ! ! Perform the Incomplete Cholesky decomposition by looping ! over the rows. ! Scale the first column. Use the structure of A to pick out ! the rows with something in column 1. ! IRBGN = JA(1)+1 IREND = JA(2)-1 DO 65 IRR = IRBGN, IREND IR = IA(IRR) ! Find the index into EL for EL(1,IR). ! Hint: it's the second entry. I = IEL(IR)+1 EL(I) = EL(I)/D(1) 65 CONTINUE ! DO 110 IROW = 2, N ! ! Update the IROW-th diagonal. ! DO 66 I = 1, IROW-1 R(I) = 0 66 CONTINUE IBGN = IEL(IROW)+1 IEND = IEL(IROW+1)-1 if ( IBGN <= IEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 70 I = IBGN, IEND R(JEL(I)) = EL(I)*D(JEL(I)) D(IROW) = D(IROW) - EL(I)*R(JEL(I)) 70 CONTINUE ! ! Check to see if we have a problem with the diagonal. ! if ( D(IROW) <= 0.0E0 ) THEN if ( IWARN == 0 ) IWARN = IROW D(IROW) = 1 ENDIF ENDIF ! ! Update each EL(IROW+1:N,IROW), if there are any. ! Use the structure of A to determine the Non-zero elements ! of the IROW-th column of EL. ! IRBGN = JA(IROW) IREND = JA(IROW+1)-1 DO 100 IRR = IRBGN, IREND IR = IA(IRR) if ( IR <= IROW ) GOTO 100 ! Find the index into EL for EL(IR,IROW) IBGN = IEL(IR)+1 IEND = IEL(IR+1)-1 if ( JEL(IBGN) > IROW ) GOTO 100 DO 90 I = IBGN, IEND if ( JEL(I) == IROW ) THEN ICEND = IEND 91 if ( JEL(ICEND) >= IROW ) THEN ICEND = ICEND - 1 GOTO 91 ENDIF ! Sum up the EL(IR,1:IROW-1)*R(1:IROW-1) contributions. !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 80 IC = IBGN, ICEND EL(I) = EL(I) - EL(IC)*R(JEL(IC)) 80 CONTINUE EL(I) = EL(I)/D(IROW) GOTO 100 ENDIF 90 CONTINUE ! ! If we get here, we have real problems... WRITE (XERN1, '(I8)') IROW call XERMSG ('SLATEC', 'SSICS', & 'A and EL data structure mismatch in row '// XERN1, 1, 2) 100 CONTINUE 110 CONTINUE ! ! Replace diagonals by their inverses. ! D(1:n) = 1.0E0/D(1:n) return end subroutine SSIDI (A, LDA, N, KPVT, DET, INERT, WORK, JOB) ! !! SSIDI computes the determinant, inertia and inverse of a real symmetric ... ! matrix using the factors from SSIFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A, D3B1A !***TYPE SINGLE PRECISION (SSIDI-S, DSIDI-D, CHIDI-C, CSIDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! SSIDI computes the determinant, inertia and inverse ! of a real symmetric matrix using the factors from SSIFA. ! ! On Entry ! ! A REAL(LDA,N) ! the output from SSIFA. ! ! LDA INTEGER ! the leading dimension of the array A. ! ! N INTEGER ! the order of the matrix A. ! ! KPVT INTEGER(N) ! the pivot vector from SSIFA. ! ! WORK REAL(N) ! work vector. Contents destroyed. ! ! JOB INTEGER ! JOB has the decimal expansion ABC where ! If C /= 0, the inverse is computed, ! If B /= 0, the determinant is computed, ! If A /= 0, the inertia is computed. ! ! For example, JOB = 111 gives all three. ! ! On Return ! ! Variables not requested by JOB are not used. ! ! A contains the upper triangle of the inverse of ! the original matrix. The strict lower triangle ! is never referenced. ! ! DET REAL(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0. ! ! INERT INTEGER(3) ! the inertia of the original matrix. ! INERT(1) = number of positive eigenvalues. ! INERT(2) = number of negative eigenvalues. ! INERT(3) = number of zero eigenvalues. ! ! Error Condition ! ! A division by zero may occur if the inverse is requested ! and SSICO has set RCOND == 0.0 ! or SSIFA has set INFO /= 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SCOPY, SDOT, SSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSIDI INTEGER LDA,N,JOB REAL A(LDA,*),WORK(*) REAL DET(2) INTEGER KPVT(*),INERT(3) ! REAL AKKP1,SDOT,TEMP REAL TEN,D,T,AK,AKP1 INTEGER J,JB,K,KM1,KS,KSTEP LOGICAL NOINV,NODET,NOERT !***FIRST EXECUTABLE STATEMENT SSIDI NOINV = MOD(JOB,10) == 0 NODET = MOD(JOB,100)/10 == 0 NOERT = MOD(JOB,1000)/100 == 0 ! 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 DO 130 K = 1, N D = A(K,K) ! ! CHECK if 1 BY 1 ! if (KPVT(K) > 0) go to 50 ! ! 2 BY 2 BLOCK ! USE DET (D S) = (D/T * C - T) * T , T = ABS(S) ! (S C) ! TO AVOID UNDERFLOW/OVERFLOW TROUBLES. ! TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. ! if (T /= 0.0E0) go to 30 T = ABS(A(K,K+1)) D = (D/T)*A(K+1,K+1) - T go to 40 30 CONTINUE D = T T = 0.0E0 40 CONTINUE 50 CONTINUE ! if (NOERT) go to 60 if (D > 0.0E0) INERT(1) = INERT(1) + 1 if (D < 0.0E0) INERT(2) = INERT(2) + 1 if (D == 0.0E0) INERT(3) = INERT(3) + 1 60 CONTINUE ! if (NODET) go to 120 DET(1) = D*DET(1) if (DET(1) == 0.0E0) go to 110 70 if (ABS(DET(1)) >= 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)) < TEN) go to 100 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 go to 90 100 CONTINUE 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE ! ! COMPUTE INVERSE(A) ! if (NOINV) go to 270 K = 1 150 if (K > N) go to 260 KM1 = K - 1 if (KPVT(K) < 0) go to 180 ! ! 1 BY 1 ! A(K,K) = 1.0E0/A(K,K) if (KM1 < 1) go to 170 call SCOPY(KM1,A(1,K),1,WORK,1) DO 160 J = 1, KM1 A(J,K) = SDOT(J,A(1,J),1,WORK,1) call SAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 160 CONTINUE A(K,K) = A(K,K) + SDOT(KM1,WORK,1,A(1,K),1) 170 CONTINUE KSTEP = 1 go to 220 180 CONTINUE ! ! 2 BY 2 ! T = ABS(A(K,K+1)) AK = A(K,K)/T AKP1 = A(K+1,K+1)/T AKKP1 = A(K,K+1)/T D = T*(AK*AKP1 - 1.0E0) A(K,K) = AKP1/D A(K+1,K+1) = AK/D A(K,K+1) = -AKKP1/D if (KM1 < 1) go to 210 call SCOPY(KM1,A(1,K+1),1,WORK,1) DO 190 J = 1, KM1 A(J,K+1) = SDOT(J,A(1,J),1,WORK,1) call SAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1) 190 CONTINUE A(K+1,K+1) = A(K+1,K+1) + SDOT(KM1,WORK,1,A(1,K+1),1) A(K,K+1) = A(K,K+1) + SDOT(KM1,A(1,K),1,A(1,K+1),1) call SCOPY(KM1,A(1,K),1,WORK,1) DO 200 J = 1, KM1 A(J,K) = SDOT(J,A(1,J),1,WORK,1) call SAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1) 200 CONTINUE A(K,K) = A(K,K) + SDOT(KM1,WORK,1,A(1,K),1) 210 CONTINUE KSTEP = 2 220 CONTINUE ! ! SWAP ! KS = ABS(KPVT(K)) if (KS == K) go to 250 call SSWAP(KS,A(1,KS),1,A(1,K),1) DO 230 JB = KS, K J = K + KS - JB TEMP = A(J,K) A(J,K) = A(KS,J) A(KS,J) = TEMP 230 CONTINUE if (KSTEP == 1) go to 240 TEMP = A(KS,K+1) A(KS,K+1) = A(K,K+1) A(K,K+1) = TEMP 240 CONTINUE 250 CONTINUE K = K + KSTEP go to 150 260 CONTINUE 270 CONTINUE return end subroutine SSIEV (A, LDA, N, E, WORK, JOB, INFO) ! !! SSIEV computes the eigenvalues and eigenvectors of a real symmetric matrix. ! !***LIBRARY SLATEC !***CATEGORY D4A1 !***TYPE SINGLE PRECISION (SSIEV-S, CHIEV-C) !***KEYWORDS COMPLEX HERMITIAN, EIGENVALUES, EIGENVECTORS, MATRIX, ! SYMMETRIC !***AUTHOR Kahaner, D. K., (NBS) ! Moler, C. B., (U. of New Mexico) ! Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! Abstract ! SSIEV computes the eigenvalues and, optionally, the eigenvectors ! of a real symmetric matrix. ! ! Call Sequence Parameters- ! (The values of parameters marked with * (star) will be changed ! by SSIEV.) ! ! A* REAL (LDA,N) ! real symmetric input matrix. ! Only the diagonal and upper triangle of A must be input, ! as SSIEV copies the upper triangle to the lower. ! That is, the user must define A(I,J), I=1,..N, and J=I,. ! ..,N. ! On return from SSIEV, if the user has set JOB ! = 0 the lower triangle of A has been altered. ! = nonzero the N eigenvectors of A are stored in its ! first N columns. See also INFO below. ! ! LDA INTEGER ! set by the user to ! the leading dimension of the array A. ! ! N INTEGER ! set by the user to ! the order of the matrix A and ! the number of elements in E. ! ! E* REAL (N) ! on return from SSIEV, E contains the N ! eigenvalues of A. See also INFO below. ! ! WORK* REAL (2*N) ! temporary storage vector. Contents changed by SSIEV. ! ! JOB INTEGER ! set by user on input ! = 0 only calculate eigenvalues of A. ! = nonzero calculate eigenvalues and eigenvectors of A. ! ! INFO* INTEGER ! on return from SSIEV, the value of INFO is ! = 0 for normal return. ! = K if the eigenvalue iteration fails to converge. ! eigenvalues and vectors 1 through K-1 are correct. ! ! ! Error Messages- ! No. 1 recoverable N is greater than LDA ! No. 2 recoverable N is less than one ! !***REFERENCES (NONE) !***ROUTINES CALLED IMTQL2, TQLRAT, TRED1, TRED2, XERMSG !***REVISION HISTORY (YYMMDD) ! 800808 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE SSIEV INTEGER INFO,JOB,LDA,N REAL A(LDA,*),E(*),WORK(*) !***FIRST EXECUTABLE STATEMENT SSIEV if (N > LDA) call XERMSG ('SLATEC', 'SSIEV', 'N > LDA.', & 1, 1) if ( N > LDA) RETURN if (N < 1) call XERMSG ('SLATEC', 'SSIEV', 'N < 1', 2, 1) if ( N < 1) RETURN ! ! CHECK N=1 CASE ! E(1) = A(1,1) INFO = 0 if ( N == 1) RETURN ! ! COPY UPPER TRIANGLE TO LOWER ! DO 10 J=1,N DO 10 I=1,J A(J,I)=A(I,J) 10 CONTINUE ! if ( JOB /= 0) go to 20 ! ! EIGENVALUES ONLY ! call TRED1(LDA,N,A,E,WORK(1),WORK(N+1)) call TQLRAT(N,E,WORK(N+1),INFO) return ! ! EIGENVALUES AND EIGENVECTORS ! 20 call TRED2(LDA,N,A,E,WORK,A) call IMTQL2(LDA,N,E,WORK,A,INFO) return end subroutine SSIFA (A, LDA, N, KPVT, INFO) ! !! SSIFA factors a real symmetric matrix by elimination with symmetric pivoting. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE SINGLE PRECISION (SSIFA-S, DSIFA-D, CHIFA-C, CSIFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! SSIFA factors a real symmetric matrix by elimination ! with symmetric pivoting. ! ! To solve A*X = B , follow SSIFA by SSISL. ! To compute INVERSE(A)*C , follow SSIFA by SSISL. ! To compute DETERMINANT(A) , follow SSIFA by SSIDI. ! To compute INERTIA(A) , follow SSIFA by SSIDI. ! To compute INVERSE(A) , follow SSIFA by SSIDI. ! ! On Entry ! ! A REAL(LDA,N) ! the symmetric matrix to be factored. ! Only the diagonal and upper triangle are used. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! On Return ! ! A a block diagonal matrix and the multipliers which ! were used to obtain it. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th pivot block is singular. This is ! not an error condition for this subroutine, ! but it does indicate that SSISL or SSIDI may ! divide by zero if called. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED ISAMAX, SAXPY, SSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSIFA INTEGER LDA,N,KPVT(*),INFO REAL A(LDA,*) ! REAL AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T REAL ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,ISAMAX LOGICAL SWAP !***FIRST EXECUTABLE STATEMENT SSIFA ! ! INITIALIZE ! ! ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ! ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 ! INFO = 0 ! ! MAIN LOOP ON K, WHICH GOES FROM N TO 1. ! K = N 10 CONTINUE ! ! LEAVE THE LOOP if K=0 OR K=1. ! if (K == 0) go to 200 if (K > 1) go to 20 KPVT(1) = 1 if (A(1,1) == 0.0E0) INFO = 1 go to 200 20 CONTINUE ! ! THIS SECTION OF CODE DETERMINES THE KIND OF ! ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, ! KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND ! SWAP WILL BE SET TO .TRUE. if AN INTERCHANGE IS ! REQUIRED. ! KM1 = K - 1 ABSAKK = ABS(A(K,K)) ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! COLUMN K. ! IMAX = ISAMAX(K-1,A(1,K),1) COLMAX = ABS(A(IMAX,K)) if (ABSAKK < ALPHA*COLMAX) go to 30 KSTEP = 1 SWAP = .FALSE. go to 90 30 CONTINUE ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! ROW IMAX. ! ROWMAX = 0.0E0 IMAXP1 = IMAX + 1 DO 40 J = IMAXP1, K ROWMAX = MAX(ROWMAX,ABS(A(IMAX,J))) 40 CONTINUE if (IMAX == 1) go to 50 JMAX = ISAMAX(IMAX-1,A(1,IMAX),1) ROWMAX = MAX(ROWMAX,ABS(A(JMAX,IMAX))) 50 CONTINUE if (ABS(A(IMAX,IMAX)) < ALPHA*ROWMAX) go to 60 KSTEP = 1 SWAP = .TRUE. go to 80 60 CONTINUE if (ABSAKK < ALPHA*COLMAX*(COLMAX/ROWMAX)) go to 70 KSTEP = 1 SWAP = .FALSE. go to 80 70 CONTINUE KSTEP = 2 SWAP = IMAX /= KM1 80 CONTINUE 90 CONTINUE if (MAX(ABSAKK,COLMAX) /= 0.0E0) go to 100 ! ! COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. ! KPVT(K) = K INFO = K go to 190 100 CONTINUE if (KSTEP == 2) go to 140 ! ! 1 X 1 PIVOT BLOCK. ! if (.NOT.SWAP) go to 120 ! ! PERFORM AN INTERCHANGE. ! call SSWAP(IMAX,A(1,IMAX),1,A(1,K),1) DO 110 JJ = IMAX, K J = K + IMAX - JJ T = A(J,K) A(J,K) = A(IMAX,J) A(IMAX,J) = T 110 CONTINUE 120 CONTINUE ! ! PERFORM THE ELIMINATION. ! DO 130 JJ = 1, KM1 J = K - JJ MULK = -A(J,K)/A(K,K) T = MULK call SAXPY(J,T,A(1,K),1,A(1,J),1) A(J,K) = MULK 130 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = K if (SWAP) KPVT(K) = IMAX go to 190 140 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (.NOT.SWAP) go to 160 ! ! PERFORM AN INTERCHANGE. ! call SSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) DO 150 JJ = IMAX, KM1 J = KM1 + IMAX - JJ T = A(J,K-1) A(J,K-1) = A(IMAX,J) A(IMAX,J) = T 150 CONTINUE T = A(K-1,K) A(K-1,K) = A(IMAX,K) A(IMAX,K) = T 160 CONTINUE ! ! PERFORM THE ELIMINATION. ! KM2 = K - 2 if (KM2 == 0) go to 180 AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) DENOM = 1.0E0 - AK*AKM1 DO 170 JJ = 1, KM2 J = KM1 - JJ BK = A(J,K)/A(K-1,K) BKM1 = A(J,K-1)/A(K-1,K) MULK = (AKM1*BK - BKM1)/DENOM MULKM1 = (AK*BKM1 - BK)/DENOM T = MULK call SAXPY(J,T,A(1,K),1,A(1,J),1) T = MULKM1 call SAXPY(J,T,A(1,K-1),1,A(1,J),1) A(J,K) = MULK A(J,K-1) = MULKM1 170 CONTINUE 180 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = 1 - K if (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE K = K - KSTEP go to 10 200 CONTINUE return end subroutine SSILUR (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSILUR is the Incomplete LU Iterative Refinement Sparse Ax = b Solver. ! ! Routine to solve a general linear system Ax = b using ! the incomplete LU decomposition with iterative refinement. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSILUR-S, DSILUR-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+4*N) ! ! call SSILUR(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= NL+NU+4*N. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of integer workspace, IWORK. LENIW >= NL+NU+4*N+10. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! ! *Description ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SSJAC, SSGS, SIR !***REFERENCES (NONE) !***ROUTINES CALLED SCHKW, SIR, SS2Y, SSILUS, SSLUI, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921019 Corrected NEL to NL. (FNF) !***END PROLOGUE SSILUR ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCDZ, LOCIL, LOCIU, LOCIW, & LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCR, LOCU, LOCW, LOCZ, & NL, NU ! .. External Subroutines .. EXTERNAL SCHKW, SIR, SS2Y, SSILUS, SSLUI, SSMV !***FIRST EXECUTABLE STATEMENT SSILUR ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements in preconditioner ILU ! matrix. Then set up the work arrays. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIL = LOCIB LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCU = LOCDIN + N LOCR = LOCU + NU LOCZ = LOCR + N LOCDZ = LOCZ + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call SCHKW( 'SSILUR', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Do the Preconditioned Iterative Refinement iteration. call SIR(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSLUI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCDZ), RWORK, IWORK) return !------------- LAST LINE OF SSILUR FOLLOWS ---------------------------- end subroutine SSILUS (N, NELT, IA, JA, A, ISYM, NL, IL, JL, L, DINV, & NU, IU, JU, U, NROW, NCOL) ! !! SSILUS is the Incomplete LU Decomposition Preconditioner SLAP Set Up. ! ! Routine to generate the incomplete LDU decomposition of a ! matrix. The unit lower triangular factor L is stored by ! rows and the unit upper triangular factor U is stored by ! columns. The inverse of the diagonal matrix D is stored. ! No fill in is allowed. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSILUS-S, DSILUS-D) !***KEYWORDS INCOMPLETE LU FACTORIZATION, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! INTEGER NL, IL(NL), JL(NL), NU, IU(NU), JU(NU) ! INTEGER NROW(N), NCOL(N) ! REAL A(NELT), L(NL), DINV(N), U(NU) ! ! call SSILUS( N, NELT, IA, JA, A, ISYM, NL, IL, JL, L, ! $ DINV, NU, IU, JU, U, NROW, NCOL ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of elements in arrays IA, JA, and A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! NL :OUT Integer. ! Number of non-zeros in the L array. ! IL :OUT Integer IL(NL). ! JL :OUT Integer JL(NL). ! L :OUT Real L(NL). ! IL, JL, L contain the unit lower triangular factor of the ! incomplete decomposition of some matrix stored in SLAP ! Row format. The Diagonal of ones *IS* stored. See ! "DESCRIPTION", below for more details about the SLAP format. ! NU :OUT Integer. ! Number of non-zeros in the U array. ! IU :OUT Integer IU(NU). ! JU :OUT Integer JU(NU). ! U :OUT Real U(NU). ! IU, JU, U contain the unit upper triangular factor of the ! incomplete decomposition of some matrix stored in SLAP ! Column format. The Diagonal of ones *IS* stored. See ! "Description", below for more details about the SLAP ! format. ! NROW :WORK Integer NROW(N). ! NROW(I) is the number of non-zero elements in the I-th row ! of L. ! NCOL :WORK Integer NCOL(N). ! NCOL(I) is the number of non-zero elements in the I-th ! column of U. ! ! *Description ! IL, JL, L should contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in SLAP ! Row format. IU, JU, U should contain the unit upper factor ! of the incomplete decomposition of the A matrix stored in ! SLAP Column format This ILU factorization can be computed by ! the SSILUS routine. The diagonals (which are all one's) are ! stored. ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the real ! array A. In other words, for each row in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going across the row (except the diagonal) in ! order. The JA array holds the column index for each ! non-zero. The IA array holds the offsets into the JA, A ! arrays for the beginning of each row. That is, ! JA(IA(IROW)), A(IA(IROW)) points to the beginning of the ! IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! points to the end of the IROW-th row. Note that we always ! have IA(N+1) = NELT+1, where N is the number of rows in ! the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! !***SEE ALSO SILUR !***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, ! Johns Hopkins University Press, Baltimore, Maryland, ! 1983. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of reference. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSILUS ! .. Scalar Arguments .. INTEGER ISYM, N, NELT, NL, NU ! .. Array Arguments .. REAL A(NELT), DINV(N), L(NL), U(NU) INTEGER IA(NELT), IL(NL), IU(NU), JA(NELT), JL(NL), JU(NU), & NCOL(N), NROW(N) ! .. Local Scalars .. REAL TEMP INTEGER I, IBGN, ICOL, IEND, INDX, INDX1, INDX2, INDXC1, INDXC2, & INDXR1, INDXR2, IROW, ITEMP, J, JBGN, JEND, JTEMP, K, KC, & KR !***FIRST EXECUTABLE STATEMENT SSILUS ! ! Count number of elements in each row of the lower triangle. ! DO 10 I=1,N NROW(I) = 0 NCOL(I) = 0 10 CONTINUE !VD$R NOCONCUR !VD$R NOVECTOR DO 30 ICOL = 1, N JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN DO 20 J = JBGN, JEND if ( IA(J) < ICOL ) THEN NCOL(ICOL) = NCOL(ICOL) + 1 ELSE NROW(IA(J)) = NROW(IA(J)) + 1 if ( ISYM /= 0 ) NCOL(IA(J)) = NCOL(IA(J)) + 1 ENDIF 20 CONTINUE ENDIF 30 CONTINUE JU(1) = 1 IL(1) = 1 DO 40 ICOL = 1, N IL(ICOL+1) = IL(ICOL) + NROW(ICOL) JU(ICOL+1) = JU(ICOL) + NCOL(ICOL) NROW(ICOL) = IL(ICOL) NCOL(ICOL) = JU(ICOL) 40 CONTINUE ! ! Copy the matrix A into the L and U structures. DO 60 ICOL = 1, N DINV(ICOL) = A(JA(ICOL)) JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN DO 50 J = JBGN, JEND IROW = IA(J) if ( IROW < ICOL ) THEN ! Part of the upper triangle. IU(NCOL(ICOL)) = IROW U(NCOL(ICOL)) = A(J) NCOL(ICOL) = NCOL(ICOL) + 1 ELSE ! Part of the lower triangle (stored by row). JL(NROW(IROW)) = ICOL L(NROW(IROW)) = A(J) NROW(IROW) = NROW(IROW) + 1 if ( ISYM /= 0 ) THEN ! Symmetric...Copy lower triangle into upper triangle as well. IU(NCOL(IROW)) = ICOL U(NCOL(IROW)) = A(J) NCOL(IROW) = NCOL(IROW) + 1 ENDIF ENDIF 50 CONTINUE ENDIF 60 CONTINUE ! ! Sort the rows of L and the columns of U. DO 110 K = 2, N JBGN = JU(K) JEND = JU(K+1)-1 if ( JBGN < JEND ) THEN DO 80 J = JBGN, JEND-1 DO 70 I = J+1, JEND if ( IU(J) > IU(I) ) THEN ITEMP = IU(J) IU(J) = IU(I) IU(I) = ITEMP TEMP = U(J) U(J) = U(I) U(I) = TEMP ENDIF 70 CONTINUE 80 CONTINUE ENDIF IBGN = IL(K) IEND = IL(K+1)-1 if ( IBGN < IEND ) THEN DO 100 I = IBGN, IEND-1 DO 90 J = I+1, IEND if ( JL(I) > JL(J) ) THEN JTEMP = JU(I) JU(I) = JU(J) JU(J) = JTEMP TEMP = L(I) L(I) = L(J) L(J) = TEMP ENDIF 90 CONTINUE 100 CONTINUE ENDIF 110 CONTINUE ! ! Perform the incomplete LDU decomposition. DO 300 I=2,N ! ! I-th row of L INDX1 = IL(I) INDX2 = IL(I+1) - 1 if ( INDX1 > INDX2) go to 200 DO 190 INDX=INDX1,INDX2 if ( INDX == INDX1) go to 180 INDXR1 = INDX1 INDXR2 = INDX - 1 INDXC1 = JU(JL(INDX)) INDXC2 = JU(JL(INDX)+1) - 1 if ( INDXC1 > INDXC2) go to 180 160 KR = JL(INDXR1) 170 KC = IU(INDXC1) if ( KR > KC) THEN INDXC1 = INDXC1 + 1 if ( INDXC1 <= INDXC2) go to 170 ELSEIF(KR < KC) THEN INDXR1 = INDXR1 + 1 if ( INDXR1 <= INDXR2) go to 160 ELSEIF(KR == KC) THEN L(INDX) = L(INDX) - L(INDXR1)*DINV(KC)*U(INDXC1) INDXR1 = INDXR1 + 1 INDXC1 = INDXC1 + 1 if ( INDXR1 <= INDXR2 .AND. INDXC1 <= INDXC2) go to 160 ENDIF 180 L(INDX) = L(INDX)/DINV(JL(INDX)) 190 CONTINUE ! ! I-th column of U 200 INDX1 = JU(I) INDX2 = JU(I+1) - 1 if ( INDX1 > INDX2) go to 260 DO 250 INDX=INDX1,INDX2 if ( INDX == INDX1) go to 240 INDXC1 = INDX1 INDXC2 = INDX - 1 INDXR1 = IL(IU(INDX)) INDXR2 = IL(IU(INDX)+1) - 1 if ( INDXR1 > INDXR2) go to 240 210 KR = JL(INDXR1) 220 KC = IU(INDXC1) if ( KR > KC) THEN INDXC1 = INDXC1 + 1 if ( INDXC1 <= INDXC2) go to 220 ELSEIF(KR < KC) THEN INDXR1 = INDXR1 + 1 if ( INDXR1 <= INDXR2) go to 210 ELSEIF(KR == KC) THEN U(INDX) = U(INDX) - L(INDXR1)*DINV(KC)*U(INDXC1) INDXR1 = INDXR1 + 1 INDXC1 = INDXC1 + 1 if ( INDXR1 <= INDXR2 .AND. INDXC1 <= INDXC2) go to 210 ENDIF 240 U(INDX) = U(INDX)/DINV(IU(INDX)) 250 CONTINUE ! ! I-th diagonal element 260 INDXR1 = IL(I) INDXR2 = IL(I+1) - 1 if ( INDXR1 > INDXR2) go to 300 INDXC1 = JU(I) INDXC2 = JU(I+1) - 1 if ( INDXC1 > INDXC2) go to 300 270 KR = JL(INDXR1) 280 KC = IU(INDXC1) if ( KR > KC) THEN INDXC1 = INDXC1 + 1 if ( INDXC1 <= INDXC2) go to 280 ELSEIF(KR < KC) THEN INDXR1 = INDXR1 + 1 if ( INDXR1 <= INDXR2) go to 270 ELSEIF(KR == KC) THEN DINV(I) = DINV(I) - L(INDXR1)*DINV(KC)*U(INDXC1) INDXR1 = INDXR1 + 1 INDXC1 = INDXC1 + 1 if ( INDXR1 <= INDXR2 .AND. INDXC1 <= INDXC2) go to 270 ENDIF ! 300 CONTINUE ! ! Replace diagonal elements by their inverses. !VD$ VECTOR DO 430 I=1,N DINV(I) = 1.0E0/DINV(I) 430 CONTINUE ! return !------------- LAST LINE OF SSILUS FOLLOWS ---------------------------- end subroutine SSISL (A, LDA, N, KPVT, B) ! !! SSISL solves a real symmetric system using the factors obtained from SSIFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE SINGLE PRECISION (SSISL-S, DSISL-D, CHISL-C, CSISL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! SSISL solves the real symmetric system ! A * X = B ! using the factors computed by SSIFA. ! ! On Entry ! ! A REAL(LDA,N) ! the output from SSIFA. ! ! LDA INTEGER ! the leading dimension of the array A . ! ! N INTEGER ! the order of the matrix A . ! ! KPVT INTEGER(N) ! the pivot vector from SSIFA. ! ! B REAL(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero may occur if SSICO has set RCOND == 0.0 ! or SSIFA has set INFO /= 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call SSIFA(A,LDA,N,KPVT,INFO) ! if (INFO /= 0) go to ... ! DO 10 J = 1, P ! call SSISL(A,LDA,N,KPVT,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSISL INTEGER LDA,N,KPVT(*) REAL A(LDA,*),B(*) ! REAL AK,AKM1,BK,BKM1,SDOT,DENOM,TEMP INTEGER K,KP ! ! LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND ! D INVERSE TO B. ! !***FIRST EXECUTABLE STATEMENT SSISL K = N 10 if (K == 0) go to 80 if (KPVT(K) < 0) go to 40 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 30 KP = KPVT(K) if (KP == K) go to 20 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call SAXPY(K-1,B(K),A(1,K),1,B(1),1) 30 CONTINUE ! ! APPLY D INVERSE. ! B(K) = B(K)/A(K,K) K = K - 1 go to 70 40 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (K == 2) go to 60 KP = ABS(KPVT(K)) if (KP == K - 1) go to 50 ! ! INTERCHANGE. ! TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call SAXPY(K-2,B(K),A(1,K),1,B(1),1) call SAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) 60 CONTINUE ! ! APPLY D INVERSE. ! AK = A(K,K)/A(K-1,K) AKM1 = A(K-1,K-1)/A(K-1,K) BK = B(K)/A(K-1,K) BKM1 = B(K-1)/A(K-1,K) DENOM = AK*AKM1 - 1.0E0 B(K) = (AKM1*BK - BKM1)/DENOM B(K-1) = (AK*BKM1 - BK)/DENOM K = K - 2 70 CONTINUE go to 10 80 CONTINUE ! ! LOOP FORWARD APPLYING THE TRANSFORMATIONS. ! K = 1 90 if (K > N) go to 160 if (KPVT(K) < 0) go to 120 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 110 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + SDOT(K-1,A(1,K),1,B(1),1) KP = KPVT(K) if (KP == K) go to 100 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 100 CONTINUE 110 CONTINUE K = K + 1 go to 150 120 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! if (K == 1) go to 140 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + SDOT(K-1,A(1,K),1,B(1),1) B(K+1) = B(K+1) + SDOT(K-1,A(1,K+1),1,B(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 130 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 130 CONTINUE 140 CONTINUE K = K + 2 150 CONTINUE go to 90 160 CONTINUE return end subroutine SSJAC (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSJAC is a Jacobi's Method Iterative Sparse Ax = b Solver. ! ! Routine to solve a general linear system Ax = b using ! Jacobi iteration. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSJAC-S, DSJAC-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) ! ! call SSJAC(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= 4*N. ! IWORK :WORK Integer IWORK(LENIW). ! Used to hold pointers into the real workspace, RWORK. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. LENIW >= 10. ! ! *Description: ! Jacobi's method solves the linear system Ax=b with the ! basic iterative method (where A = L + D + U): ! ! n+1 -1 n n ! X = D (B - LX - UX ) ! ! n -1 n ! = X + D (B - AX ) ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which one ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SSGS, SIR !***REFERENCES (NONE) !***ROUTINES CALLED SCHKW, SIR, SS2Y, SSDI, SSDS, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910506 Corrected error in C***ROUTINES CALLED list. (FNF) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE SSJAC ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER LOCD, LOCDZ, LOCIW, LOCR, LOCW, LOCZ ! .. External Subroutines .. EXTERNAL SCHKW, SIR, SS2Y, SSDI, SSDS, SSMV !***FIRST EXECUTABLE STATEMENT SSJAC ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if LOCIW = LOCIB LOCD = LOCRB LOCR = LOCD + N LOCZ = LOCR + N LOCDZ = LOCZ + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call SCHKW( 'SSJAC', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(4) = LOCD IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Convert to SLAP column format. call SS2Y(N, NELT, IA, JA, A, ISYM ) ! ! Compute the inverse of the diagonal of the matrix. This ! will be used as the preconditioner. call SSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCD)) ! ! Set up the work array and perform the iterative refinement. call SIR(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSDI, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), RWORK(LOCZ), & RWORK(LOCDZ), RWORK, IWORK ) return !------------- LAST LINE OF SSJAC FOLLOWS ----------------------------- end subroutine SSLI2 (N, B, X, NEL, IEL, JEL, EL) ! !! SSLI2 is the SLAP Lower Triangle Matrix Backsolve. ! ! Routine to solve a system of the form Lx = b , where L ! is a lower triangular matrix. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A3 !***TYPE SINGLE PRECISION (SSLI2-S, DSLI2-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NEL, IEL(NEL), JEL(NEL) ! REAL B(N), X(N), EL(NEL) ! ! call SSLI2( N, B, X, NEL, IEL, JEL, EL ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right hand side vector. ! X :OUT Real X(N). ! Solution to Lx = b. ! NEL :IN Integer. ! Number of non-zeros in the EL array. ! IEL :IN Integer IEL(NEL). ! JEL :IN Integer JEL(NEL). ! EL :IN Real EL(NEL). ! IEL, JEL, EL contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in ! SLAP Row format. The diagonal of ones *IS* stored. This ! structure can be set up by the SS2LT routine. See the ! "Description", below, for more details about the SLAP Row ! format. ! ! *Description: ! This routine is supplied with the SLAP package as a routine ! to perform the MSOLVE operation in the SIR iteration routine ! for the driver routine SSGS. It must be called via the SLAP ! MSOLVE calling sequence convention interface routine SSLI. ! **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** ! **** SLAP MSOLVE CALLING CONVENTION **** ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the real ! array A. In other words, for each row in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going across the row (except the diagonal) in ! order. The JA array holds the column index for each ! non-zero. The IA array holds the offsets into the JA, A ! arrays for the beginning of each row. That is, ! JA(IA(IROW)), A(IA(IROW)) points to the beginning of the ! IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! points to the end of the IROW-th row. Note that we always ! have IA(N+1) = NELT+1, where N is the number of rows in ! the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP Row format the "inner loop" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! !***SEE ALSO SSLI !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSLI2 ! .. Scalar Arguments .. INTEGER N, NEL ! .. Array Arguments .. REAL B(N), EL(NEL), X(N) INTEGER IEL(NEL), JEL(NEL) ! .. Local Scalars .. INTEGER I, ICOL, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT SSLI2 ! ! Initialize the solution by copying the right hands side ! into it. ! DO 10 I=1,N X(I) = B(I) 10 CONTINUE ! !VD$ NOCONCUR DO 30 ICOL = 1, N X(ICOL) = X(ICOL)/EL(JEL(ICOL)) JBGN = JEL(ICOL) + 1 JEND = JEL(ICOL+1) - 1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NOCONCUR !VD$ NODEPCHK DO 20 J = JBGN, JEND X(IEL(J)) = X(IEL(J)) - EL(J)*X(ICOL) 20 CONTINUE ENDIF 30 CONTINUE ! return !------------- LAST LINE OF SSLI2 FOLLOWS ---------------------------- end subroutine SSLI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! SSLI is the SLAP MSOLVE for Lower Triangle Matrix. ! ! This routine acts as an interface between the SLAP generic ! MSOLVE calling convention and the routine that actually ! -1 ! computes L B = X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A3 !***TYPE SINGLE PRECISION (SSLI-S, DSLI-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! It is assumed that RWORK and IWORK have initialized with ! the information required for SSLI2: ! IWORK(1) = NEL ! IWORK(2) = Starting location of IEL in IWORK. ! IWORK(3) = Starting location of JEL in IWORK. ! IWORK(4) = Starting location of EL in RWORK. ! See the DESCRIPTION of SSLI2 for details. !***REFERENCES (NONE) !***ROUTINES CALLED SSLI2 !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSLI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER LOCEL, LOCIEL, LOCJEL, NEL ! .. External Subroutines .. EXTERNAL SSLI2 !***FIRST EXECUTABLE STATEMENT SSLI ! NEL = IWORK(1) LOCIEL = IWORK(2) LOCJEL = IWORK(3) LOCEL = IWORK(4) call SSLI2(N, B, X, NEL, IWORK(LOCIEL), IWORK(LOCJEL), & RWORK(LOCEL)) ! return !------------- LAST LINE OF SSLI FOLLOWS ---------------------------- end subroutine SSLLTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! SSLLTI is the SLAP MSOLVE for LDL' (IC) Factorization. ! ! This routine acts as an interface between the SLAP generic ! MSOLVE calling convention and the routine that actually ! -1 ! computes (LDL') B = X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSLLTI-S, DSLLTI-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! It is assumed that RWORK and IWORK have initialized with ! the information required for SLLTI2: ! IWORK(1) = NEL ! IWORK(2) = Starting location of IEL in IWORK. ! IWORK(3) = Starting location of JEL in IWORK. ! IWORK(4) = Starting location of EL in RWORK. ! IWORK(5) = Starting location of DINV in RWORK. ! See the DESCRIPTION of SLLTI2 for details. !***REFERENCES (NONE) !***ROUTINES CALLED SLLTI2 !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Corrected conversion error. (FNF) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSLLTI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(NELT), B(*), RWORK(*), X(*) INTEGER IA(NELT), IWORK(*), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCEL, LOCIEL, LOCJEL, NEL ! .. External Subroutines .. EXTERNAL SLLTI2 !***FIRST EXECUTABLE STATEMENT SSLLTI NEL = IWORK(1) LOCIEL = IWORK(3) LOCJEL = IWORK(2) LOCEL = IWORK(4) LOCDIN = IWORK(5) call SLLTI2(N, B, X, NEL, IWORK(LOCIEL), IWORK(LOCJEL), & RWORK(LOCEL), RWORK(LOCDIN)) ! return !------------- LAST LINE OF SSLLTI FOLLOWS ---------------------------- end subroutine SSLUBC (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSLUBC is the Incomplete LU BiConjugate Gradient Sparse Ax=b Solver. ! ! Routine to solve a linear system Ax = b using the ! BiConjugate Gradient method with Incomplete LU ! decomposition preconditioning. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSLUBC-S, DSLUBC-D) !***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) ! ! call SSLUBC(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= NL+NU+8*N. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. ! LENIW >= NL+NU+4*N+12. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! ! *Description: ! This routine is simply a driver for the SBCGN routine. It ! calls the SSILUS routine to set up the preconditioning and ! then calls SBCGN with the appropriate MATVEC, MTTVEC and ! MSOLVE, MTSOLV routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SBCG, SSDBCG !***REFERENCES (NONE) !***ROUTINES CALLED SBCG, SCHKW, SS2Y, SSILUS, SSLUI, SSLUTI, SSMTV, ! SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SSLUBC ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCDZ, LOCIL, LOCIU, LOCIW, & LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCP, LOCPP, LOCR, & LOCRR, LOCU, LOCW, LOCZ, LOCZZ, NL, NU ! .. External Subroutines .. EXTERNAL SBCG, SCHKW, SS2Y, SSILUS, SSLUI, SSLUTI, SSMTV, SSMV !***FIRST EXECUTABLE STATEMENT SSLUBC ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements preconditioner ILU matrix. ! Then set up the work arrays. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIL = LOCIB LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCU = LOCDIN + N LOCR = LOCU + NU LOCZ = LOCR + N LOCP = LOCZ + N LOCRR = LOCP + N LOCZZ = LOCRR + N LOCPP = LOCZZ + N LOCDZ = LOCPP + N LOCW = LOCDZ + N ! ! Check the workspace allocations. call SCHKW( 'SSLUBC', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Perform the incomplete LU preconditioned ! BiConjugate Gradient algorithm. call SBCG(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSMTV, & SSLUI, SSLUTI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), & RWORK(LOCRR), RWORK(LOCZZ), RWORK(LOCPP), & RWORK(LOCDZ), RWORK, IWORK ) return !------------- LAST LINE OF SSLUBC FOLLOWS ---------------------------- end subroutine SSLUCN (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSLUCN is the Incomplete LU CG Sparse Ax=b Solver for Normal Equations. ! ! Routine to solve a general linear system Ax = b using the ! incomplete LU decomposition with the Conjugate Gradient ! method applied to the normal equations, viz., AA'y = b, ! x = A'y. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSLUCN-S, DSLUCN-D) !***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) ! ! call SSLUCN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= NL+NU+8*N. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. ! LENIW >= NL+NU+4*N+12. ! NL is the number of non-zeros in the lower triangle of the ! matrix (including the diagonal). ! NU is the number of non-zeros in the upper triangle of the ! matrix (including the diagonal). ! ! *Description: ! This routine is simply a driver for the SCGN routine. It ! calls the SSILUS routine to set up the preconditioning and then ! calls SCGN with the appropriate MATVEC and MSOLVE routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SCGN, SDCGN, SSILUS !***REFERENCES (NONE) !***ROUTINES CALLED SCGN, SCHKW, SS2Y, SSILUS, SSMMTI, SSMTV, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SSLUCN ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCATD, LOCATP, LOCATZ, LOCDIN, & LOCDZ, LOCIL, LOCIU, LOCIW, LOCJL, LOCJU, LOCL, LOCNC, & LOCNR, LOCP, LOCR, LOCU, LOCW, LOCZ, NL, NU ! .. External Subroutines .. EXTERNAL SCGN, SCHKW, SS2Y, SSILUS, SSMMTI, SSMTV, SSMV !***FIRST EXECUTABLE STATEMENT SSLUCN ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements preconditioner ILU matrix. ! Then set up the work arrays. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIL = LOCIB LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCU = LOCDIN + N LOCR = LOCU + NU LOCZ = LOCR + N LOCP = LOCZ + N LOCATP = LOCP + N LOCATZ = LOCATP + N LOCDZ = LOCATZ + N LOCATD = LOCDZ + N LOCW = LOCATD + N ! ! Check the workspace allocations. call SCHKW( 'SSLUCN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Perform Conjugate Gradient algorithm on the normal equations. call SCGN(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSMTV, SSMMTI, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), & RWORK(LOCZ), RWORK(LOCP), RWORK(LOCATP), RWORK(LOCATZ), & RWORK(LOCDZ), RWORK(LOCATD), RWORK, IWORK ) ! if ( ITER > ITMAX ) IERR = 2 return !------------- LAST LINE OF SSLUCN FOLLOWS ---------------------------- end subroutine SSLUCS (N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, & ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSLUCS is the Incomplete LU BiConjugate Gradient Squared Ax=b Solver. ! ! Routine to solve a linear system Ax = b using the ! BiConjugate Gradient Squared method with Incomplete LU ! decomposition preconditioning. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSLUCS-S, DSLUCS-D) !***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NL+NU+8*N) ! ! call SSLUCS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! This routine must calculate the residual from R = A*X - B. ! This is unnatural and hence expensive for this type of iter- ! ative method. ITOL=2 is *STRONGLY* recommended. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv time a vector is the pre- ! conditioning step. This is the *NATURAL* stopping for this ! iterative method and is *STRONGLY* recommended. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Breakdown of the method detected. ! (r0,r) approximately 0. ! IERR = 6 => Stagnation of the method detected. ! (r0,v) approximately 0. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. NL is the number of non- ! zeros in the lower triangle of the matrix (including the ! diagonal). NU is the number of non-zeros in the upper ! triangle of the matrix (including the diagonal). ! LENW :IN Integer. ! Length of the real workspace, RWORK. LENW >= NL+NU+8*N. ! IWORK :WORK Integer IWORK(LENIW). ! Integer array used for workspace. NL is the number of non- ! zeros in the lower triangle of the matrix (including the ! diagonal). NU is the number of non-zeros in the upper ! triangle of the matrix (including the diagonal). ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. ! LENIW >= NL+NU+4*N+12. ! ! *Description: ! This routine is simply a driver for the SCGSN routine. It ! calls the SSILUS routine to set up the preconditioning and ! then calls SCGSN with the appropriate MATVEC, MTTVEC and ! MSOLVE, MTSOLV routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SCGS, SSDCGS !***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver ! for nonsymmetric linear systems, Delft University ! of Technology Report 84-16, Department of Mathe- ! matics and Informatics, Delft, The Netherlands. ! 2. E. F. Kaasschieter, The solution of non-symmetric ! linear systems by biconjugate gradients or conjugate ! gradients squared, Delft University of Technology ! Report 86-21, Department of Mathematics and Informa- ! tics, Delft, The Netherlands. !***ROUTINES CALLED SCGS, SCHKW, SS2Y, SSILUS, SSLUI, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SSLUCS ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCIL, LOCIU, LOCIW, LOCJL, & LOCJU, LOCL, LOCNC, LOCNR, LOCP, LOCQ, LOCR, LOCR0, LOCU, & LOCUU, LOCV1, LOCV2, LOCW, NL, NU ! .. External Subroutines .. EXTERNAL SCGS, SCHKW, SS2Y, SSILUS, SSLUI, SSMV !***FIRST EXECUTABLE STATEMENT SSLUCS ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements preconditioner ILU matrix. ! Then set up the work arrays. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIL = LOCIB LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCUU = LOCDIN + N LOCR = LOCUU + NU LOCR0 = LOCR + N LOCP = LOCR0 + N LOCQ = LOCP + N LOCU = LOCQ + N LOCV1 = LOCU + N LOCV2 = LOCV1 + N LOCW = LOCV2 + N ! ! Check the workspace allocations. call SCHKW( 'SSLUCS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCUU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCUU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Perform the incomplete LU preconditioned ! BiConjugate Gradient Squared algorithm. call SCGS(N, B, X, NELT, IA, JA, A, ISYM, SSMV, & SSLUI, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCR0), RWORK(LOCP), & RWORK(LOCQ), RWORK(LOCU), RWORK(LOCV1), & RWORK(LOCV2), RWORK, IWORK ) return !------------- LAST LINE OF SSLUCS FOLLOWS ---------------------------- end subroutine SSLUGM (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSLUGM is the Incomplete LU GMRES Iterative Sparse Ax=b Solver. ! ! This routine uses the generalized minimum residual ! (GMRES) method with incomplete LU factorization for ! preconditioning to solve possibly non-symmetric linear ! systems of the form: Ax = b. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSLUGM-S, DSLUGM-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL ! INTEGER ITMAX, ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW) ! ! call SSLUGM(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ! $ ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, ! $ RWORK, LENW, IWORK, LENIW) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize against. ! Must be greater than 1. ! ITOL :IN Integer. ! Flag to indicate the type of convergence criterion used. ! ITOL=0 Means the iteration stops when the test described ! below on the residual RL is satisfied. This is ! the "Natural Stopping Criteria" for this routine. ! Other values of ITOL cause extra, otherwise ! unnecessary, computation per iteration and are ! therefore much less efficient. See ISSGMR (the ! stop test routine) for more information. ! ITOL=1 Means the iteration stops when the first test ! described below on the residual RL is satisfied, ! and there is either right or no preconditioning ! being used. ! ITOL=2 Implies that the user is using left ! preconditioning, and the second stopping criterion ! below is used. ! ITOL=3 Means the iteration stops when the third test ! described below on Minv*Residual is satisfied, and ! there is either left or no preconditioning begin ! used. ! ITOL=11 is often useful for checking and comparing ! different routines. For this case, the user must ! supply the "exact" solution or a very accurate ! approximation (one with an error much less than ! TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the ! difference between the iterative approximation and ! the user-supplied solution divided by the 2-norm ! of the user-supplied solution is less than TOL. ! Note that this requires the user to set up the ! "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling ! routine. The routine with this declaration should ! be loaded before the stop test so that the correct ! length is used by the loader. This procedure is ! not standard Fortran and may not work correctly on ! your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 ! then this common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described below. If TOL is set ! to zero on input, then a default value of 500*(the smallest ! positive magnitude, machine epsilon) is used. ! ITMAX :IN Integer. ! Maximum number of iterations. This routine uses the default ! of NRMAX = ITMAX/NSAVE to determine the when each restart ! should occur. See the description of NRMAX and MAXL in ! SGMRES for a full and frightfully interesting discussion of ! this topic. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. Letting norm() denote the Euclidean ! norm, ERR is defined as follows... ! If ITOL=0, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! for right or no preconditioning, and ! ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! for left preconditioning. ! If ITOL=1, then ERR = norm(SB*(B-A*X(L)))/norm(SB*B), ! since right or no preconditioning ! being used. ! If ITOL=2, then ERR = norm(SB*(M-inverse)*(B-A*X(L)))/ ! norm(SB*(M-inverse)*B), ! since left preconditioning is being ! used. ! If ITOL=3, then ERR = Max |(Minv*(B-A*X(L)))(i)/x(i)| ! i=1,n ! If ITOL=11, then ERR = norm(SB*(X(L)-SOLN))/norm(SB*SOLN). ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient storage allocated for ! RGWK or IGWK. ! IERR = 2 => Routine SPIGMR failed to reduce the norm ! of the current residual on its last call, ! and so the iteration has stalled. In ! this case, X equals the last computed ! approximation. The user must either ! increase MAXL, or choose a different ! initial guess. ! IERR =-1 => Insufficient length for RGWK array. ! IGWK(6) contains the required minimum ! length of the RGWK array. ! IERR =-2 => Inconsistent ITOL and JPRE values. ! For IERR <= 2, RGWK(1) = RHOL, which is the norm on the ! left-hand-side of the relevant stopping test defined ! below associated with the residual for the current ! approximation X(L). ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array of size LENW. ! LENW :IN Integer. ! Length of the real workspace, RWORK. ! LENW >= 1 + N*(NSAVE+7) + NSAVE*(NSAVE+3)+NL+NU. ! Here NL is the number of non-zeros in the lower triangle of ! the matrix (including the diagonal) and NU is the number of ! non-zeros in the upper triangle of the matrix (including the ! diagonal). ! For the recommended values, RWORK has size at least ! 131 + 17*N + NL + NU. ! IWORK :INOUT Integer IWORK(LENIW). ! Used to hold pointers into the RWORK array. ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. ! LENIW >= NL+NU+4*N+32. ! ! *Description: ! SSLUGM solves a linear system A*X = B rewritten in the form: ! ! (SB*A*(M-inverse)*(SX-inverse))*(SX*M*X) = SB*B, ! ! with right preconditioning, or ! ! (SB*(M-inverse)*A*(SX-inverse))*(SX*X) = SB*(M-inverse)*B, ! ! with left preconditioning, where A is an n-by-n real matrix, ! X and B are N-vectors, SB and SX are diagonal scaling ! matrices, and M is the Incomplete LU factorization of A. It ! uses preconditioned Krylov subpace methods based on the ! generalized minimum residual method (GMRES). This routine ! is a driver routine which assumes a SLAP matrix data ! structure and sets up the necessary information to do ! diagonal preconditioning and calls the main GMRES routine ! SGMRES for the solution of the linear system. SGMRES ! optionally performs either the full orthogonalization ! version of the GMRES algorithm or an incomplete variant of ! it. Both versions use restarting of the linear iteration by ! default, although the user can disable this feature. ! ! The GMRES algorithm generates a sequence of approximations ! X(L) to the true solution of the above linear system. The ! convergence criteria for stopping the iteration is based on ! the size of the scaled norm of the residual R(L) = B - ! A*X(L). The actual stopping test is either: ! ! norm(SB*(B-A*X(L))) .le. TOL*norm(SB*B), ! ! for right preconditioning, or ! ! norm(SB*(M-inverse)*(B-A*X(L))) .le. ! TOL*norm(SB*(M-inverse)*B), ! ! for left preconditioning, where norm() denotes the Euclidean ! norm, and TOL is a positive scalar less than one input by ! the user. If TOL equals zero when SSLUGM is called, then a ! default value of 500*(the smallest positive magnitude, ! machine epsilon) is used. If the scaling arrays SB and SX ! are used, then ideally they should be chosen so that the ! vectors SX*X(or SX*M*X) and SB*B have all their components ! approximately equal to one in magnitude. If one wants to ! use the same scaling in X and B, then SB and SX can be the ! same array in the calling program. ! ! The following is a list of the other routines and their ! functions used by GMRES: ! SGMRES Contains the matrix structure independent driver ! routine for GMRES. ! SPIGMR Contains the main iteration loop for GMRES. ! SORTH Orthogonalizes a new vector against older basis vectors. ! SHEQR Computes a QR decomposition of a Hessenberg matrix. ! SHELS Solves a Hessenberg least-squares system, using QR ! factors. ! RLCALC Computes the scaled residual RL. ! XLCALC Computes the solution XL. ! ISSGMR User-replaceable stopping routine. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to be ! the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***REFERENCES 1. Peter N. Brown and A. C. Hindmarsh, Reduced Storage ! Matrix Methods in Stiff ODE Systems, Lawrence Liver- ! more National Laboratory Report UCRL-95088, Rev. 1, ! Livermore, California, June 1987. !***ROUTINES CALLED SCHKW, SGMRES, SS2Y, SSILUS, SSLUI, SSMV !***REVISION HISTORY (YYMMDD) ! 880615 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920929 Corrected format of references. (FNF) ! 921019 Corrected NEL to NL. (FNF) !***END PROLOGUE SSLUGM ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, & NELT, NSAVE ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCDIN, LOCIGW, LOCIL, LOCIU, LOCIW, & LOCJL, LOCJU, LOCL, LOCNC, LOCNR, LOCRGW, LOCU, LOCW, & MYITOL, NL, NU ! .. External Subroutines .. EXTERNAL SCHKW, SGMRES, SS2Y, SSILUS, SSLUI, SSMV !***FIRST EXECUTABLE STATEMENT SSLUGM ! IERR = 0 ERR = 0 if ( NSAVE <= 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements preconditioner ILU matrix. ! Then set up the work arrays. We assume MAXL=KMP=NSAVE. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIGW = LOCIB LOCIL = LOCIGW + 20 LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCU = LOCDIN + N LOCRGW = LOCU + NU LOCW = LOCRGW + 1+N*(NSAVE+6)+NSAVE*(NSAVE+3) ! ! Check the workspace allocations. call SCHKW( 'SSLUGM', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Perform the Incomplete LU Preconditioned Generalized Minimum ! Residual iteration algorithm. The following SGMRES ! defaults are used MAXL = KMP = NSAVE, JSCAL = 0, ! JPRE = -1, NRMAX = ITMAX/NSAVE IWORK(LOCIGW ) = NSAVE IWORK(LOCIGW+1) = NSAVE IWORK(LOCIGW+2) = 0 IWORK(LOCIGW+3) = -1 IWORK(LOCIGW+4) = ITMAX/NSAVE MYITOL = 0 ! call SGMRES( N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSLUI, & MYITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, RWORK, & RWORK(LOCRGW), LENW-LOCRGW, IWORK(LOCIGW), 20, & RWORK, IWORK ) ! if ( ITER > ITMAX ) IERR = 2 return !------------- LAST LINE OF SSLUGM FOLLOWS ---------------------------- end subroutine SSLUI2 (N, B, X, IL, JL, L, DINV, IU, JU, U) ! !! SSLUI2 is the SLAP Backsolve for LDU Factorization. ! ! Routine to solve a system of the form L*D*U X = B, ! where L is a unit lower triangular matrix, D is a diagonal ! matrix, and U is a unit upper triangular matrix. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSLUI2-S, DSLUI2-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) ! REAL B(N), X(N), L(NL), DINV(N), U(NU) ! ! call SSLUI2( N, B, X, IL, JL, L, DINV, IU, JU, U ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right hand side. ! X :OUT Real X(N). ! Solution of L*D*U x = b. ! IL :IN Integer IL(NL). ! JL :IN Integer JL(NL). ! L :IN Real L(NL). ! IL, JL, L contain the unit lower triangular factor of the ! incomplete decomposition of some matrix stored in SLAP Row ! format. The diagonal of ones *IS* stored. This structure ! can be set up by the SSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NL is the number of non-zeros in the L array.) ! DINV :IN Real DINV(N). ! Inverse of the diagonal matrix D. ! IU :IN Integer IU(NU). ! JU :IN Integer JU(NU). ! U :IN Real U(NU). ! IU, JU, U contain the unit upper triangular factor of the ! incomplete decomposition of some matrix stored in SLAP ! Column format. The diagonal of ones *IS* stored. This ! structure can be set up by the SSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NU is the number of non-zeros in the U array.) ! ! *Description: ! This routine is supplied with the SLAP package as a routine ! to perform the MSOLVE operation in the SIR and SBCG ! iteration routines for the drivers SSILUR and SSLUBC. It ! must be called via the SLAP MSOLVE calling sequence ! convention interface routine SSLUI. ! **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** ! **** SLAP MSOLVE CALLING CONVENTION **** ! ! IL, JL, L should contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in SLAP ! Row format. IU, JU, U should contain the unit upper factor ! of the incomplete decomposition of the A matrix stored in ! SLAP Column format This ILU factorization can be computed by ! the SSILUS routine. The diagonals (which are all one's) are ! stored. ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the real ! array A. In other words, for each row in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going across the row (except the diagonal) in ! order. The JA array holds the column index for each ! non-zero. The IA array holds the offsets into the JA, A ! arrays for the beginning of each row. That is, ! JA(IA(IROW)), A(IA(IROW)) points to the beginning of the ! IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! points to the end of the IROW-th row. Note that we always ! have IA(N+1) = NELT+1, where N is the number of rows in ! the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format the "inner loops" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! !***SEE ALSO SSILUS !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSLUI2 ! .. Scalar Arguments .. INTEGER N ! .. Array Arguments .. REAL B(N), DINV(N), L(*), U(*), X(N) INTEGER IL(*), IU(*), JL(*), JU(*) ! .. Local Scalars .. INTEGER I, ICOL, IROW, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT SSLUI2 ! ! Solve L*Y = B, storing result in X, L stored by rows. ! DO 10 I = 1, N X(I) = B(I) 10 CONTINUE DO 30 IROW = 2, N JBGN = IL(IROW) JEND = IL(IROW+1)-1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ ASSOC !VD$ NODEPCHK DO 20 J = JBGN, JEND X(IROW) = X(IROW) - L(J)*X(JL(J)) 20 CONTINUE ENDIF 30 CONTINUE ! ! Solve D*Z = Y, storing result in X. DO 40 I=1,N X(I) = X(I)*DINV(I) 40 CONTINUE ! ! Solve U*X = Z, U stored by columns. DO 60 ICOL = N, 2, -1 JBGN = JU(ICOL) JEND = JU(ICOL+1)-1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 50 J = JBGN, JEND X(IU(J)) = X(IU(J)) - U(J)*X(ICOL) 50 CONTINUE ENDIF 60 CONTINUE ! return !------------- LAST LINE OF SSLUI2 FOLLOWS ---------------------------- end subroutine SSLUI4 (N, B, X, IL, JL, L, DINV, IU, JU, U) ! !! SSLUI4 is the SLAP Backsolve for LDU Factorization. ! ! Routine to solve a system of the form (L*D*U)' X = B, ! where L is a unit lower triangular matrix, D is a diagonal ! matrix, and U is a unit upper triangular matrix and ' ! denotes transpose. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSLUI4-S, DSLUI4-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) ! REAL B(N), X(N), L(NL), DINV(N), U(NU) ! ! call SSLUI4( N, B, X, IL, JL, L, DINV, IU, JU, U ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right hand side. ! X :OUT Real X(N). ! Solution of (L*D*U)trans x = b. ! IL :IN Integer IL(NL). ! JL :IN Integer JL(NL). ! L :IN Real L(NL). ! IL, JL, L contain the unit lower triangular factor of the ! incomplete decomposition of some matrix stored in SLAP Row ! format. The diagonal of ones *IS* stored. This structure ! can be set up by the SSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NL is the number of non-zeros in the L array.) ! DINV :IN Real DINV(N). ! Inverse of the diagonal matrix D. ! IU :IN Integer IU(NU). ! JU :IN Integer JU(NU). ! U :IN Real U(NU). ! IU, JU, U contain the unit upper triangular factor of the ! incomplete decomposition of some matrix stored in SLAP ! Column format. The diagonal of ones *IS* stored. This ! structure can be set up by the SSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NU is the number of non-zeros in the U array.) ! ! *Description: ! This routine is supplied with the SLAP package as a routine ! to perform the MTSOLV operation in the SBCG iteration ! routine for the driver SSLUBC. It must be called via the ! SLAP MTSOLV calling sequence convention interface routine ! SSLUTI. ! **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** ! **** SLAP MSOLVE CALLING CONVENTION **** ! ! IL, JL, L should contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in SLAP ! Row format. IU, JU, U should contain the unit upper factor ! of the incomplete decomposition of the A matrix stored in ! SLAP Column format This ILU factorization can be computed by ! the SSILUS routine. The diagonals (which are all one's) are ! stored. ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the real ! array A. In other words, for each row in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going across the row (except the diagonal) in ! order. The JA array holds the column index for each ! non-zero. The IA array holds the offsets into the JA, A ! arrays for the beginning of each row. That is, ! JA(IA(IROW)), A(IA(IROW)) points to the beginning of the ! IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! points to the end of the IROW-th row. Note that we always ! have IA(N+1) = NELT+1, where N is the number of rows in ! the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format the "inner loops" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! !***SEE ALSO SSILUS !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSLUI4 ! .. Scalar Arguments .. INTEGER N ! .. Array Arguments .. REAL B(N), DINV(N), L(*), U(*), X(N) INTEGER IL(*), IU(*), JL(*), JU(*) ! .. Local Scalars .. INTEGER I, ICOL, IROW, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT SSLUI4 DO 10 I=1,N X(I) = B(I) 10 CONTINUE ! ! Solve U'*Y = X, storing result in X, U stored by columns. DO 80 IROW = 2, N JBGN = JU(IROW) JEND = JU(IROW+1) - 1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ ASSOC !VD$ NODEPCHK DO 70 J = JBGN, JEND X(IROW) = X(IROW) - U(J)*X(IU(J)) 70 CONTINUE ENDIF 80 CONTINUE ! ! Solve D*Z = Y, storing result in X. DO 90 I = 1, N X(I) = X(I)*DINV(I) 90 CONTINUE ! ! Solve L'*X = Z, L stored by rows. DO 110 ICOL = N, 2, -1 JBGN = IL(ICOL) JEND = IL(ICOL+1) - 1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 100 J = JBGN, JEND X(JL(J)) = X(JL(J)) - L(J)*X(ICOL) 100 CONTINUE ENDIF 110 CONTINUE return !------------- LAST LINE OF SSLUI4 FOLLOWS ---------------------------- end subroutine SSLUI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! SSLUI is the SLAP MSOLVE for LDU Factorization. ! ! This routine acts as an interface between the SLAP generic ! MSOLVE calling convention and the routine that actually ! -1 ! computes (LDU) B = X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSLUI-S, DSLUI-D) !***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM SOLVE, ! SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! It is assumed that RWORK and IWORK have initialized with ! the information required for SSLUI2: ! IWORK(1) = Starting location of IL in IWORK. ! IWORK(2) = Starting location of JL in IWORK. ! IWORK(3) = Starting location of IU in IWORK. ! IWORK(4) = Starting location of JU in IWORK. ! IWORK(5) = Starting location of L in RWORK. ! IWORK(6) = Starting location of DINV in RWORK. ! IWORK(7) = Starting location of U in RWORK. ! See the DESCRIPTION of SSLUI2 for details. !***REFERENCES (NONE) !***ROUTINES CALLED SSLUI2 !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSLUI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU ! .. External Subroutines .. EXTERNAL SSLUI2 !***FIRST EXECUTABLE STATEMENT SSLUI ! ! Pull out the locations of the arrays holding the ILU ! factorization. ! LOCIL = IWORK(1) LOCJL = IWORK(2) LOCIU = IWORK(3) LOCJU = IWORK(4) LOCL = IWORK(5) LOCDIN = IWORK(6) LOCU = IWORK(7) ! ! Solve the system LUx = b call SSLUI2(N, B, X, IWORK(LOCIL), IWORK(LOCJL), RWORK(LOCL), & RWORK(LOCDIN), IWORK(LOCIU), IWORK(LOCJU), RWORK(LOCU) ) ! return !------------- LAST LINE OF SSLUI FOLLOWS ---------------------------- end subroutine SSLUOM (N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW) ! !! SSLUOM is the Incomplete LU Orthomin Sparse Iterative Ax=b Solver. ! ! Routine to solve a general linear system Ax = b using ! the Orthomin method with Incomplete LU decomposition. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SSLUOM-S, DSLUOM-D) !***KEYWORDS ITERATIVE INCOMPLETE LU PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, NSAVE, ITOL, ITMAX ! INTEGER ITER, IERR, IUNIT, LENW, IWORK(NL+NU+4*N+2), LENIW ! REAL B(N), X(N), A(NELT), TOL, ERR ! REAL RWORK(NL+NU+7*N+3*N*NSAVE+NSAVE) ! ! call SSLUOM(N, B, X, NELT, IA, JA, A, ISYM, NSAVE, ITOL, TOL, ! $ ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW ) ! ! *Arguments: ! N :IN Integer. ! Order of the matrix. ! B :IN Real B(N). ! Right-hand side vector. ! X :INOUT Real X(N). ! On input X is your initial guess for solution vector. ! On output X is the final approximate solution. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :INOUT Integer IA(NELT). ! JA :INOUT Integer JA(NELT). ! A :INOUT Real A(NELT). ! These arrays should hold the matrix A in either the SLAP ! Triad format or the SLAP Column format. See "Description", ! below. If the SLAP Triad format is chosen, it is changed ! internally to the SLAP Column format. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! NSAVE :IN Integer. ! Number of direction vectors to save and orthogonalize against. ! ITOL :IN Integer. ! Flag to indicate type of convergence criterion. ! If ITOL=1, iteration stops when the 2-norm of the residual ! divided by the 2-norm of the right-hand side is less than TOL. ! If ITOL=2, iteration stops when the 2-norm of M-inv times the ! residual divided by the 2-norm of M-inv times the right hand ! side is less than TOL, where M-inv is the inverse of the ! diagonal of A. ! ITOL=11 is often useful for checking and comparing different ! routines. For this case, the user must supply the "exact" ! solution or a very accurate approximation (one with an error ! much less than TOL) through a common block, ! COMMON /SSLBLK/ SOLN( ) ! If ITOL=11, iteration stops when the 2-norm of the difference ! between the iterative approximation and the user-supplied ! solution divided by the 2-norm of the user-supplied solution ! is less than TOL. Note that this requires the user to set up ! the "COMMON /SSLBLK/ SOLN(LENGTH)" in the calling routine. ! The routine with this declaration should be loaded before the ! stop test so that the correct length is used by the loader. ! This procedure is not standard Fortran and may not work ! correctly on your system (although it has worked on every ! system the authors have tried). If ITOL is not 11 then this ! common block is indeed standard Fortran. ! TOL :INOUT Real. ! Convergence criterion, as described above. (Reset if IERR=4.) ! ITMAX :IN Integer. ! Maximum number of iterations. ! ITER :OUT Integer. ! Number of iterations required to reach convergence, or ! ITMAX+1 if convergence criterion could not be achieved in ! ITMAX iterations. ! ERR :OUT Real. ! Error estimate of error in final approximate solution, as ! defined by ITOL. ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => All went well. ! IERR = 1 => Insufficient space allocated for WORK or IWORK. ! IERR = 2 => Method failed to converge in ITMAX steps. ! IERR = 3 => Error in user input. ! Check input values of N, ITOL. ! IERR = 4 => User error tolerance set too tight. ! Reset to 500*R1MACH(3). Iteration proceeded. ! IERR = 5 => Preconditioning matrix, M, is not positive ! definite. (r,z) < 0. ! IERR = 6 => Breakdown of the method detected. ! (p,Ap) < epsilon**2. ! IERR = 7 => Incomplete factorization broke down and was ! fudged. Resulting preconditioning may be less ! than the best. ! IUNIT :IN Integer. ! Unit number on which to write the error at each iteration, ! if this is desired for monitoring convergence. If unit ! number is 0, no writing will occur. ! RWORK :WORK Real RWORK(LENW). ! Real array used for workspace. NL is the number of non- ! zeros in the lower triangle of the matrix (including the ! diagonal). NU is the number of non-zeros in the upper ! triangle of the matrix (including the diagonal). ! LENW :IN Integer. ! Length of the real workspace, RWORK. ! LENW >= NL+NU+4*N+NSAVE*(3*N+1) ! IWORK :WORK Integer IWORK(LENIW) ! Integer array used for workspace. NL is the number of non- ! zeros in the lower triangle of the matrix (including the ! diagonal). NU is the number of non-zeros in the upper ! triangle of the matrix (including the diagonal). ! Upon return the following locations of IWORK hold information ! which may be of use to the user: ! IWORK(9) Amount of Integer workspace actually used. ! IWORK(10) Amount of Real workspace actually used. ! LENIW :IN Integer. ! Length of the integer workspace, IWORK. ! LENIW >= NL+NU+4*N+12. ! ! *Description: ! This routine is simply a driver for the SOMN routine. It ! calls the SSILUS routine to set up the preconditioning and ! then calls SOMN with the appropriate MATVEC and MSOLVE ! routines. ! ! The Sparse Linear Algebra Package (SLAP) utilizes two matrix ! data structures: 1) the SLAP Triad format or 2) the SLAP ! Column format. The user can hand this routine either of the ! of these data structures and SLAP will figure out which on ! is being used and act accordingly. ! ! =================== S L A P Triad format =================== ! ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! *Side Effects: ! The SLAP Triad format (IA, JA, A) is modified internally to ! be the SLAP Column format. See above. ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. ! !***SEE ALSO SOMN, SSDOMN !***REFERENCES (NONE) !***ROUTINES CALLED SCHKW, SOMN, SS2Y, SSILUS, SSLUI, SSMV !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890921 Removed TeX from comments. (FNF) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920407 COMMON BLOCK renamed SSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 921019 Corrected NEL to NL. (FNF) ! 921113 Corrected C***CATEGORY line. (FNF) !***END PROLOGUE SSLUOM ! .. Parameters .. INTEGER LOCRB, LOCIB PARAMETER (LOCRB=1, LOCIB=11) ! .. Scalar Arguments .. REAL ERR, TOL INTEGER IERR, ISYM, ITER, ITMAX, ITOL, IUNIT, LENIW, LENW, N, & NELT, NSAVE ! .. Array Arguments .. REAL A(N), B(N), RWORK(LENW), X(N) INTEGER IA(NELT), IWORK(LENIW), JA(NELT) ! .. Local Scalars .. INTEGER ICOL, J, JBGN, JEND, LOCAP, LOCCSA, LOCDIN, LOCDZ, LOCEMA, & LOCIL, LOCIU, LOCIW, LOCJL, LOCJU, LOCL, LOCNC, LOCNR, & LOCP, LOCR, LOCU, LOCW, LOCZ, NL, NU ! .. External Subroutines .. EXTERNAL SCHKW, SOMN, SS2Y, SSILUS, SSLUI, SSMV !***FIRST EXECUTABLE STATEMENT SSLUOM ! IERR = 0 if ( N < 1 .OR. NELT < 1 ) THEN IERR = 3 return end if ! ! Change the SLAP input matrix IA, JA, A to SLAP-Column format. call SS2Y( N, NELT, IA, JA, A, ISYM ) ! ! Count number of Non-Zero elements preconditioner ILU matrix. ! Then set up the work arrays. NL = 0 NU = 0 DO 20 ICOL = 1, N ! Don't count diagonal. JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN <= JEND ) THEN !VD$ NOVECTOR DO 10 J = JBGN, JEND if ( IA(J) > ICOL ) THEN NL = NL + 1 if ( ISYM /= 0 ) NU = NU + 1 ELSE NU = NU + 1 ENDIF 10 CONTINUE ENDIF 20 CONTINUE ! LOCIL = LOCIB LOCJL = LOCIL + N+1 LOCIU = LOCJL + NL LOCJU = LOCIU + NU LOCNR = LOCJU + N+1 LOCNC = LOCNR + N LOCIW = LOCNC + N ! LOCL = LOCRB LOCDIN = LOCL + NL LOCU = LOCDIN + N LOCR = LOCU + NU LOCZ = LOCR + N LOCP = LOCZ + N LOCAP = LOCP + N*(NSAVE+1) LOCEMA = LOCAP + N*(NSAVE+1) LOCDZ = LOCEMA + N*(NSAVE+1) LOCCSA = LOCDZ + N LOCW = LOCCSA + NSAVE ! ! Check the workspace allocations. call SCHKW( 'SSLUOM', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) if ( IERR /= 0 ) RETURN ! IWORK(1) = LOCIL IWORK(2) = LOCJL IWORK(3) = LOCIU IWORK(4) = LOCJU IWORK(5) = LOCL IWORK(6) = LOCDIN IWORK(7) = LOCU IWORK(9) = LOCIW IWORK(10) = LOCW ! ! Compute the Incomplete LU decomposition. call SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL), & IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) ) ! ! Perform the incomplete LU preconditioned OrthoMin algorithm. call SOMN(N, B, X, NELT, IA, JA, A, ISYM, SSMV, & SSLUI, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK(LOCR), RWORK(LOCZ), RWORK(LOCP), RWORK(LOCAP), & RWORK(LOCEMA), RWORK(LOCDZ), RWORK(LOCCSA), & RWORK, IWORK ) return end subroutine SSLUTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! SSLUTI is the SLAP MTSOLV for LDU Factorization. ! ! This routine acts as an interface between the SLAP generic ! MTSOLV calling convention and the routine that actually ! -T ! computes (LDU) B = X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSLUTI-S, DSLUTI-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! It is assumed that RWORK and IWORK have initialized with ! the information required for SSLUI4: ! IWORK(1) = Starting location of IL in IWORK. ! IWORK(2) = Starting location of JL in IWORK. ! IWORK(3) = Starting location of IU in IWORK. ! IWORK(4) = Starting location of JU in IWORK. ! IWORK(5) = Starting location of L in RWORK. ! IWORK(6) = Starting location of DINV in RWORK. ! IWORK(7) = Starting location of U in RWORK. ! See the DESCRIPTION of SSLUI4 for details. !***REFERENCES (NONE) !***ROUTINES CALLED SSLUI4 !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSLUTI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(N), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU ! .. External Subroutines .. EXTERNAL SSLUI4 !***FIRST EXECUTABLE STATEMENT SSLUTI ! ! Pull out the pointers to the L, D and U matrices and call ! the workhorse routine. ! LOCIL = IWORK(1) LOCJL = IWORK(2) LOCIU = IWORK(3) LOCJU = IWORK(4) LOCL = IWORK(5) LOCDIN = IWORK(6) LOCU = IWORK(7) ! call SSLUI4(N, B, X, IWORK(LOCIL), IWORK(LOCJL), RWORK(LOCL), & RWORK(LOCDIN), IWORK(LOCIU), IWORK(LOCJU), RWORK(LOCU)) ! return !------------- LAST LINE OF SSLUTI FOLLOWS ---------------------------- end subroutine SSMMI2 (N, B, X, IL, JL, L, DINV, IU, JU, U) ! !! SSMMI2 is the SLAP Backsolve for LDU Factorization of Normal Equations. ! ! To solve a system of the form (L*D*U)*(L*D*U)' X = B, ! where L is a unit lower triangular matrix, D is a diagonal ! matrix, and U is a unit upper triangular matrix and ' ! denotes transpose. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSMMI2-S, DSMMI2-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, IL(NL), JL(NL), IU(NU), JU(NU) ! REAL B(N), X(N), L(NL), DINV(N), U(NU) ! ! call SSMMI2( N, B, X, IL, JL, L, DINV, IU, JU, U ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! B :IN Real B(N). ! Right hand side. ! X :OUT Real X(N). ! Solution of (L*D*U)(L*D*U)trans x = b. ! IL :IN Integer IL(NL). ! JL :IN Integer JL(NL). ! L :IN Real L(NL). ! IL, JL, L contain the unit lower triangular factor of the ! incomplete decomposition of some matrix stored in SLAP Row ! format. The diagonal of ones *IS* stored. This structure ! can be set up by the SSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NL is the number of non-zeros in the L array.) ! DINV :IN Real DINV(N). ! Inverse of the diagonal matrix D. ! IU :IN Integer IU(NU). ! JU :IN Integer JU(NU). ! U :IN Real U(NU). ! IU, JU, U contain the unit upper triangular factor of the ! incomplete decomposition of some matrix stored in SLAP ! Column format. The diagonal of ones *IS* stored. This ! structure can be set up by the SSILUS routine. See the ! "Description", below for more details about the SLAP ! format. (NU is the number of non-zeros in the U array.) ! ! *Description: ! This routine is supplied with the SLAP package as a routine ! to perform the MSOLVE operation in the SBCGN iteration ! routine for the driver SSLUCN. It must be called via the ! SLAP MSOLVE calling sequence convention interface routine ! SSMMTI. ! **** THIS ROUTINE ITSELF DOES NOT CONFORM TO THE **** ! **** SLAP MSOLVE CALLING CONVENTION **** ! ! IL, JL, L should contain the unit lower triangular factor of ! the incomplete decomposition of the A matrix stored in SLAP ! Row format. IU, JU, U should contain the unit upper factor ! of the incomplete decomposition of the A matrix stored in ! SLAP Column format This ILU factorization can be computed by ! the SSILUS routine. The diagonals (which are all one's) are ! stored. ! ! =================== S L A P Column format ================== ! ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! ==================== S L A P Row format ==================== ! ! This routine requires that the matrix A be stored in the ! SLAP Row format. In this format the non-zeros are stored ! counting across rows (except for the diagonal entry, which ! must appear first in each "row") and are stored in the real ! array A. In other words, for each row in the matrix put the ! diagonal entry in A. Then put in the other non-zero ! elements going across the row (except the diagonal) in ! order. The JA array holds the column index for each ! non-zero. The IA array holds the offsets into the JA, A ! arrays for the beginning of each row. That is, ! JA(IA(IROW)), A(IA(IROW)) points to the beginning of the ! IROW-th row in JA and A. JA(IA(IROW+1)-1), A(IA(IROW+1)-1) ! points to the end of the IROW-th row. Note that we always ! have IA(N+1) = NELT+1, where N is the number of rows in ! the matrix and NELT is the number of non-zeros in the ! matrix. ! ! Here is an example of the SLAP Row storage format for a 5x5 ! Matrix (in the A and JA arrays '|' denotes the end of a row): ! ! 5x5 Matrix SLAP Row format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 111215 | 2221 | 3335 | 44 | 555153 ! |2122 0 0 0| JA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| IA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format the "inner loops" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! !***SEE ALSO SSILUS !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSMMI2 ! .. Scalar Arguments .. INTEGER N ! .. Array Arguments .. REAL B(N), DINV(N), L(*), U(N), X(N) INTEGER IL(*), IU(*), JL(*), JU(*) ! .. Local Scalars .. INTEGER I, ICOL, IROW, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT SSMMI2 ! ! Solve L*Y = B, storing result in X, L stored by rows. ! DO 10 I = 1, N X(I) = B(I) 10 CONTINUE DO 30 IROW = 2, N JBGN = IL(IROW) JEND = IL(IROW+1)-1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ ASSOC !VD$ NODEPCHK DO 20 J = JBGN, JEND X(IROW) = X(IROW) - L(J)*X(JL(J)) 20 CONTINUE ENDIF 30 CONTINUE ! ! Solve D*Z = Y, storing result in X. DO 40 I=1,N X(I) = X(I)*DINV(I) 40 CONTINUE ! ! Solve U*X = Z, U stored by columns. DO 60 ICOL = N, 2, -1 JBGN = JU(ICOL) JEND = JU(ICOL+1)-1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 50 J = JBGN, JEND X(IU(J)) = X(IU(J)) - U(J)*X(ICOL) 50 CONTINUE ENDIF 60 CONTINUE ! ! Solve U'*Y = X, storing result in X, U stored by columns. DO 80 IROW = 2, N JBGN = JU(IROW) JEND = JU(IROW+1) - 1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ ASSOC !VD$ NODEPCHK DO 70 J = JBGN, JEND X(IROW) = X(IROW) - U(J)*X(IU(J)) 70 CONTINUE ENDIF 80 CONTINUE ! ! Solve D*Z = Y, storing result in X. DO 90 I = 1, N X(I) = X(I)*DINV(I) 90 CONTINUE ! ! Solve L'*X = Z, L stored by rows. DO 110 ICOL = N, 2, -1 JBGN = IL(ICOL) JEND = IL(ICOL+1) - 1 if ( JBGN <= JEND ) THEN !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 100 J = JBGN, JEND X(JL(J)) = X(JL(J)) - L(J)*X(ICOL) 100 CONTINUE ENDIF 110 CONTINUE ! return !------------- LAST LINE OF SSMMI2 FOLLOWS ---------------------------- end subroutine SSMMTI (N, B, X, NELT, IA, JA, A, ISYM, RWORK, IWORK) ! !! SSMMTI is the SLAP MSOLVE for LDU Factorization of Normal Equations. ! ! This routine acts as an interface between the SLAP generic ! MMTSLV calling convention and the routine that actually ! -1 ! computes [(LDU)*(LDU)'] B = X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2E !***TYPE SINGLE PRECISION (SSMMTI-S, DSMMTI-D) !***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM SOLVE, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! It is assumed that RWORK and IWORK have initialized with ! the information required for SSMMI2: ! IWORK(1) = Starting location of IL in IWORK. ! IWORK(2) = Starting location of JL in IWORK. ! IWORK(3) = Starting location of IU in IWORK. ! IWORK(4) = Starting location of JU in IWORK. ! IWORK(5) = Starting location of L in RWORK. ! IWORK(6) = Starting location of DINV in RWORK. ! IWORK(7) = Starting location of U in RWORK. ! See the DESCRIPTION of SSMMI2 for details. !***REFERENCES (NONE) !***ROUTINES CALLED SSMMI2 !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 921113 Corrected C***CATEGORY line. (FNF) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSMMTI ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(NELT), B(N), RWORK(*), X(N) INTEGER IA(NELT), IWORK(10), JA(NELT) ! .. Local Scalars .. INTEGER LOCDIN, LOCIL, LOCIU, LOCJL, LOCJU, LOCL, LOCU ! .. External Subroutines .. EXTERNAL SSMMI2 !***FIRST EXECUTABLE STATEMENT SSMMTI ! ! Pull out the locations of the arrays holding the ILU ! factorization. ! LOCIL = IWORK(1) LOCJL = IWORK(2) LOCIU = IWORK(3) LOCJU = IWORK(4) LOCL = IWORK(5) LOCDIN = IWORK(6) LOCU = IWORK(7) ! call SSMMI2(N, B, X, IWORK(LOCIL), IWORK(LOCJL), & RWORK(LOCL), RWORK(LOCDIN), IWORK(LOCIU), & IWORK(LOCJU), RWORK(LOCU)) ! return !------------- LAST LINE OF SSMMTI FOLLOWS ---------------------------- end subroutine SSMTV (N, X, Y, NELT, IA, JA, A, ISYM) ! !! SSMTV is the SLAP Column Format Sparse Matrix Transpose Vector Product. ! ! Routine to calculate the sparse matrix vector product: ! Y = A'*X, where ' denotes transpose. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SSMTV-S, DSMTV-D) !***KEYWORDS MATRIX TRANSPOSE VECTOR MULTIPLY, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! REAL X(N), Y(N), A(NELT) ! ! call SSMTV(N, X, Y, NELT, IA, JA, A, ISYM ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! X :IN Real X(N). ! The vector that should be multiplied by the transpose of ! the matrix. ! Y :OUT Real Y(N). ! The product of the transpose of the matrix and the vector. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format the "inner loops" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! ! *Cautions: ! This routine assumes that the matrix A is stored in SLAP ! Column format. It does not check for this (for speed) and ! evil, ugly, ornery and nasty things will happen if the matrix ! data structure is, in fact, not SLAP Column. Beware of the ! wrong data structure! ! !***SEE ALSO SSMV !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSMTV ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(NELT), X(N), Y(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER I, IBGN, ICOL, IEND, IROW, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT SSMTV ! ! Zero out the result vector. ! DO 10 I = 1, N Y(I) = 0 10 CONTINUE ! ! Multiply by A-Transpose. ! A-Transpose is stored by rows... !VD$R NOCONCUR DO 30 IROW = 1, N IBGN = JA(IROW) IEND = JA(IROW+1)-1 !VD$ ASSOC DO 20 I = IBGN, IEND Y(IROW) = Y(IROW) + A(I)*X(IA(I)) 20 CONTINUE 30 CONTINUE ! if ( ISYM == 1 ) THEN ! ! The matrix is non-symmetric. Need to get the other half in... ! This loops assumes that the diagonal is the first entry in ! each column. ! DO 50 ICOL = 1, N JBGN = JA(ICOL)+1 JEND = JA(ICOL+1)-1 if ( JBGN > JEND ) GOTO 50 !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 40 J = JBGN, JEND Y(IA(J)) = Y(IA(J)) + A(J)*X(ICOL) 40 CONTINUE 50 CONTINUE end if return !------------- LAST LINE OF SSMTV FOLLOWS ---------------------------- end subroutine SSMV (N, X, Y, NELT, IA, JA, A, ISYM) ! !! SSMV is the SLAP Column Format Sparse Matrix Vector Product. ! ! Routine to calculate the sparse matrix vector product: ! Y = A*X. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SSMV-S, DSMV-D) !***KEYWORDS MATRIX VECTOR MULTIPLY, SLAP, SPARSE !***AUTHOR Greenbaum, Anne, (Courant Institute) ! Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM ! REAL X(N), Y(N), A(NELT) ! ! call SSMV(N, X, Y, NELT, IA, JA, A, ISYM ) ! ! *Arguments: ! N :IN Integer. ! Order of the Matrix. ! X :IN Real X(N). ! The vector that should be multiplied by the matrix. ! Y :OUT Real Y(N). ! The product of the matrix and the vector. ! NELT :IN Integer. ! Number of Non-Zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in the SLAP Column ! format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the upper ! or lower triangle of the matrix is stored. ! ! *Description ! =================== S L A P Column format ================== ! This routine requires that the matrix A be stored in the ! SLAP Column format. In this format the non-zeros are stored ! counting down columns (except for the diagonal entry, which ! must appear first in each "column") and are stored in the ! real array A. In other words, for each column in the matrix ! put the diagonal entry in A. Then put in the other non-zero ! elements going down the column (except the diagonal) in ! order. The IA array holds the row index for each non-zero. ! The JA array holds the offsets into the IA, A arrays for the ! beginning of each column. That is, IA(JA(ICOL)), ! A(JA(ICOL)) points to the beginning of the ICOL-th column in ! IA and A. IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) points to the ! end of the ICOL-th column. Note that we always have ! JA(N+1) = NELT+1, where N is the number of columns in the ! matrix and NELT is the number of non-zeros in the matrix. ! ! Here is an example of the SLAP Column storage format for a ! 5x5 Matrix (in the A and IA arrays '|' denotes the end of a ! column): ! ! 5x5 Matrix SLAP Column format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 112151 | 2212 | 3353 | 44 | 551535 ! |2122 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 ! | 0 033 035| JA: 1 4 6 8 9 12 ! | 0 0 044 0| ! |51 053 055| ! ! With the SLAP format the "inner loops" of this routine ! should vectorize on machines with hardware support for ! vector gather/scatter operations. Your compiler may require ! a compiler directive to convince it that there are no ! implicit vector dependencies. Compiler directives for the ! Alliant FX/Fortran and CRI CFT/CFT77 compilers are supplied ! with the standard SLAP distribution. ! ! *Cautions: ! This routine assumes that the matrix A is stored in SLAP ! Column format. It does not check for this (for speed) and ! evil, ugly, ornery and nasty things will happen if the matrix ! data structure is, in fact, not SLAP Column. Beware of the ! wrong data structure! ! !***SEE ALSO SSMTV !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE SSMV ! .. Scalar Arguments .. INTEGER ISYM, N, NELT ! .. Array Arguments .. REAL A(NELT), X(N), Y(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER I, IBGN, ICOL, IEND, IROW, J, JBGN, JEND !***FIRST EXECUTABLE STATEMENT SSMV ! ! Zero out the result vector. ! DO 10 I = 1, N Y(I) = 0 10 CONTINUE ! ! Multiply by A. ! !VD$R NOCONCUR DO 30 ICOL = 1, N IBGN = JA(ICOL) IEND = JA(ICOL+1)-1 !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP !VD$ NODEPCHK DO 20 I = IBGN, IEND Y(IA(I)) = Y(IA(I)) + A(I)*X(ICOL) 20 CONTINUE 30 CONTINUE ! if ( ISYM == 1 ) THEN ! ! The matrix is non-symmetric. Need to get the other half in... ! This loops assumes that the diagonal is the first entry in ! each column. ! DO 50 IROW = 1, N JBGN = JA(IROW)+1 JEND = JA(IROW+1)-1 if ( JBGN > JEND ) GOTO 50 DO 40 J = JBGN, JEND Y(IROW) = Y(IROW) + A(J)*X(IA(J)) 40 CONTINUE 50 CONTINUE end if return !------------- LAST LINE OF SSMV FOLLOWS ---------------------------- end subroutine SSORT (X, Y, N, KFLAG) ! !! SSORT sorts an array and optionally make the same interchanges in ... ! an auxiliary array. The array may be sorted in increasing ! or decreasing order. A slightly modified QUICKSORT ! algorithm is used. ! !***LIBRARY SLATEC !***CATEGORY N6A2B !***TYPE SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I) !***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING !***AUTHOR Jones, R. E., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! SSORT sorts array X and optionally makes the same interchanges in ! array Y. The array X may be sorted in increasing order or ! decreasing order. A slightly modified quicksort algorithm is used. ! ! Description of Parameters ! X - array of values to be sorted (usually abscissas) ! Y - array to be (optionally) carried along ! N - number of values in array X to be sorted ! KFLAG - control parameter ! = 2 means sort X in increasing order and carry Y along. ! = 1 means sort X in increasing order (ignoring Y) ! = -1 means sort X in decreasing order (ignoring Y) ! = -2 means sort X in decreasing order and carry Y along. ! !***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm ! for sorting with minimal storage, Communications of ! the ACM, 12, 3 (1969), pp. 185-187. !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 761101 DATE WRITTEN ! 761118 Modified to use the Singleton quicksort algorithm. (JAW) ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced statement labels. (WRB) ! 891024 Changed category. (WRB) ! 891024 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 901012 Declared all variables; changed X,Y to SX,SY. (M. McClain) ! 920501 Reformatted the REFERENCES section. (DWL, WRB) ! 920519 Clarified error messages. (DWL) ! 920801 Declarations section rebuilt and code restructured to use ! IF-THEN-ELSE-ENDIF. (RWC, WRB) !***END PROLOGUE SSORT ! .. Scalar Arguments .. INTEGER KFLAG, N ! .. Array Arguments .. REAL X(*), Y(*) ! .. Local Scalars .. REAL R, T, TT, TTY, TY INTEGER I, IJ, J, K, KK, L, M, NN ! .. Local Arrays .. INTEGER IL(21), IU(21) ! .. External Subroutines .. EXTERNAL XERMSG ! .. Intrinsic Functions .. INTRINSIC ABS, INT !***FIRST EXECUTABLE STATEMENT SSORT NN = N if (NN < 1) THEN call XERMSG ('SLATEC', 'SSORT', & 'The number of values to be sorted is not positive.', 1, 1) return end if ! KK = ABS(KFLAG) if (KK /= 1 .AND. KK /= 2) THEN call XERMSG ('SLATEC', 'SSORT', & 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, & 1) return end if ! ! Alter array X to get decreasing order if needed ! if (KFLAG <= -1) THEN DO 10 I=1,NN X(I) = -X(I) 10 CONTINUE end if ! if (KK == 2) go to 100 ! ! Sort X only ! M = 1 I = 1 J = NN R = 0.375E0 ! 20 if (I == J) go to 60 if (R <= 0.5898437E0) THEN R = R+3.90625E-2 ELSE R = R-0.21875E0 end if ! 30 K = I ! ! Select a central element of the array and save it in location T ! IJ = I + INT((J-I)*R) T = X(IJ) ! ! If first element of array is greater than T, interchange with T ! if (X(I) > T) THEN X(IJ) = X(I) X(I) = T T = X(IJ) end if L = J ! ! If last element of array is less than than T, interchange with T ! if (X(J) < T) THEN X(IJ) = X(J) X(J) = T T = X(IJ) ! ! If first element of array is greater than T, interchange with T ! if (X(I) > T) THEN X(IJ) = X(I) X(I) = T T = X(IJ) ENDIF end if ! ! Find an element in the second half of the array which is smaller ! than T ! 40 L = L-1 if (X(L) > T) go to 40 ! ! Find an element in the first half of the array which is greater ! than T ! 50 K = K+1 if (X(K) < T) go to 50 ! ! Interchange these elements ! if (K <= L) THEN TT = X(L) X(L) = X(K) X(K) = TT go to 40 end if ! ! Save upper and lower subscripts of the array yet to be sorted ! if (L-I > J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 70 ! ! Begin again on another portion of the unsorted array ! 60 M = M-1 if (M == 0) go to 190 I = IL(M) J = IU(M) ! 70 if (J-I >= 1) go to 30 if (I == 1) go to 20 I = I-1 ! 80 I = I+1 if (I == J) go to 60 T = X(I+1) if (X(I) <= T) go to 80 K = I ! 90 X(K+1) = X(K) K = K-1 if (T < X(K)) go to 90 X(K+1) = T go to 80 ! ! Sort X and carry Y along ! 100 M = 1 I = 1 J = NN R = 0.375E0 ! 110 if (I == J) go to 150 if (R <= 0.5898437E0) THEN R = R+3.90625E-2 ELSE R = R-0.21875E0 end if ! 120 K = I ! ! Select a central element of the array and save it in location T ! IJ = I + INT((J-I)*R) T = X(IJ) TY = Y(IJ) ! ! If first element of array is greater than T, interchange with T ! if (X(I) > T) THEN X(IJ) = X(I) X(I) = T T = X(IJ) Y(IJ) = Y(I) Y(I) = TY TY = Y(IJ) end if L = J ! ! If last element of array is less than T, interchange with T ! if (X(J) < T) THEN X(IJ) = X(J) X(J) = T T = X(IJ) Y(IJ) = Y(J) Y(J) = TY TY = Y(IJ) ! ! If first element of array is greater than T, interchange with T ! if (X(I) > T) THEN X(IJ) = X(I) X(I) = T T = X(IJ) Y(IJ) = Y(I) Y(I) = TY TY = Y(IJ) ENDIF end if ! ! Find an element in the second half of the array which is smaller ! than T ! 130 L = L-1 if (X(L) > T) go to 130 ! ! Find an element in the first half of the array which is greater ! than T ! 140 K = K+1 if (X(K) < T) go to 140 ! ! Interchange these elements ! if (K <= L) THEN TT = X(L) X(L) = X(K) X(K) = TT TTY = Y(L) Y(L) = Y(K) Y(K) = TTY go to 130 end if ! ! Save upper and lower subscripts of the array yet to be sorted ! if (L-I > J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 end if go to 160 ! ! Begin again on another portion of the unsorted array ! 150 M = M-1 if (M == 0) go to 190 I = IL(M) J = IU(M) ! 160 if (J-I >= 1) go to 120 if (I == 1) go to 110 I = I-1 ! 170 I = I+1 if (I == J) go to 150 T = X(I+1) TY = Y(I+1) if (X(I) <= T) go to 170 K = I ! 180 X(K+1) = X(K) Y(K+1) = Y(K) K = K-1 if (T < X(K)) go to 180 X(K+1) = T Y(K+1) = TY go to 170 ! ! Clean up ! 190 if (KFLAG <= -1) THEN DO 200 I=1,NN X(I) = -X(I) 200 CONTINUE end if return end subroutine SSPCO (AP, N, KPVT, RCOND, Z) ! !! SSPCO factors a real symmetric matrix stored in packed form ... ! by elimination with symmetric pivoting and estimate the ! condition number of the matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE SINGLE PRECISION (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! MATRIX FACTORIZATION, PACKED, SYMMETRIC !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! SSPCO factors a real symmetric matrix stored in packed ! form by elimination with symmetric pivoting and estimates ! the condition of the matrix. ! ! If RCOND is not needed, SSPFA is slightly faster. ! To solve A*X = B , follow SSPCO by SSPSL. ! To compute INVERSE(A)*C , follow SSPCO by SSPSL. ! To compute INVERSE(A) , follow SSPCO by SSPDI. ! To compute DETERMINANT(A) , follow SSPCO by SSPDI. ! To compute INERTIA(A), follow SSPCO by SSPDI. ! ! On Entry ! ! AP REAL (N*(N+1)/2) ! the packed form of a symmetric matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! Output ! ! AP a block diagonal matrix and the multipliers which ! were used to obtain it stored in packed form. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KPVT INTEGER(N) ! an integer vector of pivot indices. ! ! RCOND REAL ! an estimate of the reciprocal condition of A . ! For the system A*X = B , relative perturbations ! in A and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then A may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z REAL(N) ! a work vector whose contents are usually unimportant. ! If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a symmetric matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SASUM, SAXPY, SDOT, SSCAL, SSPFA !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSPCO INTEGER N,KPVT(*) REAL AP(*),Z(*) REAL RCOND ! 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 ! ! FIND NORM OF A USING ONLY UPPER HALF ! !***FIRST EXECUTABLE STATEMENT SSPCO J1 = 1 DO 30 J = 1, N Z(J) = SASUM(J,AP(J1),1) IJ = J1 J1 = J1 + J JM1 = J - 1 if (JM1 < 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 = MAX(ANORM,Z(J)) 40 CONTINUE ! ! FACTOR ! call SSPFA(AP,N,KPVT,INFO) ! ! RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE U*D*W = E ! EK = 1.0E0 DO 50 J = 1, N Z(J) = 0.0E0 50 CONTINUE K = N IK = (N*(N - 1))/2 60 if (K == 0) go to 120 KK = IK + K IKM1 = IK - (K - 1) KS = 1 if (KPVT(K) < 0) KS = 2 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == KPS) go to 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE if (Z(K) /= 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 == 1) go to 80 if (Z(K-1) /= 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 == 2) go to 100 if (ABS(Z(K)) <= 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) /= 0.0E0) Z(K) = Z(K)/AP(KK) if (AP(KK) == 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 == 2) IK = IK - (K + 1) go to 60 120 CONTINUE S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) ! ! SOLVE TRANS(U)*Y = W ! K = 1 IK = 0 130 if (K > N) go to 160 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 150 Z(K) = Z(K) + SDOT(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K if (KS == 2) & Z(K+1) = Z(K+1) + SDOT(K-1,AP(IKP1+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE IK = IK + K if (KS == 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) ! YNORM = 1.0E0 ! ! SOLVE U*D*V = Y ! K = N IK = N*(N - 1)/2 170 if (K == 0) go to 230 KK = IK + K IKM1 = IK - (K - 1) KS = 1 if (KPVT(K) < 0) KS = 2 if (K == KS) go to 190 KP = ABS(KPVT(K)) KPS = K + 1 - KS if (KP == 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 == 2) call SAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) 190 CONTINUE if (KS == 2) go to 210 if (ABS(Z(K)) <= 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) /= 0.0E0) Z(K) = Z(K)/AP(KK) if (AP(KK) == 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 == 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 ! ! SOLVE TRANS(U)*Z = V ! K = 1 IK = 0 240 if (K > N) go to 270 KS = 1 if (KPVT(K) < 0) KS = 2 if (K == 1) go to 260 Z(K) = Z(K) + SDOT(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K if (KS == 2) & Z(K+1) = Z(K+1) + SDOT(K-1,AP(IKP1+1),1,Z(1),1) KP = ABS(KPVT(K)) if (KP == K) go to 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE IK = IK + K if (KS == 2) IK = IK + (K + 1) K = K + KS go to 240 270 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! if (ANORM /= 0.0E0) RCOND = YNORM/ANORM if (ANORM == 0.0E0) RCOND = 0.0E0 return end subroutine SSPDI (AP, N, KPVT, DET, INERT, WORK, JOB) ! !! SSPDI computes the determinant, inertia, inverse of a real symmetric ... ! matrix stored in packed form using the factors from SSPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A, D3B1A !***TYPE SINGLE PRECISION (SSPDI-S, DSPDI-D, CHPDI-C, CSPDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! PACKED, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! SSPDI computes the determinant, inertia and inverse ! of a real symmetric matrix using the factors from SSPFA, ! where the matrix is stored in packed form. ! ! On Entry ! ! AP REAL (N*(N+1)/2) ! the output from SSPFA. ! ! N INTEGER ! the order of the matrix A. ! ! KPVT INTEGER(N) ! the pivot vector from SSPFA. ! ! WORK REAL(N) ! work vector. Contents ignored. ! ! JOB INTEGER ! JOB has the decimal expansion ABC where ! If C /= 0, the inverse is computed, ! If B /= 0, the determinant is computed, ! If A /= 0, the inertia is computed. ! ! For example, JOB = 111 gives all three. ! ! On Return ! ! Variables not requested by JOB are not used. ! ! AP contains the upper triangle of the inverse of ! the original matrix, stored in packed form. ! The columns of the upper triangle are stored ! sequentially in a one-dimensional array. ! ! DET REAL(2) ! determinant of original matrix. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) = 0.0. ! ! INERT INTEGER(3) ! the inertia of the original matrix. ! INERT(1) = number of positive eigenvalues. ! INERT(2) = number of negative eigenvalues. ! INERT(3) = number of zero eigenvalues. ! ! Error Condition ! ! A division by zero will occur if the inverse is requested ! and SSPCO has set RCOND == 0.0 ! or SSPFA has set INFO /= 0 . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SCOPY, SDOT, SSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSPDI INTEGER N,JOB REAL AP(*),WORK(*) REAL DET(2) INTEGER KPVT(*),INERT(3) ! 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 !***FIRST EXECUTABLE STATEMENT SSPDI NOINV = MOD(JOB,10) == 0 NODET = MOD(JOB,100)/10 == 0 NOERT = MOD(JOB,1000)/100 == 0 ! 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) ! ! CHECK if 1 BY 1 ! if (KPVT(K) > 0) go to 50 ! ! 2 BY 2 BLOCK ! USE DET (D S) = (D/T * C - T) * T , T = ABS(S) ! (S C) ! TO AVOID UNDERFLOW/OVERFLOW TROUBLES. ! TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. ! if (T /= 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 ! if (NOERT) go to 60 if (D > 0.0E0) INERT(1) = INERT(1) + 1 if (D < 0.0E0) INERT(2) = INERT(2) + 1 if (D == 0.0E0) INERT(3) = INERT(3) + 1 60 CONTINUE ! if (NODET) go to 120 DET(1) = D*DET(1) if (DET(1) == 0.0E0) go to 110 70 if (ABS(DET(1)) >= 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)) < 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 ! ! COMPUTE INVERSE(A) ! if (NOINV) go to 270 K = 1 IK = 0 150 if (K > N) go to 260 KM1 = K - 1 KK = IK + K IKP1 = IK + K KKP1 = IKP1 + K if (KPVT(K) < 0) go to 180 ! ! 1 BY 1 ! AP(KK) = 1.0E0/AP(KK) if (KM1 < 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 ! ! 2 BY 2 ! 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 < 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 ! ! SWAP ! KS = ABS(KPVT(K)) if (KS == 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 == 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 == 2) IK = IK + K + 1 K = K + KSTEP go to 150 260 CONTINUE 270 CONTINUE return end subroutine SSPEV (A, N, E, V, LDV, WORK, JOB, INFO) ! !! SSPEV computes eigenvalues and eigenvectors of a real symmetric matrix ... ! stored in packed form. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A1 !***TYPE SINGLE PRECISION (SSPEV-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK, PACKED, SYMMETRIC !***AUTHOR Kahaner, D. K., (NBS) ! Moler, C. B., (U. of New Mexico) ! Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! Abstract ! SSPEV computes the eigenvalues and, optionally, the eigenvectors ! of a real symmetric matrix stored in packed form. ! ! Call Sequence Parameters- ! (The values of parameters marked with * (star) will be changed ! by SSPEV.) ! ! A* REAL(N*(N+1)/2) ! real symmetric packed input matrix. Contains upper ! triangle and diagonal of A, by column (elements ! 11, 12, 22, 13, 23, 33, ...). ! ! N INTEGER ! set by the user to ! the order of the matrix A. ! ! E* REAL(N) ! on return from SSPEV, E contains the eigenvalues of A. ! See also INFO below. ! ! V* REAL(LDV,N) ! on return from SSPEV, if the user has set JOB ! = 0 V is not referenced. ! = nonzero the N eigenvectors of A are stored in the ! first N columns of V. See also INFO below. ! ! LDV INTEGER ! set by the user to ! the leading dimension of the array V if JOB is also ! set nonzero. In that case, N must be <= LDV. ! If JOB is set to zero, LDV is not referenced. ! ! WORK* REAL(2N) ! temporary storage vector. Contents changed by SSPEV. ! ! JOB INTEGER ! set by the user to ! = 0 eigenvalues only to be calculated by SSPEV. ! Neither V nor LDV are referenced. ! = nonzero eigenvalues and vectors to be calculated. ! In this case, A & V must be distinct arrays. ! Also, if LDA > LDV, SSPEV changes all the ! elements of A thru column N. If LDA < LDV, ! SSPEV changes all the elements of V through ! column N. If LDA=LDV, only A(I,J) and V(I, ! J) for I,J = 1,...,N are changed by SSPEV. ! ! INFO* INTEGER ! on return from SSPEV, the value of INFO is ! = 0 for normal return. ! = K if the eigenvalue iteration fails to converge. ! Eigenvalues and vectors 1 through K-1 are correct. ! ! ! Error Messages- ! No. 1 recoverable N is greater than LDV and JOB is nonzero ! No. 2 recoverable N is less than one ! !***REFERENCES (NONE) !***ROUTINES CALLED IMTQL2, TQLRAT, TRBAK3, TRED3, XERMSG !***REVISION HISTORY (YYMMDD) ! 800808 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) !***END PROLOGUE SSPEV INTEGER I,INFO,J,LDV,M,N REAL A(*),E(*),V(LDV,*),WORK(*) !***FIRST EXECUTABLE STATEMENT SSPEV if (N > LDV) call XERMSG ('SLATEC', 'SSPEV', 'N > LDV.', & 1, 1) if ( N > LDV) RETURN if (N < 1) call XERMSG ('SLATEC', 'SSPEV', 'N < 1', 2, 1) if ( N < 1) RETURN ! ! CHECK N=1 CASE ! E(1) = A(1) INFO = 0 if ( N == 1) RETURN ! if ( JOB /= 0) go to 20 ! ! EIGENVALUES ONLY ! call TRED3(N,1,A,E,WORK(1),WORK(N+1)) call TQLRAT(N,E,WORK(N+1),INFO) return ! ! EIGENVALUES AND EIGENVECTORS ! 20 call TRED3(N,1,A,E,WORK(1),WORK(1)) DO 30 I = 1, N DO 25 J = 1, N 25 V(I,J) = 0. 30 V(I,I) = 1. call IMTQL2(LDV,N,E,WORK,V,INFO) M = N if ( INFO /= 0) M = INFO - 1 call TRBAK3(LDV,N,1,A,M,V) return end subroutine SSPFA (AP, N, KPVT, INFO) ! !! SSPFA factors a real symmetric matrix stored in packed form by ... ! elimination with symmetric pivoting. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE SINGLE PRECISION (SSPFA-S, DSPFA-D, CHPFA-C, CSPFA-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED, ! SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! SSPFA factors a real symmetric matrix stored in ! packed form by elimination with symmetric pivoting. ! ! To solve A*X = B , follow SSPFA by SSPSL. ! To compute INVERSE(A)*C , follow SSPFA by SSPSL. ! To compute DETERMINANT(A) , follow SSPFA by SSPDI. ! To compute INERTIA(A) , follow SSPFA by SSPDI. ! To compute INVERSE(A) , follow SSPFA by SSPDI. ! ! On Entry ! ! AP REAL (N*(N+1)/2) ! the packed form of a symmetric matrix A . The ! columns of the upper triangle are stored sequentially ! in a one-dimensional array of length N*(N+1)/2 . ! See comments below for details. ! ! N INTEGER ! the order of the matrix A . ! ! Output ! ! AP a block diagonal matrix and the multipliers which ! were used to obtain it stored in packed form. ! The factorization can be written A = U*D*TRANS(U) ! where U is a product of permutation and unit ! upper triangular matrices , TRANS(U) is the ! transpose of U , and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! KPVT INTEGER(N) ! an integer vector of pivot indices. ! ! INFO INTEGER ! = 0 normal value. ! = K if the K-th pivot block is singular. This is ! not an error condition for this subroutine, ! but it does indicate that SSPSL or SSPDI may ! divide by zero if called. ! ! Packed Storage ! ! The following program segment will pack the upper ! triangle of a symmetric matrix. ! ! K = 0 ! DO 20 J = 1, N ! DO 10 I = 1, J ! K = K + 1 ! AP(K) = A(I,J) ! 10 CONTINUE ! 20 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED ISAMAX, SAXPY, SSWAP !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSPFA INTEGER N,KPVT(*),INFO REAL AP(*) ! REAL AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T REAL ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER ISAMAX,IJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP LOGICAL SWAP !***FIRST EXECUTABLE STATEMENT SSPFA ! ! INITIALIZE ! ! ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ! ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 ! INFO = 0 ! ! MAIN LOOP ON K, WHICH GOES FROM N TO 1. ! K = N IK = (N*(N - 1))/2 10 CONTINUE ! ! LEAVE THE LOOP if K=0 OR K=1. ! if (K == 0) go to 200 if (K > 1) go to 20 KPVT(1) = 1 if (AP(1) == 0.0E0) INFO = 1 go to 200 20 CONTINUE ! ! THIS SECTION OF CODE DETERMINES THE KIND OF ! ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, ! KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND ! SWAP WILL BE SET TO .TRUE. if AN INTERCHANGE IS ! REQUIRED. ! KM1 = K - 1 KK = IK + K ABSAKK = ABS(AP(KK)) ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! COLUMN K. ! IMAX = ISAMAX(K-1,AP(IK+1),1) IMK = IK + IMAX COLMAX = ABS(AP(IMK)) if (ABSAKK < ALPHA*COLMAX) go to 30 KSTEP = 1 SWAP = .FALSE. go to 90 30 CONTINUE ! ! DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN ! ROW IMAX. ! ROWMAX = 0.0E0 IMAXP1 = IMAX + 1 IM = IMAX*(IMAX - 1)/2 IMJ = IM + 2*IMAX DO 40 J = IMAXP1, K ROWMAX = MAX(ROWMAX,ABS(AP(IMJ))) IMJ = IMJ + J 40 CONTINUE if (IMAX == 1) go to 50 JMAX = ISAMAX(IMAX-1,AP(IM+1),1) JMIM = JMAX + IM ROWMAX = MAX(ROWMAX,ABS(AP(JMIM))) 50 CONTINUE IMIM = IMAX + IM if (ABS(AP(IMIM)) < ALPHA*ROWMAX) go to 60 KSTEP = 1 SWAP = .TRUE. go to 80 60 CONTINUE if (ABSAKK < ALPHA*COLMAX*(COLMAX/ROWMAX)) go to 70 KSTEP = 1 SWAP = .FALSE. go to 80 70 CONTINUE KSTEP = 2 SWAP = IMAX /= KM1 80 CONTINUE 90 CONTINUE if (MAX(ABSAKK,COLMAX) /= 0.0E0) go to 100 ! ! COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. ! KPVT(K) = K INFO = K go to 190 100 CONTINUE if (KSTEP == 2) go to 140 ! ! 1 X 1 PIVOT BLOCK. ! if (.NOT.SWAP) go to 120 ! ! PERFORM AN INTERCHANGE. ! 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 ! ! PERFORM THE ELIMINATION. ! 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) AP(JK) = MULK IJ = IJ - (J - 1) 130 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = K if (SWAP) KPVT(K) = IMAX go to 190 140 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! KM1K = IK + K - 1 IKM1 = IK - (K - 1) if (.NOT.SWAP) go to 160 ! ! PERFORM AN INTERCHANGE. ! 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 ! ! PERFORM THE ELIMINATION. ! KM2 = K - 2 if (KM2 == 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 IJ = IJ - (J - 1) 170 CONTINUE 180 CONTINUE ! ! SET THE PIVOT ARRAY. ! KPVT(K) = 1 - K if (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE IK = IK - (K - 1) if (KSTEP == 2) IK = IK - (K - 2) K = K - KSTEP go to 10 200 CONTINUE return end subroutine SSPMV (UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY) ! !! SSPMV performs the matrix-vector operation y = alpha*A*x + beta*y. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SSPMV-S, DSPMV-D, CSPMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! SSPMV performs the matrix-vector operation ! ! y := alpha*A*x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! A is an n by n symmetric matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the matrix A is supplied in the packed ! array AP as follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! supplied in AP. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! supplied in AP. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! AP - REAL array of DIMENSION at least ! ( ( n*( n + 1))/2). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. On exit, Y is overwritten by the updated ! vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SSPMV ! .. Scalar Arguments .. REAL ALPHA, BETA INTEGER INCX, INCY, N CHARACTER*1 UPLO ! .. Array Arguments .. REAL AP( * ), X( * ), Y( * ) ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA !***FIRST EXECUTABLE STATEMENT SSPMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 6 ELSE if ( INCY == 0 )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'SSPMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set up the start points in X and Y. ! if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return KK = 1 if ( LSAME( UPLO, 'U' ) )THEN ! ! Form y when AP contains the upper triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO K = KK DO 50, I = 1, J - 1 Y( I ) = Y( I ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( I ) K = K + 1 50 CONTINUE Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 KK = KK + J 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY DO 70, K = KK, KK + J - 2 Y( IY ) = Y( IY ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY KK = KK + J 80 CONTINUE end if ELSE ! ! Form y when AP contains the lower triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*AP( KK ) K = KK + 1 DO 90, I = J + 1, N Y( I ) = Y( I ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( I ) K = K + 1 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 KK = KK + ( N - J + 1 ) 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*AP( KK ) IX = JX IY = JY DO 110, K = KK + 1, KK + N - J IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY KK = KK + ( N - J + 1 ) 120 CONTINUE end if end if ! return ! ! End of SSPMV . ! end subroutine SSPR2 (UPLO, N, ALPHA, X, INCX, Y, INCY, AP) ! !! SSPR2 performs the symmetric rank 2 operation A = A + alpha*(x*y'+y*x') !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SSPR2-S, DSPR2-D, CSPR2-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! SSPR2 performs the symmetric rank 2 operation ! ! A := alpha*x*y' + alpha*y*x' + A, ! ! where alpha is a scalar, x and y are n element vectors and A is an ! n by n symmetric matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the matrix A is supplied in the packed ! array AP as follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! supplied in AP. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! supplied in AP. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! Y - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. ! Unchanged on exit. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! ! AP - REAL array of DIMENSION at least ! ( ( n*( n + 1 ) )/2 ). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. On exit, the array ! AP is overwritten by the upper triangular part of the ! updated matrix. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. On exit, the array ! AP is overwritten by the lower triangular part of the ! updated matrix. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SSPR2 ! .. Scalar Arguments .. REAL ALPHA INTEGER INCX, INCY, N CHARACTER*1 UPLO ! .. Array Arguments .. REAL AP( * ), X( * ), Y( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA !***FIRST EXECUTABLE STATEMENT SSPR2 ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( INCY == 0 )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'SSPR2 ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ( ( INCX /= 1 ).OR.( INCY /= 1 ) )THEN if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if JX = KX JY = KY end if ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! KK = 1 if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when upper triangle is stored in AP. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 20, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) K = KK DO 10, I = 1, J AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 K = K + 1 10 CONTINUE end if KK = KK + J 20 CONTINUE ELSE DO 40, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = KX IY = KY DO 30, K = KK, KK + J - 1 AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE end if JX = JX + INCX JY = JY + INCY KK = KK + J 40 CONTINUE end if ELSE ! ! Form A when lower triangle is stored in AP. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) K = KK DO 50, I = J, N AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 K = K + 1 50 CONTINUE end if KK = KK + N - J + 1 60 CONTINUE ELSE DO 80, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = JX IY = JY DO 70, K = KK, KK + N - J AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 70 CONTINUE end if JX = JX + INCX JY = JY + INCY KK = KK + N - J + 1 80 CONTINUE end if end if ! return ! ! End of SSPR2 . ! end subroutine SSPR (UPLO, N, ALPHA, X, INCX, AP) ! !! SSPR performs the symmetric rank 1 operation A = A + alpha*x*x'. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SSPR-S) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! SSPR performs the symmetric rank 1 operation ! ! A := alpha*x*x' + A, ! ! where alpha is a real scalar, x is an n element vector and A is an ! n by n symmetric matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the matrix A is supplied in the packed ! array AP as follows: ! ! UPLO = 'U' or 'u' The upper triangular part of A is ! supplied in AP. ! ! UPLO = 'L' or 'l' The lower triangular part of A is ! supplied in AP. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! AP - REAL array of DIMENSION at least ! ( ( n*( n + 1 ) )/2 ). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. On exit, the array ! AP is overwritten by the upper triangular part of the ! updated matrix. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular part of the symmetric matrix ! packed sequentially, column by column, so that AP( 1 ) ! contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. On exit, the array ! AP is overwritten by the lower triangular part of the ! updated matrix. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SSPR ! .. Scalar Arguments .. REAL ALPHA INTEGER INCX, N CHARACTER*1 UPLO ! .. Array Arguments .. REAL AP( * ), X( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA !***FIRST EXECUTABLE STATEMENT SSPR ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 end if if ( INFO /= 0 )THEN call XERBLA( 'SSPR ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Set the start point in X if the increment is not unity. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of the array AP ! are accessed sequentially with one pass through AP. ! KK = 1 if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when upper triangle is stored in AP. ! if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*X( J ) K = KK DO 10, I = 1, J AP( K ) = AP( K ) + X( I )*TEMP K = K + 1 10 CONTINUE end if KK = KK + J 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IX = KX DO 30, K = KK, KK + J - 1 AP( K ) = AP( K ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE end if JX = JX + INCX KK = KK + J 40 CONTINUE end if ELSE ! ! Form A when lower triangle is stored in AP. ! if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*X( J ) K = KK DO 50, I = J, N AP( K ) = AP( K ) + X( I )*TEMP K = K + 1 50 CONTINUE end if KK = KK + N - J + 1 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IX = JX DO 70, K = KK, KK + N - J AP( K ) = AP( K ) + X( IX )*TEMP IX = IX + INCX 70 CONTINUE end if JX = JX + INCX KK = KK + N - J + 1 80 CONTINUE end if end if ! return ! ! End of SSPR . ! end subroutine SSPSL (AP, N, KPVT, B) ! !! SSPSL solves a real symmetric system using the factors obtained from SSPFA. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2B1A !***TYPE SINGLE PRECISION (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE, SYMMETRIC !***AUTHOR Bunch, J., (UCSD) !***DESCRIPTION ! ! SSISL solves the real symmetric system ! A * X = B ! using the factors computed by SSPFA. ! ! On Entry ! ! AP REAL(N*(N+1)/2) ! the output from SSPFA. ! ! N INTEGER ! the order of the matrix A . ! ! KPVT INTEGER(N) ! the pivot vector from SSPFA. ! ! B REAL(N) ! the right hand side vector. ! ! On Return ! ! B the solution vector X . ! ! Error Condition ! ! A division by zero may occur if SSPCO has set RCOND == 0.0 ! or SSPFA has set INFO /= 0 . ! ! To compute INVERSE(A) * C where C is a matrix ! with P columns ! call SSPFA(AP,N,KPVT,INFO) ! if (INFO /= 0) go to ... ! DO 10 J = 1, P ! call SSPSL(AP,N,KPVT,C(1,J)) ! 10 CONTINUE ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891107 Modified routine equivalence list. (WRB) ! 891107 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSPSL INTEGER N,KPVT(*) REAL AP(*),B(*) ! REAL AK,AKM1,BK,BKM1,SDOT,DENOM,TEMP INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP ! ! LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND ! D INVERSE TO B. ! !***FIRST EXECUTABLE STATEMENT SSPSL K = N IK = (N*(N - 1))/2 10 if (K == 0) go to 80 KK = IK + K if (KPVT(K) < 0) go to 40 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 30 KP = KPVT(K) if (KP == K) go to 20 ! ! INTERCHANGE. ! TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE ! ! APPLY THE TRANSFORMATION. ! call SAXPY(K-1,B(K),AP(IK+1),1,B(1),1) 30 CONTINUE ! ! APPLY D INVERSE. ! B(K) = B(K)/AP(KK) K = K - 1 IK = IK - K go to 70 40 CONTINUE ! ! 2 X 2 PIVOT BLOCK. ! IKM1 = IK - (K - 1) if (K == 2) go to 60 KP = ABS(KPVT(K)) if (KP == K - 1) go to 50 ! ! INTERCHANGE. ! TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE ! ! APPLY THE TRANSFORMATION. ! 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 ! ! APPLY D INVERSE. ! 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 ! ! LOOP FORWARD APPLYING THE TRANSFORMATIONS. ! K = 1 IK = 0 90 if (K > N) go to 160 if (KPVT(K) < 0) go to 120 ! ! 1 X 1 PIVOT BLOCK. ! if (K == 1) go to 110 ! ! APPLY THE TRANSFORMATION. ! B(K) = B(K) + SDOT(K-1,AP(IK+1),1,B(1),1) KP = KPVT(K) if (KP == K) go to 100 ! ! INTERCHANGE. ! 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 ! ! 2 X 2 PIVOT BLOCK. ! if (K == 1) go to 140 ! ! APPLY THE TRANSFORMATION. ! 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 = ABS(KPVT(K)) if (KP == K) go to 130 ! ! INTERCHANGE. ! 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 SSVDC (X, LDX, N, P, S, E, U, LDU, V, LDV, WORK, JOB, & INFO) ! !! SSVDC performs the singular value decomposition of a rectangular matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D6 !***TYPE SINGLE PRECISION (SSVDC-S, DSVDC-D, CSVDC-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, ! SINGULAR VALUE DECOMPOSITION !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! SSVDC is a subroutine to reduce a real NxP matrix X by orthogonal ! transformations U and V to diagonal form. The elements S(I) are ! the singular values of X. The columns of U are the corresponding ! left singular vectors, and the columns of V the right singular ! vectors. ! ! On Entry ! ! X REAL(LDX,P), where LDX >= N. ! X contains the matrix whose singular value ! decomposition is to be computed. X is ! destroyed by SSVDC. ! ! LDX INTEGER ! LDX is the leading dimension of the array X. ! ! N INTEGER ! N is the number of rows of the matrix X. ! ! P INTEGER ! P is the number of columns of the matrix X. ! ! LDU INTEGER ! LDU is the leading dimension of the array U. ! (See below). ! ! LDV INTEGER ! LDV is the leading dimension of the array V. ! (See below). ! ! WORK REAL(N) ! work is a scratch array. ! ! JOB INTEGER ! JOB controls the computation of the singular ! vectors. It has the decimal expansion AB ! with the following meaning ! ! A == 0 Do not compute the left singular ! vectors. ! A == 1 Return the N left singular vectors ! in U. ! A >= 2 Return the first MIN(N,P) singular ! vectors in U. ! B == 0 Do not compute the right singular ! vectors. ! B == 1 Return the right singular vectors ! in V. ! ! On Return ! ! S REAL(MM), where MM=MIN(N+1,P). ! The first MIN(N,P) entries of S contain the ! singular values of X arranged in descending ! order of magnitude. ! ! E REAL(P). ! E ordinarily contains zeros. However, see the ! discussion of INFO for exceptions. ! ! U REAL(LDU,K), where LDU >= N. If JOBA == 1, then ! K == N. If JOBA >= 2 , then ! K == MIN(N,P). ! U contains the matrix of right singular vectors. ! U is not referenced if JOBA == 0. If N <= P ! or if JOBA == 2, then U may be identified with X ! in the subroutine call. ! ! V REAL(LDV,P), where LDV >= P. ! V contains the matrix of right singular vectors. ! V is not referenced if JOB == 0. If P <= N, ! then V may be identified with X in the ! subroutine call. ! ! INFO INTEGER. ! the singular values (and their corresponding ! singular vectors) S(INFO+1),S(INFO+2),...,S(M) ! are correct (here M=MIN(N,P)). Thus if ! INFO == 0, all the singular values and their ! vectors are correct. In any event, the matrix ! B = TRANS(U)*X*V is the bidiagonal matrix ! with the elements of S on its diagonal and the ! elements of E on its super-diagonal (TRANS(U) ! is the transpose of U). Thus the singular ! values of X and B are the same. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT, SNRM2, SROT, SROTG, SSCAL, SSWAP !***REVISION HISTORY (YYMMDD) ! 790319 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSVDC INTEGER LDX,N,P,LDU,LDV,JOB,INFO REAL X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) ! ! 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 !***FIRST EXECUTABLE STATEMENT SSVDC ! ! SET THE MAXIMUM NUMBER OF ITERATIONS. ! MAXIT = 30 ! ! DETERMINE WHAT IS TO BE COMPUTED. ! WANTU = .FALSE. WANTV = .FALSE. JOBU = MOD(JOB,100)/10 NCU = N if (JOBU > 1) NCU = MIN(N,P) if (JOBU /= 0) WANTU = .TRUE. if (MOD(JOB,10) /= 0) WANTV = .TRUE. ! ! REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS ! IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. ! INFO = 0 NCT = MIN(N-1,P) NRT = MAX(0,MIN(P-2,N)) LU = MAX(NCT,NRT) if (LU < 1) go to 170 DO 160 L = 1, LU LP1 = L + 1 if (L > NCT) go to 20 ! ! COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND ! PLACE THE L-TH DIAGONAL IN S(L). ! S(L) = SNRM2(N-L+1,X(L,L),1) if (S(L) == 0.0E0) go to 10 if (X(L,L) /= 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 < LP1) go to 50 DO 40 J = LP1, P if (L > NCT) go to 30 if (S(L) == 0.0E0) go to 30 ! ! APPLY THE TRANSFORMATION. ! 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 ! ! PLACE THE L-TH ROW OF X INTO E FOR THE ! SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. ! E(J) = X(L,J) 40 CONTINUE 50 CONTINUE if (.NOT.WANTU .OR. L > NCT) go to 70 ! ! PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK ! MULTIPLICATION. ! DO 60 I = L, N U(I,L) = X(I,L) 60 CONTINUE 70 CONTINUE if (L > NRT) go to 150 ! ! COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE ! L-TH SUPER-DIAGONAL IN E(L). ! E(L) = SNRM2(P-L,E(LP1),1) if (E(L) == 0.0E0) go to 80 if (E(LP1) /= 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 > N .OR. E(L) == 0.0E0) go to 120 ! ! APPLY THE TRANSFORMATION. ! 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 ! ! PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT ! BACK MULTIPLICATION. ! DO 130 I = LP1, P V(I,L) = E(I) 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE ! ! SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. ! M = MIN(P,N+1) NCTP1 = NCT + 1 NRTP1 = NRT + 1 if (NCT < P) S(NCTP1) = X(NCTP1,NCTP1) if (N < M) S(M) = 0.0E0 if (NRTP1 < M) E(NRTP1) = X(NRTP1,M) E(M) = 0.0E0 ! ! if REQUIRED, GENERATE U. ! if (.NOT.WANTU) go to 300 if (NCU < 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 < 1) go to 290 DO 280 LL = 1, NCT L = NCT - LL + 1 if (S(L) == 0.0E0) go to 250 LP1 = L + 1 if (NCU < 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 < 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 ! ! if IT IS REQUIRED, GENERATE V. ! if (.NOT.WANTV) go to 350 DO 340 LL = 1, P L = P - LL + 1 LP1 = L + 1 if (L > NRT) go to 320 if (E(L) == 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 ! ! MAIN ITERATION LOOP FOR THE SINGULAR VALUES. ! MM = M ITER = 0 360 CONTINUE ! ! QUIT if ALL THE SINGULAR VALUES HAVE BEEN FOUND. ! if (M == 0) go to 620 ! ! if TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET ! FLAG AND RETURN. ! if (ITER < MAXIT) go to 370 INFO = M go to 620 370 CONTINUE ! ! THIS SECTION OF THE PROGRAM INSPECTS FOR ! NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON ! COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. ! ! KASE = 1 if S(M) AND E(L-1) ARE NEGLIGIBLE AND L < M ! KASE = 2 if S(L) IS NEGLIGIBLE AND L < M ! KASE = 3 if E(L-1) IS NEGLIGIBLE, L < M, AND ! S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). ! KASE = 4 if E(M-1) IS NEGLIGIBLE (CONVERGENCE). ! DO 390 LL = 1, M L = M - LL if (L == 0) go to 400 TEST = ABS(S(L)) + ABS(S(L+1)) ZTEST = TEST + ABS(E(L)) if (ZTEST /= TEST) go to 380 E(L) = 0.0E0 go to 400 380 CONTINUE 390 CONTINUE 400 CONTINUE if (L /= 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 if (LS == L) go to 440 TEST = 0.0E0 if (LS /= M) TEST = TEST + ABS(E(LS)) if (LS /= L + 1) TEST = TEST + ABS(E(LS-1)) ZTEST = TEST + ABS(S(LS)) if (ZTEST /= TEST) go to 420 S(LS) = 0.0E0 go to 440 420 CONTINUE 430 CONTINUE 440 CONTINUE if (LS /= L) go to 450 KASE = 3 go to 470 450 CONTINUE if (LS /= M) go to 460 KASE = 1 go to 470 460 CONTINUE KASE = 2 L = LS 470 CONTINUE 480 CONTINUE L = L + 1 ! ! PERFORM THE TASK INDICATED BY KASE. ! go to (490,520,540,570), KASE ! ! DEFLATE NEGLIGIBLE S(M). ! 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 == 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 ! ! SPLIT AT NEGLIGIBLE S(L). ! 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 ! ! PERFORM ONE QR STEP. ! 540 CONTINUE ! ! CALCULATE THE SHIFT. ! SCALE = MAX(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 == 0.0E0 .AND. C == 0.0E0) go to 550 SHIFT = SQRT(B**2+C) if (B < 0.0E0) SHIFT = -SHIFT SHIFT = C/(B + SHIFT) 550 CONTINUE F = (SL + SM)*(SL - SM) - SHIFT G = SL*EL ! ! CHASE ZEROS. ! MM1 = M - 1 DO 560 K = L, MM1 call SROTG(F,G,CS,SN) if (K /= 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 < 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 ! ! CONVERGENCE. ! 570 CONTINUE ! ! MAKE THE SINGULAR VALUE POSITIVE. ! if (S(L) >= 0.0E0) go to 580 S(L) = -S(L) if (WANTV) call SSCAL(P,-1.0E0,V(1,L),1) 580 CONTINUE ! ! ORDER THE SINGULAR VALUE. ! 590 if (L == MM) go to 600 if (S(L) >= S(L+1)) go to 600 T = S(L) S(L) = S(L+1) S(L+1) = T if (WANTV .AND. L < P) & call SSWAP(P,V(1,L),1,V(1,L+1),1) if (WANTU .AND. L < 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 SSWAP (N, SX, INCX, SY, INCY) ! !! SSWAP interchanges two vectors. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1A5 !***TYPE SINGLE PRECISION (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) !***KEYWORDS BLAS, INTERCHANGE, LINEAR ALGEBRA, VECTOR !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Kincaid, D. R., (U. of Texas) ! Krogh, F. T., (JPL) !***DESCRIPTION ! ! B L A S Subprogram ! Description of Parameters ! ! --Input-- ! N number of elements in input vector(s) ! SX single precision vector with N elements ! INCX storage spacing between elements of SX ! SY single precision vector with N elements ! INCY storage spacing between elements of SY ! ! --Output-- ! SX input vector SY (unchanged if N <= 0) ! SY input vector SX (unchanged if N <= 0) ! ! Interchange single precision SX and single precision SY. ! For I = 0 to N-1, interchange SX(LX+I*INCX) and SY(LY+I*INCY), ! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is ! defined in a similar way using INCY. ! !***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. ! Krogh, Basic linear algebra subprograms for Fortran ! usage, Algorithm No. 539, Transactions on Mathematical ! Software 5, 3 (September 1979), pp. 308-323. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 791001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Corrected definition of LX in DESCRIPTION. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SSWAP REAL SX(*), SY(*), STEMP1, STEMP2, STEMP3 !***FIRST EXECUTABLE STATEMENT SSWAP if (N <= 0) RETURN if (INCX == INCY) IF (INCX-1) 5,20,60 ! ! Code for unequal or nonpositive increments. ! 5 IX = 1 IY = 1 if (INCX < 0) IX = (-N+1)*INCX + 1 if (INCY < 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N STEMP1 = SX(IX) SX(IX) = SY(IY) SY(IY) = STEMP1 IX = IX + INCX IY = IY + INCY 10 CONTINUE return ! ! Code for both increments equal to 1. ! ! Clean-up loop so remaining vector length is a multiple of 3. ! 20 M = MOD(N,3) if (M == 0) go to 40 DO 30 I = 1,M STEMP1 = SX(I) SX(I) = SY(I) SY(I) = STEMP1 30 CONTINUE if (N < 3) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 STEMP1 = SX(I) STEMP2 = SX(I+1) STEMP3 = SX(I+2) SX(I) = SY(I) SX(I+1) = SY(I+1) SX(I+2) = SY(I+2) SY(I) = STEMP1 SY(I+1) = STEMP2 SY(I+2) = STEMP3 50 CONTINUE return ! ! Code for equal, positive, non-unit increments. ! 60 NS = N*INCX DO 70 I = 1,NS,INCX STEMP1 = SX(I) SX(I) = SY(I) SY(I) = STEMP1 70 CONTINUE return end subroutine SSYMM (SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, BETA, & C, LDC) ! !! SSYMM multiplies a real general matrix by a real symmetric matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE SINGLE PRECISION (SSYMM-S, DSYMM-D, CSYMM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! SSYMM performs one of the matrix-matrix operations ! ! C := alpha*A*B + beta*C, ! ! or ! ! C := alpha*B*A + beta*C, ! ! where alpha and beta are scalars, A is a symmetric matrix and B and ! C are m by n matrices. ! ! Parameters ! ========== ! ! SIDE - CHARACTER*1. ! On entry, SIDE specifies whether the symmetric matrix A ! appears on the left or right in the operation as follows: ! ! SIDE = 'L' or 'l' C := alpha*A*B + beta*C, ! ! SIDE = 'R' or 'r' C := alpha*B*A + beta*C, ! ! Unchanged on exit. ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the symmetric matrix A is to be ! referenced as follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of the ! symmetric matrix is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of the ! symmetric matrix is to be referenced. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of the matrix C. ! M must be at least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of the matrix C. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, ka ), where ka is ! m when SIDE = 'L' or 'l' and is n otherwise. ! Before entry with SIDE = 'L' or 'l', the m by m part of ! the array A must contain the symmetric matrix, such that ! when UPLO = 'U' or 'u', the leading m by m upper triangular ! part of the array A must contain the upper triangular part ! of the symmetric matrix and the strictly lower triangular ! part of A is not referenced, and when UPLO = 'L' or 'l', ! the leading m by m lower triangular part of the array A ! must contain the lower triangular part of the symmetric ! matrix and the strictly upper triangular part of A is not ! referenced. ! Before entry with SIDE = 'R' or 'r', the n by n part of ! the array A must contain the symmetric matrix, such that ! when UPLO = 'U' or 'u', the leading n by n upper triangular ! part of the array A must contain the upper triangular part ! of the symmetric matrix and the strictly lower triangular ! part of A is not referenced, and when UPLO = 'L' or 'l', ! the leading n by n lower triangular part of the array A ! must contain the lower triangular part of the symmetric ! matrix and the strictly upper triangular part of A is not ! referenced. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When SIDE = 'L' or 'l' then ! LDA must be at least max( 1, m ), otherwise LDA must be at ! least max( 1, n ). ! Unchanged on exit. ! ! B - REAL array of DIMENSION ( LDB, n ). ! Before entry, the leading m by n part of the array B must ! contain the matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. LDB must be at least ! max( 1, m ). ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then C need not be set on input. ! Unchanged on exit. ! ! C - REAL array of DIMENSION ( LDC, n ). ! Before entry, the leading m by n part of the array C must ! contain the matrix C, except when beta is zero, in which ! case C need not be set on entry. ! On exit, the array C is overwritten by the m by n updated ! matrix. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SSYMM ! .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC REAL ALPHA, BETA ! .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, K, NROWA REAL TEMP1, TEMP2 ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) !***FIRST EXECUTABLE STATEMENT SSYMM ! ! Set NROWA as the number of rows of A. ! if ( LSAME( SIDE, 'L' ) )THEN NROWA = M ELSE NROWA = N end if UPPER = LSAME( UPLO, 'U' ) ! ! Test the input parameters. ! INFO = 0 if ( ( .NOT.LSAME( SIDE, 'L' ) ).AND. & ( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE if ( M < 0 )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDB < MAX( 1, M ) )THEN INFO = 9 ELSE if ( LDC < MAX( 1, M ) )THEN INFO = 12 end if if ( INFO /= 0 )THEN call XERBLA( 'SSYMM ', INFO ) return end if ! ! Quick return if possible. ! if ( ( M == 0 ).OR.( N == 0 ).OR. & ( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if return end if ! ! Start the operations. ! if ( LSAME( SIDE, 'L' ) )THEN ! ! Form C := alpha*A*B + beta*C. ! if ( UPPER )THEN DO 70, J = 1, N DO 60, I = 1, M TEMP1 = ALPHA*B( I, J ) TEMP2 = ZERO DO 50, K = 1, I - 1 C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) TEMP2 = TEMP2 + B( K, J )*A( K, I ) 50 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & TEMP1*A( I, I ) + ALPHA*TEMP2 end if 60 CONTINUE 70 CONTINUE ELSE DO 100, J = 1, N DO 90, I = M, 1, -1 TEMP1 = ALPHA*B( I, J ) TEMP2 = ZERO DO 80, K = I + 1, M C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) TEMP2 = TEMP2 + B( K, J )*A( K, I ) 80 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & TEMP1*A( I, I ) + ALPHA*TEMP2 end if 90 CONTINUE 100 CONTINUE end if ELSE ! ! Form C := alpha*B*A + beta*C. ! DO 170, J = 1, N TEMP1 = ALPHA*A( J, J ) if ( BETA == ZERO )THEN DO 110, I = 1, M C( I, J ) = TEMP1*B( I, J ) 110 CONTINUE ELSE DO 120, I = 1, M C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) 120 CONTINUE end if DO 140, K = 1, J - 1 if ( UPPER )THEN TEMP1 = ALPHA*A( K, J ) ELSE TEMP1 = ALPHA*A( J, K ) end if DO 130, I = 1, M C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 130 CONTINUE 140 CONTINUE DO 160, K = J + 1, N if ( UPPER )THEN TEMP1 = ALPHA*A( J, K ) ELSE TEMP1 = ALPHA*A( K, J ) end if DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 150 CONTINUE 160 CONTINUE 170 CONTINUE end if ! return ! ! End of SSYMM . ! end subroutine SSYMV (UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) ! !! SSYMV multiplies a real vector by a real symmetric matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SSYMV-S, DSYMV-D, CSYMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! SSYMV performs the matrix-vector operation ! ! y := alpha*A*x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! A is an n by n symmetric matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array A is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of A ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of A ! is to be referenced. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of A is not referenced. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. When BETA is ! supplied as zero then Y need not be set on input. ! Unchanged on exit. ! ! Y - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. On exit, Y is overwritten by the updated ! vector y. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SSYMV ! .. Scalar Arguments .. REAL ALPHA, BETA INTEGER INCX, INCY, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT SSYMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 5 ELSE if ( INCX == 0 )THEN INFO = 7 ELSE if ( INCY == 0 )THEN INFO = 10 end if if ( INFO /= 0 )THEN call XERBLA( 'SSYMV ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ( ALPHA == ZERO ).AND.( BETA == ONE ) ) ) & return ! ! Set up the start points in X and Y. ! if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! ! First form y := beta*y. ! if ( BETA /= ONE )THEN if ( INCY == 1 )THEN if ( BETA == ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE end if ELSE IY = KY if ( BETA == ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE end if end if end if if ( ALPHA == ZERO ) & return if ( LSAME( UPLO, 'U' ) )THEN ! ! Form y when A is stored in upper triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO DO 50, I = 1, J - 1 Y( I ) = Y( I ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( I ) 50 CONTINUE Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY DO 70, I = 1, J - 1 Y( IY ) = Y( IY ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 80 CONTINUE end if ELSE ! ! Form y when A is stored in lower triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*A( J, J ) DO 90, I = J + 1, N Y( I ) = Y( I ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( I ) 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*A( J, J ) IX = JX IY = JY DO 110, I = J + 1, N IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE end if end if ! return ! ! End of SSYMV . ! end subroutine SSYR2 (UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA) ! !! SSYR2 performs symmetric rank 2 update of a real symmetric matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SSYR2-S, DSYR2-D, CSYR2-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! SSYR2 performs the symmetric rank 2 operation ! ! A := alpha*x*y' + alpha*y*x' + A, ! ! where alpha is a scalar, x and y are n element vectors and A is an n ! by n symmetric matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array A is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of A ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of A ! is to be referenced. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! Y - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCY ) ). ! Before entry, the incremented array Y must contain the n ! element vector y. ! Unchanged on exit. ! ! INCY - INTEGER. ! On entry, INCY specifies the increment for the elements of ! Y. INCY must not be zero. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of A is not referenced. On exit, the ! upper triangular part of the array A is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of A is not referenced. On exit, the ! lower triangular part of the array A is overwritten by the ! lower triangular part of the updated matrix. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SSYR2 ! .. Scalar Arguments .. REAL ALPHA INTEGER INCX, INCY, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT SSYR2 ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( INCY == 0 )THEN INFO = 7 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'SSYR2 ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Set up the start points in X and Y if the increments are not both ! unity. ! if ( ( INCX /= 1 ).OR.( INCY /= 1 ) )THEN if ( INCX > 0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX end if if ( INCY > 0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY end if JX = KX JY = KY end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when A is stored in the upper triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 20, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) DO 10, I = 1, J A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 10 CONTINUE end if 20 CONTINUE ELSE DO 40, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = KX IY = KY DO 30, I = 1, J A( I, J ) = A( I, J ) + X( IX )*TEMP1 & + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE end if JX = JX + INCX JY = JY + INCY 40 CONTINUE end if ELSE ! ! Form A when A is stored in the lower triangle. ! if ( ( INCX == 1 ).AND.( INCY == 1 ) )THEN DO 60, J = 1, N if ( ( X( J ) /= ZERO ).OR.( Y( J ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) DO 50, I = J, N A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 50 CONTINUE end if 60 CONTINUE ELSE DO 80, J = 1, N if ( ( X( JX ) /= ZERO ).OR.( Y( JY ) /= ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = JX IY = JY DO 70, I = J, N A( I, J ) = A( I, J ) + X( IX )*TEMP1 & + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 70 CONTINUE end if JX = JX + INCX JY = JY + INCY 80 CONTINUE end if end if ! return ! ! End of SSYR2 . ! end subroutine SSYR2K (UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, & C, LDC) ! !! SSYR2K performs symmetric rank 2k update of a real symmetric matrix ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE SINGLE PRECISION (SSYR2-S, DSYR2-D, CSYR2-C, SSYR2K-S) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! SSYR2K performs one of the symmetric rank 2k operations ! ! C := alpha*A*B' + alpha*B*A' + beta*C, ! ! or ! ! C := alpha*A'*B + alpha*B'*A + beta*C, ! ! where alpha and beta are scalars, C is an n by n symmetric matrix ! and A and B are n by k matrices in the first case and k by n ! matrices in the second case. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array C is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of C ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of C ! is to be referenced. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + ! beta*C. ! ! TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + ! beta*C. ! ! TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + ! beta*C. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with TRANS = 'N' or 'n', K specifies the number ! of columns of the matrices A and B, and on entry with ! TRANS = 'T' or 't' or 'C' or 'c', K specifies the number ! of rows of the matrices A and B. K must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, ka ), where ka is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array A must contain the matrix A, otherwise ! the leading k by n part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDA must be at least max( 1, n ), otherwise LDA must ! be at least max( 1, k ). ! Unchanged on exit. ! ! B - REAL array of DIMENSION ( LDB, kb ), where kb is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array B must contain the matrix B, otherwise ! the leading k by n part of the array B must contain the ! matrix B. ! Unchanged on exit. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDB must be at least max( 1, n ), otherwise LDB must ! be at least max( 1, k ). ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! C - REAL array of DIMENSION ( LDC, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array C must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of C is not referenced. On exit, the ! upper triangular part of the array C is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array C must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of C is not referenced. On exit, the ! lower triangular part of the array C is overwritten by the ! lower triangular part of the updated matrix. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SSYR2K ! .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC REAL ALPHA, BETA ! .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) ! ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, L, NROWA REAL TEMP1, TEMP2 ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) !***FIRST EXECUTABLE STATEMENT SSYR2K ! ! Test the input parameters. ! if ( LSAME( TRANS, 'N' ) )THEN NROWA = N ELSE NROWA = K end if UPPER = LSAME( UPLO, 'U' ) ! INFO = 0 if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.LSAME( TRANS, 'N' ) ).AND. & ( .NOT.LSAME( TRANS, 'T' ) ).AND. & ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( K < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDB < MAX( 1, NROWA ) )THEN INFO = 9 ELSE if ( LDC < MAX( 1, N ) )THEN INFO = 12 end if if ( INFO /= 0 )THEN call XERBLA( 'SSYR2K', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( UPPER )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, J C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, J C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if ELSE if ( BETA == ZERO )THEN DO 60, J = 1, N DO 50, I = J, N C( I, J ) = ZERO 50 CONTINUE 60 CONTINUE ELSE DO 80, J = 1, N DO 70, I = J, N C( I, J ) = BETA*C( I, J ) 70 CONTINUE 80 CONTINUE end if end if return end if ! ! Start the operations. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form C := alpha*A*B' + alpha*B*A' + C. ! if ( UPPER )THEN DO 130, J = 1, N if ( BETA == ZERO )THEN DO 90, I = 1, J C( I, J ) = ZERO 90 CONTINUE ELSE if ( BETA /= ONE )THEN DO 100, I = 1, J C( I, J ) = BETA*C( I, J ) 100 CONTINUE end if DO 120, L = 1, K if ( ( A( J, L ) /= ZERO ).OR. & ( B( J, L ) /= ZERO ) )THEN TEMP1 = ALPHA*B( J, L ) TEMP2 = ALPHA*A( J, L ) DO 110, I = 1, J C( I, J ) = C( I, J ) + & A( I, L )*TEMP1 + B( I, L )*TEMP2 110 CONTINUE end if 120 CONTINUE 130 CONTINUE ELSE DO 180, J = 1, N if ( BETA == ZERO )THEN DO 140, I = J, N C( I, J ) = ZERO 140 CONTINUE ELSE if ( BETA /= ONE )THEN DO 150, I = J, N C( I, J ) = BETA*C( I, J ) 150 CONTINUE end if DO 170, L = 1, K if ( ( A( J, L ) /= ZERO ).OR. & ( B( J, L ) /= ZERO ) )THEN TEMP1 = ALPHA*B( J, L ) TEMP2 = ALPHA*A( J, L ) DO 160, I = J, N C( I, J ) = C( I, J ) + & A( I, L )*TEMP1 + B( I, L )*TEMP2 160 CONTINUE end if 170 CONTINUE 180 CONTINUE end if ELSE ! ! Form C := alpha*A'*B + alpha*B'*A + C. ! if ( UPPER )THEN DO 210, J = 1, N DO 200, I = 1, J TEMP1 = ZERO TEMP2 = ZERO DO 190, L = 1, K TEMP1 = TEMP1 + A( L, I )*B( L, J ) TEMP2 = TEMP2 + B( L, I )*A( L, J ) 190 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & ALPHA*TEMP1 + ALPHA*TEMP2 end if 200 CONTINUE 210 CONTINUE ELSE DO 240, J = 1, N DO 230, I = J, N TEMP1 = ZERO TEMP2 = ZERO DO 220, L = 1, K TEMP1 = TEMP1 + A( L, I )*B( L, J ) TEMP2 = TEMP2 + B( L, I )*A( L, J ) 220 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 ELSE C( I, J ) = BETA *C( I, J ) + & ALPHA*TEMP1 + ALPHA*TEMP2 end if 230 CONTINUE 240 CONTINUE end if end if ! return ! ! End of SSYR2K. ! end subroutine SSYR (UPLO, N, ALPHA, X, INCX, A, LDA) ! !! SSYR performs symmetric rank 1 update of a real symmetric matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (SSYR-S) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! SSYR performs the symmetric rank 1 operation ! ! A := alpha*x*x' + A, ! ! where alpha is a real scalar, x is an n element vector and A is an ! n by n symmetric matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array A is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of A ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of A ! is to be referenced. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1)*abs( INCX)). ! Before entry, the incremented array X must contain the n ! element vector x. ! Unchanged on exit. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of A is not referenced. On exit, the ! upper triangular part of the array A is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of A is not referenced. On exit, the ! lower triangular part of the array A is overwritten by the ! lower triangular part of the updated matrix. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SSYR ! .. Scalar Arguments .. REAL ALPHA INTEGER INCX, LDA, N CHARACTER*1 UPLO ! .. Array Arguments .. REAL A( LDA, * ), X( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, KX ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT SSYR ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO, 'U' ).AND. & .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE if ( N < 0 )THEN INFO = 2 ELSE if ( INCX == 0 )THEN INFO = 5 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'SSYR ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR.( ALPHA == ZERO ) ) & return ! ! Set the start point in X if the increment is not unity. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through the triangular part ! of A. ! if ( LSAME( UPLO, 'U' ) )THEN ! ! Form A when A is stored in upper triangle. ! if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*X( J ) DO 10, I = 1, J A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE end if 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IX = KX DO 30, I = 1, J A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE end if JX = JX + INCX 40 CONTINUE end if ELSE ! ! Form A when A is stored in lower triangle. ! if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = ALPHA*X( J ) DO 50, I = J, N A( I, J ) = A( I, J ) + X( I )*TEMP 50 CONTINUE end if 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = ALPHA*X( JX ) IX = JX DO 70, I = J, N A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if end if ! return ! ! End of SSYR . ! end subroutine SSYRK (UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC) ! !! SSYRK performs symmetric rank k update of a real symmetric matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE SINGLE PRECISION (SSYRK-S, DSYRK-D, CSYRK-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! SSYRK performs one of the symmetric rank k operations ! ! C := alpha*A*A' + beta*C, ! ! or ! ! C := alpha*A'*A + beta*C, ! ! where alpha and beta are scalars, C is an n by n symmetric matrix ! and A is an n by k matrix in the first case and a k by n matrix ! in the second case. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the upper or lower ! triangular part of the array C is to be referenced as ! follows: ! ! UPLO = 'U' or 'u' Only the upper triangular part of C ! is to be referenced. ! ! UPLO = 'L' or 'l' Only the lower triangular part of C ! is to be referenced. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. ! ! TRANS = 'T' or 't' C := alpha*A'*A + beta*C. ! ! TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix C. N must be ! at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with TRANS = 'N' or 'n', K specifies the number ! of columns of the matrix A, and on entry with ! TRANS = 'T' or 't' or 'C' or 'c', K specifies the number ! of rows of the matrix A. K must be at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, ka ), where ka is ! k when TRANS = 'N' or 'n', and is n otherwise. ! Before entry with TRANS = 'N' or 'n', the leading n by k ! part of the array A must contain the matrix A, otherwise ! the leading k by n part of the array A must contain the ! matrix A. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When TRANS = 'N' or 'n' ! then LDA must be at least max( 1, n ), otherwise LDA must ! be at least max( 1, k ). ! Unchanged on exit. ! ! BETA - REAL . ! On entry, BETA specifies the scalar beta. ! Unchanged on exit. ! ! C - REAL array of DIMENSION ( LDC, n ). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array C must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of C is not referenced. On exit, the ! upper triangular part of the array C is overwritten by the ! upper triangular part of the updated matrix. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array C must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of C is not referenced. On exit, the ! lower triangular part of the array C is overwritten by the ! lower triangular part of the updated matrix. ! ! LDC - INTEGER. ! On entry, LDC specifies the first dimension of C as declared ! in the calling (sub) program. LDC must be at least ! max( 1, n ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE SSYRK ! .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC REAL ALPHA, BETA ! .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL UPPER INTEGER I, INFO, J, L, NROWA REAL TEMP ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) !***FIRST EXECUTABLE STATEMENT SSYRK ! ! Test the input parameters. ! if ( LSAME( TRANS, 'N' ) )THEN NROWA = N ELSE NROWA = K end if UPPER = LSAME( UPLO, 'U' ) ! INFO = 0 if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.LSAME( TRANS, 'N' ) ).AND. & ( .NOT.LSAME( TRANS, 'T' ) ).AND. & ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE if ( N < 0 )THEN INFO = 3 ELSE if ( K < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 7 ELSE if ( LDC < MAX( 1, N ) )THEN INFO = 10 end if if ( INFO /= 0 )THEN call XERBLA( 'SSYRK ', INFO ) return end if ! ! Quick return if possible. ! if ( ( N == 0 ).OR. & ( ( ( ALPHA == ZERO ).OR.( K == 0 ) ).AND.( BETA == ONE ) ) ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN if ( UPPER )THEN if ( BETA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, J C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, J C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE end if ELSE if ( BETA == ZERO )THEN DO 60, J = 1, N DO 50, I = J, N C( I, J ) = ZERO 50 CONTINUE 60 CONTINUE ELSE DO 80, J = 1, N DO 70, I = J, N C( I, J ) = BETA*C( I, J ) 70 CONTINUE 80 CONTINUE end if end if return end if ! ! Start the operations. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form C := alpha*A*A' + beta*C. ! if ( UPPER )THEN DO 130, J = 1, N if ( BETA == ZERO )THEN DO 90, I = 1, J C( I, J ) = ZERO 90 CONTINUE ELSE if ( BETA /= ONE )THEN DO 100, I = 1, J C( I, J ) = BETA*C( I, J ) 100 CONTINUE end if DO 120, L = 1, K if ( A( J, L ) /= ZERO )THEN TEMP = ALPHA*A( J, L ) DO 110, I = 1, J C( I, J ) = C( I, J ) + TEMP*A( I, L ) 110 CONTINUE end if 120 CONTINUE 130 CONTINUE ELSE DO 180, J = 1, N if ( BETA == ZERO )THEN DO 140, I = J, N C( I, J ) = ZERO 140 CONTINUE ELSE if ( BETA /= ONE )THEN DO 150, I = J, N C( I, J ) = BETA*C( I, J ) 150 CONTINUE end if DO 170, L = 1, K if ( A( J, L ) /= ZERO )THEN TEMP = ALPHA*A( J, L ) DO 160, I = J, N C( I, J ) = C( I, J ) + TEMP*A( I, L ) 160 CONTINUE end if 170 CONTINUE 180 CONTINUE end if ELSE ! ! Form C := alpha*A'*A + beta*C. ! if ( UPPER )THEN DO 210, J = 1, N DO 200, I = 1, J TEMP = ZERO DO 190, L = 1, K TEMP = TEMP + A( L, I )*A( L, J ) 190 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 200 CONTINUE 210 CONTINUE ELSE DO 240, J = 1, N DO 230, I = J, N TEMP = ZERO DO 220, L = 1, K TEMP = TEMP + A( L, I )*A( L, J ) 220 CONTINUE if ( BETA == ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) end if 230 CONTINUE 240 CONTINUE end if end if ! return ! ! End of SSYRK . ! end subroutine STBMV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) ! !! STBMV multiplies a real vector by a real triangular band matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (STBMV-S, DTBMV-D, CTBMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! STBMV performs one of the matrix-vector operations ! ! x := A*x, or x := A'*x, ! ! where x is an n element vector and A is an n by n unit, or non-unit, ! upper or lower triangular band matrix, with ( k + 1) diagonals. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' x := A*x. ! ! TRANS = 'T' or 't' x := A'*x. ! ! TRANS = 'C' or 'c' x := A'*x. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with UPLO = 'U' or 'u', K specifies the number of ! super-diagonals of the matrix A. ! On entry with UPLO = 'L' or 'l', K specifies the number of ! sub-diagonals of the matrix A. ! K must satisfy 0 .le. K. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) ! by n part of the array A must contain the upper triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. The top left k by k triangle ! of the array A is not referenced. ! The following program segment will transfer an upper ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = K + 1 - J ! DO 10, I = MAX( 1, J - K ), J ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) ! by n part of the array A must contain the lower triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. The bottom right k by k triangle of the ! array A is not referenced. ! The following program segment will transfer a lower ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = 1 - J ! DO 10, I = J, MIN( N, J + K ) ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Note that when DIAG = 'U' or 'u' the elements of the array A ! corresponding to the diagonal elements of the matrix are not ! referenced, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( k + 1 ). ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. On exit, X is overwritten with the ! transformed vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE STBMV ! .. Scalar Arguments .. INTEGER INCX, K, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. REAL A( LDA, * ), X( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX, MIN !***FIRST EXECUTABLE STATEMENT STBMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( K < 0 )THEN INFO = 5 ELSE if ( LDA < ( K + 1 ) )THEN INFO = 7 ELSE if ( INCX == 0 )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'STBMV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := A*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = X( J ) L = KPLUS1 - J DO 10, I = MAX( 1, J - K ), J - 1 X( I ) = X( I ) + TEMP*A( L + I, J ) 10 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( KPLUS1, J ) end if 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX L = KPLUS1 - J DO 30, I = MAX( 1, J - K ), J - 1 X( IX ) = X( IX ) + TEMP*A( L + I, J ) IX = IX + INCX 30 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( KPLUS1, J ) end if JX = JX + INCX if ( J > K ) & KX = KX + INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = N, 1, -1 if ( X( J ) /= ZERO )THEN TEMP = X( J ) L = 1 - J DO 50, I = MIN( N, J + K ), J + 1, -1 X( I ) = X( I ) + TEMP*A( L + I, J ) 50 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( 1, J ) end if 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX L = 1 - J DO 70, I = MIN( N, J + K ), J + 1, -1 X( IX ) = X( IX ) + TEMP*A( L + I, J ) IX = IX - INCX 70 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( 1, J ) end if JX = JX - INCX if ( ( N - J ) >= K ) & KX = KX - INCX 80 CONTINUE end if end if ELSE ! ! Form x := A'*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) L = KPLUS1 - J if ( NOUNIT ) & TEMP = TEMP*A( KPLUS1, J ) DO 90, I = J - 1, MAX( 1, J - K ), -1 TEMP = TEMP + A( L + I, J )*X( I ) 90 CONTINUE X( J ) = TEMP 100 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 120, J = N, 1, -1 TEMP = X( JX ) KX = KX - INCX IX = KX L = KPLUS1 - J if ( NOUNIT ) & TEMP = TEMP*A( KPLUS1, J ) DO 110, I = J - 1, MAX( 1, J - K ), -1 TEMP = TEMP + A( L + I, J )*X( IX ) IX = IX - INCX 110 CONTINUE X( JX ) = TEMP JX = JX - INCX 120 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 140, J = 1, N TEMP = X( J ) L = 1 - J if ( NOUNIT ) & TEMP = TEMP*A( 1, J ) DO 130, I = J + 1, MIN( N, J + K ) TEMP = TEMP + A( L + I, J )*X( I ) 130 CONTINUE X( J ) = TEMP 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) KX = KX + INCX IX = KX L = 1 - J if ( NOUNIT ) & TEMP = TEMP*A( 1, J ) DO 150, I = J + 1, MIN( N, J + K ) TEMP = TEMP + A( L + I, J )*X( IX ) IX = IX + INCX 150 CONTINUE X( JX ) = TEMP JX = JX + INCX 160 CONTINUE end if end if end if ! return ! ! End of STBMV . ! end subroutine STBSV (UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX) ! !! STBSV solves a real triangular banded system of linear equations. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (STBSV-S, DTBSV-D, CTBSV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! STBSV solves one of the systems of equations ! ! A*x = b, or A'*x = b, ! ! where b and x are n element vectors and A is an n by n unit, or ! non-unit, upper or lower triangular band matrix, with ( k + 1) ! diagonals. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the equations to be solved as ! follows: ! ! TRANS = 'N' or 'n' A*x = b. ! ! TRANS = 'T' or 't' A'*x = b. ! ! TRANS = 'C' or 'c' A'*x = b. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! K - INTEGER. ! On entry with UPLO = 'U' or 'u', K specifies the number of ! super-diagonals of the matrix A. ! On entry with UPLO = 'L' or 'l', K specifies the number of ! sub-diagonals of the matrix A. ! K must satisfy 0 .le. K. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n ). ! Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) ! by n part of the array A must contain the upper triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. The top left k by k triangle ! of the array A is not referenced. ! The following program segment will transfer an upper ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = K + 1 - J ! DO 10, I = MAX( 1, J - K ), J ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) ! by n part of the array A must contain the lower triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. The bottom right k by k triangle of the ! array A is not referenced. ! The following program segment will transfer a lower ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! DO 20, J = 1, N ! M = 1 - J ! DO 10, I = J, MIN( N, J + K ) ! A( M + I, J ) = matrix( I, J ) ! 10 CONTINUE ! 20 CONTINUE ! ! Note that when DIAG = 'U' or 'u' the elements of the array A ! corresponding to the diagonal elements of the matrix are not ! referenced, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! ( k + 1 ). ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element right-hand side vector b. On exit, X is overwritten ! with the solution vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE STBSV ! .. Scalar Arguments .. INTEGER INCX, K, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. REAL A( LDA, * ), X( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX, MIN !***FIRST EXECUTABLE STATEMENT STBSV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( K < 0 )THEN INFO = 5 ELSE if ( LDA < ( K + 1 ) )THEN INFO = 7 ELSE if ( INCX == 0 )THEN INFO = 9 end if if ( INFO /= 0 )THEN call XERBLA( 'STBSV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed by sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := inv( A )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 20, J = N, 1, -1 if ( X( J ) /= ZERO )THEN L = KPLUS1 - J if ( NOUNIT ) & X( J ) = X( J )/A( KPLUS1, J ) TEMP = X( J ) DO 10, I = J - 1, MAX( 1, J - K ), -1 X( I ) = X( I ) - TEMP*A( L + I, J ) 10 CONTINUE end if 20 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 40, J = N, 1, -1 KX = KX - INCX if ( X( JX ) /= ZERO )THEN IX = KX L = KPLUS1 - J if ( NOUNIT ) & X( JX ) = X( JX )/A( KPLUS1, J ) TEMP = X( JX ) DO 30, I = J - 1, MAX( 1, J - K ), -1 X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX - INCX 30 CONTINUE end if JX = JX - INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN L = 1 - J if ( NOUNIT ) & X( J ) = X( J )/A( 1, J ) TEMP = X( J ) DO 50, I = J + 1, MIN( N, J + K ) X( I ) = X( I ) - TEMP*A( L + I, J ) 50 CONTINUE end if 60 CONTINUE ELSE JX = KX DO 80, J = 1, N KX = KX + INCX if ( X( JX ) /= ZERO )THEN IX = KX L = 1 - J if ( NOUNIT ) & X( JX ) = X( JX )/A( 1, J ) TEMP = X( JX ) DO 70, I = J + 1, MIN( N, J + K ) X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX + INCX 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if end if ELSE ! ! Form x := inv( A')*x. ! if ( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 if ( INCX == 1 )THEN DO 100, J = 1, N TEMP = X( J ) L = KPLUS1 - J DO 90, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( I ) 90 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( KPLUS1, J ) X( J ) = TEMP 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX L = KPLUS1 - J DO 110, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX + INCX 110 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( KPLUS1, J ) X( JX ) = TEMP JX = JX + INCX if ( J > K ) & KX = KX + INCX 120 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) L = 1 - J DO 130, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( I ) 130 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( 1, J ) X( J ) = TEMP 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX L = 1 - J DO 150, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX - INCX 150 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( 1, J ) X( JX ) = TEMP JX = JX - INCX if ( ( N - J ) >= K ) & KX = KX - INCX 160 CONTINUE end if end if end if ! return ! ! End of STBSV . ! end subroutine STEPS (F, NEQN, Y, X, H, EPS, WT, START, HOLD, K, KOLD, & CRASH, PHI, P, YP, PSI, ALPHA, BETA, SIG, V, W, G, PHASE1, NS, & NORND, KSTEPS, TWOU, FOURU, XOLD, KPREV, IVC, IV, KGI, GI, & RPAR, IPAR) ! !! STEPS integrates a system of ordinary differential equations one step. ! !***LIBRARY SLATEC (DEPAC) !***CATEGORY I1A1B !***TYPE SINGLE PRECISION (STEPS-S, DSTEPS-D) !***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, ! ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR !***AUTHOR Shampine, L. F., (SNLA) ! Gordon, M. K., (SNLA) ! MODIFIED BY H.A. WATTS !***DESCRIPTION ! ! Written by L. F. Shampine and M. K. Gordon ! ! Abstract ! ! Subroutine STEPS is normally used indirectly through subroutine ! DEABM . Because DEABM suffices for most problems and is much ! easier to use, using it should be considered before using STEPS ! alone. ! ! Subroutine STEPS integrates a system of NEQN first order ordinary ! differential equations one step, normally from X to X+H, using a ! modified divided difference form of the Adams Pece formulas. Local ! extrapolation is used to improve absolute stability and accuracy. ! The code adjusts its order and step size to control the local error ! per unit step in a generalized sense. Special devices are included ! to control roundoff error and to detect when the user is requesting ! too much accuracy. ! ! This code is completely explained and documented in the text, ! Computer Solution of Ordinary Differential Equations, The Initial ! Value Problem by L. F. Shampine and M. K. Gordon. ! Further details on use of this code are available in "Solving ! Ordinary Differential Equations with ODE, STEP, and INTRP", ! by L. F. Shampine and M. K. Gordon, SLA-73-1060. ! ! ! The parameters represent -- ! F -- subroutine to evaluate derivatives ! NEQN -- number of equations to be integrated ! Y(*) -- solution vector at X ! X -- independent variable ! H -- appropriate step size for next step. Normally determined by ! code ! EPS -- local error tolerance ! WT(*) -- vector of weights for error criterion ! START -- logical variable set .TRUE. for first step, .FALSE. ! otherwise ! HOLD -- step size used for last successful step ! K -- appropriate order for next step (determined by code) ! KOLD -- order used for last successful step ! CRASH -- logical variable set .TRUE. when no step can be taken, ! .FALSE. otherwise. ! YP(*) -- derivative of solution vector at X after successful ! step ! KSTEPS -- counter on attempted steps ! TWOU -- 2.*U where U is machine unit roundoff quantity ! FOURU -- 4.*U where U is machine unit roundoff quantity ! RPAR,IPAR -- parameter arrays which you may choose to use ! for communication between your program and subroutine F. ! They are not altered or used by STEPS. ! The variables X,XOLD,KOLD,KGI and IVC and the arrays Y,PHI,ALPHA,G, ! W,P,IV and GI are required for the interpolation subroutine SINTRP. ! The remaining variables and arrays are included in the call list ! only to eliminate local retention of variables between calls. ! ! Input to STEPS ! ! First call -- ! ! The user must provide storage in his calling program for all arrays ! in the call list, namely ! ! 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),GI(11),IV(10), ! 2 RPAR(*),IPAR(*) ! ! **Note** ! ! The user must also declare START , CRASH , PHASE1 and NORND ! logical variables and F an EXTERNAL subroutine, supply the ! subroutine F(X,Y,YP) to evaluate ! DY(I)/DX = YP(I) = F(X,Y(1),Y(2),...,Y(NEQN)) ! and initialize only the following parameters. ! NEQN -- number of equations to be integrated ! Y(*) -- vector of initial values of dependent variables ! X -- initial value of the independent variable ! H -- nominal step size indicating direction of integration ! and maximum size of step. Must be variable ! EPS -- local error tolerance per step. Must be variable ! WT(*) -- vector of non-zero weights for error criterion ! START -- .TRUE. ! YP(*) -- vector of initial derivative values ! KSTEPS -- set KSTEPS to zero ! TWOU -- 2.*U where U is machine unit roundoff quantity ! FOURU -- 4.*U where U is machine unit roundoff quantity ! Define U to be the machine unit roundoff quantity by calling ! the function routine R1MACH, U = R1MACH(4), or by ! computing U so that U is the smallest positive number such ! that 1.0+U > 1.0. ! ! STEPS requires that the L2 norm of the vector with components ! LOCAL ERROR(L)/WT(L) be less than EPS for a successful step. The ! array WT allows the user to specify an error test appropriate ! for his problem. For example, ! WT(L) = 1.0 specifies absolute error, ! = ABS(Y(L)) error relative to the most recent value of the ! L-th component of the solution, ! = ABS(YP(L)) error relative to the most recent value of ! the L-th component of the derivative, ! = MAX(WT(L),ABS(Y(L))) error relative to the largest ! magnitude of L-th component obtained so far, ! = ABS(Y(L))*RELERR/EPS + ABSERR/EPS specifies a mixed ! relative-absolute test where RELERR is relative ! error, ABSERR is absolute error and EPS = ! MAX(RELERR,ABSERR) . ! ! Subsequent calls -- ! ! Subroutine STEPS is designed so that all information needed to ! continue the integration, including the step size H and the order ! K , is returned with each step. With the exception of the step ! size, the error tolerance, and the weights, none of the parameters ! should be altered. The array WT must be updated after each step ! to maintain relative error tests like those above. Normally the ! integration is continued just beyond the desired endpoint and the ! solution interpolated there with subroutine SINTRP . If it is ! impossible to integrate beyond the endpoint, the step size may be ! reduced to hit the endpoint since the code will not take a step ! larger than the H input. Changing the direction of integration, ! i.e., the sign of H , requires the user set START = .TRUE. before ! calling STEPS again. This is the only situation in which START ! should be altered. ! ! Output from STEPS ! ! Successful Step -- ! ! The subroutine returns after each successful step with START and ! CRASH set .FALSE. . X represents the independent variable ! advanced one step of length HOLD from its value on input and Y ! the solution vector at the new value of X . All other parameters ! represent information corresponding to the new X needed to ! continue the integration. ! ! Unsuccessful Step -- ! ! When the error tolerance is too small for the machine precision, ! the subroutine returns without taking a step and CRASH = .TRUE. . ! An appropriate step size and error tolerance for continuing are ! estimated and all other information is restored as upon input ! before returning. To continue with the larger tolerance, the user ! just calls the code again. A restart is neither required nor ! desirable. ! !***REFERENCES L. F. Shampine and M. K. Gordon, Solving ordinary ! differential equations with ODE, STEP, and INTRP, ! Report SLA-73-1060, Sandia Laboratories, 1973. !***ROUTINES CALLED HSTART, R1MACH !***REVISION HISTORY (YYMMDD) ! 740101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE STEPS ! LOGICAL START,CRASH,PHASE1,NORND DIMENSION Y(*),WT(*),PHI(NEQN,16),P(*),YP(*),PSI(12), & ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), & RPAR(*),IPAR(*) DIMENSION TWO(13),GSTR(13) EXTERNAL F SAVE TWO, GSTR ! DATA TWO(1),TWO(2),TWO(3),TWO(4),TWO(5),TWO(6),TWO(7),TWO(8), & TWO(9),TWO(10),TWO(11),TWO(12),TWO(13) /2.0,4.0,8.0,16.0, & 32.0,64.0,128.0,256.0,512.0,1024.0,2048.0,4096.0,8192.0/ DATA GSTR(1),GSTR(2),GSTR(3),GSTR(4),GSTR(5),GSTR(6),GSTR(7), & GSTR(8),GSTR(9),GSTR(10),GSTR(11),GSTR(12),GSTR(13)/0.500, & 0.0833,0.0417,0.0264,0.0188,0.0143,0.0114,0.00936,0.00789, & 0.00679,0.00592,0.00524,0.00468/ ! ! ! *** BEGIN BLOCK 0 *** ! CHECK if STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE ! PRECISION. if FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A ! STARTING STEP SIZE. ! *** ! ! if STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE ! !***FIRST EXECUTABLE STATEMENT STEPS CRASH = .TRUE. if ( ABS(H) >= FOURU*ABS(X)) go to 5 H = SIGN(FOURU*ABS(X),H) return 5 P5EPS = 0.5*EPS ! ! if ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE ! ROUND = 0.0 DO 10 L = 1,NEQN 10 ROUND = ROUND + (Y(L)/WT(L))**2 ROUND = TWOU*SQRT(ROUND) if ( P5EPS >= 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 ! ! INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP ! ! call F(X,Y,YP,RPAR,IPAR) ! SUM = 0.0 DO 20 L = 1,NEQN PHI(L,1) = YP(L) 20 PHI(L,2) = 0.0 !20 SUM = SUM + (YP(L)/WT(L))**2 ! SUM = SQRT(SUM) ! ABSH = ABS(H) ! if ( EPS < 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) ! H = SIGN(MAX(ABSH,FOURU*ABS(X)),H) ! U = R1MACH(4) BIG = SQRT(R1MACH(2)) call HSTART (F,NEQN,X,X+H,Y,YP,WT,1,U,BIG, & PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H) ! HOLD = 0.0 K = 1 KOLD = 0 KPREV = 0 START = .FALSE. PHASE1 = .TRUE. NORND = .TRUE. if ( P5EPS > 100.0*ROUND) go to 99 NORND = .FALSE. DO 25 L = 1,NEQN 25 PHI(L,15) = 0.0 99 IFAIL = 0 ! *** END BLOCK 0 *** ! ! *** BEGIN BLOCK 1 *** ! COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING ! THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. ! *** ! 100 KP1 = K+1 KP2 = K+2 KM1 = K-1 KM2 = K-2 ! ! NS IS THE NUMBER OF STEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT ! ONE. WHEN K < NS, NO COEFFICIENTS CHANGE ! if ( H /= HOLD) NS = 0 if (NS <= KOLD) NS = NS+1 NSP1 = NS+1 if (K < NS) go to 199 ! ! COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH ! ARE CHANGED ! BETA(NS) = 1.0 REALNS = NS ALPHA(NS) = 1.0/REALNS TEMP1 = H*REALNS SIG(NSP1) = 1.0 if ( K < 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 ! ! COMPUTE COEFFICIENTS G(*) ! ! INITIALIZE V(*) AND SET W(*). ! if ( NS > 1) go to 120 DO 115 IQ = 1,K TEMP3 = IQ*(IQ+1) V(IQ) = 1.0/TEMP3 115 W(IQ) = V(IQ) IVC = 0 KGI = 0 if (K == 1) go to 140 KGI = 1 GI(1) = W(2) go to 140 ! ! if ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) ! 120 if ( K <= KPREV) go to 130 if (IVC == 0) go to 122 JV = KP1 - IV(IVC) IVC = IVC - 1 go to 123 122 JV = 1 TEMP4 = K*KP1 V(K) = 1.0/TEMP4 W(K) = V(K) if (K /= 2) go to 123 KGI = 1 GI(1) = W(2) 123 NSM2 = NS-2 if ( NSM2 < JV) go to 130 DO 125 J = JV,NSM2 I = K-J V(I) = V(I) - ALPHA(J+1)*V(I+1) 125 W(I) = V(I) if (I /= 2) go to 130 KGI = NS - 1 GI(KGI) = W(2) ! ! UPDATE V(*) AND SET W(*) ! 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) if (LIMIT1 == 1) go to 137 KGI = NS GI(KGI) = W(2) 137 W(LIMIT1+1) = V(LIMIT1+1) if (K >= KOLD) go to 140 IVC = IVC + 1 IV(IVC) = LIMIT1 + 2 ! ! COMPUTE THE G(*) IN THE WORK VECTOR W(*) ! 140 NSP2 = NS + 2 KPREV = K if ( KP1 < 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 ! *** END BLOCK 1 *** ! ! *** BEGIN BLOCK 2 *** ! PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED ! SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, ! K-1, K-2 AS if CONSTANT STEP SIZE WERE USED. ! *** ! ! INCREMENT COUNTER ON ATTEMPTED STEPS ! KSTEPS = KSTEPS + 1 ! ! CHANGE PHI TO PHI STAR ! if ( K < 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 ! ! PREDICT SOLUTION AND DIFFERENCES ! 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,RPAR,IPAR) ! ! ESTIMATE ERRORS AT ORDERS K,K-1,K-2 ! 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 ! ! TEST if ORDER SHOULD BE LOWERED ! if ( KM2)299,290,285 285 if ( MAX(ERKM1,ERKM2) <= ERK) KNEW = KM1 go to 299 290 if ( ERKM1 <= 0.5*ERK) KNEW = KM1 ! ! TEST if STEP SUCCESSFUL ! 299 if ( ERR <= EPS) go to 400 ! *** END BLOCK 2 *** ! ! *** BEGIN BLOCK 3 *** ! THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . ! if THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE ! THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR ! TOLERANCE AND RETURN if ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE ! PRECISION. ! *** ! ! RESTORE X, PHI(*,*) AND PSI(*) ! 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 < 2) go to 320 DO 315 I = 2,K 315 PSI(I-1) = PSI(I) - H ! ! ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP ! SIZE ! 320 IFAIL = IFAIL + 1 TEMP2 = 0.5 if ( IFAIL - 3) 335,330,325 325 if ( P5EPS < 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK) 330 KNEW = 1 335 H = TEMP2*H K = KNEW NS = 0 if ( ABS(H) >= FOURU*ABS(X)) go to 340 CRASH = .TRUE. H = SIGN(FOURU*ABS(X),H) EPS = EPS + EPS return 340 go to 100 ! *** END BLOCK 3 *** ! ! *** BEGIN BLOCK 4 *** ! THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE ! THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE ! DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. ! *** 400 KOLD = K HOLD = H ! ! CORRECT AND EVALUATE ! TEMP1 = H*G(KP1) if ( NORND) go to 410 DO 405 L = 1,NEQN TEMP3 = Y(L) RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) Y(L) = P(L) + RHO PHI(L,15) = (Y(L) - P(L)) - RHO 405 P(L) = TEMP3 go to 420 410 DO 415 L = 1,NEQN TEMP3 = Y(L) Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) 415 P(L) = TEMP3 420 call F(X,Y,YP,RPAR,IPAR) ! ! UPDATE DIFFERENCES FOR NEXT STEP ! 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 ! ! ESTIMATE ERROR AT ORDER K+1 UNLESS: ! IN FIRST PHASE WHEN ALWAYS RAISE ORDER, ! ALREADY DECIDED TO LOWER ORDER, ! STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE ! ERKP1 = 0.0 if ( KNEW == KM1 .OR. K == 12) PHASE1 = .FALSE. if ( PHASE1) go to 450 if ( KNEW == KM1) go to 455 if ( KP1 > NS) go to 460 DO 440 L = 1,NEQN 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) ! ! USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER ! FOR NEXT STEP ! if ( K > 1) go to 445 if ( ERKP1 >= 0.5*ERK) go to 460 go to 450 445 if ( ERKM1 <= MIN(ERK,ERKP1)) go to 455 if ( ERKP1 >= ERK .OR. K == 12) go to 460 ! ! HERE ERKP1 < ERK < MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE ! BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED ! ! RAISE ORDER ! 450 K = KP1 ERK = ERKP1 go to 460 ! ! LOWER ORDER ! 455 K = KM1 ERK = ERKM1 ! ! WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP ! 460 HNEW = H + H if ( PHASE1) go to 465 if ( P5EPS >= ERK*TWO(K+1)) go to 465 HNEW = H if ( P5EPS >= ERK) go to 465 TEMP2 = K+1 R = (P5EPS/ERK)**(1.0/TEMP2) HNEW = ABSH*MAX(0.5,MIN(0.9,R)) HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) 465 H = HNEW return ! *** END BLOCK 4 *** end subroutine STIN (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) ! !! STIN reads in SLAP Triad Format Linear System. ! Routine to read in a SLAP Triad format matrix and right ! hand side and solution to the system, if known. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY N1 !***TYPE SINGLE PRECISION (STIN-S, DTIN-D) !***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB ! REAL A(NELT), SOLN(N), RHS(N) ! ! call STIN( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) ! ! *Arguments: ! N :OUT Integer ! Order of the Matrix. ! NELT :INOUT Integer. ! On input NELT is the maximum number of non-zeros that ! can be stored in the IA, JA, A arrays. ! On output NELT is the number of non-zeros stored in A. ! IA :OUT Integer IA(NELT). ! JA :OUT Integer JA(NELT). ! A :OUT Real A(NELT). ! On output these arrays hold the matrix A in the SLAP ! Triad format. See "Description", below. ! ISYM :OUT Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! SOLN :OUT Real SOLN(N). ! The solution to the linear system, if present. This array ! is accessed if and only if JOB to read it in, see below. ! If the user requests that SOLN be read in, but it is not in ! the file, then it is simply zeroed out. ! RHS :OUT Real RHS(N). ! The right hand side vector. This array is accessed if and ! only if JOB is set to read it in, see below. ! If the user requests that RHS be read in, but it is not in ! the file, then it is simply zeroed out. ! IUNIT :IN Integer. ! Fortran logical I/O device unit number to write the matrix ! to. This unit must be connected in a system dependent fashion ! to a file or the console or you will get a nasty message ! from the Fortran I/O libraries. ! JOB :INOUT Integer. ! Flag indicating what I/O operations to perform. ! On input JOB indicates what Input operations to try to ! perform. ! JOB = 0 => Read only the matrix. ! JOB = 1 => Read matrix and RHS (if present). ! JOB = 2 => Read matrix and SOLN (if present). ! JOB = 3 => Read matrix, RHS and SOLN (if present). ! On output JOB indicates what operations were actually ! performed. ! JOB = 0 => Read in only the matrix. ! JOB = 1 => Read in the matrix and RHS. ! JOB = 2 => Read in the matrix and SOLN. ! JOB = 3 => Read in the matrix, RHS and SOLN. ! ! *Description: ! The format for the input is as follows. On the first line ! are counters and flags: N, NELT, ISYM, IRHS, ISOLN. N, NELT ! and ISYM are described above. IRHS is a flag indicating if ! the RHS was written out (1 is yes, 0 is no). ISOLN is a ! flag indicating if the SOLN was written out (1 is yes, 0 is ! no). The format for the fist line is: 5i10. Then comes the ! NELT Triad's IA(I), JA(I) and A(I), I = 1, NELT. The format ! for these lines is : 1X,I5,1X,I5,1X,E16.7. Then comes ! RHS(I), I = 1, N, if IRHS = 1. Then comes SOLN(I), I = 1, ! N, if ISOLN = 1. The format for these lines is: 1X,E16.7. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE STIN ! .. Scalar Arguments .. INTEGER ISYM, IUNIT, JOB, N, NELT ! .. Array Arguments .. REAL A(NELT), RHS(N), SOLN(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER I, IRHS, ISOLN, JOBRET, NELTMX ! .. Intrinsic Functions .. INTRINSIC MIN !***FIRST EXECUTABLE STATEMENT STIN ! ! Read in the information heading. ! NELTMX = NELT READ(IUNIT,1000) N, NELT, ISYM, IRHS, ISOLN NELT = MIN( NELT, NELTMX ) ! ! Read in the matrix non-zeros in Triad format. DO 10 I = 1, NELT READ(IUNIT,1010) IA(I), JA(I), A(I) 10 CONTINUE ! ! If requested, read in the rhs. JOBRET = 0 if ( JOB == 1 .OR. JOB == 3 ) THEN ! ! Check to see if rhs is in the file. if ( IRHS == 1 ) THEN JOBRET = 1 READ(IUNIT,1020) (RHS(I),I=1,N) ELSE DO 20 I = 1, N RHS(I) = 0 20 CONTINUE ENDIF end if ! ! If requested, read in the solution. if ( JOB > 1 ) THEN ! ! Check to see if solution is in the file. if ( ISOLN == 1 ) THEN JOBRET = JOBRET + 2 READ(IUNIT,1020) (SOLN(I),I=1,N) ELSE DO 30 I = 1, N SOLN(I) = 0 30 CONTINUE ENDIF end if ! JOB = JOBRET return 1000 FORMAT(5I10) 1010 FORMAT(1X,I5,1X,I5,1X,E16.7) 1020 FORMAT(1X,E16.7) !------------- LAST LINE OF STIN FOLLOWS ---------------------------- end subroutine STOD (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, WM, IWM, & F, JAC, RPAR, IPAR) ! !! STOD integrates a system of first order ODE's over one step for DEBDF. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DEBDF !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (STOD-S, DSTOD-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! STOD integrates a system of first order odes over one step in the ! integrator package DEBDF. ! ---------------------------------------------------------------------- ! STOD performs one step of the integration of an initial value ! problem for a system of ordinary differential equations. ! Note.. STOD is independent of the value of the iteration method ! indicator MITER, when this is /= 0, and hence is independent ! of the type of chord method used, or the Jacobian structure. ! Communication with STOD is done with the following variables.. ! ! Y = An array of length >= n used as the Y argument in ! all calls to F and JAC. ! NEQ = Integer array containing problem size in NEQ(1), and ! passed as the NEQ argument in all calls to F and JAC. ! YH = An NYH by LMAX array containing the dependent variables ! and their approximate scaled derivatives, where ! LMAX = MAXORD + 1. YH(I,J+1) contains the approximate ! J-th derivative of Y(I), scaled by H**J/Factorial(j) ! (J = 0,1,...,NQ). On entry for the first step, the first ! two columns of YH must be set from the initial values. ! NYH = A constant integer >= N, the first dimension of YH. ! YH1 = A one-dimensional array occupying the same space as YH. ! EWT = An array of N elements with which the estimated local ! errors in YH are compared. ! SAVF = An array of working storage, of length N. ! ACOR = A work array of length N, used for the accumulated ! corrections. On a successful return, ACOR(I) contains ! the estimated one-step local error in Y(I). ! WM,IWM = Real and integer work arrays associated with matrix ! operations in chord iteration (MITER /= 0). ! PJAC = Name of routine to evaluate and preprocess Jacobian matrix ! if a chord method is being used. ! SLVS = Name of routine to solve linear system in chord iteration. ! H = The step size to be attempted on the next step. ! H is altered by the error control algorithm during the ! problem. H can be either positive or negative, but its ! sign must remain constant throughout the problem. ! HMIN = The minimum absolute value of the step size H to be used. ! HMXI = Inverse of the maximum absolute value of H to be used. ! HMXI = 0.0 is allowed and corresponds to an infinite HMAX. ! HMIN and HMXI may be changed at any time, but will not ! take effect until the next change of H is considered. ! TN = The independent variable. TN is updated on each step taken. ! JSTART = An integer used for input only, with the following ! values and meanings.. ! 0 Perform the first step. ! > 0 Take a new step continuing from the last. ! -1 Take the next step with a new value of H, MAXORD, ! N, METH, MITER, and/or matrix parameters. ! -2 Take the next step with a new value of H, ! but with other inputs unchanged. ! On return, JSTART is set to 1 to facilitate continuation. ! KFLAG = a completion code with the following meanings.. ! 0 The step was successful. ! -1 The requested error could not be achieved. ! -2 Corrector convergence could not be achieved. ! A return with KFLAG = -1 or -2 means either ! ABS(H) = HMIN or 10 consecutive failures occurred. ! On a return with KFLAG negative, the values of TN and ! the YH array are as of the beginning of the last ! step, and H is the last step size attempted. ! MAXORD = The maximum order of integration method to be allowed. ! METH/MITER = The method flags. See description in driver. ! N = The number of first-order differential equations. ! ---------------------------------------------------------------------- ! !***SEE ALSO DEBDF !***ROUTINES CALLED CFOD, PJAC, SLVS, VNWRMS !***COMMON BLOCKS DEBDF1 !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) ! 920422 Changed DIMENSION statement. (WRB) !***END PROLOGUE STOD EXTERNAL F, JAC ! !LLL. OPTIMIZE INTEGER NEQ, NYH, IWM, I, I1, IALTH, IER, IOWND, IREDO, IRET, & IPUP, J, JB, JSTART, KFLAG, L, LMAX, M, MAXORD, MEO, METH, & MITER, N, NCF, NEWQ, NFE, NJE, NQ, NQNYH, NQU, NST, NSTEPJ REAL Y, YH, YH1, EWT, SAVF, ACOR, WM, & ROWND, CONIT, CRATE, EL, ELCO, HOLD, RC, RMAX, TESCO, & EL0, H, HMIN, HMXI, HU, TN, UROUND, & DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, & R, RH, RHDN, RHSM, RHUP, TOLD, VNWRMS DIMENSION Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), & ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*) COMMON /DEBDF1/ ROWND, CONIT, CRATE, EL(13), ELCO(13,12), & HOLD, RC, RMAX, TESCO(3,12), & EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(7), KSTEPS, IOD(6), & IALTH, IPUP, LMAX, MEO, NQNYH, NSTEPJ, & IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, & NJE, NQU ! ! !***FIRST EXECUTABLE STATEMENT STOD KFLAG = 0 TOLD = TN NCF = 0 if (JSTART > 0) go to 200 if (JSTART == -1) go to 100 if (JSTART == -2) go to 160 !----------------------------------------------------------------------- ! ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE ! INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED ! IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL ! INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. if A FAILURE ! OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 ! FOR THE NEXT INCREASE. !----------------------------------------------------------------------- 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 !----------------------------------------------------------------------- ! THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. ! IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE. ! if AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), ! IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. ! if THE CALLER HAS CHANGED METH, CFOD IS CALLED TO RESET ! THE COEFFICIENTS OF THE METHOD. ! if THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT ! ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. ! if H IS TO BE CHANGED, YH MUST BE RESCALED. ! if H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 ! TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. !----------------------------------------------------------------------- 100 IPUP = MITER LMAX = MAXORD + 1 if (IALTH == 1) IALTH = 2 if (METH == MEO) go to 110 call CFOD (METH, ELCO, TESCO) MEO = METH if (NQ > MAXORD) go to 120 IALTH = L IRET = 1 go to 150 110 if (NQ <= 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/(NQ+2) DDN = VNWRMS (N, SAVF, EWT)/TESCO(1,L) EXDN = 1.0E0/L RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0) RH = MIN(RHDN,1.0E0) IREDO = 3 if (H == HOLD) go to 170 RH = MIN(RH,ABS(H/HOLD)) H = HOLD go to 175 !----------------------------------------------------------------------- ! CFOD IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE ! CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET ! WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. !----------------------------------------------------------------------- 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/(NQ+2) go to (160, 170, 200), IRET !----------------------------------------------------------------------- ! if H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST ! RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO ! L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS ! FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. !----------------------------------------------------------------------- 160 if (H == HOLD) go to 200 RH = H/HOLD H = HOLD IREDO = 3 go to 175 170 RH = MAX(RH,HMIN/ABS(H)) 175 RH = MIN(RH,RMAX) RH = RH/MAX(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 == 0) go to 680 !----------------------------------------------------------------------- ! THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY ! MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. ! RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). ! WHEN RC DIFFERS FROM 1 BY MORE THAN 30 PERCENT, IPUP IS SET TO MITER ! TO FORCE PJAC TO BE CALLED, if A JACOBIAN IS INVOLVED. ! IN ANY CASE, PJAC IS CALLED AT LEAST EVERY 20-TH STEP. !----------------------------------------------------------------------- 200 if (ABS(RC-1.0E0) > 0.3E0) IPUP = MITER if (NST >= NSTEPJ+20) IPUP = MITER TN = TN + H I1 = NQNYH + 1 DO 215 JB = 1,NQ I1 = I1 - NYH DO 210 I = I1,NQNYH 210 YH1(I) = YH1(I) + YH1(I+NYH) 215 CONTINUE KSTEPS = KSTEPS + 1 !----------------------------------------------------------------------- ! UP TO 3 CORRECTOR ITERATIONS ARE TAKEN. A CONVERGENCE TEST IS ! MADE ON THE R.M.S. NORM OF EACH CORRECTION, WEIGHTED BY THE ERROR ! WEIGHT VECTOR EWT. THE SUM OF THE CORRECTIONS IS ACCUMULATED IN THE ! VECTOR ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. !----------------------------------------------------------------------- 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 <= 0) go to 250 !----------------------------------------------------------------------- ! if INDICATED, THE MATRIX P = I - H*EL(1)*J IS REEVALUATED AND ! PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. IPUP IS SET ! TO 0 AS AN INDICATOR THAT THIS HAS BEEN DONE. !----------------------------------------------------------------------- IPUP = 0 RC = 1.0E0 NSTEPJ = NST CRATE = 0.7E0 call PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, & RPAR, IPAR) if (IER /= 0) go to 430 250 DO 260 I = 1,N 260 ACOR(I) = 0.0E0 270 if (MITER /= 0) go to 350 !----------------------------------------------------------------------- ! IN THE CASE OF FUNCTIONAL ITERATION, UPDATE Y DIRECTLY FROM ! THE RESULT OF THE LAST FUNCTION EVALUATION. !----------------------------------------------------------------------- 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 !----------------------------------------------------------------------- ! IN THE CASE OF THE CHORD METHOD, COMPUTE THE CORRECTOR ERROR, ! AND SOLVE THE LINEAR SYSTEM WITH THAT AS RIGHT-HAND SIDE AND ! P AS COEFFICIENT MATRIX. !----------------------------------------------------------------------- 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 /= 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) !----------------------------------------------------------------------- ! TEST FOR CONVERGENCE. if M > 0, AN ESTIMATE OF THE CONVERGENCE ! RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. !----------------------------------------------------------------------- 400 if (M /= 0) CRATE = MAX(0.2E0*CRATE,DEL/DELP) DCON = DEL*MIN(1.0E0,1.5E0*CRATE)/(TESCO(2,NQ)*CONIT) if (DCON <= 1.0E0) go to 450 M = M + 1 if (M == 3) go to 410 if (M >= 2 .AND. DEL > 2.0E0*DELP) go to 410 DELP = DEL call F (TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 go to 270 !----------------------------------------------------------------------- ! THE CORRECTOR ITERATION FAILED TO CONVERGE IN 3 TRIES. ! if MITER /= 0 AND THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR ! THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES ! BEFORE PREDICTION, AND H IS REDUCED, if POSSIBLE. IF H CANNOT BE ! REDUCED OR 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2. !----------------------------------------------------------------------- 410 if (IPUP == 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 440 YH1(I) = YH1(I) - YH1(I+NYH) 445 CONTINUE if (ABS(H) <= HMIN*1.00001E0) go to 670 if (NCF == 10) go to 670 RH = 0.25E0 IPUP = MITER IREDO = 1 go to 170 !----------------------------------------------------------------------- ! THE CORRECTOR HAS CONVERGED. IPUP IS SET TO -1 if MITER /= 0, ! TO SIGNAL THAT THE JACOBIAN INVOLVED MAY NEED UPDATING LATER. ! THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 ! if IT FAILS. !----------------------------------------------------------------------- 450 if (MITER /= 0) IPUP = -1 if (M == 0) DSM = DEL/TESCO(2,NQ) if (M > 0) DSM = VNWRMS (N, ACOR, EWT)/TESCO(2,NQ) if (DSM > 1.0E0) go to 500 !----------------------------------------------------------------------- ! AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. ! CONSIDER CHANGING H if IALTH = 1. OTHERWISE DECREASE IALTH BY 1. ! if IALTH IS THEN 1 AND NQ < MAXORD, THEN ACOR IS SAVED FOR ! USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. ! if A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER ! BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY if IT IS BY A ! FACTOR OF AT LEAST 1.1. if NOT, IALTH IS SET TO 3 TO PREVENT ! TESTING FOR THAT MANY STEPS. !----------------------------------------------------------------------- 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 == 0) go to 520 if (IALTH > 1) go to 690 if (L == LMAX) go to 690 DO 490 I = 1,N 490 YH(I,LMAX) = ACOR(I) go to 690 !----------------------------------------------------------------------- ! THE ERROR TEST FAILED. KFLAG KEEPS TRACK OF MULTIPLE FAILURES. ! RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE ! TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR ! ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE ! BY A FACTOR OF 0.2 OR LESS. !----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 TN = TOLD I1 = NQNYH + 1 DO 515 JB = 1,NQ I1 = I1 - NYH DO 510 I = I1,NQNYH 510 YH1(I) = YH1(I) - YH1(I+NYH) 515 CONTINUE RMAX = 2.0E0 if (ABS(H) <= HMIN*1.00001E0) go to 660 if (KFLAG <= -3) go to 640 IREDO = 2 RHUP = 0.0E0 go to 540 !----------------------------------------------------------------------- ! REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS ! RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED ! AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. ! IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. ! THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN ! ACCORDINGLY. if THE ORDER IS TO BE INCREASED, WE COMPUTE ONE ! ADDITIONAL SCALED DERIVATIVE. !----------------------------------------------------------------------- 520 RHUP = 0.0E0 if (L == 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/(L+1) RHUP = 1.0E0/(1.4E0*DUP**EXUP + 0.0000014E0) 540 EXSM = 1.0E0/L RHSM = 1.0E0/(1.2E0*DSM**EXSM + 0.0000012E0) RHDN = 0.0E0 if (NQ == 1) go to 560 DDN = VNWRMS (N, YH(1,L), EWT)/TESCO(1,NQ) EXDN = 1.0E0/NQ RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0) 560 if (RHSM >= RHUP) go to 570 if (RHUP > RHDN) go to 590 go to 580 570 if (RHSM < RHDN) go to 580 NEWQ = NQ RH = RHSM go to 620 580 NEWQ = NQ - 1 RH = RHDN if (KFLAG < 0 .AND. RH > 1.0E0) RH = 1.0E0 go to 620 590 NEWQ = L RH = RHUP if (RH < 1.1E0) go to 610 R = EL(L)/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 == 0) .AND. (RH < 1.1E0)) go to 610 if (KFLAG <= -2) RH = MIN(RH,0.2E0) !----------------------------------------------------------------------- ! if THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. ! IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. ! THEN EXIT FROM 680 if THE STEP WAS OK, OR REDO THE STEP OTHERWISE. !----------------------------------------------------------------------- if (NEWQ == NQ) go to 170 630 NQ = NEWQ L = NQ + 1 IRET = 2 go to 150 !----------------------------------------------------------------------- ! CONTROL REACHES THIS SECTION if 3 OR MORE FAILURES HAVE OCCURRED. ! if 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -1. ! IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE ! YH ARRAY HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST ! DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1. THEN ! H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED, ! UNTIL IT SUCCEEDS OR H REACHES HMIN. !----------------------------------------------------------------------- 640 if (KFLAG == -10) go to 660 RH = 0.1E0 RH = MAX(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 == 1) go to 200 NQ = 1 L = 2 IRET = 3 go to 150 !----------------------------------------------------------------------- ! ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD ! TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. !----------------------------------------------------------------------- 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 !----------------------- END OF SUBROUTINE STOD ----------------------- end subroutine STOR1 (U, YH, V, YP, NTEMP, NDISK, NTAPE) ! !! STOR1 is subsidiary to BVSUP. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (STOR1-S, DSTOR1-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! ********************************************************************** ! 0 -- Storage at output points. ! NTEMP = ! 1 -- Temporary storage ! ********************************************************************** ! !***SEE ALSO BVSUP !***ROUTINES CALLED (NONE) !***COMMON BLOCKS ML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE STOR1 DIMENSION U(*),YH(*),V(*),YP(*) ! ! ********************************************************************** ! COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC ! ! ********************************************************************** ! !***FIRST EXECUTABLE STATEMENT STOR1 NCTNF = NCOMP * NFC DO 10 J = 1,NCTNF 10 U(J) = YH(J) if (INHOMO == 1) go to 30 ! ! ZERO PARTICULAR SOLUTION ! if (NTEMP == 1) return DO 20 J = 1,NCOMP 20 V(J) = 0. go to 70 ! ! NONZERO PARTICULAR SOLUTION ! 30 if (NTEMP == 0) go to 50 ! DO 40 J = 1,NCOMP 40 V(J) = YP(J) return ! 50 DO 60 J = 1,NCOMP 60 V(J) = C * YP(J) ! ! IS OUTPUT INFORMATION TO BE WRITTEN TO DISK ! 70 if (NDISK == 1) WRITE (NTAPE) (V(J),J=1,NCOMP),(U(J),J=1,NCTNF) ! return end subroutine STOUT (N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB) ! !! STOUT writes out SLAP Triad Format Linear System. ! Routine to write out a SLAP Triad format matrix and right ! hand side and solution to the system, if known. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY N1 !***TYPE SINGLE PRECISION (STOUT-S, DTOUT-D) !***KEYWORDS DIAGNOSTICS, LINEAR SYSTEM, SLAP SPARSE !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-60 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, IUNIT, JOB ! REAL A(NELT), SOLN(N), RHS(N) ! ! call STOUT( N, NELT, IA, JA, A, ISYM, SOLN, RHS, IUNIT, JOB ) ! ! *Arguments: ! N :IN Integer ! Order of the Matrix. ! NELT :IN Integer. ! Number of non-zeros stored in A. ! IA :IN Integer IA(NELT). ! JA :IN Integer JA(NELT). ! A :IN Real A(NELT). ! These arrays should hold the matrix A in the SLAP ! Triad format. See "Description", below. ! ISYM :IN Integer. ! Flag to indicate symmetric storage format. ! If ISYM=0, all non-zero entries of the matrix are stored. ! If ISYM=1, the matrix is symmetric, and only the lower ! triangle of the matrix is stored. ! SOLN :IN Real SOLN(N). ! The solution to the linear system, if known. This array ! is accessed if and only if JOB is set to print it out, ! see below. ! RHS :IN Real RHS(N). ! The right hand side vector. This array is accessed if and ! only if JOB is set to print it out, see below. ! IUNIT :IN Integer. ! Fortran logical I/O device unit number to write the matrix ! to. This unit must be connected in a system dependent fashion ! to a file or the console or you will get a nasty message ! from the Fortran I/O libraries. ! JOB :IN Integer. ! Flag indicating what I/O operations to perform. ! JOB = 0 => Print only the matrix. ! = 1 => Print matrix and RHS. ! = 2 => Print matrix and SOLN. ! = 3 => Print matrix, RHS and SOLN. ! ! *Description: ! The format for the output is as follows. On the first line ! are counters and flags: N, NELT, ISYM, IRHS, ISOLN. N, NELT ! and ISYM are described above. IRHS is a flag indicating if ! the RHS was written out (1 is yes, 0 is no). ISOLN is a ! flag indicating if the SOLN was written out (1 is yes, 0 is ! no). The format for the fist line is: 5i10. Then comes the ! NELT Triad's IA(I), JA(I) and A(I), I = 1, NELT. The format ! for these lines is : 1X,I5,1X,I5,1X,E16.7. Then comes ! RHS(I), I = 1, N, if IRHS = 1. Then comes SOLN(I), I = 1, ! N, if ISOLN = 1. The format for these lines is: 1X,E16.7. ! ! =================== S L A P Triad format =================== ! This routine requires that the matrix A be stored in the ! SLAP Triad format. In this format only the non-zeros are ! stored. They may appear in *ANY* order. The user supplies ! three arrays of length NELT, where NELT is the number of ! non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)). For ! each non-zero the user puts the row and column index of that ! matrix element in the IA and JA arrays. The value of the ! non-zero matrix element is placed in the corresponding ! location of the A array. This is an extremely easy data ! structure to generate. On the other hand it is not too ! efficient on vector computers for the iterative solution of ! linear systems. Hence, SLAP changes this input data ! structure to the SLAP Column format for the iteration (but ! does not change it back). ! ! Here is an example of the SLAP Triad storage format for a ! 5x5 Matrix. Recall that the entries may appear in any order. ! ! 5x5 Matrix SLAP Triad format for 5x5 matrix on left. ! 1 2 3 4 5 6 7 8 91011 ! |1112 0 015| A: 5112113315535522354421 ! |2122 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 ! | 0 033 035| JA: 1 2 1 3 5 3 5 2 5 4 1 ! | 0 0 044 0| ! |51 053 055| ! ! *Cautions: ! This routine will attempt to write to the Fortran logical output ! unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that ! this logical unit is attached to a file or terminal before calling ! this routine with a non-zero value for IUNIT. This routine does ! not check for the validity of a non-zero IUNIT unit number. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 920511 Added complete declaration section. (WRB) ! 930701 Updated CATEGORY section. (FNF, WRB) !***END PROLOGUE STOUT ! .. Scalar Arguments .. INTEGER ISYM, IUNIT, JOB, N, NELT ! .. Array Arguments .. REAL A(NELT), RHS(N), SOLN(N) INTEGER IA(NELT), JA(NELT) ! .. Local Scalars .. INTEGER I, IRHS, ISOLN !***FIRST EXECUTABLE STATEMENT STOUT ! ! If RHS and SOLN are to be printed also. ! Write out the information heading. ! IRHS = 0 ISOLN = 0 if ( JOB == 1 .OR. JOB == 3 ) IRHS = 1 if ( JOB > 1 ) ISOLN = 1 WRITE(IUNIT,1000) N, NELT, ISYM, IRHS, ISOLN ! ! Write out the matrix non-zeros in Triad format. DO 10 I = 1, NELT WRITE(IUNIT,1010) IA(I), JA(I), A(I) 10 CONTINUE ! ! If requested, write out the rhs. if ( IRHS == 1 ) THEN WRITE(IUNIT,1020) (RHS(I),I=1,N) end if ! ! If requested, write out the solution. if ( ISOLN == 1 ) THEN WRITE(IUNIT,1020) (SOLN(I),I=1,N) end if return 1000 FORMAT(5I10) 1010 FORMAT(1X,I5,1X,I5,1X,E16.7) 1020 FORMAT(1X,E16.7) !------------- LAST LINE OF STOUT FOLLOWS ---------------------------- end subroutine STPMV (UPLO, TRANS, DIAG, N, AP, X, INCX) ! !! STPMV performs x = A*x or x = A'*x for triangular A. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (STPMV-S, DTPMV-D, CTPMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! STPMV performs one of the matrix-vector operations ! ! x := A*x, or x := A'*x, ! ! where x is an n element vector and A is an n by n unit, or non-unit, ! upper or lower triangular matrix, supplied in packed form. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' x := A*x. ! ! TRANS = 'T' or 't' x := A'*x. ! ! TRANS = 'C' or 'c' x := A'*x. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! AP - REAL array of DIMENSION at least ! ( ( n*( n + 1))/2). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) ! respectively, and so on. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) ! respectively, and so on. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced, but are assumed to be unity. ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. On exit, X is overwritten with the ! transformed vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE STPMV ! .. Scalar Arguments .. INTEGER INCX, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. REAL AP( * ), X( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA !***FIRST EXECUTABLE STATEMENT STPMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( INCX == 0 )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'STPMV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x:= A*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK =1 if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = X( J ) K = KK DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*AP( K ) K = K + 1 10 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*AP( KK + J - 1 ) end if KK = KK + J 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 30, K = KK, KK + J - 2 X( IX ) = X( IX ) + TEMP*AP( K ) IX = IX + INCX 30 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*AP( KK + J - 1 ) end if JX = JX + INCX KK = KK + J 40 CONTINUE end if ELSE KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 60, J = N, 1, -1 if ( X( J ) /= ZERO )THEN TEMP = X( J ) K = KK DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*AP( K ) K = K - 1 50 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*AP( KK - N + J ) end if KK = KK - ( N - J + 1 ) 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 X( IX ) = X( IX ) + TEMP*AP( K ) IX = IX - INCX 70 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*AP( KK - N + J ) end if JX = JX - INCX KK = KK - ( N - J + 1 ) 80 CONTINUE end if end if ELSE ! ! Form x := A'*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) if ( NOUNIT ) & TEMP = TEMP*AP( KK ) K = KK - 1 DO 90, I = J - 1, 1, -1 TEMP = TEMP + AP( K )*X( I ) K = K - 1 90 CONTINUE X( J ) = TEMP KK = KK - J 100 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 120, J = N, 1, -1 TEMP = X( JX ) IX = JX if ( NOUNIT ) & TEMP = TEMP*AP( KK ) DO 110, K = KK - 1, KK - J + 1, -1 IX = IX - INCX TEMP = TEMP + AP( K )*X( IX ) 110 CONTINUE X( JX ) = TEMP JX = JX - INCX KK = KK - J 120 CONTINUE end if ELSE KK = 1 if ( INCX == 1 )THEN DO 140, J = 1, N TEMP = X( J ) if ( NOUNIT ) & TEMP = TEMP*AP( KK ) K = KK + 1 DO 130, I = J + 1, N TEMP = TEMP + AP( K )*X( I ) K = K + 1 130 CONTINUE X( J ) = TEMP KK = KK + ( N - J + 1 ) 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) IX = JX if ( NOUNIT ) & TEMP = TEMP*AP( KK ) DO 150, K = KK + 1, KK + N - J IX = IX + INCX TEMP = TEMP + AP( K )*X( IX ) 150 CONTINUE X( JX ) = TEMP JX = JX + INCX KK = KK + ( N - J + 1 ) 160 CONTINUE end if end if end if ! return ! ! End of STPMV . ! end subroutine STPSV (UPLO, TRANS, DIAG, N, AP, X, INCX) ! !! STPSV solves a triangular system of linear equations. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (STPSV-S, DTPSV-D, CTPSV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! STPSV solves one of the systems of equations ! ! A*x = b, or A'*x = b, ! ! where b and x are n element vectors and A is an n by n unit, or ! non-unit, upper or lower triangular matrix, supplied in packed form. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the equations to be solved as ! follows: ! ! TRANS = 'N' or 'n' A*x = b. ! ! TRANS = 'T' or 't' A'*x = b. ! ! TRANS = 'C' or 'c' A'*x = b. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! AP - REAL array of DIMENSION at least ! ( ( n*( n + 1))/2). ! Before entry with UPLO = 'U' or 'u', the array AP must ! contain the upper triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) ! respectively, and so on. ! Before entry with UPLO = 'L' or 'l', the array AP must ! contain the lower triangular matrix packed sequentially, ! column by column, so that AP( 1 ) contains a( 1, 1 ), ! AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) ! respectively, and so on. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced, but are assumed to be unity. ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element right-hand side vector b. On exit, X is overwritten ! with the solution vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE STPSV ! .. Scalar Arguments .. INTEGER INCX, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. REAL AP( * ), X( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA !***FIRST EXECUTABLE STATEMENT STPSV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( INCX == 0 )THEN INFO = 7 end if if ( INFO /= 0 )THEN call XERBLA( 'STPSV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of AP are ! accessed sequentially with one pass through AP. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := inv( A )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 20, J = N, 1, -1 if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/AP( KK ) TEMP = X( J ) K = KK - 1 DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*AP( K ) K = K - 1 10 CONTINUE end if KK = KK - J 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/AP( KK ) TEMP = X( JX ) IX = JX DO 30, K = KK - 1, KK - J + 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*AP( K ) 30 CONTINUE end if JX = JX - INCX KK = KK - J 40 CONTINUE end if ELSE KK = 1 if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/AP( KK ) TEMP = X( J ) K = KK + 1 DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*AP( K ) K = K + 1 50 CONTINUE end if KK = KK + ( N - J + 1 ) 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/AP( KK ) TEMP = X( JX ) IX = JX DO 70, K = KK + 1, KK + N - J IX = IX + INCX X( IX ) = X( IX ) - TEMP*AP( K ) 70 CONTINUE end if JX = JX + INCX KK = KK + ( N - J + 1 ) 80 CONTINUE end if end if ELSE ! ! Form x := inv( A' )*x. ! if ( LSAME( UPLO, 'U' ) )THEN KK = 1 if ( INCX == 1 )THEN DO 100, J = 1, N TEMP = X( J ) K = KK DO 90, I = 1, J - 1 TEMP = TEMP - AP( K )*X( I ) K = K + 1 90 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK + J - 1 ) X( J ) = TEMP KK = KK + J 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX DO 110, K = KK, KK + J - 2 TEMP = TEMP - AP( K )*X( IX ) IX = IX + INCX 110 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK + J - 1 ) X( JX ) = TEMP JX = JX + INCX KK = KK + J 120 CONTINUE end if ELSE KK = ( N*( N + 1 ) )/2 if ( INCX == 1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) K = KK DO 130, I = N, J + 1, -1 TEMP = TEMP - AP( K )*X( I ) K = K - 1 130 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK - N + J ) X( J ) = TEMP KK = KK - ( N - J + 1 ) 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1 TEMP = TEMP - AP( K )*X( IX ) IX = IX - INCX 150 CONTINUE if ( NOUNIT ) & TEMP = TEMP/AP( KK - N + J ) X( JX ) = TEMP JX = JX - INCX KK = KK - (N - J + 1 ) 160 CONTINUE end if end if end if ! return ! ! End of STPSV . ! end subroutine STRCO (T, LDT, N, RCOND, Z, JOB) ! !! STRCO estimates the condition number of a triangular matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A3 !***TYPE SINGLE PRECISION (STRCO-S, DTRCO-D, CTRCO-C) !***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, ! TRIANGULAR MATRIX !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! STRCO estimates the condition of a real triangular matrix. ! ! On Entry ! ! T REAL(LDT,N) ! T contains the triangular matrix. The zero ! elements of the matrix are not referenced, and ! the corresponding elements of the array can be ! used to store other information. ! ! LDT INTEGER ! LDT is the leading dimension of the array T. ! ! N INTEGER ! N is the order of the system. ! ! JOB INTEGER ! = 0 T is lower triangular. ! = nonzero T is upper triangular. ! ! On Return ! ! RCOND REAL ! an estimate of the reciprocal condition of T . ! For the system T*X = B , relative perturbations ! in T and B of size EPSILON may cause ! relative perturbations in X of size EPSILON/RCOND . ! If RCOND is so small that the logical expression ! 1.0 + RCOND == 1.0 ! is true, then T may be singular to working ! precision. In particular, RCOND is zero if ! exact singularity is detected or the estimate ! underflows. ! ! Z REAL(N) ! a work vector whose contents are usually unimportant. ! If T is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SASUM, SAXPY, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE STRCO INTEGER LDT,N,JOB REAL T(LDT,*),Z(*) REAL RCOND ! REAL W,WK,WKM,EK REAL TNORM,YNORM,S,SM,SASUM INTEGER I1,J,J1,J2,K,KK,L LOGICAL LOWER !***FIRST EXECUTABLE STATEMENT STRCO LOWER = JOB == 0 ! ! COMPUTE 1-NORM OF T ! TNORM = 0.0E0 DO 10 J = 1, N L = J if (LOWER) L = N + 1 - J I1 = 1 if (LOWER) I1 = J TNORM = MAX(TNORM,SASUM(L,T(I1,J),1)) 10 CONTINUE ! ! RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . ! ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . ! TRANS(T) IS THE TRANSPOSE OF T . ! THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL ! GROWTH IN THE ELEMENTS OF Y . ! THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. ! ! SOLVE TRANS(T)*Y = E ! EK = 1.0E0 DO 20 J = 1, N Z(J) = 0.0E0 20 CONTINUE DO 100 KK = 1, N K = KK if (LOWER) K = N + 1 - KK if (Z(K) /= 0.0E0) EK = SIGN(EK,-Z(K)) if (ABS(EK-Z(K)) <= ABS(T(K,K))) go to 30 S = ABS(T(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 (T(K,K) == 0.0E0) go to 40 WK = WK/T(K,K) WKM = WKM/T(K,K) go to 50 40 CONTINUE WK = 1.0E0 WKM = 1.0E0 50 CONTINUE if (KK == N) go to 90 J1 = K + 1 if (LOWER) J1 = 1 J2 = N if (LOWER) J2 = K - 1 DO 60 J = J1, J2 SM = SM + ABS(Z(J)+WKM*T(K,J)) Z(J) = Z(J) + WK*T(K,J) S = S + ABS(Z(J)) 60 CONTINUE if (S >= SM) go to 80 W = WKM - WK WK = WKM DO 70 J = J1, J2 Z(J) = Z(J) + W*T(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) ! YNORM = 1.0E0 ! ! SOLVE T*Z = Y ! DO 130 KK = 1, N K = N + 1 - KK if (LOWER) K = KK if (ABS(Z(K)) <= ABS(T(K,K))) go to 110 S = ABS(T(K,K))/ABS(Z(K)) call SSCAL(N,S,Z,1) YNORM = S*YNORM 110 CONTINUE if (T(K,K) /= 0.0E0) Z(K) = Z(K)/T(K,K) if (T(K,K) == 0.0E0) Z(K) = 1.0E0 I1 = 1 if (LOWER) I1 = K + 1 if (KK >= N) go to 120 W = -Z(K) call SAXPY(N-KK,W,T(I1,K),1,Z(I1),1) 120 CONTINUE 130 CONTINUE ! MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) call SSCAL(N,S,Z,1) YNORM = S*YNORM ! if (TNORM /= 0.0E0) RCOND = YNORM/TNORM if (TNORM == 0.0E0) RCOND = 0.0E0 return end subroutine STRDI (T, LDT, N, DET, JOB, INFO) ! !! STRDI computes the determinant and inverse of a triangular matrix. ! !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A3, D3A3 !***TYPE SINGLE PRECISION (STRDI-S, DTRDI-D, CTRDI-C) !***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, ! TRIANGULAR !***AUTHOR Moler, C. B., (U. of New Mexico) !***DESCRIPTION ! ! STRDI computes the determinant and inverse of a real ! triangular matrix. ! ! On Entry ! ! T REAL(LDT,N) ! T contains the triangular matrix. The zero ! elements of the matrix are not referenced, and ! the corresponding elements of the array can be ! used to store other information. ! ! LDT INTEGER ! LDT is the leading dimension of the array T. ! ! N INTEGER ! N is the order of the system. ! ! JOB INTEGER ! = 010 no det, inverse of lower triangular. ! = 011 no det, inverse of upper triangular. ! = 100 det, no inverse. ! = 110 det, inverse of lower triangular. ! = 111 det, inverse of upper triangular. ! ! On Return ! ! T inverse of original matrix if requested. ! Otherwise unchanged. ! ! DET REAL(2) ! determinant of original matrix if requested. ! Otherwise not referenced. ! Determinant = DET(1) * 10.0**DET(2) ! with 1.0 <= ABS(DET(1)) < 10.0 ! or DET(1) == 0.0 . ! ! INFO INTEGER ! INFO contains zero if the system is nonsingular ! and the inverse is requested. ! Otherwise INFO contains the index of ! a zero diagonal element of T. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SSCAL !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE STRDI INTEGER LDT,N,JOB,INFO REAL T(LDT,*),DET(2) ! REAL TEMP REAL TEN INTEGER I,J,K,KB,KM1,KP1 !***FIRST EXECUTABLE STATEMENT STRDI ! ! COMPUTE DETERMINANT ! if (JOB/100 == 0) go to 70 DET(1) = 1.0E0 DET(2) = 0.0E0 TEN = 10.0E0 DO 50 I = 1, N DET(1) = T(I,I)*DET(1) if (DET(1) == 0.0E0) go to 60 10 if (ABS(DET(1)) >= 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)) < 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 ! ! COMPUTE INVERSE OF UPPER TRIANGULAR ! if (MOD(JOB/10,10) == 0) go to 170 if (MOD(JOB,10) == 0) go to 120 DO 100 K = 1, N INFO = K if (T(K,K) == 0.0E0) go to 110 T(K,K) = 1.0E0/T(K,K) TEMP = -T(K,K) call SSCAL(K-1,TEMP,T(1,K),1) KP1 = K + 1 if (N < KP1) go to 90 DO 80 J = KP1, N TEMP = T(K,J) T(K,J) = 0.0E0 call SAXPY(K,TEMP,T(1,K),1,T(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE INFO = 0 110 CONTINUE go to 160 120 CONTINUE ! ! COMPUTE INVERSE OF LOWER TRIANGULAR ! DO 150 KB = 1, N K = N + 1 - KB INFO = K if (T(K,K) == 0.0E0) go to 180 T(K,K) = 1.0E0/T(K,K) TEMP = -T(K,K) if (K /= N) call SSCAL(N-K,TEMP,T(K+1,K),1) KM1 = K - 1 if (KM1 < 1) go to 140 DO 130 J = 1, KM1 TEMP = T(K,J) T(K,J) = 0.0E0 call SAXPY(N-K+1,TEMP,T(K,K),1,T(K,J),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE INFO = 0 160 CONTINUE 170 CONTINUE 180 CONTINUE return end subroutine STRMM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, & B, LDB) ! !! STRMM multiplies a real general matrix by a real triangular matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE SINGLE PRECISION (STRMM-S, DTRMM-D, CTRMM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! STRMM performs one of the matrix-matrix operations ! ! B := alpha*op( A )*B, or B := alpha*B*op( A ), ! ! where alpha is a scalar, B is an m by n matrix, A is a unit, or ! non-unit, upper or lower triangular matrix and op( A ) is one of ! ! op( A ) = A or op( A ) = A'. ! ! Parameters ! ========== ! ! SIDE - CHARACTER*1. ! On entry, SIDE specifies whether op( A ) multiplies B from ! the left or right as follows: ! ! SIDE = 'L' or 'l' B := alpha*op( A )*B. ! ! SIDE = 'R' or 'r' B := alpha*B*op( A ). ! ! Unchanged on exit. ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix A is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANSA - CHARACTER*1. ! On entry, TRANSA specifies the form of op( A ) to be used in ! the matrix multiplication as follows: ! ! TRANSA = 'N' or 'n' op( A ) = A. ! ! TRANSA = 'T' or 't' op( A ) = A'. ! ! TRANSA = 'C' or 'c' op( A ) = A'. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit triangular ! as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of B. M must be at ! least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of B. N must be ! at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. When alpha is ! zero then A is not referenced and B need not be set before ! entry. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, k ), where k is m ! when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. ! Before entry with UPLO = 'U' or 'u', the leading k by k ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading k by k ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When SIDE = 'L' or 'l' then ! LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' ! then LDA must be at least max( 1, n ). ! Unchanged on exit. ! ! B - REAL array of DIMENSION ( LDB, n ). ! Before entry, the leading m by n part of the array B must ! contain the matrix B, and on exit is overwritten by the ! transformed matrix. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. LDB must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE STRMM ! .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB REAL ALPHA ! .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ) ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA REAL TEMP ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) !***FIRST EXECUTABLE STATEMENT STRMM ! ! Test the input parameters. ! LSIDE = LSAME( SIDE , 'L' ) if ( LSIDE )THEN NROWA = M ELSE NROWA = N end if NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) ! INFO = 0 if ( ( .NOT.LSIDE ).AND. & ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE if ( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. & ( .NOT.LSAME( TRANSA, 'T' ) ).AND. & ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE if ( ( .NOT.LSAME( DIAG , 'U' ) ).AND. & ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE if ( M < 0 )THEN INFO = 5 ELSE if ( N < 0 )THEN INFO = 6 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 9 ELSE if ( LDB < MAX( 1, M ) )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'STRMM ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE return end if ! ! Start the operations. ! if ( LSIDE )THEN if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*A*B. ! if ( UPPER )THEN DO 50, J = 1, N DO 40, K = 1, M if ( B( K, J ) /= ZERO )THEN TEMP = ALPHA*B( K, J ) DO 30, I = 1, K - 1 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 30 CONTINUE if ( NOUNIT ) & TEMP = TEMP*A( K, K ) B( K, J ) = TEMP end if 40 CONTINUE 50 CONTINUE ELSE DO 80, J = 1, N DO 70 K = M, 1, -1 if ( B( K, J ) /= ZERO )THEN TEMP = ALPHA*B( K, J ) B( K, J ) = TEMP if ( NOUNIT ) & B( K, J ) = B( K, J )*A( K, K ) DO 60, I = K + 1, M B( I, J ) = B( I, J ) + TEMP*A( I, K ) 60 CONTINUE end if 70 CONTINUE 80 CONTINUE end if ELSE ! ! Form B := alpha*B*A'. ! if ( UPPER )THEN DO 110, J = 1, N DO 100, I = M, 1, -1 TEMP = B( I, J ) if ( NOUNIT ) & TEMP = TEMP*A( I, I ) DO 90, K = 1, I - 1 TEMP = TEMP + A( K, I )*B( K, J ) 90 CONTINUE B( I, J ) = ALPHA*TEMP 100 CONTINUE 110 CONTINUE ELSE DO 140, J = 1, N DO 130, I = 1, M TEMP = B( I, J ) if ( NOUNIT ) & TEMP = TEMP*A( I, I ) DO 120, K = I + 1, M TEMP = TEMP + A( K, I )*B( K, J ) 120 CONTINUE B( I, J ) = ALPHA*TEMP 130 CONTINUE 140 CONTINUE end if end if ELSE if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*B*A. ! if ( UPPER )THEN DO 180, J = N, 1, -1 TEMP = ALPHA if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 150, I = 1, M B( I, J ) = TEMP*B( I, J ) 150 CONTINUE DO 170, K = 1, J - 1 if ( A( K, J ) /= ZERO )THEN TEMP = ALPHA*A( K, J ) DO 160, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 160 CONTINUE end if 170 CONTINUE 180 CONTINUE ELSE DO 220, J = 1, N TEMP = ALPHA if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 190, I = 1, M B( I, J ) = TEMP*B( I, J ) 190 CONTINUE DO 210, K = J + 1, N if ( A( K, J ) /= ZERO )THEN TEMP = ALPHA*A( K, J ) DO 200, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 200 CONTINUE end if 210 CONTINUE 220 CONTINUE end if ELSE ! ! Form B := alpha*B*A'. ! if ( UPPER )THEN DO 260, K = 1, N DO 240, J = 1, K - 1 if ( A( J, K ) /= ZERO )THEN TEMP = ALPHA*A( J, K ) DO 230, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 230 CONTINUE end if 240 CONTINUE TEMP = ALPHA if ( NOUNIT ) & TEMP = TEMP*A( K, K ) if ( TEMP /= ONE )THEN DO 250, I = 1, M B( I, K ) = TEMP*B( I, K ) 250 CONTINUE end if 260 CONTINUE ELSE DO 300, K = N, 1, -1 DO 280, J = K + 1, N if ( A( J, K ) /= ZERO )THEN TEMP = ALPHA*A( J, K ) DO 270, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 270 CONTINUE end if 280 CONTINUE TEMP = ALPHA if ( NOUNIT ) & TEMP = TEMP*A( K, K ) if ( TEMP /= ONE )THEN DO 290, I = 1, M B( I, K ) = TEMP*B( I, K ) 290 CONTINUE end if 300 CONTINUE end if end if end if ! return ! ! End of STRMM . ! end subroutine STRMV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) ! !! STRMV multiplies a real vector by a real triangular matrix. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (STRMV-S, DTRMV-D, CTRMV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! STRMV performs one of the matrix-vector operations ! ! x := A*x, or x := A'*x, ! ! where x is an n element vector and A is an n by n unit, or non-unit, ! upper or lower triangular matrix. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the operation to be performed as ! follows: ! ! TRANS = 'N' or 'n' x := A*x. ! ! TRANS = 'T' or 't' x := A'*x. ! ! TRANS = 'C' or 'c' x := A'*x. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element vector x. On exit, X is overwritten with the ! transformed vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE STRMV ! .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. REAL A( LDA, * ), X( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT STRMV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 end if if ( INFO /= 0 )THEN call XERBLA( 'STRMV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := A*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 20, J = 1, N if ( X( J ) /= ZERO )THEN TEMP = X( J ) DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*A( I, J ) 10 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( J, J ) end if 20 CONTINUE ELSE JX = KX DO 40, J = 1, N if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 30, I = 1, J - 1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX + INCX 30 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( J, J ) end if JX = JX + INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = N, 1, -1 if ( X( J ) /= ZERO )THEN TEMP = X( J ) DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*A( I, J ) 50 CONTINUE if ( NOUNIT ) & X( J ) = X( J )*A( J, J ) end if 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN TEMP = X( JX ) IX = KX DO 70, I = N, J + 1, -1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX - INCX 70 CONTINUE if ( NOUNIT ) & X( JX ) = X( JX )*A( J, J ) end if JX = JX - INCX 80 CONTINUE end if end if ELSE ! ! Form x := A'*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE X( J ) = TEMP 100 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 120, J = N, 1, -1 TEMP = X( JX ) IX = JX if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 110, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + A( I, J )*X( IX ) 110 CONTINUE X( JX ) = TEMP JX = JX - INCX 120 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 140, J = 1, N TEMP = X( J ) if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 130, I = J + 1, N TEMP = TEMP + A( I, J )*X( I ) 130 CONTINUE X( J ) = TEMP 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) IX = JX if ( NOUNIT ) & TEMP = TEMP*A( J, J ) DO 150, I = J + 1, N IX = IX + INCX TEMP = TEMP + A( I, J )*X( IX ) 150 CONTINUE X( JX ) = TEMP JX = JX + INCX 160 CONTINUE end if end if end if ! return ! ! End of STRMV . ! end subroutine STRSL (T, LDT, N, B, JOB, INFO) ! !! STRSL solves a triangular system of linear equations.] ! !***PURPOSE Solve a system of the form T*X=B or TRANS(T)*X=B, where ! T is a triangular matrix. !***LIBRARY SLATEC (LINPACK) !***CATEGORY D2A3 !***TYPE SINGLE PRECISION (STRSL-S, DTRSL-D, CTRSL-C) !***KEYWORDS LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM, ! TRIANGULAR MATRIX !***AUTHOR Stewart, G. W., (U. of Maryland) !***DESCRIPTION ! ! STRSL solves systems of the form ! ! T * X = B ! or ! TRANS(T) * X = B ! ! where T is a triangular matrix of order N. Here TRANS(T) ! denotes the transpose of the matrix T. ! ! On Entry ! ! T REAL(LDT,N) ! T contains the matrix of the system. The zero ! elements of the matrix are not referenced, and ! the corresponding elements of the array can be ! used to store other information. ! ! LDT INTEGER ! LDT is the leading dimension of the array T. ! ! N INTEGER ! N is the order of the system. ! ! B REAL(N). ! B contains the right hand side of the system. ! ! JOB INTEGER ! JOB specifies what kind of system is to be solved. ! If JOB is ! ! 00 solve T*X=B, T lower triangular, ! 01 solve T*X=B, T upper triangular, ! 10 solve TRANS(T)*X=B, T lower triangular, ! 11 solve TRANS(T)*X=B, T upper triangular. ! ! On Return ! ! B B contains the solution, if INFO == 0. ! Otherwise B is unaltered. ! ! INFO INTEGER ! INFO contains zero if the system is nonsingular. ! Otherwise INFO contains the index of ! the first zero diagonal element of T. ! !***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. ! Stewart, LINPACK Users' Guide, SIAM, 1979. !***ROUTINES CALLED SAXPY, SDOT !***REVISION HISTORY (YYMMDD) ! 780814 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900326 Removed duplicate information from DESCRIPTION section. ! (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE STRSL INTEGER LDT,N,JOB,INFO REAL T(LDT,*),B(*) ! ! REAL SDOT,TEMP INTEGER CASE,J,JJ !***FIRST EXECUTABLE STATEMENT STRSL ! ! CHECK FOR ZERO DIAGONAL ELEMENTS. ! DO 10 INFO = 1, N if (T(INFO,INFO) == 0.0E0) go to 150 10 CONTINUE INFO = 0 ! ! DETERMINE THE TASK AND go to IT. ! CASE = 1 if (MOD(JOB,10) /= 0) CASE = 2 if (MOD(JOB,100)/10 /= 0) CASE = CASE + 2 go to (20,50,80,110), CASE ! ! SOLVE T*X=B FOR T LOWER TRIANGULAR ! 20 CONTINUE B(1) = B(1)/T(1,1) if (N < 2) go to 40 DO 30 J = 2, N TEMP = -B(J-1) call SAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) B(J) = B(J)/T(J,J) 30 CONTINUE 40 CONTINUE go to 140 ! ! SOLVE T*X=B FOR T UPPER TRIANGULAR. ! 50 CONTINUE B(N) = B(N)/T(N,N) if (N < 2) go to 70 DO 60 JJ = 2, N J = N - JJ + 1 TEMP = -B(J+1) call SAXPY(J,TEMP,T(1,J+1),1,B(1),1) B(J) = B(J)/T(J,J) 60 CONTINUE 70 CONTINUE go to 140 ! ! SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. ! 80 CONTINUE B(N) = B(N)/T(N,N) if (N < 2) go to 100 DO 90 JJ = 2, N J = N - JJ + 1 B(J) = B(J) - SDOT(JJ-1,T(J+1,J),1,B(J+1),1) B(J) = B(J)/T(J,J) 90 CONTINUE 100 CONTINUE go to 140 ! ! SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. ! 110 CONTINUE B(1) = B(1)/T(1,1) if (N < 2) go to 130 DO 120 J = 2, N B(J) = B(J) - SDOT(J-1,T(1,J),1,B(1),1) B(J) = B(J)/T(J,J) 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE return end subroutine STRSM (SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, & B, LDB) ! !! STRSM solves a triangular system of linear equations with multiple RHS. ! !***PURPOSE Solve a real triangular system of equations with multiple ! right-hand sides. !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B6 !***TYPE SINGLE PRECISION (STRSM-S, DTRSM-D, CTRSM-C) !***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S. (NAG) !***DESCRIPTION ! ! STRSM solves one of the matrix equations ! ! op( A )*X = alpha*B, or X*op( A ) = alpha*B, ! ! where alpha is a scalar, X and B are m by n matrices, A is a unit, or ! non-unit, upper or lower triangular matrix and op( A ) is one of ! ! op( A ) = A or op( A ) = A'. ! ! The matrix X is overwritten on B. ! ! Parameters ! ========== ! ! SIDE - CHARACTER*1. ! On entry, SIDE specifies whether op( A ) appears on the left ! or right of X as follows: ! ! SIDE = 'L' or 'l' op( A )*X = alpha*B. ! ! SIDE = 'R' or 'r' X*op( A ) = alpha*B. ! ! Unchanged on exit. ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix A is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANSA - CHARACTER*1. ! On entry, TRANSA specifies the form of op( A ) to be used in ! the matrix multiplication as follows: ! ! TRANSA = 'N' or 'n' op( A ) = A. ! ! TRANSA = 'T' or 't' op( A ) = A'. ! ! TRANSA = 'C' or 'c' op( A ) = A'. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit triangular ! as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! M - INTEGER. ! On entry, M specifies the number of rows of B. M must be at ! least zero. ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the number of columns of B. N must be ! at least zero. ! Unchanged on exit. ! ! ALPHA - REAL . ! On entry, ALPHA specifies the scalar alpha. When alpha is ! zero then A is not referenced and B need not be set before ! entry. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, k ), where k is m ! when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. ! Before entry with UPLO = 'U' or 'u', the leading k by k ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading k by k ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. When SIDE = 'L' or 'l' then ! LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' ! then LDA must be at least max( 1, n ). ! Unchanged on exit. ! ! B - REAL array of DIMENSION ( LDB, n ). ! Before entry, the leading m by n part of the array B must ! contain the right-hand side matrix B, and on exit is ! overwritten by the solution matrix X. ! ! LDB - INTEGER. ! On entry, LDB specifies the first dimension of B as declared ! in the calling (sub) program. LDB must be at least ! max( 1, m ). ! Unchanged on exit. ! !***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. ! A set of level 3 basic linear algebra subprograms. ! ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE STRSM ! .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB REAL ALPHA ! .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ) ! ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX ! .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA REAL TEMP ! .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) !***FIRST EXECUTABLE STATEMENT STRSM ! ! Test the input parameters. ! LSIDE = LSAME( SIDE , 'L' ) if ( LSIDE )THEN NROWA = M ELSE NROWA = N end if NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) ! INFO = 0 if ( ( .NOT.LSIDE ).AND. & ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE if ( ( .NOT.UPPER ).AND. & ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE if ( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. & ( .NOT.LSAME( TRANSA, 'T' ) ).AND. & ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE if ( ( .NOT.LSAME( DIAG , 'U' ) ).AND. & ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE if ( M < 0 )THEN INFO = 5 ELSE if ( N < 0 )THEN INFO = 6 ELSE if ( LDA < MAX( 1, NROWA ) )THEN INFO = 9 ELSE if ( LDB < MAX( 1, M ) )THEN INFO = 11 end if if ( INFO /= 0 )THEN call XERBLA( 'STRSM ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! ! And when alpha.eq.zero. ! if ( ALPHA == ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE return end if ! ! Start the operations. ! if ( LSIDE )THEN if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*inv( A )*B. ! if ( UPPER )THEN DO 60, J = 1, N if ( ALPHA /= ONE )THEN DO 30, I = 1, M B( I, J ) = ALPHA*B( I, J ) 30 CONTINUE end if DO 50, K = M, 1, -1 if ( B( K, J ) /= ZERO )THEN if ( NOUNIT ) & B( K, J ) = B( K, J )/A( K, K ) DO 40, I = 1, K - 1 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 40 CONTINUE end if 50 CONTINUE 60 CONTINUE ELSE DO 100, J = 1, N if ( ALPHA /= ONE )THEN DO 70, I = 1, M B( I, J ) = ALPHA*B( I, J ) 70 CONTINUE end if DO 90 K = 1, M if ( B( K, J ) /= ZERO )THEN if ( NOUNIT ) & B( K, J ) = B( K, J )/A( K, K ) DO 80, I = K + 1, M B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 80 CONTINUE end if 90 CONTINUE 100 CONTINUE end if ELSE ! ! Form B := alpha*inv( A' )*B. ! if ( UPPER )THEN DO 130, J = 1, N DO 120, I = 1, M TEMP = ALPHA*B( I, J ) DO 110, K = 1, I - 1 TEMP = TEMP - A( K, I )*B( K, J ) 110 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 120 CONTINUE 130 CONTINUE ELSE DO 160, J = 1, N DO 150, I = M, 1, -1 TEMP = ALPHA*B( I, J ) DO 140, K = I + 1, M TEMP = TEMP - A( K, I )*B( K, J ) 140 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 150 CONTINUE 160 CONTINUE end if end if ELSE if ( LSAME( TRANSA, 'N' ) )THEN ! ! Form B := alpha*B*inv( A ). ! if ( UPPER )THEN DO 210, J = 1, N if ( ALPHA /= ONE )THEN DO 170, I = 1, M B( I, J ) = ALPHA*B( I, J ) 170 CONTINUE end if DO 190, K = 1, J - 1 if ( A( K, J ) /= ZERO )THEN DO 180, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 180 CONTINUE end if 190 CONTINUE if ( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 200, I = 1, M B( I, J ) = TEMP*B( I, J ) 200 CONTINUE end if 210 CONTINUE ELSE DO 260, J = N, 1, -1 if ( ALPHA /= ONE )THEN DO 220, I = 1, M B( I, J ) = ALPHA*B( I, J ) 220 CONTINUE end if DO 240, K = J + 1, N if ( A( K, J ) /= ZERO )THEN DO 230, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 230 CONTINUE end if 240 CONTINUE if ( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 250, I = 1, M B( I, J ) = TEMP*B( I, J ) 250 CONTINUE end if 260 CONTINUE end if ELSE ! ! Form B := alpha*B*inv( A' ). ! if ( UPPER )THEN DO 310, K = N, 1, -1 if ( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 270, I = 1, M B( I, K ) = TEMP*B( I, K ) 270 CONTINUE end if DO 290, J = 1, K - 1 if ( A( J, K ) /= ZERO )THEN TEMP = A( J, K ) DO 280, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 280 CONTINUE end if 290 CONTINUE if ( ALPHA /= ONE )THEN DO 300, I = 1, M B( I, K ) = ALPHA*B( I, K ) 300 CONTINUE end if 310 CONTINUE ELSE DO 360, K = 1, N if ( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 320, I = 1, M B( I, K ) = TEMP*B( I, K ) 320 CONTINUE end if DO 340, J = K + 1, N if ( A( J, K ) /= ZERO )THEN TEMP = A( J, K ) DO 330, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 330 CONTINUE end if 340 CONTINUE if ( ALPHA /= ONE )THEN DO 350, I = 1, M B( I, K ) = ALPHA*B( I, K ) 350 CONTINUE end if 360 CONTINUE end if end if end if ! return ! ! End of STRSM . ! end subroutine STRSV (UPLO, TRANS, DIAG, N, A, LDA, X, INCX) ! !! STRSV solves a real triangular system of linear equations. ! !***LIBRARY SLATEC (BLAS) !***CATEGORY D1B4 !***TYPE SINGLE PRECISION (STRSV-S, DTRSV-D, CTRSV-C) !***KEYWORDS LEVEL 2 BLAS, LINEAR ALGEBRA !***AUTHOR Dongarra, J. J., (ANL) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! STRSV solves one of the systems of equations ! ! A*x = b, or A'*x = b, ! ! where b and x are n element vectors and A is an n by n unit, or ! non-unit, upper or lower triangular matrix. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! Parameters ! ========== ! ! UPLO - CHARACTER*1. ! On entry, UPLO specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! UPLO = 'U' or 'u' A is an upper triangular matrix. ! ! UPLO = 'L' or 'l' A is a lower triangular matrix. ! ! Unchanged on exit. ! ! TRANS - CHARACTER*1. ! On entry, TRANS specifies the equations to be solved as ! follows: ! ! TRANS = 'N' or 'n' A*x = b. ! ! TRANS = 'T' or 't' A'*x = b. ! ! TRANS = 'C' or 'c' A'*x = b. ! ! Unchanged on exit. ! ! DIAG - CHARACTER*1. ! On entry, DIAG specifies whether or not A is unit ! triangular as follows: ! ! DIAG = 'U' or 'u' A is assumed to be unit triangular. ! ! DIAG = 'N' or 'n' A is not assumed to be unit ! triangular. ! ! Unchanged on exit. ! ! N - INTEGER. ! On entry, N specifies the order of the matrix A. ! N must be at least zero. ! Unchanged on exit. ! ! A - REAL array of DIMENSION ( LDA, n). ! Before entry with UPLO = 'U' or 'u', the leading n by n ! upper triangular part of the array A must contain the upper ! triangular matrix and the strictly lower triangular part of ! A is not referenced. ! Before entry with UPLO = 'L' or 'l', the leading n by n ! lower triangular part of the array A must contain the lower ! triangular matrix and the strictly upper triangular part of ! A is not referenced. ! Note that when DIAG = 'U' or 'u', the diagonal elements of ! A are not referenced either, but are assumed to be unity. ! Unchanged on exit. ! ! LDA - INTEGER. ! On entry, LDA specifies the first dimension of A as declared ! in the calling (sub) program. LDA must be at least ! max( 1, n ). ! Unchanged on exit. ! ! X - REAL array of dimension at least ! ( 1 + ( n - 1 )*abs( INCX ) ). ! Before entry, the incremented array X must contain the n ! element right-hand side vector b. On exit, X is overwritten ! with the solution vector x. ! ! INCX - INTEGER. ! On entry, INCX specifies the increment for the elements of ! X. INCX must not be zero. ! Unchanged on exit. ! !***REFERENCES Dongarra, J. J., Du Croz, J., Hammarling, S., and ! Hanson, R. J. An extended set of Fortran basic linear ! algebra subprograms. ACM TOMS, Vol. 14, No. 1, ! pp. 1-17, March 1988. !***ROUTINES CALLED LSAME, XERBLA !***REVISION HISTORY (YYMMDD) ! 861022 DATE WRITTEN ! 910605 Modified to meet SLATEC prologue standards. Only comment ! lines were modified. (BKS) !***END PROLOGUE STRSV ! .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO ! .. Array Arguments .. REAL A( LDA, * ), X( * ) ! .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) ! .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT ! .. External Functions .. LOGICAL LSAME EXTERNAL LSAME ! .. External Subroutines .. EXTERNAL XERBLA ! .. Intrinsic Functions .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT STRSV ! ! Test the input parameters. ! INFO = 0 if ( .NOT.LSAME( UPLO , 'U' ).AND. & .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE if ( .NOT.LSAME( TRANS, 'N' ).AND. & .NOT.LSAME( TRANS, 'T' ).AND. & .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE if ( .NOT.LSAME( DIAG , 'U' ).AND. & .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE if ( N < 0 )THEN INFO = 4 ELSE if ( LDA < MAX( 1, N ) )THEN INFO = 6 ELSE if ( INCX == 0 )THEN INFO = 8 end if if ( INFO /= 0 )THEN call XERBLA( 'STRSV ', INFO ) return end if ! ! Quick return if possible. ! if ( N == 0 ) & return ! NOUNIT = LSAME( DIAG, 'N' ) ! ! Set up the start point in X if the increment is not unity. This ! will be ( N - 1 )*INCX too small for descending loops. ! if ( INCX <= 0 )THEN KX = 1 - ( N - 1 )*INCX ELSE if ( INCX /= 1 )THEN KX = 1 end if ! ! Start the operations. In this version the elements of A are ! accessed sequentially with one pass through A. ! if ( LSAME( TRANS, 'N' ) )THEN ! ! Form x := inv( A )*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 20, J = N, 1, -1 if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE end if 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE end if JX = JX - INCX 40 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 60, J = 1, N if ( X( J ) /= ZERO )THEN if ( NOUNIT ) & X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE end if 60 CONTINUE ELSE JX = KX DO 80, J = 1, N if ( X( JX ) /= ZERO )THEN if ( NOUNIT ) & X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE end if JX = JX + INCX 80 CONTINUE end if end if ELSE ! ! Form x := inv( A' )*x. ! if ( LSAME( UPLO, 'U' ) )THEN if ( INCX == 1 )THEN DO 100, J = 1, N TEMP = X( J ) DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) X( J ) = TEMP 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX DO 110, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX + INCX 120 CONTINUE end if ELSE if ( INCX == 1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) DO 130, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 130 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) X( J ) = TEMP 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 150 CONTINUE if ( NOUNIT ) & TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX - INCX 160 CONTINUE end if end if end if ! return ! ! End of STRSV . ! end subroutine STWAY (U, V, YHP, INOUT, STOWA) ! !! STWAY stores or recalls integration data for a restart of BVSUP. ! !***SUBSIDIARY !***PURPOSE Subsidiary to BVSUP !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (STWAY-S, DSTWAY-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This subroutine stores (recalls) integration data in the event ! that a restart is needed (the homogeneous solution vectors become ! too dependent to continue) ! !***SEE ALSO BVSUP !***ROUTINES CALLED STOR1 !***COMMON BLOCKS ML15TO, ML18JR, ML8SZ !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE STWAY ! DIMENSION U(*),V(*),YHP(*),STOWA(*) ! COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, & KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, & ICOCO ! !***FIRST EXECUTABLE STATEMENT STWAY if (INOUT == 1) go to 100 ! ! SAVE IN STOWA ARRAY AND ISTKOP ! KS=NFC*NCOMP call STOR1(STOWA,U,STOWA(KS+1),V,1,0,0) KS=KS+NCOMP if (NEQIVP == 0) go to 50 DO 25 J=1,NEQIVP KSJ=KS+J 25 STOWA(KSJ)=YHP(KSJ) 50 KS=KS+NEQIVP STOWA(KS+1)=X ISTKOP=KOP if (XOP == X) ISTKOP=KOP+1 return ! ! RECALL FROM STOWA ARRAY AND ISTKOP ! 100 KS=NFC*NCOMP call STOR1(YHP,STOWA,YHP(KS+1),STOWA(KS+1),1,0,0) KS=KS+NCOMP if (NEQIVP == 0) go to 150 DO 125 J=1,NEQIVP KSJ=KS+J 125 YHP(KSJ)=STOWA(KSJ) 150 KS=KS+NEQIVP X=STOWA(KS+1) INFO(1)=0 KO=KOP-ISTKOP KOP=ISTKOP if (NDISK == 0 .OR. KO == 0) RETURN DO 175 K=1,KO 175 BACKSPACE NTAPE return end subroutine SUDS (A, X, B, NEQ, NUK, NRDA, IFLAG, MLSO, WORK, & IWORK) ! !! SUDS solves an undetermined linear system for BVSUP. ! !***SUBSIDIARY !***PURPOSE Subsidiary to BVSUP !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SUDS-S, DSUDS-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! SUDS solves the underdetermined system of linear equations A Z = B ! where A is NEQ by NUK and NEQ <= NUK. In particular, if rank A ! equals IRA, a vector X and a matrix U are determined such that ! X is the UNIQUE solution of smallest length, satisfying A X = B, ! and the columns of U form an orthonormal basis for the null ! space of A, satisfying A U = 0 . Then all solutions Z are ! given by ! Z = X + C(1)*U(1) + ..... + C(NUK-IRA)*U(NUK-IRA) ! where U(J) represents the J-th column of U and the C(J) are ! arbitrary constants. ! If the system of equations are not compatible, only the least ! squares solution of minimal length is computed. ! SUDS is an interfacing routine which calls subroutine LSSUDS ! for the solution. LSSUDS in turn calls subroutine ORTHOR and ! possibly subroutine OHTROL for the decomposition of A by ! orthogonal transformations. In the process, ORTHOR calls upon ! subroutine CSCALE for scaling. ! ! ********************************************************************** ! INPUT ! ********************************************************************** ! ! A -- Contains the matrix of NEQ equations in NUK unknowns and must ! be dimensioned NRDA by NUK. The original A is destroyed. ! X -- Solution array of length at least NUK ! B -- Given constant vector of length NEQ, B is destroyed ! NEQ -- Number of equations, NEQ greater or equal to 1 ! NUK -- Number of columns in the matrix (which is also the number ! of unknowns), NUK not smaller than NEQ ! NRDA -- Row dimension of A, NRDA greater or equal to NEQ ! IFLAG -- Status indicator ! =0 For the first call (and for each new problem defined by ! a new matrix A) when the matrix data is treated as exact ! =-K For the first call (and for each new problem defined by ! a new matrix A) when the matrix data is assumed to be ! accurate to about K digits ! =1 For subsequent calls whenever the matrix A has already ! been decomposed (problems with new vectors B but ! same matrix A can be handled efficiently) ! MLSO -- =0 If only the minimal length solution is wanted ! =1 If the complete solution is wanted, includes the ! linear space defined by the matrix U in the abstract ! WORK(*),IWORK(*) -- Arrays for storage of internal information, ! WORK must be dimensioned at least ! NUK + 3*NEQ + MLSO*NUK*(NUK-rank A) ! where it is possible for 0 <= rank A <= NEQ ! IWORK must be dimensioned at least 3 + NEQ ! IWORK(2) -- Scaling indicator ! =-1 If the matrix is to be pre-scaled by ! columns when appropriate ! If the scaling indicator is not equal to -1 ! no scaling will be attempted ! For most problems scaling will probably not be necessary ! ! ********************************************************************** ! OUTPUT ! ********************************************************************** ! ! IFLAG -- Status indicator ! =1 If solution was obtained ! =2 If improper input is detected ! =3 If rank of matrix is less than NEQ ! To continue simply reset IFLAG=1 and call SUDS again ! =4 If the system of equations appears to be inconsistent. ! However, the least squares solution of minimal length ! was obtained. ! X -- Minimal length least squares solution of A X = B ! A -- Contains the strictly upper triangular part of the reduced ! matrix and transformation information ! WORK(*),IWORK(*) -- Contains information needed on subsequent ! calls (IFLAG=1 case on input) which must not ! be altered. ! The matrix U described in the abstract is ! stored in the NUK*(NUK-rank A) elements of ! the work array beginning at WORK(1+NUK+3*NEQ). ! However U is not defined when MLSO=0 or ! IFLAG=4. ! IWORK(1) Contains the numerically determined ! rank of the matrix A ! ! ********************************************************************** ! !***SEE ALSO BVSUP !***REFERENCES H. A. Watts, Solving linear least squares problems ! using SODS/SUDS/CODS, Sandia Report SAND77-0683, ! Sandia Laboratories, 1977. !***ROUTINES CALLED LSSUDS !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR and REFERENCES sections. (WRB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE SUDS DIMENSION A(NRDA,*),X(*),B(*),WORK(*),IWORK(*) ! !***FIRST EXECUTABLE STATEMENT SUDS IS=2 IP=3 IL=IP+NEQ KV=1+NEQ KT=KV+NEQ KS=KT+NEQ KU=KS+NUK ! call LSSUDS(A,X,B,NEQ,NUK,NRDA,WORK(KU),NUK,IFLAG,MLSO,IWORK(1), & IWORK(IS),A,WORK(1),IWORK(IP),B,WORK(KV),WORK(KT), & IWORK(IL),WORK(KS)) ! return end subroutine SVCO (RSAV, ISAV) ! !! SVCO transfers data from a common block to arrays for DEBDF. ! !***SUBSIDIARY !***PURPOSE Subsidiary to DEBDF !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SVCO-S, DSVCO-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! SVCO transfers data from a common block to arrays within the ! integrator package DEBDF. ! !***SEE ALSO DEBDF !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DEBDF1 !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SVCO ! ! !----------------------------------------------------------------------- ! THIS ROUTINE STORES IN RSAV AND ISAV THE CONTENTS OF COMMON BLOCK ! DEBDF1 , WHICH IS USED INTERNALLY IN THE DEBDF PACKAGE. ! ! RSAV = REAL ARRAY OF LENGTH 218 OR MORE. ! ISAV = INTEGER ARRAY OF LENGTH 33 OR MORE. !----------------------------------------------------------------------- INTEGER ISAV, I, ILS, LENILS, LENRLS REAL RSAV, RLS DIMENSION RSAV(*), ISAV(*) COMMON /DEBDF1/ RLS(218), ILS(33) SAVE LENRLS, LENILS DATA LENRLS/218/, LENILS/33/ ! !***FIRST EXECUTABLE STATEMENT SVCO DO 10 I = 1,LENRLS 10 RSAV(I) = RLS(I) DO 20 I = 1,LENILS 20 ISAV(I) = ILS(I) return !----------------------- END OF SUBROUTINE SVCO ----------------------- end subroutine SVD (NM, M, N, A, W, MATU, U, MATV, V, IERR, RV1) ! !! SVD performs the singular value decomposition of a rectangular matrix. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SVD-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure SVD, ! NUM. MATH. 14, 403-420(1970) by Golub and Reinsch. ! HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). ! ! This subroutine determines the singular value decomposition ! T ! A=USV of a REAL M by N rectangular matrix. Householder ! bidiagonalization and a variant of the QR algorithm are used. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A, U and V, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! Note that NM must be at least as large as the maximum ! of M and N. ! ! M is the number of rows of A and U. ! ! N is the number of columns of A and U and the order of V. ! ! A contains the rectangular input matrix to be decomposed. A is ! a two-dimensional REAL array, dimensioned A(NM,N). ! ! MATU should be set to .TRUE. if the U matrix in the ! decomposition is desired, and to .FALSE. otherwise. ! MATU is a LOGICAL variable. ! ! MATV should be set to .TRUE. if the V matrix in the ! decomposition is desired, and to .FALSE. otherwise. ! MATV is a LOGICAL variable. ! ! On Output ! ! A is unaltered (unless overwritten by U or V). ! ! W contains the N (non-negative) singular values of A (the ! diagonal elements of S). They are unordered. If an ! error exit is made, the singular values should be correct ! for indices IERR+1, IERR+2, ..., N. W is a one-dimensional ! REAL array, dimensioned W(N). ! ! U contains the matrix U (orthogonal column vectors) of the ! decomposition if MATU has been set to .TRUE. Otherwise, ! U is used as a temporary array. U may coincide with A. ! If an error exit is made, the columns of U corresponding ! to indices of correct singular values should be correct. ! U is a two-dimensional REAL array, dimensioned U(NM,N). ! ! V contains the matrix V (orthogonal) of the decomposition if ! MATV has been set to .TRUE. Otherwise, V is not referenced. ! V may also coincide with A if U does not. If an error ! exit is made, the columns of V corresponding to indices of ! correct singular values should be correct. V is a two- ! dimensional REAL array, dimensioned V(NM,N). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! K if the K-th singular value has not been ! determined after 30 iterations. ! ! RV1 is a one-dimensional REAL array used for temporary storage, ! dimensioned RV1(N). ! ! CALLS PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***SEE ALSO EISDOC !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 811101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE SVD ! INTEGER I,J,K,L,M,N,II,I1,KK,K1,LL,L1,MN,NM,ITS,IERR REAL A(NM,*),W(*),U(NM,*),V(NM,*),RV1(*) REAL C,F,G,H,S,X,Y,Z,SCALE,S1 REAL PYTHAG LOGICAL MATU,MATV ! !***FIRST EXECUTABLE STATEMENT SVD IERR = 0 ! DO 100 I = 1, M ! DO 100 J = 1, N U(I,J) = A(I,J) 100 CONTINUE ! .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... G = 0.0E0 SCALE = 0.0E0 S1 = 0.0E0 ! DO 300 I = 1, N L = I + 1 RV1(I) = SCALE * G G = 0.0E0 S = 0.0E0 SCALE = 0.0E0 if (I > M) go to 210 ! DO 120 K = I, M 120 SCALE = SCALE + ABS(U(K,I)) ! if (SCALE == 0.0E0) go to 210 ! DO 130 K = I, M U(K,I) = U(K,I) / SCALE S = S + U(K,I)**2 130 CONTINUE ! F = U(I,I) G = -SIGN(SQRT(S),F) H = F * G - S U(I,I) = F - G if (I == N) go to 190 ! DO 150 J = L, N S = 0.0E0 ! DO 140 K = I, M 140 S = S + U(K,I) * U(K,J) ! F = S / H ! DO 150 K = I, M U(K,J) = U(K,J) + F * U(K,I) 150 CONTINUE ! 190 DO 200 K = I, M 200 U(K,I) = SCALE * U(K,I) ! 210 W(I) = SCALE * G G = 0.0E0 S = 0.0E0 SCALE = 0.0E0 if (I > M .OR. I == N) go to 290 ! DO 220 K = L, N 220 SCALE = SCALE + ABS(U(I,K)) ! if (SCALE == 0.0E0) go to 290 ! DO 230 K = L, N U(I,K) = U(I,K) / SCALE S = S + U(I,K)**2 230 CONTINUE ! F = U(I,L) G = -SIGN(SQRT(S),F) H = F * G - S U(I,L) = F - G ! DO 240 K = L, N 240 RV1(K) = U(I,K) / H ! if (I == M) go to 270 ! DO 260 J = L, M S = 0.0E0 ! DO 250 K = L, N 250 S = S + U(J,K) * U(I,K) ! DO 260 K = L, N U(J,K) = U(J,K) + S * RV1(K) 260 CONTINUE ! 270 DO 280 K = L, N 280 U(I,K) = SCALE * U(I,K) ! 290 S1 = MAX(S1,ABS(W(I))+ABS(RV1(I))) 300 CONTINUE ! .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS .......... if (.NOT. MATV) go to 410 ! .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... DO 400 II = 1, N I = N + 1 - II if (I == N) go to 390 if (G == 0.0E0) go to 360 ! DO 320 J = L, N ! .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... 320 V(J,I) = (U(I,J) / U(I,L)) / G ! DO 350 J = L, N S = 0.0E0 ! DO 340 K = L, N 340 S = S + U(I,K) * V(K,J) ! DO 350 K = L, N V(K,J) = V(K,J) + S * V(K,I) 350 CONTINUE ! 360 DO 380 J = L, N V(I,J) = 0.0E0 V(J,I) = 0.0E0 380 CONTINUE ! 390 V(I,I) = 1.0E0 G = RV1(I) L = I 400 CONTINUE ! .......... ACCUMULATION OF LEFT-HAND TRANSFORMATIONS .......... 410 if (.NOT. MATU) go to 510 ! ..........FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- .......... MN = N if (M < N) MN = M ! DO 500 II = 1, MN I = MN + 1 - II L = I + 1 G = W(I) if (I == N) go to 430 ! DO 420 J = L, N 420 U(I,J) = 0.0E0 ! 430 if (G == 0.0E0) go to 475 if (I == MN) go to 460 ! DO 450 J = L, N S = 0.0E0 ! DO 440 K = L, M 440 S = S + U(K,I) * U(K,J) ! .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... F = (S / U(I,I)) / G ! DO 450 K = I, M U(K,J) = U(K,J) + F * U(K,I) 450 CONTINUE ! 460 DO 470 J = I, M 470 U(J,I) = U(J,I) / G ! go to 490 ! 475 DO 480 J = I, M 480 U(J,I) = 0.0E0 ! 490 U(I,I) = U(I,I) + 1.0E0 500 CONTINUE ! .......... DIAGONALIZATION OF THE BIDIAGONAL FORM .......... 510 CONTINUE ! .......... FOR K=N STEP -1 UNTIL 1 DO -- .......... DO 700 KK = 1, N K1 = N - KK K = K1 + 1 ITS = 0 ! .......... TEST FOR SPLITTING. ! FOR L=K STEP -1 UNTIL 1 DO -- .......... 520 DO 530 LL = 1, K L1 = K - LL L = L1 + 1 if (S1 + ABS(RV1(L)) == S1) go to 565 ! .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT ! THROUGH THE BOTTOM OF THE LOOP .......... if (S1 + ABS(W(L1)) == S1) go to 540 530 CONTINUE ! .......... CANCELLATION OF RV1(L) if L GREATER THAN 1 .......... 540 C = 0.0E0 S = 1.0E0 ! DO 560 I = L, K F = S * RV1(I) RV1(I) = C * RV1(I) if (S1 + ABS(F) == S1) go to 565 G = W(I) H = PYTHAG(F,G) W(I) = H C = G / H S = -F / H if (.NOT. MATU) go to 560 ! DO 550 J = 1, M Y = U(J,L1) Z = U(J,I) U(J,L1) = Y * C + Z * S U(J,I) = -Y * S + Z * C 550 CONTINUE ! 560 CONTINUE ! .......... TEST FOR CONVERGENCE .......... 565 Z = W(K) if (L == K) go to 650 ! .......... SHIFT FROM BOTTOM 2 BY 2 MINOR .......... if (ITS == 30) go to 1000 ITS = ITS + 1 X = W(L) Y = W(K1) G = RV1(K1) H = RV1(K) F = 0.5E0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y) G = PYTHAG(F,1.0E0) F = X - (Z / X) * Z + (H / X) * (Y / (F + SIGN(G,F)) - H) ! .......... NEXT QR TRANSFORMATION .......... C = 1.0E0 S = 1.0E0 ! DO 600 I1 = L, K1 I = I1 + 1 G = RV1(I) Y = W(I) H = S * G G = C * G Z = PYTHAG(F,H) RV1(I1) = Z C = F / Z S = H / Z F = X * C + G * S G = -X * S + G * C H = Y * S Y = Y * C if (.NOT. MATV) go to 575 ! DO 570 J = 1, N X = V(J,I1) Z = V(J,I) V(J,I1) = X * C + Z * S V(J,I) = -X * S + Z * C 570 CONTINUE ! 575 Z = PYTHAG(F,H) W(I1) = Z ! .......... ROTATION CAN BE ARBITRARY if Z IS ZERO .......... if (Z == 0.0E0) go to 580 C = F / Z S = H / Z 580 F = C * G + S * Y X = -S * G + C * Y if (.NOT. MATU) go to 600 ! DO 590 J = 1, M Y = U(J,I1) Z = U(J,I) U(J,I1) = Y * C + Z * S U(J,I) = -Y * S + Z * C 590 CONTINUE ! 600 CONTINUE ! RV1(L) = 0.0E0 RV1(K) = F W(K) = X go to 520 ! .......... CONVERGENCE .......... 650 if (Z >= 0.0E0) go to 700 ! .......... W(K) IS MADE NON-NEGATIVE .......... W(K) = -Z if (.NOT. MATV) go to 700 ! DO 690 J = 1, N 690 V(J,K) = -V(J,K) ! 700 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO A ! SINGULAR VALUE AFTER 30 ITERATIONS .......... 1000 IERR = K 1001 RETURN end subroutine SVECS (NCOMP, LNFC, YHP, WORK, IWORK, INHOMO, IFLAG) ! !! SVECS is subsidiary to BVSUP. ! !***SUBSIDIARY !***PURPOSE Subsidiary to BVSUP !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SVECS-S, DVECS-D) !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This subroutine is used for the special structure of complex valued ! problems. MGSBV is called upon to obtain LNFC vectors from an ! original set of 2*LNFC independent vectors so that the resulting ! LNFC vectors together with their imaginary product or mate vectors ! form an independent set. ! !***SEE ALSO BVSUP !***ROUTINES CALLED MGSBV !***COMMON BLOCKS ML18JR !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890921 Realigned order of variables in certain COMMON blocks. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910722 Updated AUTHOR section. (ALS) !***END PROLOGUE SVECS ! DIMENSION YHP(NCOMP,*),WORK(*),IWORK(*) COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, & INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,LNFCC, & ICOCO !***FIRST EXECUTABLE STATEMENT SVECS if (LNFC == 1) go to 5 NIV=LNFC LNFC=2*LNFC LNFCC=2*LNFCC KP=LNFC+2+LNFCC IDP=INDPVT INDPVT=0 call MGSBV(NCOMP,LNFC,YHP,NCOMP,NIV,IFLAG,WORK(1),WORK(KP), & IWORK(1),INHOMO,YHP(1,LNFC+1),WORK(LNFC+2),DUM) LNFC=LNFC/2 LNFCC=LNFCC/2 INDPVT=IDP if (IFLAG == 0 .AND. NIV == LNFC) go to 5 IFLAG=99 return 5 DO 6 K=1,NCOMP 6 YHP(K,LNFC+1)=YHP(K,LNFCC+1) IFLAG=1 return end subroutine SVOUT (N, SX, IFMT, IDIGIT) ! !! SVOUT prints out a single precision array. ! !***SUBSIDIARY !***PURPOSE Subsidiary to SPLP !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SVOUT-S, DVOUT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! SINGLE PRECISION VECTOR OUTPUT ROUTINE. ! ! INPUT.. ! ! N,SX(*) PRINT THE SINGLE PRECISION ARRAY SX(I),I=1,...,N, ON ! OUTPUT UNIT LOUT. THE HEADING IN THE FORTRAN FORMAT ! STATEMENT IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST ! STEP. THE COMPONENTS SX(I) ARE INDEXED, ON OUTPUT, ! IN A PLEASANT FORMAT. ! IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON OUTPUT ! UNIT LOUT WITH THE VARIABLE FORMAT FORTRAN STATEMENT ! WRITE(LOUT,IFMT) ! IDIGIT PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. ! THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,10 OR 14 ! WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF ! PLACES. if IDIGIT < 0, 72 PRINTING COLUMNS ARE UTILIZED ! TO WRITE EACH LINE OF OUTPUT OF THE ARRAY SX(*). (THIS ! CAN BE USED ON MOST TIME-SHARING TERMINALS). IF ! IDIGIT >= 0, 133 PRINTING COLUMNS ARE UTILIZED. (THIS CAN ! BE USED ON MOST LINE PRINTERS). ! ! EXAMPLE.. ! ! PRINT AN ARRAY CALLED (COSTS OF PURCHASES) OF LENGTH 100 SHOWING ! 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING ! SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. ! ! DIMENSION COSTS(100) ! N = 100 ! IDIGIT = -6 ! call SVOUT(N,COSTS,'(''1COSTS OF PURCHASES'')',IDIGIT) ! !***SEE ALSO SPLP !***ROUTINES CALLED I1MACH !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 891107 Added comma after 1P edit descriptor in FORMAT ! statements. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE SVOUT DIMENSION SX(*) CHARACTER IFMT*(*) ! ! GET THE UNIT NUMBER WHERE OUTPUT WILL BE WRITTEN. !***FIRST EXECUTABLE STATEMENT SVOUT J=2 LOUT=I1MACH(J) WRITE(LOUT,IFMT) if ( N <= 0) RETURN NDIGIT = IDIGIT if ( IDIGIT == 0) NDIGIT = 4 if ( IDIGIT >= 0) go to 80 ! NDIGIT = -IDIGIT if ( NDIGIT > 4) go to 20 ! DO 10 K1=1,N,5 K2 = MIN(N,K1+4) WRITE(LOUT,1000) K1,K2,(SX(I),I=K1,K2) 10 CONTINUE return ! 20 CONTINUE if ( NDIGIT > 6) go to 40 ! DO 30 K1=1,N,4 K2 = MIN(N,K1+3) WRITE(LOUT,1001) K1,K2,(SX(I),I=K1,K2) 30 CONTINUE return ! 40 CONTINUE if ( NDIGIT > 10) go to 60 ! DO 50 K1=1,N,3 K2=MIN(N,K1+2) WRITE(LOUT,1002) K1,K2,(SX(I),I=K1,K2) 50 CONTINUE return ! 60 CONTINUE DO 70 K1=1,N,2 K2 = MIN(N,K1+1) WRITE(LOUT,1003) K1,K2,(SX(I),I=K1,K2) 70 CONTINUE return ! 80 CONTINUE if ( NDIGIT > 4) go to 100 ! DO 90 K1=1,N,10 K2 = MIN(N,K1+9) WRITE(LOUT,1000) K1,K2,(SX(I),I=K1,K2) 90 CONTINUE return ! 100 CONTINUE if ( NDIGIT > 6) go to 120 ! DO 110 K1=1,N,8 K2 = MIN(N,K1+7) WRITE(LOUT,1001) K1,K2,(SX(I),I=K1,K2) 110 CONTINUE return ! 120 CONTINUE if ( NDIGIT > 10) go to 140 ! DO 130 K1=1,N,6 K2 = MIN(N,K1+5) WRITE(LOUT,1002) K1,K2,(SX(I),I=K1,K2) 130 CONTINUE return ! 140 CONTINUE DO 150 K1=1,N,5 K2 = MIN(N,K1+4) WRITE(LOUT,1003) K1,K2,(SX(I),I=K1,K2) 150 CONTINUE return 1000 FORMAT(1X,I4,' - ',I4,1P,10E12.3) 1001 FORMAT(1X,I4,' - ',I4,1X,1P,8E14.5) 1002 FORMAT(1X,I4,' - ',I4,1X,1P,6E18.9) 1003 FORMAT(1X,I4,' - ',I4,1X,1P,5E24.13) end subroutine SWRITP (IPAGE, LIST, RLIST, LPAGE, IREC) ! !! SWRITP writes a record out to a file for SPLP. ! !***SUBSIDIARY !***PURPOSE Subsidiary to SPLP !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SWRITP-S, DWRITP-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! WRITE RECORD NUMBER IRECN, OF LENGTH LPG, FROM STORAGE ! ARRAY LIST(*) ONTO UNIT NUMBER IPAGEF. ! WRITE RECORD NUMBER IRECN+1, OF LENGTH LPG, ONTO UNIT ! NUMBER IPAGEF FROM THE STORAGE ARRAY RLIST(*). ! ! TO CHANGE THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE ! /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/. ! !***SEE ALSO SPLP !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 890605 Corrected references to XERRWV. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) !***END PROLOGUE SWRITP INTEGER LIST(*) REAL RLIST(*) CHARACTER*8 XERN1, XERN2 !***FIRST EXECUTABLE STATEMENT SWRITP IPAGEF=IPAGE LPG =LPAGE IRECN =IREC WRITE(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG) WRITE(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG) return ! 100 WRITE (XERN1, '(I8)') LPG WRITE (XERN2, '(I8)') IRECN call XERMSG ('SLATEC', 'SWRITP', 'IN SPLP, LGP = ' // XERN1 // & ' IRECN = ' // XERN2, 100, 1) return end subroutine SXLCAL (N, LGMR, X, XL, ZL, HES, MAXLP1, Q, V, R0NRM, & WK, SZ, JSCAL, JPRE, MSOLVE, NMSL, RPAR, IPAR, NELT, IA, JA, A, & ISYM) ! !! SXLCAL is an internal routine for SGMRES. ! !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE PRECISION (SXLCAL-S, DXLCAL-D) !***KEYWORDS GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION, ! NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE !***AUTHOR Brown, Peter, (LLNL), pnbrown@llnl.gov ! Hindmarsh, Alan, (LLNL), alanh@llnl.gov ! Seager, Mark K., (LLNL), seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO Box 808, L-60 ! Livermore, CA 94550 (510) 423-3141 !***DESCRIPTION ! This routine computes the solution XL, the current SGMRES ! iterate, given the V(I)'s and the QR factorization of the ! Hessenberg matrix HES. This routine is only called when ! ITOL=11. ! ! *Usage: ! INTEGER N, LGMR, MAXLP1, JSCAL, JPRE, NMSL, IPAR(USER DEFINED) ! INTEGER NELT, IA(NELT), JA(NELT), ISYM ! REAL X(N), XL(N), ZL(N), HES(MAXLP1,MAXL), Q(2*MAXL), ! $ V(N,MAXLP1), R0NRM, WK(N), SZ(N), RPAR(USER DEFINED), ! $ A(NELT) ! EXTERNAL MSOLVE ! ! call SXLCAL(N, LGMR, X, XL, ZL, HES, MAXLP1, Q, V, R0NRM, ! $ WK, SZ, JSCAL, JPRE, MSOLVE, NMSL, RPAR, IPAR, ! $ NELT, IA, JA, A, ISYM) ! ! *Arguments: ! N :IN Integer ! The order of the matrix A, and the lengths ! of the vectors SR, SZ, R0 and Z. ! LGMR :IN Integer ! The number of iterations performed and ! the current order of the upper Hessenberg ! matrix HES. ! X :IN Real X(N) ! The current approximate solution as of the last restart. ! XL :OUT Real XL(N) ! An array of length N used to hold the approximate ! solution X(L). ! Warning: XL and ZL are the same array in the calling routine. ! ZL :IN Real ZL(N) ! An array of length N used to hold the approximate ! solution Z(L). ! HES :IN Real HES(MAXLP1,MAXL) ! The upper triangular factor of the QR decomposition ! of the (LGMR+1) by LGMR upper Hessenberg matrix whose ! entries are the scaled inner-products of A*V(*,i) and V(*,k). ! MAXLP1 :IN Integer ! MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. ! MAXL is the maximum allowable order of the matrix HES. ! Q :IN Real Q(2*MAXL) ! A real array of length 2*MAXL containing the components ! of the Givens rotations used in the QR decomposition ! of HES. It is loaded in SHEQR. ! V :IN Real V(N,MAXLP1) ! The N by(LGMR+1) array containing the LGMR ! orthogonal vectors V(*,1) to V(*,LGMR). ! R0NRM :IN Real ! The scaled norm of the initial residual for the ! current call to SPIGMR. ! WK :IN Real WK(N) ! A real work array of length N. ! SZ :IN Real SZ(N) ! A vector of length N containing the non-zero ! elements of the diagonal scaling matrix for Z. ! JSCAL :IN Integer ! A flag indicating whether arrays SR and SZ are used. ! JSCAL=0 means SR and SZ are not used and the ! algorithm will perform as if all ! SR(i) = 1 and SZ(i) = 1. ! JSCAL=1 means only SZ is used, and the algorithm ! performs as if all SR(i) = 1. ! JSCAL=2 means only SR is used, and the algorithm ! performs as if all SZ(i) = 1. ! JSCAL=3 means both SR and SZ are used. ! JPRE :IN Integer ! The preconditioner type flag. ! MSOLVE :EXT External. ! Name of the routine which solves a linear system Mz = r for ! z given r with the preconditioning matrix M (M is supplied via ! RPAR and IPAR arrays. The name of the MSOLVE routine must ! be declared external in the calling program. The calling ! sequence to MSOLVE is: ! call MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR) ! Where N is the number of unknowns, R is the right-hand side ! vector and Z is the solution upon return. NELT, IA, JA, A and ! ISYM are defined as below. RPAR is a real array that can be ! used to pass necessary preconditioning information and/or ! workspace to MSOLVE. IPAR is an integer work array for the ! same purpose as RPAR. ! NMSL :IN Integer ! The number of calls to MSOLVE. ! RPAR :IN Real RPAR(USER DEFINED) ! Real workspace passed directly to the MSOLVE routine. ! IPAR :IN Integer IPAR(USER DEFINED) ! Integer workspace passed directly to the MSOLVE routine. ! NELT :IN Integer ! The length of arrays IA, JA and A. ! IA :IN Integer IA(NELT) ! An integer array of length NELT containing matrix data. ! It is passed directly to the MATVEC and MSOLVE routines. ! JA :IN Integer JA(NELT) ! An integer array of length NELT containing matrix data. ! It is passed directly to the MATVEC and MSOLVE routines. ! A :IN Real A(NELT) ! A real array of length NELT containing matrix data. ! It is passed directly to the MATVEC and MSOLVE routines. ! ISYM :IN Integer ! A flag to indicate symmetric matrix storage. ! If ISYM=0, all non-zero entries of the matrix are ! stored. If ISYM=1, the matrix is symmetric and ! only the upper or lower triangular part is stored. ! !***SEE ALSO SGMRES !***ROUTINES CALLED SAXPY, SCOPY, SHELS !***REVISION HISTORY (YYMMDD) ! 871001 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890915 Made changes requested at July 1989 CML Meeting. (MKS) ! 890922 Numerous changes to prologue to make closer to SLATEC ! standard. (FNF) ! 890929 Numerous changes to reduce SP/DP differences. (FNF) ! 910411 Prologue converted to Version 4.0 format. (BAB) ! 910502 Removed MSOLVE from ROUTINES CALLED list. (FNF) ! 910506 Made subsidiary to SGMRES. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE SXLCAL ! The following is for optimized compilation on LLNL/LTSS Crays. !LLL. OPTIMIZE ! .. Scalar Arguments .. REAL R0NRM INTEGER ISYM, JPRE, JSCAL, LGMR, MAXLP1, N, NELT, NMSL ! .. Array Arguments .. REAL A(NELT), HES(MAXLP1,*), Q(*), RPAR(*), SZ(*), V(N,*), WK(N), & X(N), XL(N), ZL(N) INTEGER IA(NELT), IPAR(*), JA(NELT) ! .. Subroutine Arguments .. EXTERNAL MSOLVE ! .. Local Scalars .. INTEGER I, K, LL, LLP1 ! .. External Subroutines .. EXTERNAL SAXPY, SCOPY, SHELS !***FIRST EXECUTABLE STATEMENT SXLCAL LL = LGMR LLP1 = LL + 1 DO 10 K = 1,LLP1 WK(K) = 0 10 CONTINUE WK(1) = R0NRM call SHELS(HES, MAXLP1, LL, Q, WK) DO 20 K = 1,N ZL(K) = 0 20 CONTINUE DO 30 I = 1,LL call SAXPY(N, WK(I), V(1,I), 1, ZL, 1) 30 CONTINUE if ((JSCAL == 1) .OR.(JSCAL == 3)) THEN DO 40 K = 1,N ZL(K) = ZL(K)/SZ(K) 40 CONTINUE end if if (JPRE > 0) THEN call SCOPY(N, ZL, 1, WK, 1) call MSOLVE(N, WK, ZL, NELT, IA, JA, A, ISYM, RPAR, IPAR) NMSL = NMSL + 1 end if ! ! Calculate XL from X and ZL. ! XL(1:n) = X(1:n) + ZL(1:n) return end subroutine TEVLC (N, D, E2, IERR) ! !! TEVLC finds eigenvalues of a symmetric tridiagonal matrix by rational QL. ! !***SUBSIDIARY !***PURPOSE Subsidiary to CBLKTR !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (TEVLC-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine finds the eigenvalues of a symmetric tridiagonal ! matrix by the rational QL method. ! ! On Input- ! ! N is the order of the matrix, ! ! D contains the diagonal elements of the input matrix, ! ! E2 contains the subdiagonal elements of the input matrix ! in its last N-1 positions. E2(1) is arbitrary. ! ! On Output- ! ! D contains the eigenvalues in ascending order. If an ! error exit is made, the eigenvalues are correct and ! ordered for indices 1,2,...IERR-1, but may not be ! the smallest eigenvalues, ! ! E2 has been destroyed, ! ! IERR is set to ! ZERO for normal return, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! !***SEE ALSO CBLKTR !***REFERENCES C. H. Reinsch, Eigenvalues of a real, symmetric, tri- ! diagonal matrix, Algorithm 464, Communications of the ! ACM 16, 11 (November 1973), pp. 689. !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CCBLK !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 920528 DESCRIPTION revised and REFERENCES section added. (WRB) !***END PROLOGUE TEVLC ! INTEGER I ,J ,L ,M , & N ,II ,L1 ,MML , & IERR REAL D(*) ,E2(*) REAL B ,C ,F ,G , & H ,P ,R ,S , & MACHEP ! COMMON /CCBLK/ NPP ,K ,MACHEP ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT TEVLC IERR = 0 if (N == 1) go to 115 ! DO 101 I=2,N E2(I-1) = E2(I)*E2(I) 101 CONTINUE ! F = 0.0 B = 0.0 E2(N) = 0.0 ! DO 112 L=1,N J = 0 H = MACHEP*(ABS(D(L))+SQRT(E2(L))) if (B > H) go to 102 B = H C = B*B ! ! ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ********** ! 102 DO 103 M=L,N if (E2(M) <= C) go to 104 ! ! ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT ! THROUGH THE BOTTOM OF THE LOOP ********** ! 103 CONTINUE ! 104 if (M == L) go to 108 105 if (J == 30) go to 114 J = J+1 ! ! ********** 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) D(L) = S/(P+SIGN(R,P)) H = G-D(L) ! DO 106 I=L1,N D(I) = D(I)-H 106 CONTINUE ! F = F+H ! ! ********** RATIONAL QL TRANSFORMATION ********** ! G = D(M) if (G == 0.0) G = B H = G S = 0.0 MML = M-L ! ! ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** ! DO 107 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 == 0.0) G = B H = G*P/R 107 CONTINUE ! E2(L) = S*G D(L) = H ! ! ********** GUARD AGAINST UNDERFLOWED H ********** ! if (H == 0.0) go to 108 if (ABS(E2(L)) <= ABS(C/H)) go to 108 E2(L) = H*E2(L) if (E2(L) /= 0.0) go to 105 108 P = D(L)+F ! ! ********** ORDER EIGENVALUES ********** ! if (L == 1) go to 110 ! ! ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** ! DO 109 II=2,L I = L+2-II if (P >= D(I-1)) go to 111 D(I) = D(I-1) 109 CONTINUE ! 110 I = 1 111 D(I) = P 112 CONTINUE ! if (ABS(D(N)) >= ABS(D(1))) go to 115 NHALF = N/2 DO 113 I=1,NHALF NTOP = N-I DHOLD = D(I) D(I) = D(NTOP+1) D(NTOP+1) = DHOLD 113 CONTINUE go to 115 ! ! ********** SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30 ITERATIONS ********** ! 114 IERR = L 115 RETURN ! ! ********** LAST CARD OF TQLRAT ********** ! end subroutine TEVLS (N, D, E2, IERR) ! !! TEVLS finds eigenvalues of a symmetric tridiagonal matrix by rational QL. ! !***SUBSIDIARY !***PURPOSE Subsidiary to BLKTRI !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (TEVLS-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine finds the eigenvalues of a symmetric tridiagonal ! matrix by the rational QL method. ! ! On Input- ! ! N is the order of the matrix, ! ! D contains the diagonal elements of the input matrix, ! ! E2 contains the subdiagonal elements of the input matrix ! in its last N-1 positions. E2(1) is arbitrary. ! ! On Output- ! ! D contains the eigenvalues in ascending order. If an ! error exit is made, the eigenvalues are correct and ! ordered for indices 1,2,...IERR-1, but may not be ! the smallest eigenvalues, ! ! E2 has been destroyed, ! ! IERR is set to ! ZERO for normal return, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! !***SEE ALSO BLKTRI !***REFERENCES C. H. Reinsch, Eigenvalues of a real, symmetric, tri- ! diagonal matrix, Algorithm 464, Communications of the ! ACM 16, 11 (November 1973), pp. 689. !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CBLKT !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) ! 920528 DESCRIPTION revised and REFERENCES section added. (WRB) !***END PROLOGUE TEVLS ! INTEGER I ,J ,L ,M , & N ,II ,L1 ,MML , & IERR REAL D(*) ,E2(*) REAL B ,C ,F ,G , & H ,P ,R ,S , & MACHEP ! COMMON /CBLKT/ NPP ,K ,MACHEP ,CNV , & NM ,NCMPLX ,IK !***FIRST EXECUTABLE STATEMENT TEVLS IERR = 0 if (N == 1) go to 115 ! DO 101 I=2,N E2(I-1) = E2(I)*E2(I) 101 CONTINUE ! F = 0.0 B = 0.0 E2(N) = 0.0 ! DO 112 L=1,N J = 0 H = MACHEP*(ABS(D(L))+SQRT(E2(L))) if (B > H) go to 102 B = H C = B*B ! ! ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ********** ! 102 DO 103 M=L,N if (E2(M) <= C) go to 104 ! ! ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT ! THROUGH THE BOTTOM OF THE LOOP ********** ! 103 CONTINUE ! 104 if (M == L) go to 108 105 if (J == 30) go to 114 J = J+1 ! ! ********** 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) D(L) = S/(P+SIGN(R,P)) H = G-D(L) ! DO 106 I=L1,N D(I) = D(I)-H 106 CONTINUE ! F = F+H ! ! ********** RATIONAL QL TRANSFORMATION ********** ! G = D(M) if (G == 0.0) G = B H = G S = 0.0 MML = M-L ! ! ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** ! DO 107 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 == 0.0) G = B H = G*P/R 107 CONTINUE ! E2(L) = S*G D(L) = H ! ! ********** GUARD AGAINST UNDERFLOWED H ********** ! if (H == 0.0) go to 108 if (ABS(E2(L)) <= ABS(C/H)) go to 108 E2(L) = H*E2(L) if (E2(L) /= 0.0) go to 105 108 P = D(L)+F ! ! ********** ORDER EIGENVALUES ********** ! if (L == 1) go to 110 ! ! ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** ! DO 109 II=2,L I = L+2-II if (P >= D(I-1)) go to 111 D(I) = D(I-1) 109 CONTINUE ! 110 I = 1 111 D(I) = P 112 CONTINUE ! if (ABS(D(N)) >= ABS(D(1))) go to 115 NHALF = N/2 DO 113 I=1,NHALF NTOP = N-I DHOLD = D(I) D(I) = D(NTOP+1) D(NTOP+1) = DHOLD 113 CONTINUE go to 115 ! ! ********** SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30 ITERATIONS ********** ! 114 IERR = L 115 RETURN ! ! ********** LAST CARD OF TQLRAT ********** ! end subroutine timestamp ( ) ! !******************************************************************************* ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Modified: ! ! 31 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! character ( len = 8 ) ampm integer d character ( len = 8 ) date integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone ! call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine TINVIT (NM, N, D, E, E2, M, W, IND, Z, IERR, RV1, RV2, & RV3, RV4, RV6) ! !! TINVIT computes eigenvectors of symmetric tridiagonal matrix ... ! corresponding to specified eigenvalues, using inverse ! iteration. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C3 !***TYPE SINGLE PRECISION (TINVIT-S) !***KEYWORDS EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the inverse iteration tech- ! nique in the ALGOL procedure TRISTURM by Peters and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). ! ! This subroutine finds those eigenvectors of a TRIDIAGONAL ! SYMMETRIC matrix corresponding to specified eigenvalues, ! using inverse iteration. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, Z, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is ! arbitrary. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! E2 contains the squares of the corresponding elements of E, ! with zeros corresponding to negligible elements of E. ! E(I) is considered negligible if it is not larger than ! the product of the relative machine precision and the sum ! of the magnitudes of D(I) and D(I-1). E2(1) must contain ! 0.0e0 if the eigenvalues are in ascending order, or 2.0e0 ! if the eigenvalues are in descending order. If BISECT, ! TRIDIB, or IMTQLV has been used to find the eigenvalues, ! their output E2 array is exactly what is expected here. ! E2 is a one-dimensional REAL array, dimensioned E2(N). ! ! M is the number of specified eigenvalues for which eigenvectors ! are to be determined. M is an INTEGER variable. ! ! W contains the M eigenvalues in ascending or descending order. ! W is a one-dimensional REAL array, dimensioned W(M). ! ! IND contains in its first M positions the submatrix indices ! associated with the corresponding eigenvalues in W -- ! 1 for eigenvalues belonging to the first submatrix from ! the top, 2 for those belonging to the second submatrix, etc. ! If BISECT or TRIDIB has been used to determine the ! eigenvalues, their output IND array is suitable for input ! to TINVIT. IND is a one-dimensional INTEGER array, ! dimensioned IND(M). ! ! On Output ! ! ** All input arrays are unaltered.** ! ! Z contains the associated set of orthonormal eigenvectors. ! Any vector which fails to converge is set to zero. ! Z is a two-dimensional REAL array, dimensioned Z(NM,M). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! -J if the eigenvector corresponding to the J-th ! eigenvalue fails to converge in 5 iterations. ! ! RV1, RV2 and RV3 are one-dimensional REAL arrays used for ! temporary storage. They are used to store the main diagonal ! and the two adjacent diagonals of the triangular matrix ! produced in the inverse iteration process. RV1, RV2 and ! RV3 are dimensioned RV1(N), RV2(N) and RV3(N). ! ! RV4 and RV6 are one-dimensional REAL arrays used for temporary ! storage. RV4 holds the multipliers of the Gaussian ! elimination process. RV6 holds the approximate eigenvectors ! in this process. RV4 and RV6 are dimensioned RV4(N) and ! RV6(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TINVIT ! INTEGER I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP INTEGER IND(*) REAL D(*),E(*),E2(*),W(*),Z(NM,*) REAL RV1(*),RV2(*),RV3(*),RV4(*),RV6(*) REAL U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,NORM,ORDER ! !***FIRST EXECUTABLE STATEMENT TINVIT IERR = 0 if (M == 0) go to 1001 TAG = 0 ORDER = 1.0E0 - E2(1) Q = 0 ! .......... ESTABLISH AND PROCESS NEXT SUBMATRIX .......... 100 P = Q + 1 ! DO 120 Q = P, N if (Q == N) go to 140 if (E2(Q+1) == 0.0E0) go to 140 120 CONTINUE ! .......... FIND VECTORS BY INVERSE ITERATION .......... 140 TAG = TAG + 1 S = 0 ! DO 920 R = 1, M if (IND(R) /= TAG) go to 920 ITS = 1 X1 = W(R) if (S /= 0) go to 510 ! .......... CHECK FOR ISOLATED ROOT .......... XU = 1.0E0 if (P /= Q) go to 490 RV6(P) = 1.0E0 go to 870 490 NORM = ABS(D(P)) IP = P + 1 ! DO 500 I = IP, Q 500 NORM = MAX(NORM, ABS(D(I)) + ABS(E(I))) ! .......... EPS2 IS THE CRITERION FOR GROUPING, ! EPS3 REPLACES ZERO PIVOTS AND EQUAL ! ROOTS ARE MODIFIED BY EPS3, ! EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... EPS2 = 1.0E-3 * NORM EPS3 = NORM 502 EPS3 = 0.5E0*EPS3 if (NORM + EPS3 > NORM) go to 502 UK = SQRT(REAL(Q-P+5)) EPS3 = UK * EPS3 EPS4 = UK * EPS3 UK = EPS4 / UK S = P 505 GROUP = 0 go to 520 ! .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... 510 if (ABS(X1-X0) >= EPS2) go to 505 GROUP = GROUP + 1 if (ORDER * (X1 - X0) <= 0.0E0) X1 = X0 + ORDER * EPS3 ! .......... ELIMINATION WITH INTERCHANGES AND ! INITIALIZATION OF VECTOR .......... 520 V = 0.0E0 ! DO 580 I = P, Q RV6(I) = UK if (I == P) go to 560 if (ABS(E(I)) < ABS(U)) go to 540 ! .......... WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF ! E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY .......... XU = U / E(I) RV4(I) = XU RV1(I-1) = E(I) RV2(I-1) = D(I) - X1 RV3(I-1) = 0.0E0 if (I /= Q) RV3(I-1) = E(I+1) U = V - XU * RV2(I-1) V = -XU * RV3(I-1) go to 580 540 XU = E(I) / U RV4(I) = XU RV1(I-1) = U RV2(I-1) = V RV3(I-1) = 0.0E0 560 U = D(I) - X1 - XU * V if (I /= Q) V = E(I+1) 580 CONTINUE ! if (U == 0.0E0) U = EPS3 RV1(Q) = U RV2(Q) = 0.0E0 RV3(Q) = 0.0E0 ! .......... BACK SUBSTITUTION ! FOR I=Q STEP -1 UNTIL P DO -- .......... 600 DO 620 II = P, Q I = P + Q - II RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) V = U U = RV6(I) 620 CONTINUE ! .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS ! MEMBERS OF GROUP .......... if (GROUP == 0) go to 700 J = R ! DO 680 JJ = 1, GROUP 630 J = J - 1 if (IND(J) /= TAG) go to 630 XU = 0.0E0 ! DO 640 I = P, Q 640 XU = XU + RV6(I) * Z(I,J) ! DO 660 I = P, Q 660 RV6(I) = RV6(I) - XU * Z(I,J) ! 680 CONTINUE ! 700 NORM = 0.0E0 ! DO 720 I = P, Q 720 NORM = NORM + ABS(RV6(I)) ! if (NORM >= 1.0E0) go to 840 ! .......... FORWARD SUBSTITUTION .......... if (ITS == 5) go to 830 if (NORM /= 0.0E0) go to 740 RV6(S) = EPS4 S = S + 1 if (S > Q) S = P go to 780 740 XU = EPS4 / NORM ! DO 760 I = P, Q 760 RV6(I) = RV6(I) * XU ! .......... ELIMINATION OPERATIONS ON NEXT VECTOR ! ITERATE .......... 780 DO 820 I = IP, Q U = RV6(I) ! .......... if RV1(I-1) == E(I), A ROW INTERCHANGE ! WAS PERFORMED EARLIER IN THE ! TRIANGULARIZATION PROCESS .......... if (RV1(I-1) /= E(I)) go to 800 U = RV6(I-1) RV6(I-1) = RV6(I) 800 RV6(I) = U - RV4(I) * RV6(I-1) 820 CONTINUE ! ITS = ITS + 1 go to 600 ! .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... 830 IERR = -R XU = 0.0E0 go to 870 ! .......... NORMALIZE SO THAT SUM OF SQUARES IS ! 1 AND EXPAND TO FULL ORDER .......... 840 U = 0.0E0 ! DO 860 I = P, Q 860 U = U + RV6(I)**2 ! XU = 1.0E0 / SQRT(U) ! 870 DO 880 I = 1, N 880 Z(I,R) = 0.0E0 ! DO 900 I = P, Q 900 Z(I,R) = RV6(I) * XU ! X0 = X1 920 CONTINUE ! if (Q < N) go to 100 1001 RETURN end subroutine TQL1 (N, D, E, IERR) ! !! TQL1 computes eigenvalues of symmetric tridiagonal matrix by the QL method. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5, D4C2A !***TYPE SINGLE PRECISION (TQL1-S) !***KEYWORDS EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX, EISPACK, ! QL METHOD !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure TQL1, ! NUM. MATH. 11, 293-306(1968) by Bowdler, Martin, Reinsch, and ! Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). ! ! This subroutine finds the eigenvalues of a SYMMETRIC ! TRIDIAGONAL matrix by the QL method. ! ! On Input ! ! N is the order of the matrix. N is an INTEGER variable. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is ! arbitrary. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! On Output ! ! D contains the eigenvalues in ascending order. If an ! error exit is made, the eigenvalues are correct and ! ordered for indices 1, 2, ..., IERR-1, but may not be ! the smallest eigenvalues. ! ! E has been destroyed. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TQL1 ! INTEGER I,J,L,M,N,II,L1,L2,MML,IERR REAL D(*),E(*) REAL B,C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2 REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT TQL1 IERR = 0 if (N == 1) go to 1001 ! DO 100 I = 2, N 100 E(I-1) = E(I) ! F = 0.0E0 B = 0.0E0 E(N) = 0.0E0 ! DO 290 L = 1, N J = 0 H = ABS(D(L)) + ABS(E(L)) if (B < H) B = H ! .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... DO 110 M = L, N if (B + ABS(E(M)) == B) go to 120 ! .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT ! THROUGH THE BOTTOM OF THE LOOP .......... 110 CONTINUE ! 120 if (M == L) go to 210 130 if (J == 30) go to 1000 J = J + 1 ! .......... FORM SHIFT .......... L1 = L + 1 L2 = L1 + 1 G = D(L) P = (D(L1) - G) / (2.0E0 * E(L)) R = PYTHAG(P,1.0E0) D(L) = E(L) / (P + SIGN(R,P)) D(L1) = E(L) * (P + SIGN(R,P)) DL1 = D(L1) H = G - D(L) if (L2 > N) go to 145 ! DO 140 I = L2, N 140 D(I) = D(I) - H ! 145 F = F + H ! .......... QL TRANSFORMATION .......... P = D(M) C = 1.0E0 C2 = C EL1 = E(L1) S = 0.0E0 MML = M - L ! .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... DO 200 II = 1, MML C3 = C2 C2 = C S2 = S I = M - II G = C * E(I) H = C * P if (ABS(P) < ABS(E(I))) go to 150 C = E(I) / P R = SQRT(C*C+1.0E0) E(I+1) = S * P * R S = C / R C = 1.0E0 / R go to 160 150 C = P / E(I) R = SQRT(C*C+1.0E0) E(I+1) = S * E(I) * R S = 1.0E0 / R C = C * S 160 P = C * D(I) - S * G D(I+1) = H + S * (C * G + S * D(I)) 200 CONTINUE ! P = -S * S2 * C3 * EL1 * E(L) / DL1 E(L) = S * P D(L) = C * P if (B + ABS(E(L)) > B) go to 130 210 P = D(L) + F ! .......... ORDER EIGENVALUES .......... if (L == 1) go to 250 ! .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... DO 230 II = 2, L I = L + 2 - II if (P >= D(I-1)) go to 270 D(I) = D(I-1) 230 CONTINUE ! 250 I = 1 270 D(I) = P 290 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN end subroutine TQL2 (NM, N, D, E, Z, IERR) ! !! TQL2 computes eigenvalues and eigenvectors of symmetric tridiagonal matrix. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5, D4C2A !***TYPE SINGLE PRECISION (TQL2-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure TQL2, ! NUM. MATH. 11, 293-306(1968) by Bowdler, Martin, Reinsch, and ! Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). ! ! This subroutine finds the eigenvalues and eigenvectors ! of a SYMMETRIC TRIDIAGONAL matrix by the QL method. ! The eigenvectors of a FULL SYMMETRIC matrix can also ! be found if TRED2 has been used to reduce this ! full matrix to tridiagonal form. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, Z, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is ! arbitrary. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! Z contains the transformation matrix produced in the ! reduction by TRED2, if performed. If the eigenvectors ! of the tridiagonal matrix are desired, Z must contain ! the identity matrix. Z is a two-dimensional REAL array, ! dimensioned Z(NM,N). ! ! On Output ! ! D contains the eigenvalues in ascending order. If an ! error exit is made, the eigenvalues are correct but ! unordered for indices 1, 2, ..., IERR-1. ! ! E has been destroyed. ! ! Z contains orthonormal eigenvectors of the symmetric ! tridiagonal (or full) matrix. If an error exit is made, ! Z contains the eigenvectors associated with the stored ! eigenvalues. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED PYTHAG !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TQL2 ! INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR REAL D(*),E(*),Z(NM,*) REAL B,C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2 REAL PYTHAG ! !***FIRST EXECUTABLE STATEMENT TQL2 IERR = 0 if (N == 1) go to 1001 ! DO 100 I = 2, N 100 E(I-1) = E(I) ! F = 0.0E0 B = 0.0E0 E(N) = 0.0E0 ! DO 240 L = 1, N J = 0 H = ABS(D(L)) + ABS(E(L)) if (B < H) B = H ! .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... DO 110 M = L, N if (B + ABS(E(M)) == B) go to 120 ! .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT ! THROUGH THE BOTTOM OF THE LOOP .......... 110 CONTINUE ! 120 if (M == L) go to 220 130 if (J == 30) go to 1000 J = J + 1 ! .......... FORM SHIFT .......... L1 = L + 1 L2 = L1 + 1 G = D(L) P = (D(L1) - G) / (2.0E0 * E(L)) R = PYTHAG(P,1.0E0) D(L) = E(L) / (P + SIGN(R,P)) D(L1) = E(L) * (P + SIGN(R,P)) DL1 = D(L1) H = G - D(L) if (L2 > N) go to 145 ! DO 140 I = L2, N 140 D(I) = D(I) - H ! 145 F = F + H ! .......... QL TRANSFORMATION .......... P = D(M) C = 1.0E0 C2 = C EL1 = E(L1) S = 0.0E0 MML = M - L ! .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... DO 200 II = 1, MML C3 = C2 C2 = C S2 = S I = M - II G = C * E(I) H = C * P if (ABS(P) < ABS(E(I))) go to 150 C = E(I) / P R = SQRT(C*C+1.0E0) E(I+1) = S * P * R S = C / R C = 1.0E0 / R go to 160 150 C = P / E(I) R = SQRT(C*C+1.0E0) E(I+1) = S * E(I) * R S = 1.0E0 / R C = C * S 160 P = C * D(I) - S * G D(I+1) = H + S * (C * G + S * D(I)) ! .......... 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 ! 200 CONTINUE ! P = -S * S2 * C3 * EL1 * E(L) / DL1 E(L) = S * P D(L) = C * P if (B + ABS(E(L)) > B) go to 130 220 D(L) = D(L) + F 240 CONTINUE ! .......... ORDER EIGENVALUES AND EIGENVECTORS .......... DO 300 II = 2, N I = II - 1 K = I P = D(I) ! DO 260 J = II, N if (D(J) >= P) go to 260 K = J P = D(J) 260 CONTINUE ! if (K == I) go to 300 D(K) = D(I) D(I) = P ! DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE ! 300 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN end subroutine TQLRAT (N, D, E2, IERR) ! !! TQLRAT computes the eigenvalues of symmetric tridiagonal matrix ... ! using a rational variant of the QL method. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5, D4C2A !***TYPE SINGLE PRECISION (TQLRAT-S) !***KEYWORDS EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX, EISPACK, ! QL METHOD !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure TQLRAT. ! ! This subroutine finds the eigenvalues of a SYMMETRIC ! TRIDIAGONAL matrix by the rational QL method. ! ! On Input ! ! N is the order of the matrix. N is an INTEGER variable. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E2 contains the squares of the subdiagonal elements of the ! symmetric tridiagonal matrix in its last N-1 positions. ! E2(1) is arbitrary. E2 is a one-dimensional REAL array, ! dimensioned E2(N). ! ! On Output ! ! D contains the eigenvalues in ascending order. If an ! error exit is made, the eigenvalues are correct and ! ordered for indices 1, 2, ..., IERR-1, but may not be ! the smallest eigenvalues. ! ! E2 has been destroyed. ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! J if the J-th eigenvalue has not been ! determined after 30 iterations. ! ! Calls PYTHAG(A,B) for sqrt(A**2 + B**2). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. ! C. H. Reinsch, Eigenvalues of a real, symmetric, tri- ! diagonal matrix, Algorithm 464, Communications of the ! ACM 16, 11 (November 1973), pp. 689. !***ROUTINES CALLED PYTHAG, R1MACH !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TQLRAT ! INTEGER I,J,L,M,N,II,L1,MML,IERR REAL D(*),E2(*) REAL B,C,F,G,H,P,R,S,MACHEP REAL PYTHAG LOGICAL FIRST ! SAVE FIRST, MACHEP DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT TQLRAT if (FIRST) THEN MACHEP = R1MACH(4) end if FIRST = .FALSE. ! IERR = 0 if (N == 1) go to 1001 ! DO 100 I = 2, N 100 E2(I-1) = E2(I) ! F = 0.0E0 B = 0.0E0 E2(N) = 0.0E0 ! DO 290 L = 1, N J = 0 H = MACHEP * (ABS(D(L)) + SQRT(E2(L))) if (B > H) go to 105 B = H C = B * B ! .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... 105 DO 110 M = L, N if (E2(M) <= C) go to 120 ! .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT ! THROUGH THE BOTTOM OF THE LOOP .......... 110 CONTINUE ! 120 if (M == L) go to 210 130 if (J == 30) go to 1000 J = J + 1 ! .......... FORM SHIFT .......... L1 = L + 1 S = SQRT(E2(L)) G = D(L) P = (D(L1) - G) / (2.0E0 * S) R = PYTHAG(P,1.0E0) D(L) = S / (P + SIGN(R,P)) H = G - D(L) ! DO 140 I = L1, N 140 D(I) = D(I) - H ! F = F + H ! .......... RATIONAL QL TRANSFORMATION .......... G = D(M) if (G == 0.0E0) G = B H = G S = 0.0E0 MML = M - L ! .......... 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 == 0.0E0) G = B H = G * P / R 200 CONTINUE ! E2(L) = S * G D(L) = H ! .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST .......... if (H == 0.0E0) go to 210 if (ABS(E2(L)) <= ABS(C/H)) go to 210 E2(L) = H * E2(L) if (E2(L) /= 0.0E0) go to 130 210 P = D(L) + F ! .......... ORDER EIGENVALUES .......... if (L == 1) go to 250 ! .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... DO 230 II = 2, L I = L + 2 - II if (P >= D(I-1)) go to 270 D(I) = D(I-1) 230 CONTINUE ! 250 I = 1 270 D(I) = P 290 CONTINUE ! go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN end subroutine TRBAK1 (NM, N, A, E, M, Z) ! !! TRBAK1 forms the eigenvectors of real symmetric matrix ... ! from the eigenvectors of a symmetric tridiagonal matrix formed by TRED1. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (TRBAK1-S) !***KEYWORDS EIGENVECTORS OF A REAL SYMMETRIC MATRIX, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure TRBAK1, ! NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). ! ! This subroutine forms the eigenvectors of a REAL SYMMETRIC ! matrix by back transforming those of the corresponding ! symmetric tridiagonal matrix determined by TRED1. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! A contains information about the orthogonal transformations ! used in the reduction by TRED1 in its strict lower ! triangle. A is a two-dimensional REAL array, dimensioned ! A(NM,N). ! ! E contains the subdiagonal elements of the tridiagonal matrix ! in its last N-1 positions. E(1) is arbitrary. These ! elements provide the remaining information about the ! orthogonal transformations. E is a one-dimensional REAL ! array, dimensioned E(N). ! ! M is the number of columns of Z to be back transformed. ! M is an INTEGER variable. ! ! Z contains the eigenvectors to be back transformed in its ! first M columns. Z is a two-dimensional REAL array, ! dimensioned Z(NM,M). ! ! On Output ! ! Z contains the transformed eigenvectors in its first M columns. ! ! Note that TRBAK1 preserves vector Euclidean norms. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TRBAK1 ! INTEGER I,J,K,L,M,N,NM REAL A(NM,*),E(*),Z(NM,*) REAL S ! !***FIRST EXECUTABLE STATEMENT TRBAK1 if (M == 0) go to 200 if (N == 1) go to 200 ! DO 140 I = 2, N L = I - 1 if (E(I) == 0.0E0) go to 140 ! DO 130 J = 1, M S = 0.0E0 ! DO 110 K = 1, L 110 S = S + A(I,K) * Z(K,J) ! .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN TRED1. ! DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... S = (S / A(I,L)) / E(I) ! DO 120 K = 1, L 120 Z(K,J) = Z(K,J) + S * A(I,K) ! 130 CONTINUE ! 140 CONTINUE ! 200 RETURN end subroutine TRBAK3 (NM, N, NV, A, M, Z) ! !! TRBAK3 forms the eigenvectors of a real symmetric matrix from the ... ! eigenvectors of a symmetric tridiagonal matrix formed by TRED3. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C4 !***TYPE SINGLE PRECISION (TRBAK3-S) !***KEYWORDS EIGENVECTORS OF A REAL SYMMETRIC MATRIX, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure TRBAK3, ! NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). ! ! This subroutine forms the eigenvectors of a REAL SYMMETRIC ! matrix by back transforming those of the corresponding ! symmetric tridiagonal matrix determined by TRED3. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, Z, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! NV is an INTEGER variable set equal to the dimension of the ! array A as specified in the calling program. NV must not ! be less than N*(N+1)/2. ! ! A contains information about the orthogonal transformations ! used in the reduction by TRED3 in its first N*(N+1)/2 ! positions. A is a one-dimensional REAL array, dimensioned ! A(NV). ! ! M is the number of columns of Z to be back transformed. ! M is an INTEGER variable. ! ! Z contains the eigenvectors to be back transformed in its ! first M columns. Z is a two-dimensional REAL array, ! dimensioned Z(NM,M). ! ! On Output ! ! Z contains the transformed eigenvectors in its first M columns. ! ! Note that TRBAK3 preserves vector Euclidean norms. ! ! Questions and comments should be directed to b. s. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TRBAK3 ! INTEGER I,J,K,L,M,N,IK,IZ,NM,NV REAL A(*),Z(NM,*) REAL H,S ! !***FIRST EXECUTABLE STATEMENT TRBAK3 if (M == 0) go to 200 if (N == 1) go to 200 ! DO 140 I = 2, N L = I - 1 IZ = (I * L) / 2 IK = IZ + I H = A(IK) if (H == 0.0E0) go to 140 ! DO 130 J = 1, M S = 0.0E0 IK = IZ ! DO 110 K = 1, L IK = IK + 1 S = S + A(IK) * Z(K,J) 110 CONTINUE ! .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... S = (S / H) / H IK = IZ ! DO 120 K = 1, L IK = IK + 1 Z(K,J) = Z(K,J) - S * A(IK) 120 CONTINUE ! 130 CONTINUE ! 140 CONTINUE ! 200 RETURN end subroutine TRED1 (NM, N, A, D, E, E2) ! !! TRED1 reduces a real symmetric matrix to symmetric tridiagonal ... ! matrix using orthogonal similarity transformations. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B1 !***TYPE SINGLE PRECISION (TRED1-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure TRED1, ! NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). ! ! This subroutine reduces a REAL SYMMETRIC matrix ! to a symmetric tridiagonal matrix using ! orthogonal similarity transformations. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, A, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! A contains the real symmetric input matrix. Only the lower ! triangle of the matrix need be supplied. A is a two- ! dimensional REAL array, dimensioned A(NM,N). ! ! On Output ! ! A contains information about the orthogonal transformations ! used in the reduction in its strict lower triangle. The ! full upper triangle of A is unaltered. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is set ! to zero. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! E2 contains the squares of the corresponding elements of E. ! E2 may coincide with E if the squares are not needed. ! E2 is a one-dimensional REAL array, dimensioned E2(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TRED1 ! INTEGER I,J,K,L,N,II,NM,JP1 REAL A(NM,*),D(*),E(*),E2(*) REAL F,G,H,SCALE ! !***FIRST EXECUTABLE STATEMENT TRED1 DO 100 I = 1, N 100 D(I) = A(I,I) ! .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... DO 300 II = 1, N I = N + 1 - II L = I - 1 H = 0.0E0 SCALE = 0.0E0 if (L < 1) go to 130 ! .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... DO 120 K = 1, L 120 SCALE = SCALE + ABS(A(I,K)) ! if (SCALE /= 0.0E0) go to 140 130 E(I) = 0.0E0 E2(I) = 0.0E0 go to 290 ! 140 DO 150 K = 1, L A(I,K) = A(I,K) / SCALE H = H + A(I,K) * A(I,K) 150 CONTINUE ! E2(I) = SCALE * SCALE * H F = A(I,L) G = -SIGN(SQRT(H),F) E(I) = SCALE * G H = H - F * G A(I,L) = F - G if (L == 1) go to 270 F = 0.0E0 ! DO 240 J = 1, L G = 0.0E0 ! .......... FORM ELEMENT OF A*U .......... DO 180 K = 1, J 180 G = G + A(J,K) * A(I,K) ! JP1 = J + 1 if (L < JP1) go to 220 ! DO 200 K = JP1, L 200 G = G + A(K,J) * A(I,K) ! .......... FORM ELEMENT OF P .......... 220 E(J) = G / H F = F + E(J) * A(I,J) 240 CONTINUE ! H = F / (H + H) ! .......... FORM REDUCED A .......... DO 260 J = 1, L F = A(I,J) G = E(J) - H * F E(J) = G ! DO 260 K = 1, J A(J,K) = A(J,K) - F * E(K) - G * A(I,K) 260 CONTINUE ! 270 DO 280 K = 1, L 280 A(I,K) = SCALE * A(I,K) ! 290 H = D(I) D(I) = A(I,I) A(I,I) = H 300 CONTINUE ! return end subroutine TRED2 (NM, N, A, D, E, Z) ! !! TRED2 reduces a real symmetric matrix to a symmetric tridiagonal ... ! matrix using and accumulating orthogonal transformations. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B1 !***TYPE SINGLE PRECISION (TRED2-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure TRED2, ! NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). ! ! This subroutine reduces a REAL SYMMETRIC matrix to a ! symmetric tridiagonal matrix using and accumulating ! orthogonal similarity transformations. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameters, A and Z, as declared in the calling ! program dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix A. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! A contains the real symmetric input matrix. Only the lower ! triangle of the matrix need be supplied. A is a two- ! dimensional REAL array, dimensioned A(NM,N). ! ! On Output ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is set ! to zero. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! Z contains the orthogonal transformation matrix produced in ! the reduction. Z is a two-dimensional REAL array, ! dimensioned Z(NM,N). ! ! A and Z may coincide. If distinct, A is unaltered. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TRED2 ! INTEGER I,J,K,L,N,II,NM,JP1 REAL A(NM,*),D(*),E(*),Z(NM,*) REAL F,G,H,HH,SCALE ! !***FIRST EXECUTABLE STATEMENT TRED2 DO 100 I = 1, N ! DO 100 J = 1, I Z(I,J) = A(I,J) 100 CONTINUE ! if (N == 1) go to 320 ! .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... DO 300 II = 2, N I = N + 2 - II L = I - 1 H = 0.0E0 SCALE = 0.0E0 if (L < 2) go to 130 ! .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... DO 120 K = 1, L 120 SCALE = SCALE + ABS(Z(I,K)) ! if (SCALE /= 0.0E0) go to 140 130 E(I) = Z(I,L) go to 290 ! 140 DO 150 K = 1, L Z(I,K) = Z(I,K) / SCALE H = H + Z(I,K) * Z(I,K) 150 CONTINUE ! F = Z(I,L) G = -SIGN(SQRT(H),F) E(I) = SCALE * G H = H - F * G Z(I,L) = F - G F = 0.0E0 ! DO 240 J = 1, L Z(J,I) = Z(I,J) / H G = 0.0E0 ! .......... FORM ELEMENT OF A*U .......... DO 180 K = 1, J 180 G = G + Z(J,K) * Z(I,K) ! JP1 = J + 1 if (L < JP1) go to 220 ! DO 200 K = JP1, L 200 G = G + Z(K,J) * Z(I,K) ! .......... FORM ELEMENT OF P .......... 220 E(J) = G / H F = F + E(J) * Z(I,J) 240 CONTINUE ! HH = F / (H + H) ! .......... FORM REDUCED A .......... DO 260 J = 1, L F = Z(I,J) G = E(J) - HH * F E(J) = G ! DO 260 K = 1, J Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K) 260 CONTINUE ! 290 D(I) = H 300 CONTINUE ! 320 D(1) = 0.0E0 E(1) = 0.0E0 ! .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... DO 500 I = 1, N L = I - 1 if (D(I) == 0.0E0) go to 380 ! DO 360 J = 1, L G = 0.0E0 ! DO 340 K = 1, L 340 G = G + Z(I,K) * Z(K,J) ! DO 360 K = 1, L Z(K,J) = Z(K,J) - G * Z(K,I) 360 CONTINUE ! 380 D(I) = Z(I,I) Z(I,I) = 1.0E0 if (L < 1) go to 500 ! DO 400 J = 1, L Z(I,J) = 0.0E0 Z(J,I) = 0.0E0 400 CONTINUE ! 500 CONTINUE ! return end subroutine TRED3 (N, NV, A, D, E, E2) ! !! TRED3 reduces a real symmetric matrix stored in packed form to ! symmetric tridiagonal matrix using orthogonal transformations. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4C1B1 !***TYPE SINGLE PRECISION (TRED3-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure TRED3, ! NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). ! ! This subroutine reduces a REAL SYMMETRIC matrix, stored as ! a one-dimensional array, to a symmetric tridiagonal matrix ! using orthogonal similarity transformations. ! ! On Input ! ! N is the order of the matrix A. N is an INTEGER variable. ! ! NV is an INTEGER variable set equal to the dimension of the ! array A as specified in the calling program. NV must not ! be less than N*(N+1)/2. ! ! A contains the lower triangle, stored row-wise, of the real ! symmetric packed matrix. A is a one-dimensional REAL ! array, dimensioned A(NV). ! ! On Output ! ! A contains information about the orthogonal transformations ! used in the reduction in its first N*(N+1)/2 positions. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is set ! to zero. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! E2 contains the squares of the corresponding elements of E. ! E2 may coincide with E if the squares are not needed. ! E2 is a one-dimensional REAL array, dimensioned E2(N). ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TRED3 ! INTEGER I,J,K,L,N,II,IZ,JK,NV REAL A(*),D(*),E(*),E2(*) REAL F,G,H,HH,SCALE ! ! .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... !***FIRST EXECUTABLE STATEMENT TRED3 DO 300 II = 1, N I = N + 1 - II L = I - 1 IZ = (I * L) / 2 H = 0.0E0 SCALE = 0.0E0 if (L < 1) go to 130 ! .......... 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 ! if (SCALE /= 0.0E0) go to 140 130 E(I) = 0.0E0 E2(I) = 0.0E0 go to 290 ! 140 DO 150 K = 1, L D(K) = D(K) / SCALE H = H + D(K) * D(K) 150 CONTINUE ! E2(I) = SCALE * SCALE * H F = D(L) G = -SIGN(SQRT(H),F) E(I) = SCALE * G H = H - F * G D(L) = F - G A(IZ) = SCALE * D(L) if (L == 1) go to 290 F = 0.0E0 ! DO 240 J = 1, L G = 0.0E0 JK = (J * (J-1)) / 2 ! .......... FORM ELEMENT OF A*U .......... DO 180 K = 1, L JK = JK + 1 if (K > J) JK = JK + K - 2 G = G + A(JK) * D(K) 180 CONTINUE ! .......... FORM ELEMENT OF P .......... E(J) = G / H F = F + E(J) * D(J) 240 CONTINUE ! HH = F / (H + H) JK = 0 ! .......... FORM REDUCED A .......... DO 260 J = 1, L F = D(J) G = E(J) - HH * F E(J) = G ! DO 260 K = 1, J JK = JK + 1 A(JK) = A(JK) - F * E(K) - G * D(K) 260 CONTINUE ! 290 D(I) = A(IZ+1) A(IZ+1) = SCALE * SQRT(H) 300 CONTINUE ! return end subroutine TRI3 (M, A, B, C, K, Y1, Y2, Y3, TCOS, D, W1, W2, W3) ! !! TRI3 solves three tridiagonal systems for GENBUN. ! !***SUBSIDIARY !***PURPOSE Subsidiary to GENBUN !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (TRI3-S, CMPTR3-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve three linear systems whose common coefficient ! matrix is a rational function in the matrix given by ! ! TRIDIAGONAL (...,A(I),B(I),C(I),...) ! !***SEE ALSO GENBUN !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE TRI3 DIMENSION A(*) ,B(*) ,C(*) ,K(4) , & TCOS(*) ,Y1(*) ,Y2(*) ,Y3(*) , & D(*) ,W1(*) ,W2(*) ,W3(*) INTEGER K1P1, K2P1, K3P1, K4P1 ! !***FIRST EXECUTABLE STATEMENT TRI3 MM1 = M-1 K1 = K(1) K2 = K(2) K3 = K(3) K4 = K(4) K1P1 = K1+1 K2P1 = K2+1 K3P1 = K3+1 K4P1 = K4+1 K2K3K4 = K2+K3+K4 if (K2K3K4 == 0) go to 101 L1 = (K1+1)/(K2+1) L2 = (K1+1)/(K3+1) L3 = (K1+1)/(K4+1) LINT1 = 1 LINT2 = 1 LINT3 = 1 KINT1 = K1 KINT2 = KINT1+K2 KINT3 = KINT2+K3 101 CONTINUE DO 115 N=1,K1 X = TCOS(N) if (K2K3K4 == 0) go to 107 if (N /= L1) go to 103 DO 102 I=1,M W1(I) = Y1(I) 102 CONTINUE 103 if (N /= L2) go to 105 DO 104 I=1,M W2(I) = Y2(I) 104 CONTINUE 105 if (N /= L3) go to 107 DO 106 I=1,M W3(I) = Y3(I) 106 CONTINUE 107 CONTINUE Z = 1./(B(1)-X) D(1) = C(1)*Z Y1(1) = Y1(1)*Z Y2(1) = Y2(1)*Z Y3(1) = Y3(1)*Z DO 108 I=2,M Z = 1./(B(I)-X-A(I)*D(I-1)) D(I) = C(I)*Z Y1(I) = (Y1(I)-A(I)*Y1(I-1))*Z Y2(I) = (Y2(I)-A(I)*Y2(I-1))*Z Y3(I) = (Y3(I)-A(I)*Y3(I-1))*Z 108 CONTINUE DO 109 IP=1,MM1 I = M-IP Y1(I) = Y1(I)-D(I)*Y1(I+1) Y2(I) = Y2(I)-D(I)*Y2(I+1) Y3(I) = Y3(I)-D(I)*Y3(I+1) 109 CONTINUE if (K2K3K4 == 0) go to 115 if (N /= L1) go to 111 I = LINT1+KINT1 XX = X-TCOS(I) DO 110 I=1,M Y1(I) = XX*Y1(I)+W1(I) 110 CONTINUE LINT1 = LINT1+1 L1 = (LINT1*K1P1)/K2P1 111 if (N /= L2) go to 113 I = LINT2+KINT2 XX = X-TCOS(I) DO 112 I=1,M Y2(I) = XX*Y2(I)+W2(I) 112 CONTINUE LINT2 = LINT2+1 L2 = (LINT2*K1P1)/K3P1 113 if (N /= L3) go to 115 I = LINT3+KINT3 XX = X-TCOS(I) DO 114 I=1,M Y3(I) = XX*Y3(I)+W3(I) 114 CONTINUE LINT3 = LINT3+1 L3 = (LINT3*K1P1)/K4P1 115 CONTINUE return end subroutine TRIDIB (N, EPS1, D, E, E2, LB, UB, M11, M, W, IND, & IERR, RV4, RV5) ! !! TRIDIB computes the eigenvalues of a symmetric tridiagonal matrix ... ! in a given interval using Sturm sequencing. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5, D4C2A !***TYPE SINGLE PRECISION (TRIDIB-S) !***KEYWORDS EIGENVALUES OF A REAL SYMMETRIC MATRIX, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine is a translation of the ALGOL procedure BISECT, ! NUM. MATH. 9, 386-393(1967) by Barth, Martin, and Wilkinson. ! HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971). ! ! This subroutine finds those eigenvalues of a TRIDIAGONAL ! SYMMETRIC matrix between specified boundary indices, ! using bisection. ! ! On Input ! ! N is the order of the matrix. N is an INTEGER variable. ! ! EPS1 is an absolute error tolerance for the computed eigen- ! values. If the input EPS1 is non-positive, it is reset for ! each submatrix to a default value, namely, minus the product ! of the relative machine precision and the 1-norm of the ! submatrix. EPS1 is a REAL variable. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is ! arbitrary. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! E2 contains the squares of the corresponding elements of E. ! E2(1) is arbitrary. E2 is a one-dimensional REAL array, ! dimensioned E2(N). ! ! M11 specifies the lower boundary index for the set of desired ! eigenvalues. M11 is an INTEGER variable. ! ! M specifies the number of eigenvalues desired. The upper ! boundary index M22 is then obtained as M22=M11+M-1. ! M is an INTEGER variable. ! ! On Output ! ! EPS1 is unaltered unless it has been reset to its ! (last) default value. ! ! D and E are unaltered. ! ! Elements of E2, corresponding to elements of E regarded ! as negligible, have been replaced by zero causing the ! matrix to split into a direct sum of submatrices. ! E2(1) is also set to zero. ! ! LB and UB define an interval containing exactly the desired ! eigenvalues. LB and UB are REAL variables. ! ! W contains, in its first M positions, the eigenvalues ! between indices M11 and M22 in ascending order. ! W is a one-dimensional REAL array, dimensioned W(M). ! ! IND contains in its first M positions the submatrix indices ! associated with the corresponding eigenvalues in W -- ! 1 for eigenvalues belonging to the first submatrix from ! the top, 2 for those belonging to the second submatrix, etc. ! IND is an one-dimensional INTEGER array, dimensioned IND(M). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 3*N+1 if multiple eigenvalues at index M11 make ! unique selection of LB impossible, ! 3*N+2 if multiple eigenvalues at index M22 make ! unique selection of UB impossible. ! ! RV4 and RV5 are one-dimensional REAL arrays used for temporary ! storage of the lower and upper bounds for the eigenvalues in ! the bisection process. RV4 and RV5 are dimensioned RV4(N) ! and RV5(N). ! ! Note that subroutine TQL1, IMTQL1, or TQLRAT is generally faster ! than TRIDIB, if more than N/4 eigenvalues are to be found. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TRIDIB ! INTEGER I,J,K,L,M,N,P,Q,R,S,II,M1,M2,M11,M22,TAG,IERR,ISTURM REAL D(*),E(*),E2(*),W(*),RV4(*),RV5(*) REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP,S1,S2 INTEGER IND(*) LOGICAL FIRST ! SAVE FIRST, MACHEP DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT TRIDIB if (FIRST) THEN MACHEP = R1MACH(4) end if FIRST = .FALSE. ! IERR = 0 TAG = 0 XU = D(1) X0 = D(1) U = 0.0E0 ! .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN ! INTERVAL CONTAINING ALL THE EIGENVALUES .......... DO 40 I = 1, N X1 = U U = 0.0E0 if (I /= N) U = ABS(E(I+1)) XU = MIN(D(I)-(X1+U),XU) X0 = MAX(D(I)+(X1+U),X0) if (I == 1) go to 20 S1 = ABS(D(I)) + ABS(D(I-1)) S2 = S1 + ABS(E(I)) if (S2 > S1) go to 40 20 E2(I) = 0.0E0 40 CONTINUE ! X1 = MAX(ABS(XU),ABS(X0)) * MACHEP * N XU = XU - X1 T1 = XU X0 = X0 + X1 T2 = X0 ! .......... DETERMINE AN INTERVAL CONTAINING EXACTLY ! THE DESIRED EIGENVALUES .......... P = 1 Q = N M1 = M11 - 1 if (M1 == 0) go to 75 ISTURM = 1 50 V = X1 X1 = XU + (X0 - XU) * 0.5E0 if (X1 == V) go to 980 go to 320 60 if (S - M1) 65, 73, 70 65 XU = X1 go to 50 70 X0 = X1 go to 50 73 XU = X1 T1 = X1 75 M22 = M1 + M if (M22 == N) go to 90 X0 = T2 ISTURM = 2 go to 50 80 if (S - M22) 65, 85, 70 85 T2 = X1 90 Q = 0 R = 0 ! .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING ! INTERVAL BY THE GERSCHGORIN BOUNDS .......... 100 if (R == M) go to 1001 TAG = TAG + 1 P = Q + 1 XU = D(P) X0 = D(P) U = 0.0E0 ! DO 120 Q = P, N X1 = U U = 0.0E0 V = 0.0E0 if (Q == N) go to 110 U = ABS(E(Q+1)) V = E2(Q+1) 110 XU = MIN(D(Q)-(X1+U),XU) X0 = MAX(D(Q)+(X1+U),X0) if (V == 0.0E0) go to 140 120 CONTINUE ! 140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP if (EPS1 <= 0.0E0) EPS1 = -X1 if (P /= Q) go to 180 ! .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... if (T1 > D(P) .OR. D(P) >= T2) go to 940 M1 = P M2 = P RV5(P) = D(P) go to 900 180 X1 = X1 * (Q-P+1) LB = MAX(T1,XU-X1) UB = MIN(T2,X0+X1) X1 = LB ISTURM = 3 go to 320 200 M1 = S + 1 X1 = UB ISTURM = 4 go to 320 220 M2 = S if (M1 > M2) go to 940 ! .......... FIND ROOTS BY BISECTION .......... X0 = UB ISTURM = 5 ! DO 240 I = M1, M2 RV5(I) = UB RV4(I) = LB 240 CONTINUE ! .......... LOOP FOR K-TH EIGENVALUE ! FOR K=M2 STEP -1 UNTIL M1 DO -- ! (-DO- NOT USED TO LEGALIZE -COMPUTED go to-) .......... K = M2 250 XU = LB ! .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... DO 260 II = M1, K I = M1 + K - II if (XU >= RV4(I)) go to 260 XU = RV4(I) go to 280 260 CONTINUE ! 280 if (X0 > RV5(K)) X0 = RV5(K) ! .......... NEXT BISECTION STEP .......... 300 X1 = (XU + X0) * 0.5E0 S1 = ABS(XU) + ABS(X0) + ABS(EPS1) S2 = S1 + ABS(X0-XU)/2.0E0 if (S2 == S1) go to 420 ! .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... 320 S = P - 1 U = 1.0E0 ! DO 340 I = P, Q if (U /= 0.0E0) go to 325 V = ABS(E(I)) / MACHEP if (E2(I) == 0.0E0) V = 0.0E0 go to 330 325 V = E2(I) / U 330 U = D(I) - X1 - V if (U < 0.0E0) S = S + 1 340 CONTINUE ! go to (60,80,200,220,360), ISTURM ! .......... REFINE INTERVALS .......... 360 if (S >= K) go to 400 XU = X1 if (S >= M1) go to 380 RV4(M1) = X1 go to 300 380 RV4(S+1) = X1 if (RV5(S) > X1) RV5(S) = X1 go to 300 400 X0 = X1 go to 300 ! .......... K-TH EIGENVALUE FOUND .......... 420 RV5(K) = X1 K = K - 1 if (K >= M1) go to 250 ! .......... ORDER EIGENVALUES TAGGED WITH THEIR ! SUBMATRIX ASSOCIATIONS .......... 900 S = R R = R + M2 - M1 + 1 J = 1 K = M1 ! DO 920 L = 1, R if (J > S) go to 910 if (K > M2) go to 940 if (RV5(K) >= W(L)) go to 915 ! DO 905 II = J, S I = L + S - II W(I+1) = W(I) IND(I+1) = IND(I) 905 CONTINUE ! 910 W(L) = RV5(K) IND(L) = TAG K = K + 1 go to 920 915 J = J + 1 920 CONTINUE ! 940 if (Q < N) go to 100 go to 1001 ! .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING ! EXACTLY THE DESIRED EIGENVALUES .......... 980 IERR = 3 * N + ISTURM 1001 LB = T1 UB = T2 return end subroutine TRIDQ (MR, A, B, C, Y, D) ! !! TRIDQ is subsidiary to POIS3D. ! !***SUBSIDIARY !***PURPOSE Subsidiary to POIS3D !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (TRIDQ-S) !***AUTHOR (UNKNOWN) !***SEE ALSO POIS3D !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900308 Renamed routine from TRID to TRIDQ. (WRB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE TRIDQ DIMENSION A(*) ,B(*) ,C(*) ,Y(*) , & D(*) !***FIRST EXECUTABLE STATEMENT TRIDQ M = MR MM1 = M-1 Z = 1./B(1) D(1) = C(1)*Z Y(1) = Y(1)*Z DO 101 I=2,MM1 Z = 1./(B(I)-A(I)*D(I-1)) D(I) = C(I)*Z Y(I) = (Y(I)-A(I)*Y(I-1))*Z 101 CONTINUE Z = B(M)-A(M)*D(MM1) if (Z /= 0.) go to 102 Y(M) = 0. go to 103 102 Y(M) = (Y(M)-A(M)*Y(MM1))/Z 103 CONTINUE DO 104 IP=1,MM1 I = M-IP Y(I) = Y(I)-D(I)*Y(I+1) 104 CONTINUE return end subroutine TRIS4 (N, A, B, C, D, U, Z) ! !! TRIS4 is subsidiary to SEPX4. ! !***SUBSIDIARY !***PURPOSE Subsidiary to SEPX4 !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (TRIS4-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine solves for a non-zero eigenvector corresponding ! to the zero eigenvalue of the transpose of the rank ! deficient ONE matrix with subdiagonal A, diagonal B, and ! superdiagonal C , with A(1) in the (1,N) position, with ! C(N) in the (N,1) position, AND all other elements zero. ! !***SEE ALSO SEPX4 !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE TRIS4 ! DIMENSION A(*) ,B(*) ,C(*) ,D(*) , & U(*) ,Z(*) !***FIRST EXECUTABLE STATEMENT TRIS4 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) ! ! SET LAST COMPONENT EQUAL TO ONE ! 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 TRISP (N, A, B, C, D, U, Z) ! !! TRISP is subsidiary to SEPELI. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (TRISP-S) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine solves for a non-zero eigenvector corresponding ! to the zero eigenvalue of the transpose of the rank ! deficient ONE matrix with subdiagonal A, diagonal B, and ! superdiagonal C , with A(1) in the (1,N) position, with ! C(N) in the (N,1) position, and all other elements zero. ! !***SEE ALSO SEPELI !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE TRISP ! DIMENSION A(*) ,B(*) ,C(*) ,D(*) , & U(*) ,Z(*) !***FIRST EXECUTABLE STATEMENT TRISP 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) ! ! SET LAST COMPONENT EQUAL TO ONE ! 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 TRIX (IDEGBR, IDEGCR, M, A, B, C, Y, TCOS, D, W) ! !! TRIX is subsidiary to GENBUN. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (TRIX-S, CMPTRX-C) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to solve a system of linear equations where the ! coefficient matrix is a rational function in the matrix given by ! TRIDIAGONAL ( . . . , A(I), B(I), C(I), . . . ). ! !***SEE ALSO GENBUN !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900402 Added TYPE section. (WRB) !***END PROLOGUE TRIX ! DIMENSION A(*) ,B(*) ,C(*) ,Y(*) , & TCOS(*) ,D(*) ,W(*) INTEGER KB, KC !***FIRST EXECUTABLE STATEMENT TRIX MM1 = M-1 KB = IDEGBR+1 KC = IDEGCR+1 L = (IDEGBR+1)/(IDEGCR+1) LINT = 1 DO 108 K=1,IDEGBR X = TCOS(K) if (K /= L) go to 102 I = IDEGBR+LINT XX = X-TCOS(I) DO 101 I=1,M W(I) = Y(I) Y(I) = XX*Y(I) 101 CONTINUE 102 CONTINUE Z = 1./(B(1)-X) D(1) = C(1)*Z Y(1) = Y(1)*Z DO 103 I=2,MM1 Z = 1./(B(I)-X-A(I)*D(I-1)) D(I) = C(I)*Z Y(I) = (Y(I)-A(I)*Y(I-1))*Z 103 CONTINUE Z = B(M)-X-A(M)*D(MM1) if (Z /= 0.) go to 104 Y(M) = 0. go to 105 104 Y(M) = (Y(M)-A(M)*Y(MM1))/Z 105 CONTINUE DO 106 IP=1,MM1 I = M-IP Y(I) = Y(I)-D(I)*Y(I+1) 106 CONTINUE if (K /= L) go to 108 DO 107 I=1,M Y(I) = Y(I)+W(I) 107 CONTINUE LINT = LINT+1 L = (LINT*KB)/KC 108 CONTINUE return end subroutine TSTURM (NM, N, EPS1, D, E, E2, LB, UB, MM, M, W, Z, & IERR, RV1, RV2, RV3, RV4, RV5, RV6) ! !! TSTURM finds those eigenvalues of a symmetric tridiagonal matrix ... ! in a given interval and their associated eigenvectors by ! Sturm sequencing. ! !***LIBRARY SLATEC (EISPACK) !***CATEGORY D4A5, D4C2A !***TYPE SINGLE PRECISION (TSTURM-S) !***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK !***AUTHOR Smith, B. T., et al. !***DESCRIPTION ! ! This subroutine finds those eigenvalues of a TRIDIAGONAL ! SYMMETRIC matrix which lie in a specified interval and their ! associated eigenvectors, using bisection and inverse iteration. ! ! On Input ! ! NM must be set to the row dimension of the two-dimensional ! array parameter, Z, as declared in the calling program ! dimension statement. NM is an INTEGER variable. ! ! N is the order of the matrix. N is an INTEGER variable. ! N must be less than or equal to NM. ! ! EPS1 is an absolute error tolerance for the computed eigen- ! values. It should be chosen so that the accuracy of these ! eigenvalues is commensurate with relative perturbations of ! the order of the relative machine precision in the matrix ! elements. If the input EPS1 is non-positive, it is reset ! for each submatrix to a default value, namely, minus the ! product of the relative machine precision and the 1-norm of ! the submatrix. EPS1 is a REAL variable. ! ! D contains the diagonal elements of the symmetric tridiagonal ! matrix. D is a one-dimensional REAL array, dimensioned D(N). ! ! E contains the subdiagonal elements of the symmetric ! tridiagonal matrix in its last N-1 positions. E(1) is ! arbitrary. E is a one-dimensional REAL array, dimensioned ! E(N). ! ! E2 contains the squares of the corresponding elements of E. ! E2(1) is arbitrary. E2 is a one-dimensional REAL array, ! dimensioned E2(N). ! ! LB and UB define the interval to be searched for eigenvalues. ! If LB is not less than UB, no eigenvalues will be found. ! LB and UB are REAL variables. ! ! MM should be set to an upper bound for the number of ! eigenvalues in the interval. MM is an INTEGER variable. ! WARNING - If more than MM eigenvalues are determined to lie ! in the interval, an error return is made with no values or ! vectors found. ! ! On Output ! ! EPS1 is unaltered unless it has been reset to its ! (last) default value. ! ! D and E are unaltered. ! ! Elements of E2, corresponding to elements of E regarded as ! negligible, have been replaced by zero causing the matrix to ! split into a direct sum of submatrices. E2(1) is also set ! to zero. ! ! M is the number of eigenvalues determined to lie in (LB,UB). ! M is an INTEGER variable. ! ! W contains the M eigenvalues in ascending order if the matrix ! does not split. If the matrix splits, the eigenvalues are ! in ascending order for each submatrix. If a vector error ! exit is made, W contains those values already found. W is a ! one-dimensional REAL array, dimensioned W(MM). ! ! Z contains the associated set of orthonormal eigenvectors. ! If an error exit is made, Z contains those vectors already ! found. Z is a one-dimensional REAL array, dimensioned ! Z(NM,MM). ! ! IERR is an INTEGER flag set to ! Zero for normal return, ! 3*N+1 if M exceeds MM no eigenvalues or eigenvectors ! are computed, ! 4*N+J if the eigenvector corresponding to the J-th ! eigenvalue fails to converge in 5 iterations, then ! the eigenvalues and eigenvectors in W and Z should ! be correct for indices 1, 2, ..., J-1. ! ! RV1, RV2, RV3, RV4, RV5, and RV6 are temporary storage arrays, ! dimensioned RV1(N), RV2(N), RV3(N), RV4(N), RV5(N), and ! RV6(N). ! ! The ALGOL procedure STURMCNT contained in TRISTURM ! appears in TSTURM in-line. ! ! Questions and comments should be directed to B. S. Garbow, ! APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY ! ------------------------------------------------------------------ ! !***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, ! Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- ! system Routines - EISPACK Guide, Springer-Verlag, ! 1976. !***ROUTINES CALLED R1MACH !***REVISION HISTORY (YYMMDD) ! 760101 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE TSTURM ! INTEGER I,J,K,M,N,P,Q,R,S,II,IP,JJ,MM,M1,M2,NM,ITS INTEGER IERR,GROUP,ISTURM REAL D(*),E(*),E2(*),W(*),Z(NM,*) REAL RV1(*),RV2(*),RV3(*),RV4(*),RV5(*),RV6(*) REAL U,V,LB,T1,T2,UB,UK,XU,X0,X1,EPS1,EPS2,EPS3,EPS4 REAL NORM,MACHEP,S1,S2 LOGICAL FIRST ! SAVE FIRST, MACHEP DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT TSTURM if (FIRST) THEN MACHEP = R1MACH(4) end if FIRST = .FALSE. ! IERR = 0 T1 = LB T2 = UB ! .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... DO 40 I = 1, N if (I == 1) go to 20 S1 = ABS(D(I)) + ABS(D(I-1)) S2 = S1 + ABS(E(I)) if (S2 > S1) go to 40 20 E2(I) = 0.0E0 40 CONTINUE ! .......... DETERMINE THE NUMBER OF EIGENVALUES ! IN THE INTERVAL .......... P = 1 Q = N X1 = UB ISTURM = 1 go to 320 60 M = S X1 = LB ISTURM = 2 go to 320 80 M = M - S if (M > MM) go to 980 Q = 0 R = 0 ! .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING ! INTERVAL BY THE GERSCHGORIN BOUNDS .......... 100 if (R == M) go to 1001 P = Q + 1 XU = D(P) X0 = D(P) U = 0.0E0 ! DO 120 Q = P, N X1 = U U = 0.0E0 V = 0.0E0 if (Q == N) go to 110 U = ABS(E(Q+1)) V = E2(Q+1) 110 XU = MIN(D(Q)-(X1+U),XU) X0 = MAX(D(Q)+(X1+U),X0) if (V == 0.0E0) go to 140 120 CONTINUE ! 140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP if (EPS1 <= 0.0E0) EPS1 = -X1 if (P /= Q) go to 180 ! .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... if (T1 > D(P) .OR. D(P) >= T2) go to 940 R = R + 1 ! DO 160 I = 1, N 160 Z(I,R) = 0.0E0 ! W(R) = D(P) Z(P,R) = 1.0E0 go to 940 180 X1 = X1 * (Q-P+1) LB = MAX(T1,XU-X1) UB = MIN(T2,X0+X1) X1 = LB ISTURM = 3 go to 320 200 M1 = S + 1 X1 = UB ISTURM = 4 go to 320 220 M2 = S if (M1 > M2) go to 940 ! .......... FIND ROOTS BY BISECTION .......... X0 = UB ISTURM = 5 ! DO 240 I = M1, M2 RV5(I) = UB RV4(I) = LB 240 CONTINUE ! .......... LOOP FOR K-TH EIGENVALUE ! FOR K=M2 STEP -1 UNTIL M1 DO -- ! (-DO- NOT USED TO LEGALIZE -COMPUTED go to-) .......... K = M2 250 XU = LB ! .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... DO 260 II = M1, K I = M1 + K - II if (XU >= RV4(I)) go to 260 XU = RV4(I) go to 280 260 CONTINUE ! 280 if (X0 > RV5(K)) X0 = RV5(K) ! .......... NEXT BISECTION STEP .......... 300 X1 = (XU + X0) * 0.5E0 S1 = 2.0E0*(ABS(XU) + ABS(X0) + ABS(EPS1)) S2 = S1 + ABS(X0 - XU) if (S2 == S1) go to 420 ! .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... 320 S = P - 1 U = 1.0E0 ! DO 340 I = P, Q if (U /= 0.0E0) go to 325 V = ABS(E(I)) / MACHEP if (E2(I) == 0.0E0) V = 0.0E0 go to 330 325 V = E2(I) / U 330 U = D(I) - X1 - V if (U < 0.0E0) S = S + 1 340 CONTINUE ! go to (60,80,200,220,360), ISTURM ! .......... REFINE INTERVALS .......... 360 if (S >= K) go to 400 XU = X1 if (S >= M1) go to 380 RV4(M1) = X1 go to 300 380 RV4(S+1) = X1 if (RV5(S) > X1) RV5(S) = X1 go to 300 400 X0 = X1 go to 300 ! .......... K-TH EIGENVALUE FOUND .......... 420 RV5(K) = X1 K = K - 1 if (K >= M1) go to 250 ! .......... FIND VECTORS BY INVERSE ITERATION .......... NORM = ABS(D(P)) IP = P + 1 ! DO 500 I = IP, Q 500 NORM = MAX(NORM, ABS(D(I)) + ABS(E(I))) ! .......... EPS2 IS THE CRITERION FOR GROUPING, ! EPS3 REPLACES ZERO PIVOTS AND EQUAL ! ROOTS ARE MODIFIED BY EPS3, ! EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... EPS2 = 1.0E-3 * NORM UK = SQRT(REAL(Q-P+5)) EPS3 = UK * MACHEP * NORM EPS4 = UK * EPS3 UK = EPS4 / SQRT(UK) GROUP = 0 S = P ! DO 920 K = M1, M2 R = R + 1 ITS = 1 W(R) = RV5(K) X1 = RV5(K) ! .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... if (K == M1) go to 520 if (X1 - X0 >= EPS2) GROUP = -1 GROUP = GROUP + 1 if (X1 <= X0) X1 = X0 + EPS3 ! .......... ELIMINATION WITH INTERCHANGES AND ! INITIALIZATION OF VECTOR .......... 520 V = 0.0E0 ! DO 580 I = P, Q RV6(I) = UK if (I == P) go to 560 if (ABS(E(I)) < ABS(U)) go to 540 XU = U / E(I) RV4(I) = XU RV1(I-1) = E(I) RV2(I-1) = D(I) - X1 RV3(I-1) = 0.0E0 if (I /= Q) RV3(I-1) = E(I+1) U = V - XU * RV2(I-1) V = -XU * RV3(I-1) go to 580 540 XU = E(I) / U RV4(I) = XU RV1(I-1) = U RV2(I-1) = V RV3(I-1) = 0.0E0 560 U = D(I) - X1 - XU * V if (I /= Q) V = E(I+1) 580 CONTINUE ! if (U == 0.0E0) U = EPS3 RV1(Q) = U RV2(Q) = 0.0E0 RV3(Q) = 0.0E0 ! .......... BACK SUBSTITUTION ! FOR I=Q STEP -1 UNTIL P DO -- .......... 600 continue DO II = P, Q I = P + Q - II RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) V = U U = RV6(I) end do ! ! ORTHOGONALIZE WITH RESPECT TO PREVIOUS MEMBERS OF GROUP. ! DO JJ = 1, GROUP J = R - GROUP - 1 + JJ XU = 0.0E0 DO I = P, Q XU = XU + RV6(I) * Z(I,J) end do DO I = P, Q RV6(I) = RV6(I) - XU * Z(I,J) end do end do 700 NORM = 0.0E0 ! DO 720 I = P, Q 720 NORM = NORM + ABS(RV6(I)) ! if (NORM >= 1.0E0) go to 840 ! .......... FORWARD SUBSTITUTION .......... if (ITS == 5) go to 960 if (NORM /= 0.0E0) go to 740 RV6(S) = EPS4 S = S + 1 if (S > Q) S = P go to 780 740 XU = EPS4 / NORM ! DO 760 I = P, Q 760 RV6(I) = RV6(I) * XU ! .......... ELIMINATION OPERATIONS ON NEXT VECTOR ITERATE. ! 780 DO 820 I = IP, Q U = RV6(I) ! .......... if RV1(I-1) == E(I), A ROW INTERCHANGE ! WAS PERFORMED EARLIER IN THE ! TRIANGULARIZATION PROCESS .......... if (RV1(I-1) /= E(I)) go to 800 U = RV6(I-1) RV6(I-1) = RV6(I) 800 RV6(I) = U - RV4(I) * RV6(I-1) 820 CONTINUE ! ITS = ITS + 1 go to 600 ! .......... NORMALIZE SO THAT SUM OF SQUARES IS ! 1 AND EXPAND TO FULL ORDER .......... 840 U = 0.0E0 ! DO 860 I = P, Q 860 U = U + RV6(I)**2 ! XU = 1.0E0 / SQRT(U) ! DO 880 I = 1, N 880 Z(I,R) = 0.0E0 ! DO 900 I = P, Q 900 Z(I,R) = RV6(I) * XU ! X0 = X1 920 CONTINUE ! 940 if (Q < N) go to 100 go to 1001 ! .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... 960 IERR = 4 * N + R go to 1001 ! .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF ! EIGENVALUES IN INTERVAL .......... 980 IERR = 3 * N + 1 1001 LB = T1 UB = T2 return end subroutine U11LS (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, H, & W, EB, IC, IR) ! !! U11LS is subsidiary to LLSIA. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (U11LS-S, DU11LS-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This routine performs a QR factorization of A ! using Householder transformations. Row and ! column pivots are chosen to reduce the growth ! of round-off and to help detect possible rank ! deficiency. ! !***SEE ALSO LLSIA !***ROUTINES CALLED ISAMAX, ISWAP, SAXPY, SDOT, SNRM2, SSCAL, SSWAP, ! XERMSG !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE U11LS DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*) INTEGER IC(*),IR(*) ! ! INITIALIZATION ! !***FIRST EXECUTABLE STATEMENT U11LS J=0 KRANK=N DO 10 I=1,N IC(I)=I 10 CONTINUE DO I=1,M IR(I)=I end do ! ! DETERMINE REL AND ABS ERROR VECTORS ! ! ! CALCULATE COL LENGTH ! DO 30 I=1,N H(I)=SNRM2(M,A(1,I),1) W(I)=H(I) 30 CONTINUE ! ! INITIALIZE ERROR BOUNDS ! DO 40 I=1,N EB(I)=MAX(DB(I),UB(I)*H(I)) UB(I)=EB(I) DB(I)=0.0 40 CONTINUE ! ! DISCARD SELF DEPENDENT COLUMNS ! I=1 50 if ( EB(I) >= H(I)) go to 60 if ( I == KRANK) go to 70 I=I+1 go to 50 ! ! MATRIX REDUCTION ! 60 CONTINUE KK=KRANK KRANK=KRANK-1 if ( MODE == 0) RETURN if ( I > NP) go to 64 call XERMSG ('SLATEC', 'U11LS', & 'FIRST NP COLUMNS ARE LINEARLY DEPENDENT', 8, 0) KRANK=I-1 return 64 CONTINUE if ( I > 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 ! ! TEST FOR ZERO RANK ! 70 if ( KRANK > 0) go to 80 KRANK=0 KSURE=0 return 80 CONTINUE ! ! M A I N L O O P ! 110 CONTINUE J=J+1 JP1=J+1 JM1=J-1 KZ=KRANK if ( J <= NP) KZ=J ! ! EACH COL HAS MM=M-J+1 COMPONENTS ! MM=M-J+1 ! ! UB DETERMINES COLUMN PIVOT ! 115 IMIN=J if ( H(J) == 0.) go to 170 RMIN=UB(J)/H(J) DO 120 I=J,KZ if ( UB(I) >= H(I)*RMIN) go to 120 RMIN=UB(I)/H(I) IMIN=I 120 CONTINUE ! ! TEST FOR RANK DEFICIENCY ! if ( RMIN < 1.0) go to 200 TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN) if ( TT >= 1.0) go to 170 ! COMPUTE EXACT UB DO 125 I=1,JM1 W(I)=A(I,IMIN) 125 CONTINUE L=JM1 130 W(L)=W(L)/A(L,L) if ( L == 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 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) >= 1.0) go to 170 go to 200 ! ! MATRIX REDUCTION ! 170 CONTINUE KK=KRANK KRANK=KRANK-1 KZ=KRANK if ( MODE == 0) RETURN if ( J > NP) go to 172 call XERMSG ('SLATEC', 'U11LS', & 'FIRST NP COLUMNS ARE LINEARLY DEPENDENT', 8, 0) KRANK=J-1 return 172 CONTINUE if ( IMIN > 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 > KRANK) go to 300 go to 115 ! ! COLUMN PIVOT ! 200 if ( IMIN == J) go to 230 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) ! ! ROW PIVOT ! 230 CONTINUE JMAX=ISAMAX(MM,A(J,J),1) JMAX=JMAX+J-1 if ( JMAX == J) go to 240 call SSWAP(N,A(J,1),MDA,A(JMAX,1),MDA) call ISWAP(1,IR(J),1,IR(JMAX),1) 240 CONTINUE ! ! APPLY HOUSEHOLDER TRANSFORMATION ! TN=SNRM2(MM,A(J,J),1) if ( TN == 0.0) go to 170 if ( A(J,J) /= 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 == N) go to 250 DO 248 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 <= NP) go to 248 if ( H(I) == 0.0) go to 248 TT=1.0-(ABS(A(J,I))/H(I))**2 TT=MAX(TT,0.0) T=TT TT=1.0+.05*TT*(H(I)/W(I))**2 if ( TT == 1.0) go to 244 H(I)=H(I)*SQRT(T) go to 246 244 CONTINUE H(I)=SNRM2(M-J,A(J+1,I),1) W(I)=H(I) 246 CONTINUE 248 CONTINUE 250 CONTINUE H(J)=A(J,J) A(J,J)=-TN ! ! ! UPDATE UB, DB ! UB(J)=UB(J)/ABS(A(J,J)) DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J) if ( J == 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 110 ! ! E N D M A I N L O O P ! 300 CONTINUE ! ! COMPUTE KSURE ! KM1=KRANK-1 DO 318 I=1,KM1 IS=0 KMI=KRANK-I DO 315 II=1,KMI if ( UB(II) <= UB(II+1)) go to 315 IS=1 TEMP=UB(II) UB(II)=UB(II+1) UB(II+1)=TEMP 315 CONTINUE if ( IS == 0) go to 320 318 CONTINUE 320 CONTINUE KSURE=0 SUM=0.0 DO 328 I=1,KRANK R2=UB(I)*UB(I) if ( R2+SUM >= 1.0) go to 330 SUM=SUM+R2 KSURE=KSURE+1 328 CONTINUE 330 CONTINUE ! ! if SYSTEM IS OF REDUCED RANK AND MODE = 2 ! COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION ! if ( KRANK == N .OR. MODE < 2) go to 360 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 == 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 350 CONTINUE 360 CONTINUE return end subroutine U11US (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, H, & W, EB, IR, IC) ! !! U11US is subsidiary to ULSIA. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (U11US-S, DU11US-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This routine performs an LQ factorization of the ! matrix A using Householder transformations. Row ! and column pivots are chosen to reduce the growth ! of round-off and to help detect possible rank ! deficiency. ! !***SEE ALSO ULSIA !***ROUTINES CALLED ISAMAX, ISWAP, SAXPY, SDOT, SNRM2, SSCAL, SSWAP, ! XERMSG !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE U11US DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*) INTEGER IC(*),IR(*) ! ! INITIALIZATION ! !***FIRST EXECUTABLE STATEMENT U11US J=0 KRANK=M DO 10 I=1,N IC(I)=I 10 CONTINUE DO 12 I=1,M IR(I)=I 12 CONTINUE ! ! DETERMINE REL AND ABS ERROR VECTORS ! ! ! ! CALCULATE ROW LENGTH ! DO 30 I=1,M H(I)=SNRM2(N,A(I,1),MDA) W(I)=H(I) 30 CONTINUE ! ! INITIALIZE ERROR BOUNDS ! DO 40 I=1,M EB(I)=MAX(DB(I),UB(I)*H(I)) UB(I)=EB(I) DB(I)=0.0 40 CONTINUE ! ! DISCARD SELF DEPENDENT ROWS ! I=1 50 if ( EB(I) >= H(I)) go to 60 if ( I == KRANK) go to 70 I=I+1 go to 50 ! ! MATRIX REDUCTION ! 60 CONTINUE KK=KRANK KRANK=KRANK-1 if ( MODE == 0) RETURN if ( I > NP) go to 64 call XERMSG ('SLATEC', 'U11US', & 'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0) KRANK=I-1 return 64 CONTINUE if ( I > 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 ! ! TEST FOR ZERO RANK ! 70 if ( KRANK > 0) go to 80 KRANK=0 KSURE=0 return 80 CONTINUE ! ! M A I N L O O P ! 110 CONTINUE J=J+1 JP1=J+1 JM1=J-1 KZ=KRANK if ( J <= NP) KZ=J ! ! EACH ROW HAS NN=N-J+1 COMPONENTS ! NN=N-J+1 ! ! UB DETERMINES ROW PIVOT ! 115 IMIN=J if ( H(J) == 0.) go to 170 RMIN=UB(J)/H(J) DO 120 I=J,KZ if ( UB(I) >= H(I)*RMIN) go to 120 RMIN=UB(I)/H(I) IMIN=I 120 CONTINUE ! ! TEST FOR RANK DEFICIENCY ! if ( RMIN < 1.0) go to 200 TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN) if ( TT >= 1.0) go to 170 ! COMPUTE EXACT UB DO 125 I=1,JM1 W(I)=A(IMIN,I) 125 CONTINUE L=JM1 130 W(L)=W(L)/A(L,L) if ( L == 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 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) >= 1.0) go to 170 go to 200 ! ! MATRIX REDUCTION ! 170 CONTINUE KK=KRANK KRANK=KRANK-1 KZ=KRANK if ( MODE == 0) RETURN if ( J > NP) go to 172 call XERMSG ('SLATEC', 'U11US', & 'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0) KRANK=J-1 return 172 CONTINUE if ( IMIN > 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 > KRANK) go to 300 go to 115 ! ! ROW PIVOT ! 200 if ( IMIN == J) go to 230 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) ! ! COLUMN PIVOT ! 230 CONTINUE JMAX=ISAMAX(NN,A(J,J),MDA) JMAX=JMAX+J-1 if ( JMAX == J) go to 240 call SSWAP(M,A(1,J),1,A(1,JMAX),1) call ISWAP(1,IC(J),1,IC(JMAX),1) 240 CONTINUE ! ! APPLY HOUSEHOLDER TRANSFORMATION ! TN=SNRM2(NN,A(J,J),MDA) if ( TN == 0.0) go to 170 if ( A(J,J) /= 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 == M) go to 250 DO 248 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 <= NP) go to 248 if ( H(I) == 0.0) go to 248 TT=1.0-(ABS(A(I,J))/H(I))**2 TT=MAX(TT,0.0) T=TT TT=1.0+.05*TT*(H(I)/W(I))**2 if ( TT == 1.0) go to 244 H(I)=H(I)*SQRT(T) go to 246 244 CONTINUE H(I)=SNRM2(N-J,A(I,J+1),MDA) W(I)=H(I) 246 CONTINUE 248 CONTINUE 250 CONTINUE H(J)=A(J,J) A(J,J)=-TN ! ! ! UPDATE UB, DB ! UB(J)=UB(J)/ABS(A(J,J)) DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J) if ( J == 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 110 ! ! E N D M A I N L O O P ! 300 CONTINUE ! ! COMPUTE KSURE ! KM1=KRANK-1 DO 318 I=1,KM1 IS=0 KMI=KRANK-I DO 315 II=1,KMI if ( UB(II) <= UB(II+1)) go to 315 IS=1 TEMP=UB(II) UB(II)=UB(II+1) UB(II+1)=TEMP 315 CONTINUE if ( IS == 0) go to 320 318 CONTINUE 320 CONTINUE KSURE=0 SUM=0.0 DO 328 I=1,KRANK R2=UB(I)*UB(I) if ( R2+SUM >= 1.0) go to 330 SUM=SUM+R2 KSURE=KSURE+1 328 CONTINUE 330 CONTINUE ! ! if SYSTEM IS OF REDUCED RANK AND MODE = 2 ! COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION ! if ( KRANK == M .OR. MODE < 2) go to 360 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 == 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 350 CONTINUE 360 CONTINUE return end subroutine U12LS (A, MDA, M, N, B, MDB, NB, MODE, KRANK, RNORM, H, & W, IC, IR) ! !! U12LS is subsidiary to LLSIA. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (U12LS-S, DU12LS-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given the Householder QR factorization of A, this ! subroutine solves the system AX=B. If the system ! is of reduced rank, this routine returns a solution ! according to the selected mode. ! ! Note - If MODE /= 2, W is never accessed. ! !***SEE ALSO LLSIA !***ROUTINES CALLED SAXPY, SDOT, SNRM2, SSWAP !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE U12LS DIMENSION A(MDA,*),B(MDB,*),RNORM(*),H(*),W(*) INTEGER IC(*),IR(*) !***FIRST EXECUTABLE STATEMENT U12LS K=KRANK KP1=K+1 ! ! RANK=0 ! if ( K > 0) go to 410 DO 404 JB=1,NB RNORM(JB)=SNRM2(M,B(1,JB),1) 404 CONTINUE DO 406 JB=1,NB DO 406 I=1,N B(I,JB)=0.0 406 CONTINUE return ! ! REORDER B TO REFLECT ROW INTERCHANGES ! 410 CONTINUE I=0 412 I=I+1 if ( I == M) go to 418 J=IR(I) if ( J == I) go to 412 if ( J < 0) go to 412 IR(I)=-IR(I) DO 413 JB=1,NB RNORM(JB)=B(I,JB) 413 CONTINUE IJ=I 414 DO 415 JB=1,NB B(IJ,JB)=B(J,JB) 415 CONTINUE IJ=J J=IR(IJ) IR(IJ)=-IR(IJ) if ( J /= I) go to 414 DO 416 JB=1,NB B(IJ,JB)=RNORM(JB) 416 CONTINUE go to 412 418 CONTINUE DO 420 I=1,M IR(I)=ABS(IR(I)) 420 CONTINUE ! ! APPLY HOUSEHOLDER TRANSFORMATIONS TO B ! DO 430 J=1,K TT=A(J,J) A(J,J)=H(J) DO 425 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) 425 CONTINUE A(J,J)=TT 430 CONTINUE ! ! FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) ! DO 440 JB=1,NB RNORM(JB)=SNRM2((M-K),B(KP1,JB),1) 440 CONTINUE ! ! BACK SOLVE UPPER TRIANGULAR R ! I=K 442 DO 444 JB=1,NB B(I,JB)=B(I,JB)/A(I,I) 444 CONTINUE if ( I == 1) go to 450 IM1=I-1 DO 448 JB=1,NB call SAXPY(IM1,-B(I,JB),A(1,I),1,B(1,JB),1) 448 CONTINUE I=IM1 go to 442 450 CONTINUE ! ! RANK LT N ! ! TRUNCATED SOLUTION ! if ( K == N) go to 480 DO 460 JB=1,NB DO 460 I=KP1,N B(I,JB)=0.0 460 CONTINUE if ( MODE == 1) go to 480 ! ! MINIMAL LENGTH SOLUTION ! NMK=N-K DO 470 JB=1,NB DO 465 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) 465 CONTINUE 470 CONTINUE ! ! ! REORDER B TO REFLECT COLUMN INTERCHANGES ! 480 CONTINUE I=0 482 I=I+1 if ( I == N) go to 488 J=IC(I) if ( J == I) go to 482 if ( J < 0) go to 482 IC(I)=-IC(I) 484 call SSWAP(NB,B(J,1),MDB,B(I,1),MDB) IJ=IC(J) IC(J)=-IC(J) J=IJ if ( J == I) go to 482 go to 484 488 CONTINUE DO 490 I=1,N IC(I)=ABS(IC(I)) 490 CONTINUE ! ! SOLUTION VECTORS ARE IN FIRST N ROWS OF B(,) ! return end subroutine U12US (A, MDA, M, N, B, MDB, NB, MODE, KRANK, RNORM, H, & W, IR, IC) ! !! U12US is subsidiary to ULSIA. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (U12US-S, DU12US-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Given the Householder LQ factorization of A, this ! subroutine solves the system AX=B. If the system ! is of reduced rank, this routine returns a solution ! according to the selected mode. ! ! Note - If MODE /= 2, W is never accessed. ! !***SEE ALSO ULSIA !***ROUTINES CALLED SAXPY, SDOT, SNRM2, SSWAP !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE U12US DIMENSION A(MDA,*),B(MDB,*),RNORM(*),H(*),W(*) INTEGER IC(*),IR(*) !***FIRST EXECUTABLE STATEMENT U12US K=KRANK KP1=K+1 ! ! RANK=0 ! if ( K > 0) go to 410 DO 404 JB=1,NB RNORM(JB)=SNRM2(M,B(1,JB),1) 404 CONTINUE DO 406 JB=1,NB DO 406 I=1,N B(I,JB)=0.0 406 CONTINUE return ! ! REORDER B TO REFLECT ROW INTERCHANGES ! 410 CONTINUE I=0 412 I=I+1 if ( I == M) go to 418 J=IR(I) if ( J == I) go to 412 if ( J < 0) go to 412 IR(I)=-IR(I) DO 413 JB=1,NB RNORM(JB)=B(I,JB) 413 CONTINUE IJ=I 414 DO 415 JB=1,NB B(IJ,JB)=B(J,JB) 415 CONTINUE IJ=J J=IR(IJ) IR(IJ)=-IR(IJ) if ( J /= I) go to 414 DO 416 JB=1,NB B(IJ,JB)=RNORM(JB) 416 CONTINUE go to 412 418 CONTINUE DO 420 I=1,M IR(I)=ABS(IR(I)) 420 CONTINUE ! ! if A IS OF REDUCED RANK AND MODE=2, ! APPLY HOUSEHOLDER TRANSFORMATIONS TO B ! if ( MODE < 2 .OR. K == M) go to 440 MMK=M-K DO 430 JB=1,NB DO 425 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) 425 CONTINUE 430 CONTINUE ! ! FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) ! 440 DO 442 JB=1,NB RNORM(JB)=SNRM2((M-K),B(KP1,JB),1) 442 CONTINUE ! ! BACK SOLVE LOWER TRIANGULAR L ! DO 450 JB=1,NB DO 448 I=1,K B(I,JB)=B(I,JB)/A(I,I) if ( I == K) go to 450 IP1=I+1 call SAXPY(K-I,-B(I,JB),A(IP1,I),1,B(IP1,JB),1) 448 CONTINUE 450 CONTINUE ! ! ! TRUNCATED SOLUTION ! if ( K == N) go to 462 DO 460 JB=1,NB DO 460 I=KP1,N B(I,JB)=0.0 460 CONTINUE ! ! APPLY HOUSEHOLDER TRANSFORMATIONS TO B ! 462 DO 470 I=1,K J=KP1-I TT=A(J,J) A(J,J)=H(J) DO 465 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) 465 CONTINUE A(J,J)=TT 470 CONTINUE ! ! ! REORDER B TO REFLECT COLUMN INTERCHANGES ! I=0 482 I=I+1 if ( I == N) go to 488 J=IC(I) if ( J == I) go to 482 if ( J < 0) go to 482 IC(I)=-IC(I) 484 call SSWAP(NB,B(J,1),MDB,B(I,1),MDB) IJ=IC(J) IC(J)=-IC(J) J=IJ if ( J == I) go to 482 go to 484 488 CONTINUE DO 490 I=1,N IC(I)=ABS(IC(I)) 490 CONTINUE ! ! SOLUTION VECTORS ARE IN FIRST N ROWS OF B(,) ! return end subroutine ULSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, NP, & KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO) ! !! ULSIA solves an underdetermined linear system of equations ... ! by performing an LQ factorization of the matrix using ! Householder transformations. Emphasis is put on detecting ! possible rank deficiency. ! !***LIBRARY SLATEC !***CATEGORY D9 !***TYPE SINGLE PRECISION (ULSIA-S, DULSIA-D) !***KEYWORDS LINEAR LEAST SQUARES, LQ FACTORIZATION, ! UNDERDETERMINED LINEAR SYSTEM !***AUTHOR Manteuffel, T. A., (LANL) !***DESCRIPTION ! ! ULSIA computes the minimal length solution(s) to the problem AX=B ! where A is an M by N matrix with M <= N and B is the M by NB ! matrix of right hand sides. User input bounds on the uncertainty ! in the elements of A are used to detect numerical rank deficiency. ! The algorithm employs a row and column pivot strategy to ! minimize the growth of uncertainty and round-off errors. ! ! ULSIA requires (MDA+1)*N + (MDB+1)*NB + 6*M dimensioned space ! ! ****************************************************************** ! * * ! * WARNING - All input arrays are changed on exit. * ! * * ! ****************************************************************** ! ! Input.. ! ! A(,) Linear coefficient matrix of AX=B, with MDA the ! MDA,M,N actual first dimension of A in the calling program. ! M is the row dimension (no. of EQUATIONS of the ! problem) and N the col dimension (no. of UNKNOWNS). ! Must have MDA >= M and M <= N. ! ! B(,) Right hand side(s), with MDB the actual first ! MDB,NB dimension of B in the calling program. NB is the ! number of M by 1 right hand sides. Since the ! solution is returned in B, must have MDB >= N. If ! NB = 0, B is never accessed. ! ! ****************************************************************** ! * * ! * Note - Use of RE and AE are what make this * ! * code significantly different from * ! * other linear least squares solvers. * ! * However, the inexperienced user is * ! * advised to set RE=0.,AE=0.,KEY=0. * ! * * ! ****************************************************************** ! ! RE(),AE(),KEY ! RE() RE() is a vector of length N such that RE(I) is ! the maximum relative uncertainty in row I of ! the matrix A. The values of RE() must be between ! 0 and 1. A minimum of 10*machine precision will ! be enforced. ! ! AE() AE() is a vector of length N such that AE(I) is ! the maximum absolute uncertainty in row I of ! the matrix A. The values of AE() must be greater ! than or equal to 0. ! ! KEY For ease of use, RE and AE may be input as either ! vectors or scalars. If a scalar is input, the algo- ! rithm will use that value for each column of A. ! The parameter KEY indicates whether scalars or ! vectors are being input. ! KEY=0 RE scalar AE scalar ! KEY=1 RE vector AE scalar ! KEY=2 RE scalar AE vector ! KEY=3 RE vector AE vector ! ! ! MODE The integer MODE indicates how the routine ! is to react if rank deficiency is detected. ! If MODE = 0 return immediately, no solution ! 1 compute truncated solution ! 2 compute minimal length least squares sol ! The inexperienced user is advised to set MODE=0 ! ! NP The first NP rows of A will not be interchanged ! with other rows even though the pivot strategy ! would suggest otherwise. ! The inexperienced user is advised to set NP=0. ! ! WORK() A real work array dimensioned 5*M. However, if ! RE or AE have been specified as vectors, dimension ! WORK 4*M. If both RE and AE have been specified ! as vectors, dimension WORK 3*M. ! ! LW Actual dimension of WORK ! ! IWORK() Integer work array dimensioned at least N+M. ! ! LIW Actual dimension of IWORK. ! ! ! INFO Is a flag which provides for the efficient ! solution of subsequent problems involving the ! same A but different B. ! If INFO = 0 original call ! INFO = 1 subsequent calls ! On subsequent calls, the user must supply A, KRANK, ! LW, IWORK, LIW, and the first 2*M locations of WORK ! as output by the original call to ULSIA. MODE must ! be equal to the value of MODE in the original call. ! If MODE < 2, only the first N locations of WORK ! are accessed. AE, RE, KEY, and NP are not accessed. ! ! ! ! ! Output.. ! ! A(,) Contains the lower triangular part of the reduced ! matrix and the transformation information. It togeth ! with the first M elements of WORK (see below) ! completely specify the LQ factorization of A. ! ! B(,) Contains the N by NB solution matrix for X. ! ! KRANK,KSURE The numerical rank of A, based upon the relative ! and absolute bounds on uncertainty, is bounded ! above by KRANK and below by KSURE. The algorithm ! returns a solution based on KRANK. KSURE provides ! an indication of the precision of the rank. ! ! RNORM() Contains the Euclidean length of the NB residual ! vectors B(I)-AX(I), I=1,NB. If the matrix A is of ! full rank, then RNORM=0.0. ! ! WORK() The first M locations of WORK contain values ! necessary to reproduce the Householder ! transformation. ! ! IWORK() The first N locations contain the order in ! which the columns of A were used. The next ! M locations contain the order in which the ! rows of A were used. ! ! INFO Flag to indicate status of computation on completion ! -1 Parameter error(s) ! 0 - Rank deficient, no solution ! 1 - Rank deficient, truncated solution ! 2 - Rank deficient, minimal length least squares sol ! 3 - Numerical rank 0, zero solution ! 4 - Rank < NP ! 5 - Full rank ! !***REFERENCES T. Manteuffel, An interval analysis approach to rank ! determination in linear least squares problems, ! Report SAND80-0655, Sandia Laboratories, June 1980. !***ROUTINES CALLED R1MACH, U11US, U12US, XERMSG !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Fixed an error message. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE ULSIA DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*) INTEGER IWORK(*) ! !***FIRST EXECUTABLE STATEMENT ULSIA if ( INFO < 0 .OR. INFO > 1) go to 514 IT=INFO INFO=-1 if ( NB == 0 .AND. IT == 1) go to 501 if ( M < 1) go to 502 if ( N < 1) go to 503 if ( N < M) go to 504 if ( MDA < M) go to 505 if ( LIW < M+N) go to 506 if ( MODE < 0 .OR. MODE > 3) go to 515 if ( NB == 0) go to 4 if ( NB < 0) go to 507 if ( MDB < N) go to 508 if ( IT == 0) go to 4 go to 400 4 if ( KEY < 0.OR.KEY > 3) go to 509 if ( KEY == 0 .AND. LW < 5*M) go to 510 if ( KEY == 1 .AND. LW < 4*M) go to 510 if ( KEY == 2 .AND. LW < 4*M) go to 510 if ( KEY == 3 .AND. LW < 3*M) go to 510 if ( NP < 0 .OR. NP > M) go to 516 ! EPS=10.*R1MACH(4) M1=1 M2=M1+M M3=M2+M M4=M3+M M5=M4+M ! if ( KEY == 1) go to 100 if ( KEY == 2) go to 200 if ( KEY == 3) go to 300 ! if ( RE(1) < 0.0) go to 511 if ( RE(1) > 1.0) go to 512 if ( RE(1) < EPS) RE(1)=EPS if ( AE(1) < 0.0) go to 513 DO 20 I=1,M W(M4-1+I)=RE(1) W(M5-1+I)=AE(1) 20 CONTINUE call U11US(A,MDA,M,N,W(M4),W(M5),MODE,NP,KRANK,KSURE, & W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) go to 400 ! 100 CONTINUE if ( AE(1) < 0.0) go to 513 DO 120 I=1,M if ( RE(I) < 0.0) go to 511 if ( RE(I) > 1.0) go to 512 if ( RE(I) < EPS) RE(I)=EPS W(M4-1+I)=AE(1) 120 CONTINUE call U11US(A,MDA,M,N,RE,W(M4),MODE,NP,KRANK,KSURE, & W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) go to 400 ! 200 CONTINUE if ( RE(1) < 0.0) go to 511 if ( RE(1) > 1.0) go to 512 if ( RE(1) < EPS) RE(1)=EPS DO 220 I=1,M W(M4-1+I)=RE(1) if ( AE(I) < 0.0) go to 513 220 CONTINUE call U11US(A,MDA,M,N,W(M4),AE,MODE,NP,KRANK,KSURE, & W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) go to 400 ! 300 CONTINUE DO 320 I=1,M if ( RE(I) < 0.0) go to 511 if ( RE(I) > 1.0) go to 512 if ( RE(I) < EPS) RE(I)=EPS if ( AE(I) < 0.0) go to 513 320 CONTINUE call U11US(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE, & W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2)) ! ! DETERMINE INFO ! 400 if ( KRANK /= M) go to 402 INFO=5 go to 410 402 if ( KRANK /= 0) go to 404 INFO=3 go to 410 404 if ( KRANK >= NP) go to 406 INFO=4 return 406 INFO=MODE if ( MODE == 0) RETURN 410 if ( NB == 0) RETURN ! ! ! SOLUTION PHASE ! M1=1 M2=M1+M M3=M2+M if ( INFO == 2) go to 420 if ( LW < M2-1) go to 510 call U12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK, & RNORM,W(M1),W(M1),IWORK(M1),IWORK(M2)) return ! 420 if ( LW < M3-1) go to 510 call U12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK, & RNORM,W(M1),W(M2),IWORK(M1),IWORK(M2)) return ! ! ERROR MESSAGES ! 501 call XERMSG ('SLATEC', 'ULSIA', & 'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0) return 502 call XERMSG ('SLATEC', 'ULSIA', 'M < 1', 2, 1) return 503 call XERMSG ('SLATEC', 'ULSIA', 'N < 1', 2, 1) return 504 call XERMSG ('SLATEC', 'ULSIA', 'N < M', 2, 1) return 505 call XERMSG ('SLATEC', 'ULSIA', 'MDA < M', 2, 1) return 506 call XERMSG ('SLATEC', 'ULSIA', 'LIW < M+N', 2, 1) return 507 call XERMSG ('SLATEC', 'ULSIA', 'NB < 0', 2, 1) return 508 call XERMSG ('SLATEC', 'ULSIA', 'MDB < N', 2, 1) return 509 call XERMSG ('SLATEC', 'ULSIA', 'KEY OUT OF RANGE', 2, 1) return 510 call XERMSG ('SLATEC', 'ULSIA', 'INSUFFICIENT WORK SPACE', 8, 1) INFO=-1 return 511 call XERMSG ('SLATEC', 'ULSIA', 'RE(I) < 0', 2, 1) return 512 call XERMSG ('SLATEC', 'ULSIA', 'RE(I) > 1', 2, 1) return 513 call XERMSG ('SLATEC', 'ULSIA', 'AE(I) < 0', 2, 1) return 514 call XERMSG ('SLATEC', 'ULSIA', 'INFO OUT OF RANGE', 2, 1) return 515 call XERMSG ('SLATEC', 'ULSIA', 'MODE OUT OF RANGE', 2, 1) return 516 call XERMSG ('SLATEC', 'ULSIA', 'NP OUT OF RANGE', 2, 1) return end subroutine USRMAT (I, J, AIJ, INDCAT, PRGOPT, DATTRV, IFLAG) ! !! USRMAT is subsidiary to SPLP. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (USRMAT-S, DUSRMT-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! The user may supply this code ! !***SEE ALSO SPLP !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811215 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE USRMAT DIMENSION PRGOPT(*),DATTRV(*),IFLAG(10) ! !***FIRST EXECUTABLE STATEMENT USRMAT if ( IFLAG(1) == 1) THEN ! ! THIS IS THE INITIALIZATION STEP. THE VALUES OF IFLAG(K),K=2,3,4, ! ARE RESPECTIVELY THE COLUMN INDEX, THE ROW INDEX (OR THE NEXT COL. ! INDEX), AND THE POINTER TO THE MATRIX ENTRY'S VALUE WITHIN ! DATTRV(*). ALSO CHECK (DATTRV(1)=0.) SIGNIFYING NO DATA. if ( DATTRV(1) == 0.) THEN I = 0 J = 0 IFLAG(1) = 3 ELSE IFLAG(2)=-DATTRV(1) IFLAG(3)= DATTRV(2) IFLAG(4)= 3 ENDIF ! return ELSE J=IFLAG(2) I=IFLAG(3) L=IFLAG(4) if ( I == 0) THEN ! ! SIGNAL THAT ALL OF THE NONZERO ENTRIES HAVE BEEN DEFINED. IFLAG(1)=3 return ELSE if ( I < 0) THEN ! ! SIGNAL THAT A SWITCH IS MADE TO A NEW COLUMN. J=-I I=DATTRV(L) L=L+1 ENDIF ! AIJ=DATTRV(L) ! ! UPDATE THE INDICES AND POINTERS FOR THE NEXT ENTRY. IFLAG(2)=J IFLAG(3)=DATTRV(L+1) IFLAG(4)=L+2 ! ! INDCAT=0 DENOTES THAT ENTRIES OF THE MATRIX ARE ASSIGNED THE ! VALUES FROM DATTRV(*). NO ACCUMULATION IS PERFORMED. INDCAT=0 return end if end FUNCTION VNWRMS (N, V, W) ! !! VNWRMS is subsidiary to DEBDF. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (VNWRMS-S, DVNRMS-D) !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! VNWRMS computes a weighted root-mean-square vector norm for the ! integrator package DEBDF. ! !***SEE ALSO DEBDF !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE VNWRMS ! ! !LLL. OPTIMIZE !----------------------------------------------------------------------- ! THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM ! OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS ! CONTAINED IN THE ARRAY W OF LENGTH N.. ! VNWRMS = SQRT( (1/N) * SUM( V(I)/W(I) )**2 ) !----------------------------------------------------------------------- INTEGER N, I real VNWRMS REAL V, W, SUM DIMENSION V(*), W(*) !***FIRST EXECUTABLE STATEMENT VNWRMS SUM = 0.0E0 DO 10 I = 1,N 10 SUM = SUM + (V(I)/W(I))**2 VNWRMS = SQRT(SUM/N) return !----------------------- END OF FUNCTION VNWRMS ------------------------ end subroutine WNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, & IDOPE, DOPE, DONE) ! !! WNLIT is subsidiary to WNNLS. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (WNLIT-S, DWNLIT-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! This is a companion subprogram to WNNLS( ). ! The documentation for WNNLS( ) has complete usage instructions. ! ! Note The M by (N+1) matrix W( , ) contains the rt. hand side ! B as the (N+1)st col. ! ! Triangularize L1 by L1 subsystem, where L1=MIN(M,L), with ! col interchanges. ! !***SEE ALSO WNNLS !***ROUTINES CALLED H12, ISAMAX, SCOPY, SROTM, SROTMG, SSCAL, SSWAP, ! WNLT1, WNLT2, WNLT3 !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and revised. (WRB & RWC) ! 890620 Revised to make WNLT1, WNLT2, and WNLT3 subroutines. (RWC) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) !***END PROLOGUE WNLIT INTEGER IDOPE(*), IPIVOT(*), ITYPE(*), L, M, MDW, N REAL DOPE(*), H(*), RNORM, SCALE(*), W(MDW,*) LOGICAL DONE ! EXTERNAL H12, ISAMAX, SCOPY, SROTM, SROTMG, SSCAL, SSWAP, WNLT1, & WNLT2, WNLT3 INTEGER ISAMAX LOGICAL WNLT2 ! REAL ALSQ, AMAX, EANORM, FACTOR, HBAR, RN, SPARAM(5), & T, TAU INTEGER I, I1, IMAX, IR, J, J1, JJ, JP, KRANK, L1, LB, LEND, ME, & MEND, NIV, NSOLN LOGICAL INDEP, RECALC ! !***FIRST EXECUTABLE STATEMENT WNLIT ME = IDOPE(1) NSOLN = IDOPE(2) L1 = IDOPE(3) ! ALSQ = DOPE(1) EANORM = DOPE(2) TAU = DOPE(3) ! LB = MIN(M-1,L) RECALC = .TRUE. RNORM = 0.E0 KRANK = 0 ! ! We set FACTOR=1.0 so that the heavy weight ALAMDA will be ! included in the test for column independence. ! FACTOR = 1.E0 LEND = L DO 180 I=1,LB ! ! Set IR to point to the I-th row. ! IR = I MEND = M call WNLT1 (I, LEND, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, & W) ! ! Update column SS and find pivot column. ! call WNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) ! ! Perform column interchange. ! Test independence of incoming column. ! 130 if (WNLT2(ME, MEND, IR, FACTOR, TAU, SCALE, W(1,I))) THEN ! ! Eliminate I-th column below diagonal using modified Givens ! transformations applied to (A B). ! ! When operating near the ME line, use the largest element ! above it as the pivot. ! DO 160 J=M,I+1,-1 JP = J-1 if (J == ME+1) THEN IMAX = ME AMAX = SCALE(ME)*W(ME,I)**2 DO 150 JP=J-1,I,-1 T = SCALE(JP)*W(JP,I)**2 if (T > AMAX) THEN IMAX = JP AMAX = T ENDIF 150 CONTINUE JP = IMAX ENDIF ! if (W(J,I) /= 0.E0) THEN call SROTMG (SCALE(JP), SCALE(J), W(JP,I), W(J,I), & SPARAM) W(J,I) = 0.E0 call SROTM (N+1-I, W(JP,I+1), MDW, W(J,I+1), MDW, & SPARAM) ENDIF 160 CONTINUE ELSE if (LEND > I) THEN ! ! Column I is dependent. Swap with column LEND. ! Perform column interchange, ! and find column in remaining set with largest SS. ! call WNLT3 (I, LEND, M, MDW, IPIVOT, H, W) LEND = LEND - 1 IMAX = ISAMAX(LEND-I+1, H(I), 1) + I - 1 HBAR = H(IMAX) go to 130 ELSE KRANK = I - 1 go to 190 ENDIF 180 CONTINUE KRANK = L1 ! 190 if (KRANK < ME) THEN FACTOR = ALSQ DO 200 I=KRANK+1,ME call sinit ( L, 0.E0, W(I,1), MDW) 200 CONTINUE ! ! Determine the rank of the remaining equality constraint ! equations by eliminating within the block of constrained ! variables. Remove any redundant constraints. ! RECALC = .TRUE. LB = MIN(L+ME-KRANK, N) DO 270 I=L+1,LB IR = KRANK + I - L LEND = N MEND = ME call WNLT1 (I, LEND, ME, IR, MDW, RECALC, IMAX, HBAR, H, & SCALE, W) ! ! Update col ss and find pivot col ! call WNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) ! ! Perform column interchange ! Eliminate elements in the I-th col. ! DO 240 J=ME,IR+1,-1 if (W(J,I) /= 0.E0) THEN call SROTMG (SCALE(J-1), SCALE(J), W(J-1,I), W(J,I), & SPARAM) W(J,I) = 0.E0 call SROTM (N+1-I, W(J-1,I+1), MDW,W(J,I+1), MDW, & SPARAM) ENDIF 240 CONTINUE ! ! I=column being eliminated. ! Test independence of incoming column. ! Remove any redundant or dependent equality constraints. ! if (.NOT.WNLT2(ME, MEND, IR, FACTOR,TAU,SCALE,W(1,I))) THEN JJ = IR DO 260 IR=JJ,ME call sinit ( N, 0.E0, W(IR,1), MDW) RNORM = RNORM + (SCALE(IR)*W(IR,N+1)/ALSQ)*W(IR,N+1) W(IR,N+1) = 0.E0 SCALE(IR) = 1.E0 ! ! Reclassify the zeroed row as a least squares equation. ! ITYPE(IR) = 1 260 CONTINUE ! ! Reduce ME to reflect any discovered dependent equality ! constraints. ! ME = JJ - 1 go to 280 ENDIF 270 CONTINUE end if ! ! Try to determine the variables KRANK+1 through L1 from the ! least squares equations. Continue the triangularization with ! pivot element W(ME+1,I). ! 280 if (KRANK < L1) THEN RECALC = .TRUE. ! ! Set FACTOR=ALSQ to remove effect of heavy weight from ! test for column independence. ! FACTOR = ALSQ DO 350 I=KRANK+1,L1 ! ! Set IR to point to the ME+1-st row. ! IR = ME+1 LEND = L MEND = M call WNLT1 (I, L, M, IR, MDW, RECALC, IMAX, HBAR, H, SCALE, & W) ! ! Update column SS and find pivot column. ! call WNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) ! ! Perform column interchange. ! Eliminate I-th column below the IR-th element. ! DO 320 J=M,IR+1,-1 if (W(J,I) /= 0.E0) THEN call SROTMG (SCALE(J-1), SCALE(J), W(J-1,I), W(J,I), & SPARAM) W(J,I) = 0.E0 call SROTM (N+1-I, W(J-1,I+1), MDW, W(J,I+1), MDW, & SPARAM) ENDIF 320 CONTINUE ! ! Test if new pivot element is near zero. ! If so, the column is dependent. ! Then check row norm test to be classified as independent. ! T = SCALE(IR)*W(IR,I)**2 INDEP = T > (TAU*EANORM)**2 if (INDEP) THEN RN = 0.E0 DO 340 I1=IR,M DO 330 J1=I+1,N RN = MAX(RN, SCALE(I1)*W(I1,J1)**2) 330 CONTINUE 340 CONTINUE INDEP = T > RN*TAU**2 ENDIF ! ! If independent, swap the IR-th and KRANK+1-th rows to ! maintain the triangular form. Update the rank indicator ! KRANK and the equality constraint pointer ME. ! if (.NOT.INDEP) go to 360 call SSWAP(N+1, W(KRANK+1,1), MDW, W(IR,1), MDW) call SSWAP(1, SCALE(KRANK+1), 1, SCALE(IR), 1) ! ! Reclassify the least square equation as an equality ! constraint and rescale it. ! ITYPE(IR) = 0 T = SQRT(SCALE(KRANK+1)) call SSCAL(N+1, T, W(KRANK+1,1), MDW) SCALE(KRANK+1) = ALSQ ME = ME+1 KRANK = KRANK+1 350 CONTINUE end if ! ! If pseudorank is less than L, apply Householder transformation. ! from right. ! 360 if (KRANK < L) THEN DO 370 J=KRANK,1,-1 call H12 (1, J, KRANK+1, L, W(J,1), MDW, H(J), W, MDW, 1, & J-1) 370 CONTINUE end if ! NIV = KRANK + NSOLN - L if (L == N) DONE = .TRUE. ! ! End of initial triangularization. ! IDOPE(1) = ME IDOPE(2) = KRANK IDOPE(3) = NIV return end subroutine WNLSM (W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, & IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) ! !! WNLSM is subsidiary to WNNLS ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (WNLSM-S, DWNLSM-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! This is a companion subprogram to WNNLS. ! The documentation for WNNLS has complete usage instructions. ! ! In addition to the parameters discussed in the prologue to ! subroutine WNNLS, the following work arrays are used in ! subroutine WNLSM (they are passed through the calling ! sequence from WNNLS for purposes of variable dimensioning). ! Their contents will in general be of no interest to the user. ! ! IPIVOT(*) ! An array of length N. Upon completion it contains the ! pivoting information for the cols of W(*,*). ! ! ITYPE(*) ! An array of length M which is used to keep track ! of the classification of the equations. ITYPE(I)=0 ! denotes equation I as an equality constraint. ! ITYPE(I)=1 denotes equation I as a least squares ! equation. ! ! WD(*) ! An array of length N. Upon completion it contains the ! dual solution vector. ! ! H(*) ! An array of length N. Upon completion it contains the ! pivot scalars of the Householder transformations performed ! in the case KRANK < L. ! ! SCALE(*) ! An array of length M which is used by the subroutine ! to store the diagonal matrix of weights. ! These are used to apply the modified Givens ! transformations. ! ! Z(*),TEMP(*) ! Working arrays of length N. ! ! D(*) ! An array of length N that contains the ! column scaling for the matrix (E). ! (A) ! !***SEE ALSO WNNLS !***ROUTINES CALLED H12, ISAMAX, R1MACH, SASUM, SAXPY, SCOPY, SNRM2, ! SROTM, SROTMG, SSCAL, SSWAP, WNLIT, XERMSG !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890618 Completely restructured and revised. (WRB & RWC) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900328 Added TYPE section. (WRB) ! 900510 Fixed an error message. (RWC) !***END PROLOGUE WNLSM INTEGER IPIVOT(*), ITYPE(*), L, MA, MDW, MME, MODE, N REAL D(*), H(*), PRGOPT(*), RNORM, SCALE(*), TEMP(*), & W(MDW,*), WD(*), X(*), Z(*) ! EXTERNAL H12, ISAMAX, R1MACH, SASUM, SAXPY, SCOPY, SNRM2, SROTM, & SROTMG, SSCAL, SSWAP, WNLIT, XERMSG REAL R1MACH, SASUM, SNRM2 INTEGER ISAMAX ! REAL ALAMDA, ALPHA, ALSQ, AMAX, BLOWUP, BNORM, & DOPE(3), EANORM, FAC, SM, SPARAM(5), SRELPR, T, TAU, WMAX, Z2, & ZZ INTEGER I, IDOPE(3), IMAX, ISOL, ITEMP, ITER, ITMAX, IWMAX, J, & JCON, JP, KEY, KRANK, L1, LAST, LINK, M, ME, NEXT, NIV, NLINK, & NOPT, NSOLN, NTIMES LOGICAL DONE, FEASBL, FIRST, HITCON, POS ! SAVE SRELPR, FIRST DATA FIRST /.TRUE./ !***FIRST EXECUTABLE STATEMENT WNLSM ! ! Initialize variables. ! SRELPR is the precision for the particular machine ! being used. This logic avoids resetting it every entry. ! if (FIRST) SRELPR = R1MACH(4) FIRST = .FALSE. ! ! Set the nominal tolerance used in the code. ! TAU = SQRT(SRELPR) ! M = MA + MME ME = MME MODE = 2 ! ! To process option vector ! FAC = 1.E-4 ! ! Set the nominal blow up factor used in the code. ! BLOWUP = TAU ! ! The nominal column scaling used in the code is ! the identity scaling. ! call sinit ( N, 1.E0, D, 1) ! ! Define bound for number of options to change. ! NOPT = 1000 ! ! Define bound for positive value of LINK. ! NLINK = 100000 NTIMES = 0 LAST = 1 LINK = PRGOPT(1) if (LINK <= 0 .OR. LINK > NLINK) THEN call XERMSG ('SLATEC', 'WNLSM', & 'WNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) return end if ! 100 if (LINK > 1) THEN NTIMES = NTIMES + 1 if (NTIMES > NOPT) THEN call XERMSG ('SLATEC', 'WNLSM', & 'WNNLS, THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 3, 1) return ENDIF ! KEY = PRGOPT(LAST+1) if (KEY == 6 .AND. PRGOPT(LAST+2) /= 0.E0) THEN DO 110 J = 1,N T = SNRM2(M,W(1,J),1) if (T /= 0.E0) T = 1.E0/T D(J) = T 110 CONTINUE ENDIF ! if (KEY == 7) call SCOPY (N, PRGOPT(LAST+2), 1, D, 1) if (KEY == 8) TAU = MAX(SRELPR,PRGOPT(LAST+2)) if (KEY == 9) BLOWUP = MAX(SRELPR,PRGOPT(LAST+2)) ! NEXT = PRGOPT(LINK) if (NEXT <= 0 .OR. NEXT > NLINK) THEN call XERMSG ('SLATEC', 'WNLSM', & 'WNNLS, THE OPTION VECTOR IS UNDEFINED', 3, 1) return ENDIF ! LAST = LINK LINK = NEXT go to 100 end if ! DO 120 J = 1,N call SSCAL (M, D(J), W(1,J), 1) 120 CONTINUE ! ! Process option vector ! DONE = .FALSE. ITER = 0 ITMAX = 3*(N-L) MODE = 0 NSOLN = L L1 = MIN(M,L) ! ! Compute scale factor to apply to equality constraint equations. ! DO 130 J = 1,N WD(J) = SASUM(M,W(1,J),1) 130 CONTINUE ! IMAX = ISAMAX(N,WD,1) EANORM = WD(IMAX) BNORM = SASUM(M,W(1,N+1),1) ALAMDA = EANORM/(SRELPR*FAC) ! ! Define scaling diagonal matrix for modified Givens usage and ! classify equation types. ! ALSQ = ALAMDA**2 DO 140 I = 1,M ! ! When equation I is heavily weighted ITYPE(I)=0, ! else ITYPE(I)=1. ! if (I <= ME) THEN T = ALSQ ITEMP = 0 ELSE T = 1.E0 ITEMP = 1 ENDIF SCALE(I) = T ITYPE(I) = ITEMP 140 CONTINUE ! ! Set the solution vector X(*) to zero and the column interchange ! matrix to the identity. ! call sinit ( N, 0.E0, X, 1) DO 150 I = 1,N IPIVOT(I) = I 150 CONTINUE ! ! Perform initial triangularization in the submatrix ! corresponding to the unconstrained variables. ! Set first L components of dual vector to zero because ! these correspond to the unconstrained variables. ! call sinit ( L, 0.E0, WD, 1) ! ! The arrays IDOPE(*) and DOPE(*) are used to pass ! information to WNLIT(). This was done to avoid ! a long calling sequence or the use of COMMON. ! IDOPE(1) = ME IDOPE(2) = NSOLN IDOPE(3) = L1 ! DOPE(1) = ALSQ DOPE(2) = EANORM DOPE(3) = TAU call WNLIT (W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, & IDOPE, DOPE, DONE) ME = IDOPE(1) KRANK = IDOPE(2) NIV = IDOPE(3) ! ! Perform WNNLS algorithm using the following steps. ! ! Until(DONE) ! compute search direction and feasible point ! when (HITCON) add constraints ! else perform multiplier test and drop a constraint ! fin ! Compute-Final-Solution ! ! To compute search direction and feasible point, ! solve the triangular system of currently non-active ! variables and store the solution in Z(*). ! ! To solve system ! Copy right hand side into TEMP vector to use overwriting method. ! 160 if (DONE) go to 330 ISOL = L + 1 if (NSOLN >= ISOL) THEN call SCOPY (NIV, W(1,N+1), 1, TEMP, 1) DO 170 J = NSOLN,ISOL,-1 if (J > KRANK) THEN I = NIV - NSOLN + J ELSE I = J ENDIF ! if (J > KRANK .AND. J <= L) THEN Z(J) = 0.E0 ELSE Z(J) = TEMP(I)/W(I,J) call SAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) ENDIF 170 CONTINUE end if ! ! Increment iteration counter and check against maximum number ! of iterations. ! ITER = ITER + 1 if (ITER > ITMAX) THEN MODE = 1 DONE = .TRUE. end if ! ! Check to see if any constraints have become active. ! If so, calculate an interpolation factor so that all ! active constraints are removed from the basis. ! ALPHA = 2.E0 HITCON = .FALSE. DO 180 J = L+1,NSOLN ZZ = Z(J) if (ZZ <= 0.E0) THEN T = X(J)/(X(J)-ZZ) if (T < ALPHA) THEN ALPHA = T JCON = J ENDIF HITCON = .TRUE. ENDIF 180 CONTINUE ! ! Compute search direction and feasible point ! if (HITCON) THEN ! ! To add constraints, use computed ALPHA to interpolate between ! last feasible solution X(*) and current unconstrained (and ! infeasible) solution Z(*). ! DO 190 J = L+1,NSOLN X(J) = X(J) + ALPHA*(Z(J)-X(J)) 190 CONTINUE FEASBL = .FALSE. ! ! Remove column JCON and shift columns JCON+1 through N to the ! left. Swap column JCON into the N th position. This achieves ! upper Hessenberg form for the nonactive constraints and ! leaves an upper Hessenberg matrix to retriangularize. ! 200 DO 210 I = 1,M T = W(I,JCON) call SCOPY (N-JCON, W(I, JCON+1), MDW, W(I, JCON), MDW) W(I,N) = T 210 CONTINUE ! ! Update permuted index vector to reflect this shift and swap. ! ITEMP = IPIVOT(JCON) DO 220 I = JCON,N - 1 IPIVOT(I) = IPIVOT(I+1) 220 CONTINUE IPIVOT(N) = ITEMP ! ! Similarly permute X(*) vector. ! call SCOPY (N-JCON, X(JCON+1), 1, X(JCON), 1) X(N) = 0.E0 NSOLN = NSOLN - 1 NIV = NIV - 1 ! ! Retriangularize upper Hessenberg matrix after adding ! constraints. ! I = KRANK + JCON - L DO 230 J = JCON,NSOLN if (ITYPE(I) == 0 .AND. ITYPE(I+1) == 0) THEN ! ! Zero IP1 to I in column J ! if (W(I+1,J) /= 0.E0) THEN call SROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), & SPARAM) W(I+1,J) = 0.E0 call SROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, & SPARAM) ENDIF ELSEIF (ITYPE(I) == 1 .AND. ITYPE(I+1) == 1) THEN ! ! Zero IP1 to I in column J ! if (W(I+1,J) /= 0.E0) THEN call SROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), & SPARAM) W(I+1,J) = 0.E0 call SROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, & SPARAM) ENDIF ELSEIF (ITYPE(I) == 1 .AND. ITYPE(I+1) == 0) THEN call SSWAP (N+1, 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 ! ! Swapped row was formerly a pivot element, so it will ! be large enough to perform elimination. ! Zero IP1 to I in column J. ! if (W(I+1,J) /= 0.E0) THEN call SROTMG (SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), & SPARAM) W(I+1,J) = 0.E0 call SROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, & SPARAM) ENDIF ELSEIF (ITYPE(I) == 0 .AND. ITYPE(I+1) == 1) THEN if (SCALE(I)*W(I,J)**2/ALSQ > (TAU*EANORM)**2) THEN ! ! Zero IP1 to I in column J ! if (W(I+1,J) /= 0.E0) THEN call SROTMG (SCALE(I), SCALE(I+1), W(I,J), & W(I+1,J), SPARAM) W(I+1,J) = 0.E0 call SROTM (N+1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, & SPARAM) ENDIF ELSE call SSWAP (N+1, 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) = 0.E0 ENDIF ENDIF I = I + 1 230 CONTINUE ! ! See if the remaining coefficients in the solution set are ! feasible. They should be because of the way ALPHA was ! determined. If any are infeasible, it is due to roundoff ! error. Any that are non-positive will be set to zero and ! removed from the solution set. ! DO 240 JCON = L+1,NSOLN if (X(JCON) <= 0.E0) go to 250 240 CONTINUE FEASBL = .TRUE. 250 if (.NOT.FEASBL) go to 200 ELSE ! ! To perform multiplier test and drop a constraint. ! call SCOPY (NSOLN, Z, 1, X, 1) if (NSOLN < N) call sinit ( N-NSOLN, 0.E0, X(NSOLN+1), 1) ! ! Reclassify least squares equations as equalities as necessary. ! I = NIV + 1 260 if (I <= ME) THEN if (ITYPE(I) == 0) THEN I = I + 1 ELSE call SSWAP (N+1, 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 ME = ME - 1 ENDIF go to 260 ENDIF ! ! Form inner product vector WD(*) of dual coefficients. ! DO 280 J = NSOLN+1,N SM = 0.E0 DO 270 I = NSOLN+1,M SM = SM + SCALE(I)*W(I,J)*W(I,N+1) 270 CONTINUE WD(J) = SM 280 CONTINUE ! ! Find J such that WD(J)=WMAX is maximum. This determines ! that the incoming column J will reduce the residual vector ! and be positive. ! 290 WMAX = 0.E0 IWMAX = NSOLN + 1 DO 300 J = NSOLN+1,N if (WD(J) > WMAX) THEN WMAX = WD(J) IWMAX = J ENDIF 300 CONTINUE if (WMAX <= 0.E0) go to 330 ! ! Set dual coefficients to zero for incoming column. ! WD(IWMAX) = 0.E0 ! ! WMAX > 0.E0, so okay to move column IWMAX to solution set. ! Perform transformation to retriangularize, and test for near ! linear dependence. ! ! Swap column IWMAX into NSOLN-th position to maintain upper ! Hessenberg form of adjacent columns, and add new column to ! triangular decomposition. ! NSOLN = NSOLN + 1 NIV = NIV + 1 if (NSOLN /= IWMAX) THEN call SSWAP (M, W(1,NSOLN), 1, W(1,IWMAX), 1) WD(IWMAX) = WD(NSOLN) WD(NSOLN) = 0.E0 ITEMP = IPIVOT(NSOLN) IPIVOT(NSOLN) = IPIVOT(IWMAX) IPIVOT(IWMAX) = ITEMP ENDIF ! ! Reduce column NSOLN so that the matrix of nonactive constraints ! variables is triangular. ! DO 320 J = M,NIV+1,-1 JP = J - 1 ! ! When operating near the ME line, test to see if the pivot ! element is near zero. If so, use the largest element above ! it as the pivot. This is to maintain the sharp interface ! between weighted and non-weighted rows in all cases. ! if (J == ME+1) THEN IMAX = ME AMAX = SCALE(ME)*W(ME,NSOLN)**2 DO 310 JP = J - 1,NIV,-1 T = SCALE(JP)*W(JP,NSOLN)**2 if (T > AMAX) THEN IMAX = JP AMAX = T ENDIF 310 CONTINUE JP = IMAX ENDIF ! if (W(J,NSOLN) /= 0.E0) THEN call SROTMG (SCALE(JP), SCALE(J), W(JP,NSOLN), & W(J,NSOLN), SPARAM) W(J,NSOLN) = 0.E0 call SROTM (N+1-NSOLN, W(JP,NSOLN+1), MDW, W(J,NSOLN+1), & MDW, SPARAM) ENDIF 320 CONTINUE ! ! Solve for Z(NSOLN)=proposed new value for X(NSOLN). Test if ! this is nonpositive or too large. If this was true or if the ! pivot term was zero, reject the column as dependent. ! if (W(NIV,NSOLN) /= 0.E0) THEN ISOL = NIV Z2 = W(ISOL,N+1)/W(ISOL,NSOLN) Z(NSOLN) = Z2 POS = Z2 > 0.E0 if (Z2*EANORM >= BNORM .AND. POS) THEN POS = .NOT. (BLOWUP*Z2*EANORM >= BNORM) ENDIF ! ! Try to add row ME+1 as an additional equality constraint. ! Check size of proposed new solution component. ! Reject it if it is too large. ! ELSEIF (NIV <= ME .AND. W(ME+1,NSOLN) /= 0.E0) THEN ISOL = ME + 1 if (POS) THEN ! ! Swap rows ME+1 and NIV, and scale factors for these rows. ! call SSWAP (N+1, W(ME+1,1), MDW, W(NIV,1), MDW) call SSWAP (1, SCALE(ME+1), 1, SCALE(NIV), 1) ITEMP = ITYPE(ME+1) ITYPE(ME+1) = ITYPE(NIV) ITYPE(NIV) = ITEMP ME = ME + 1 ENDIF ELSE POS = .FALSE. ENDIF ! if (.NOT.POS) THEN NSOLN = NSOLN - 1 NIV = NIV - 1 ENDIF if (.NOT.(POS.OR.DONE)) go to 290 end if go to 160 ! ! Else perform multiplier test and drop a constraint. To compute ! final solution. Solve system, store results in X(*). ! ! Copy right hand side into TEMP vector to use overwriting method. ! 330 ISOL = 1 if (NSOLN >= ISOL) THEN call SCOPY (NIV, W(1,N+1), 1, TEMP, 1) DO 340 J = NSOLN,ISOL,-1 if (J > KRANK) THEN I = NIV - NSOLN + J ELSE I = J ENDIF ! if (J > KRANK .AND. J <= L) THEN Z(J) = 0.E0 ELSE Z(J) = TEMP(I)/W(I,J) call SAXPY (I-1, -Z(J), W(1,J), 1, TEMP, 1) ENDIF 340 CONTINUE end if ! ! Solve system. ! call SCOPY (NSOLN, Z, 1, X, 1) ! ! Apply Householder transformations to X(*) if KRANK < L ! if (KRANK < L) THEN DO 350 I = 1,KRANK call H12 (2, I, KRANK+1, L, W(I,1), MDW, H(I), X, 1, 1, 1) 350 CONTINUE end if ! ! Fill in trailing zeroes for constrained variables not in solution. ! if (NSOLN < N) call sinit ( N-NSOLN, 0.E0, X(NSOLN+1), 1) ! ! Permute solution vector to natural order. ! DO 380 I = 1,N J = I 360 if (IPIVOT(J) == I) go to 370 J = J + 1 go to 360 ! 370 IPIVOT(J) = IPIVOT(I) IPIVOT(I) = J call SSWAP (1, X(J), 1, X(I), 1) 380 CONTINUE ! ! Rescale the solution using the column scaling. ! DO 390 J = 1,N X(J) = X(J)*D(J) 390 CONTINUE ! DO 400 I = NSOLN+1,M T = W(I,N+1) if (I <= ME) T = T/ALAMDA T = (SCALE(I)*T)*T RNORM = RNORM + T 400 CONTINUE ! RNORM = SQRT(RNORM) return end subroutine WNLT1 (I, LEND, MEND, IR, MDW, RECALC, IMAX, HBAR, H, & SCALE, W) ! !! WNLT1 is subsidiary to WNLIT. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (WNLT1-S, DWNLT1-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! To update the column Sum Of Squares and find the pivot column. ! The column Sum of Squares Vector will be updated at each step. ! When numerically necessary, these values will be recomputed. ! !***SEE ALSO WNLIT !***ROUTINES CALLED ISAMAX !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890620 Code extracted from WNLIT and made a subroutine. (RWC)) !***END PROLOGUE WNLT1 INTEGER I, IMAX, IR, LEND, MDW, MEND REAL H(*), HBAR, SCALE(*), W(MDW,*) LOGICAL RECALC ! EXTERNAL ISAMAX INTEGER ISAMAX ! INTEGER J, K ! !***FIRST EXECUTABLE STATEMENT WNLT1 if (IR /= 1 .AND. (.NOT.RECALC)) THEN ! ! Update column SS=sum of squares. ! DO 10 J=I,LEND H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 10 CONTINUE ! ! Test for numerical accuracy. ! IMAX = ISAMAX(LEND-I+1, H(I), 1) + I - 1 RECALC = (HBAR+1.E-3*H(IMAX)) == HBAR end if ! ! If required, recalculate column SS, using rows IR through MEND. ! if (RECALC) THEN DO 30 J=I,LEND H(J) = 0.E0 DO 20 K=IR,MEND H(J) = H(J) + SCALE(K)*W(K,J)**2 20 CONTINUE 30 CONTINUE ! ! Find column with largest SS. ! IMAX = ISAMAX(LEND-I+1, H(I), 1) + I - 1 HBAR = H(IMAX) end if return end LOGICAL FUNCTION WNLT2 (ME, MEND, IR, FACTOR, TAU, SCALE, WIC) ! !! WNLT2 is subsidiary to WNLIT. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (WNLT2-S, DWNLT2-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! To test independence of incoming column. ! ! Test the column IC to determine if it is linearly independent ! of the columns already in the basis. In the initial tri. step, ! we usually want the heavy weight ALAMDA to be included in the ! test for independence. In this case, the value of FACTOR will ! have been set to 1.E0 before this procedure is invoked. ! In the potentially rank deficient problem, the value of FACTOR ! will have been set to ALSQ=ALAMDA**2 to remove the effect of the ! heavy weight from the test for independence. ! ! Write new column as partitioned vector ! (A1) number of components in solution so far = NIV ! (A2) M-NIV components ! And compute SN = inverse weighted length of A1 ! RN = inverse weighted length of A2 ! Call the column independent when RN > TAU*SN ! !***SEE ALSO WNILT !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890620 Code extracted from WNLIT and made a subroutine. (RWC)) !***END PROLOGUE WNLT2 REAL FACTOR, SCALE(*), TAU, WIC(*) INTEGER IR, ME, MEND ! REAL RN, SN, T INTEGER J ! !***FIRST EXECUTABLE STATEMENT WNLT2 SN = 0.E0 RN = 0.E0 DO 10 J=1,MEND T = SCALE(J) if (J <= ME) T = T/FACTOR T = T*WIC(J)**2 ! if (J < IR) THEN SN = SN + T ELSE RN = RN + T ENDIF 10 CONTINUE WNLT2 = RN > SN*TAU**2 return end subroutine WNLT3 (I, IMAX, M, MDW, IPIVOT, H, W) ! !! WNLT3 is subsidiary to WNLIT. ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (WNLT3-S, DWNLT3-D) !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! Perform column interchange. ! Exchange elements of permuted index vector and perform column ! interchanges. ! !***SEE ALSO WNLIT !***ROUTINES CALLED SSWAP !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890620 Code extracted from WNLT and made a subroutine. (RWC)) !***END PROLOGUE WNLT3 INTEGER I, IMAX, IPIVOT(*), M, MDW REAL H(*), W(MDW,*) ! EXTERNAL SSWAP ! REAL T INTEGER ITEMP ! !***FIRST EXECUTABLE STATEMENT WNLT3 if (IMAX /= I) THEN ITEMP = IPIVOT(I) IPIVOT(I) = IPIVOT(IMAX) IPIVOT(IMAX) = ITEMP ! call SSWAP(M, W(1,IMAX), 1, W(1,I), 1) ! T = H(IMAX) H(IMAX) = H(I) H(I) = T end if return end subroutine WNNLS (W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, & IWORK, WORK) ! !! WNNLS solves a linearly constrained least squares problem with ... ! equality constraints and nonnegativity constraints on ! selected variables. ! !***LIBRARY SLATEC !***CATEGORY K1A2A !***TYPE SINGLE PRECISION (WNNLS-S, DWNNLS-D) !***KEYWORDS CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING, ! EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS, ! NONNEGATIVITY CONSTRAINTS, QUADRATIC PROGRAMMING !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, K. H., (SNLA) !***DESCRIPTION ! ! Abstract ! ! This subprogram solves a linearly constrained least squares ! problem. Suppose there are given matrices E and A of ! respective dimensions ME by N and MA by N, and vectors F ! and B of respective lengths ME and MA. This subroutine ! solves the problem ! ! EX = F, (equations to be exactly satisfied) ! ! AX = B, (equations to be approximately satisfied, ! in the least squares sense) ! ! subject to components L+1,...,N nonnegative ! ! Any values ME >= 0, MA >= 0 and 0 <= L <= N are permitted. ! ! The problem is reposed as problem WNNLS ! ! (WT*E)X = (WT*F) ! ( A) ( B), (least squares) ! subject to components L+1,...,N nonnegative. ! ! The subprogram chooses the heavy weight (or penalty parameter) WT. ! ! The parameters for WNNLS are ! ! INPUT.. ! ! W(*,*),MDW, The array W(*,*) is double subscripted with first ! ME,MA,N,L dimensioning parameter equal to MDW. For this ! discussion let us call M = ME + MA. Then MDW ! must satisfy MDW >= M. The condition MDW < M ! is an error. ! ! The array W(*,*) contains the matrices and vectors ! ! (E F) ! (A B) ! ! in rows and columns 1,...,M and 1,...,N+1 ! respectively. Columns 1,...,L correspond to ! unconstrained variables X(1),...,X(L). The ! remaining variables are constrained to be ! nonnegative. The condition L < 0 or L > N is ! an error. ! ! PRGOPT(*) This real-valued array is the option vector. ! If the user is satisfied with the nominal ! subprogram features set ! ! PRGOPT(1)=1 (or PRGOPT(1)=1.0) ! ! Otherwise PRGOPT(*) is a linked list consisting of ! groups of data of the following form ! ! LINK ! KEY ! DATA SET ! ! The parameters LINK and KEY are each one word. ! The DATA SET can be comprised of several words. ! The number of items depends on the value of KEY. ! The value of LINK points to the first ! entry of the next group of data within ! PRGOPT(*). The exception is when there are ! no more options to change. In that ! case LINK=1 and the values KEY and DATA SET ! are not referenced. The general layout of ! PRGOPT(*) is as follows. ! ! ...PRGOPT(1)=LINK1 (link to first entry of next group) ! . PRGOPT(2)=KEY1 (key to the option change) ! . PRGOPT(3)=DATA VALUE (data value for this change) ! . . ! . . ! . . ! ...PRGOPT(LINK1)=LINK2 (link to the first entry of ! . next group) ! . PRGOPT(LINK1+1)=KEY2 (key to the option change) ! . PRGOPT(LINK1+2)=DATA VALUE ! ... . ! . . ! . . ! ...PRGOPT(LINK)=1 (no more options to change) ! ! Values of LINK that are nonpositive are errors. ! A value of LINK > NLINK=100000 is also an error. ! This helps prevent using invalid but positive ! values of LINK that will probably extend ! beyond the program limits of PRGOPT(*). ! Unrecognized values of KEY are ignored. The ! order of the options is arbitrary and any number ! of options can be changed with the following ! restriction. To prevent cycling in the ! processing of the option array a count of the ! number of options changed is maintained. ! Whenever this count exceeds NOPT=1000 an error ! message is printed and the subprogram returns. ! ! OPTIONS.. ! ! KEY=6 ! Scale the nonzero columns of the ! entire data matrix ! (E) ! (A) ! to have length one. The DATA SET for ! this option is a single value. It must ! be nonzero if unit length column scaling is ! desired. ! ! KEY=7 ! Scale columns of the entire data matrix ! (E) ! (A) ! with a user-provided diagonal matrix. ! The DATA SET for this option consists ! of the N diagonal scaling factors, one for ! each matrix column. ! ! KEY=8 ! Change the rank determination tolerance from ! the nominal value of SQRT(SRELPR). This quantity ! can be no smaller than SRELPR, The arithmetic- ! storage precision. The quantity used ! here is internally restricted to be at ! least SRELPR. The DATA SET for this option ! is the new tolerance. ! ! KEY=9 ! Change the blow-up parameter from the ! nominal value of SQRT(SRELPR). The reciprocal of ! this parameter is used in rejecting solution ! components as too large when a variable is ! first brought into the active set. Too large ! means that the proposed component times the ! reciprocal of the parameter is not less than ! the ratio of the norms of the right-side ! vector and the data matrix. ! This parameter can be no smaller than SRELPR, ! the arithmetic-storage precision. ! ! For example, suppose we want to provide ! a diagonal matrix to scale the problem ! matrix and change the tolerance used for ! determining linear dependence of dropped col ! vectors. For these options the dimensions of ! PRGOPT(*) must be at least N+6. The FORTRAN ! statements defining these options would ! be as follows. ! ! PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*)) ! PRGOPT(2)=7 (user-provided scaling key) ! ! call SCOPY(N,D,1,PRGOPT(3),1) (copy the N ! scaling factors from a user array called D(*) ! into PRGOPT(3)-PRGOPT(N+2)) ! ! PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*)) ! PRGOPT(N+4)=8 (linear dependence tolerance key) ! PRGOPT(N+5)=... (new value of the tolerance) ! ! PRGOPT(N+6)=1 (no more options to change) ! ! ! IWORK(1), The amounts of working storage actually allocated ! IWORK(2) for the working arrays WORK(*) and IWORK(*), ! respectively. These quantities are compared with ! the actual amounts of storage needed for WNNLS( ). ! Insufficient storage allocated for either WORK(*) ! or IWORK(*) is considered an error. This feature ! was included in WNNLS( ) because miscalculating ! the storage formulas for WORK(*) and IWORK(*) ! might very well lead to subtle and hard-to-find ! execution errors. ! ! The length of WORK(*) must be at least ! ! LW = ME+MA+5*N ! This test will not be made if IWORK(1) <= 0. ! ! The length of IWORK(*) must be at least ! ! LIW = ME+MA+N ! This test will not be made if IWORK(2) <= 0. ! ! OUTPUT.. ! ! X(*) An array dimensioned at least N, which will ! contain the N components of the solution vector ! on output. ! ! RNORM The residual norm of the solution. The value of ! RNORM contains the residual vector length of the ! equality constraints and least squares equations. ! ! MODE The value of MODE indicates the success or failure ! of the subprogram. ! ! MODE = 0 Subprogram completed successfully. ! ! = 1 Max. number of iterations (equal to ! 3*(N-L)) exceeded. Nearly all problems ! should complete in fewer than this ! number of iterations. An approximate ! solution and its corresponding residual ! vector length are in X(*) and RNORM. ! ! = 2 Usage error occurred. The offending ! condition is noted with the error ! processing subprogram, XERMSG( ). ! ! User-designated ! Working arrays.. ! ! WORK(*) A real-valued working array of length at least ! M + 5*N. ! ! IWORK(*) An integer-valued working array of length at least ! M+N. ! !***REFERENCES K. H. Haskell and R. J. Hanson, An algorithm for ! linear least squares problems with equality and ! nonnegativity constraints, Report SAND77-0552, Sandia ! Laboratories, June 1978. ! K. H. Haskell and R. J. Hanson, Selected algorithms for ! the linearly constrained least squares problem - a ! users guide, Report SAND78-1290, Sandia Laboratories, ! August 1979. ! K. H. Haskell and R. J. Hanson, An algorithm for ! linear least squares problems with equality and ! nonnegativity constraints, Mathematical Programming ! 21 (1981), pp. 98-118. ! R. J. Hanson and K. H. Haskell, Two algorithms for the ! linearly constrained least squares problem, ACM ! Transactions on Mathematical Software, September 1982. ! C. L. Lawson and R. J. Hanson, Solving Least Squares ! Problems, Prentice-Hall, Inc., 1974. !***ROUTINES CALLED WNLSM, XERMSG !***REVISION HISTORY (YYMMDD) ! 790701 DATE WRITTEN ! 890206 REVISION DATE from Version 3.2 ! 890618 Completely restructured and revised. (WRB & RWC) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) ! 900510 Convert XERRWV calls to XERMSG calls. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE WNNLS REAL PRGOPT(*), RNORM, W(MDW,*), WORK(*), X(*) INTEGER IWORK(*) CHARACTER*8 XERN1 ! ! !***FIRST EXECUTABLE STATEMENT WNNLS MODE = 0 if (MA+ME <= 0 .OR. N <= 0) RETURN if (IWORK(1) > 0) THEN LW = ME + MA + 5*N if (IWORK(1) < LW) THEN WRITE (XERN1, '(I8)') LW call XERMSG ('SLATEC', 'WNNLS', 'INSUFFICIENT STORAGE ' // & 'ALLOCATED FOR WORK(*), NEED LW = ' // XERN1, 2, 1) MODE = 2 return ENDIF end if ! if (IWORK(2) > 0) THEN LIW = ME + MA + N if (IWORK(2) < LIW) THEN WRITE (XERN1, '(I8)') LIW call XERMSG ('SLATEC', 'WNNLS', 'INSUFFICIENT STORAGE ' // & 'ALLOCATED FOR IWORK(*), NEED LIW = ' // XERN1, 2, 1) MODE = 2 return ENDIF end if ! if (MDW < ME+MA) THEN call XERMSG ('SLATEC', 'WNNLS', & 'THE VALUE MDW < ME+MA IS AN ERROR', 1, 1) MODE = 2 return end if ! if (L < 0 .OR. L > N) THEN call XERMSG ('SLATEC', 'WNNLS', & 'L >= 0 .AND. L <= N IS REQUIRED', 2, 1) MODE = 2 return end if ! ! THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS ! WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS ! REQUIRED BY THE MAIN SUBROUTINE WNLSM( ). ! L1 = N + 1 L2 = L1 + N L3 = L2 + ME + MA L4 = L3 + N L5 = L4 + N ! 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 XADD (X, IX, Y, IY, Z, IZ, IERROR) ! !! XADD provides single-precision floating-point arithmetic ... ! with an extended exponent range. ! !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE SINGLE PRECISION (XADD-S, DXADD-D) !***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! REAL X, Y, Z ! INTEGER IX, IY, IZ ! ! FORMS THE EXTENDED-RANGE SUM (Z,IZ) = ! (X,IX) + (Y,IY). (Z,IZ) IS ADJUSTED ! BEFORE RETURNING. THE INPUT OPERANDS ! NEED NOT BE IN ADJUSTED FORM, BUT THEIR ! PRINCIPAL PARTS MUST SATISFY ! RADIX**(-2L) <= ABS(X) <= RADIX**(2L), ! RADIX**(-2L) <= ABS(Y) <= RADIX**(2L). ! !***SEE ALSO XSET !***REFERENCES (NONE) !***ROUTINES CALLED XADJ !***COMMON BLOCKS XBLK2 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XADD REAL X, Y, Z INTEGER IX, IY, IZ REAL RADIX, RADIXL, RAD2L, DLG10R INTEGER L, L2, KMAX COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX SAVE /XBLK2/ ! ! ! THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE ! ARE ! (1) 1 < L <= 0.5*LOGR(0.5*DZERO) ! ! (2) NRADPL < L <= KMAX/6 ! ! (3) KMAX <= (2**NBITS - 4*L - 1)/2 ! ! THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING ! IN SUBROUTINE XSET. ! !***FIRST EXECUTABLE STATEMENT XADD IERROR=0 if (X /= 0.0) go to 10 Z = Y IZ = IY go to 220 10 if (Y /= 0.0) go to 20 Z = X IZ = IX go to 220 20 CONTINUE if (IX >= 0 .AND. IY >= 0) go to 40 if (IX < 0 .AND. IY < 0) go to 40 if (ABS(IX) <= 6*L .AND. ABS(IY) <= 6*L) go to 40 if (IX >= 0) go to 30 Z = Y IZ = IY go to 220 30 CONTINUE Z = X IZ = IX go to 220 40 I = IX - IY if (I) 80, 50, 90 50 if (ABS(X) > 1.0 .AND. ABS(Y) > 1.0) go to 60 if (ABS(X) < 1.0 .AND. ABS(Y) < 1.0) go to 70 Z = X + Y IZ = IX go to 220 60 S = X/RADIXL T = Y/RADIXL Z = S + T IZ = IX + L go to 220 70 S = X*RADIXL T = Y*RADIXL Z = S + T IZ = IX - L go to 220 80 S = Y IS = IY T = X go to 100 90 S = X IS = IX T = Y 100 CONTINUE ! ! AT THIS POINT, THE ONE OF (X,IX) OR (Y,IY) THAT HAS THE ! LARGER AUXILIARY INDEX IS STORED IN (S,IS). THE PRINCIPAL ! PART OF THE OTHER INPUT IS STORED IN T. ! I1 = ABS(I)/L I2 = MOD(ABS(I),L) if (ABS(T) >= RADIXL) go to 130 if (ABS(T) >= 1.0) go to 120 if (RADIXL*ABS(T) >= 1.0) go to 110 J = I1 + 1 T = T*RADIX**(L-I2) go to 140 110 J = I1 T = T*RADIX**(-I2) go to 140 120 J = I1 - 1 if (J < 0) go to 110 T = T*RADIX**(-I2)/RADIXL go to 140 130 J = I1 - 2 if (J < 0) go to 120 T = T*RADIX**(-I2)/RAD2L 140 CONTINUE ! ! AT THIS POINT, SOME OR ALL OF THE DIFFERENCE IN THE ! AUXILIARY INDICES HAS BEEN USED TO EFFECT A LEFT SHIFT ! OF T. THE SHIFTED VALUE OF T SATISFIES ! ! RADIX**(-2*L) <= ABS(T) <= 1.0 ! ! AND, if J=0, NO FURTHER SHIFTING REMAINS TO BE DONE. ! if (J == 0) go to 190 if (ABS(S) >= RADIXL .OR. J > 3) go to 150 if (ABS(S) >= 1.0) go to (180, 150, 150), J if (RADIXL*ABS(S) >= 1.0) go to (180, 170, 150), J go to (180, 170, 160), J 150 Z = S IZ = IS go to 220 160 S = S*RADIXL 170 S = S*RADIXL 180 S = S*RADIXL 190 CONTINUE ! ! AT THIS POINT, THE REMAINING DIFFERENCE IN THE ! AUXILIARY INDICES HAS BEEN USED TO EFFECT A RIGHT SHIFT ! OF S. if THE SHIFTED VALUE OF S WOULD HAVE EXCEEDED ! RADIX**L, THEN (S,IS) IS RETURNED AS THE VALUE OF THE ! SUM. ! if (ABS(S) > 1.0 .AND. ABS(T) > 1.0) go to 200 if (ABS(S) < 1.0 .AND. ABS(T) < 1.0) go to 210 Z = S + T IZ = IS - J*L go to 220 200 S = S/RADIXL T = T/RADIXL Z = S + T IZ = IS - J*L + L go to 220 210 S = S*RADIXL T = T*RADIXL Z = S + T IZ = IS - J*L - L 220 call XADJ(Z, IZ,IERROR) return end subroutine XADJ (X, IX, IERROR) ! !! XADJ transforms X*RADIX**IX so RADIX**(-L) <= ABS(X) < RADIX(L). ! !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE SINGLE PRECISION (XADJ-S, DXADJ-D) !***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! REAL X ! INTEGER IX ! ! TRANSFORMS (X,IX) SO THAT ! RADIX**(-L) <= ABS(X) < RADIX**L. ! ON MOST COMPUTERS THIS TRANSFORMATION DOES ! NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS ! THE NUMBER BASE OF SINGLE-PRECISION ARITHMETIC. ! !***SEE ALSO XSET !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***COMMON BLOCKS XBLK2 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! CALLs to XERROR changed to CALLs to XERMSG. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XADJ REAL X INTEGER IX REAL RADIX, RADIXL, RAD2L, DLG10R INTEGER L, L2, KMAX COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX SAVE /XBLK2/ ! ! THE CONDITION IMPOSED ON L AND KMAX BY THIS SUBROUTINE ! IS ! 2*L <= KMAX ! ! THIS CONDITION MUST BE MET BY APPROPRIATE CODING ! IN SUBROUTINE XSET. ! !***FIRST EXECUTABLE STATEMENT XADJ IERROR=0 if (X == 0.0) go to 50 if (ABS(X) >= 1.0) go to 20 if (RADIXL*ABS(X) >= 1.0) go to 60 X = X*RAD2L if (IX < 0) go to 10 IX = IX - L2 go to 70 10 if (IX < -KMAX+L2) go to 40 IX = IX - L2 go to 70 20 if (ABS(X) < RADIXL) go to 60 X = X/RAD2L if (IX > 0) go to 30 IX = IX + L2 go to 70 30 if (IX > KMAX-L2) go to 40 IX = IX + L2 go to 70 40 call XERMSG ('SLATEC', 'XADJ', 'overflow in auxiliary index', 107, & 1) IERROR=107 return 50 IX = 0 60 if (ABS(IX) > KMAX) go to 40 70 RETURN end subroutine XC210 (K, Z, J, IERROR) ! !! XC210 determines J and Z so that RADIX**K = Z * 10**J. ! !***PURPOSE To provide single-precision floating-point arithmetic ! with an extended exponent range. !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE SINGLE PRECISION (XC210-S, DXC210-D) !***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! INTEGER K, J ! REAL Z ! ! GIVEN K THIS SUBROUTINE COMPUTES J AND Z ! SUCH THAT RADIX**K = Z*10**J, WHERE Z IS IN ! THE RANGE 1/10 <= Z < 1. ! THE VALUE OF Z WILL BE ACCURATE TO FULL ! SINGLE-PRECISION PROVIDED THE NUMBER ! OF DECIMAL PLACES IN THE LARGEST ! INTEGER PLUS THE NUMBER OF DECIMAL ! PLACES CARRIED IN SINGLE-PRECISION DOES NOT ! EXCEED 60. XC210 IS CALLED BY SUBROUTINE ! XCON WHEN NECESSARY. THE USER SHOULD ! NEVER NEED TO call XC210 DIRECTLY. ! !***SEE ALSO XSET !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***COMMON BLOCKS XBLK3 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! CALLs to XERROR changed to CALLs to XERMSG. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XC210 INTEGER K, J REAL Z INTEGER NLG102, MLG102, LG102 COMMON /XBLK3/ NLG102, MLG102, LG102(21) SAVE /XBLK3/ ! ! THE CONDITIONS IMPOSED ON NLG102, MLG102, AND LG102 BY ! THIS SUBROUTINE ARE ! ! (1) NLG102 >= 2 ! ! (2) MLG102 >= 1 ! ! (3) 2*MLG102*(MLG102 - 1) <= 2**NBITS - 1 ! ! THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING ! IN SUBROUTINE XSET. ! !***FIRST EXECUTABLE STATEMENT XC210 IERROR=0 if (K == 0) go to 70 M = MLG102 KA = ABS(K) KA1 = KA/M KA2 = MOD(KA,M) if (KA1 >= M) go to 60 NM1 = NLG102 - 1 NP1 = NLG102 + 1 IT = KA2*LG102(NP1) IC = IT/M ID = MOD(IT,M) Z = ID if (KA1 > 0) go to 20 DO 10 II=1,NM1 I = NP1 - II IT = KA2*LG102(I) + IC IC = IT/M ID = MOD(IT,M) Z = Z/M + ID 10 CONTINUE JA = KA*LG102(1) + IC go to 40 20 CONTINUE DO 30 II=1,NM1 I = NP1 - II IT = KA2*LG102(I) + KA1*LG102(I+1) + IC IC = IT/M ID = MOD(IT,M) Z = Z/M + ID 30 CONTINUE JA = KA*LG102(1) + KA1*LG102(2) + IC 40 CONTINUE Z = Z/M if (K > 0) go to 50 J = -JA Z = 10.0**(-Z) go to 80 50 CONTINUE J = JA + 1 Z = 10.0**(Z-1.0) go to 80 60 CONTINUE ! THIS ERROR OCCURS if K EXCEEDS MLG102**2 - 1 IN MAGNITUDE. ! call XERMSG ('SLATEC', 'XC210', 'K too large', 108, 1) IERROR=108 return 70 CONTINUE J = 0 Z = 1.0 80 RETURN end subroutine XCON (X, IX, IERROR) ! !! XCON converts (X,IX) = X * RADIX**IX to decimal form. ! !***PURPOSE To provide single-precision floating-point arithmetic ! with an extended exponent range. !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE SINGLE PRECISION (XCON-S, DXCON-D) !***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! REAL X ! INTEGER IX ! ! CONVERTS (X,IX) = X*RADIX**IX ! TO DECIMAL FORM IN PREPARATION FOR ! PRINTING, SO THAT (X,IX) = X*10**IX ! WHERE 1/10 <= ABS(X) < 1 ! IS RETURNED, EXCEPT THAT IF ! (ABS(X),IX) IS BETWEEN RADIX**(-2L) ! AND RADIX**(2L) THEN THE REDUCED ! FORM WITH IX = 0 IS RETURNED. ! !***SEE ALSO XSET !***REFERENCES (NONE) !***ROUTINES CALLED XADJ, XC210, XRED !***COMMON BLOCKS XBLK2 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XCON REAL X INTEGER IX ! ! THE CONDITIONS IMPOSED ON L AND KMAX BY THIS SUBROUTINE ! ARE ! (1) 4 <= L <= 2**NBITS - 1 - KMAX ! ! (2) KMAX <= ((2**NBITS)-2)/LOG10R - L ! ! THESE CONDITIONS MUST BE MET BY APPROPRIATE CODING ! IN SUBROUTINE XSET. ! REAL RADIX, RADIXL, RAD2L, DLG10R INTEGER L, L2, KMAX COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX SAVE /XBLK2/, ISPACE ! REAL A, B, Z ! DATA ISPACE /1/ ! THE PARAMETER ISPACE IS THE INCREMENT USED IN FORM- ! ING THE AUXILIARY INDEX OF THE DECIMAL EXTENDED-RANGE ! FORM. THE RETURNED VALUE OF IX WILL BE AN INTEGER MULT- ! IPLE OF ISPACE. ISPACE MUST SATISFY 1 <= ISPACE <= ! L/2. if A VALUE GREATER THAN 1 IS TAKEN, THE RETURNED ! VALUE OF X WILL SATISFY 10**(-ISPACE) <= ABS(X) <= 1 ! WHEN (ABS(X),IX) < RADIX**(-2L) AND 1/10 <= ABS(X) ! < 10**(ISPACE-1) WHEN (ABS(X),IX) > RADIX**(2L). ! !***FIRST EXECUTABLE STATEMENT XCON IERROR=0 call XRED(X, IX,IERROR) if (IERROR /= 0) RETURN if (IX == 0) go to 150 call XADJ(X, IX,IERROR) if (IERROR /= 0) RETURN ! ! CASE 1 IS WHEN (X,IX) IS LESS THAN RADIX**(-2L) IN MAGNITUDE, ! CASE 2 IS WHEN (X,IX) IS GREATER THAN RADIX**(2L) IN MAGNITUDE. ITEMP = 1 ICASE = (3+SIGN(ITEMP,IX))/2 go to (10, 20), ICASE 10 if (ABS(X) < 1.0) go to 30 X = X/RADIXL IX = IX + L go to 30 20 if (ABS(X) >= 1.0) go to 30 X = X*RADIXL IX = IX - L 30 CONTINUE ! ! AT THIS POINT, RADIX**(-L) <= ABS(X) < 1.0 IN CASE 1, ! 1.0 <= ABS(X) < RADIX**L IN CASE 2. I = LOG10(ABS(X))/DLG10R A = RADIX**I go to (40, 60), ICASE 40 if (A <= RADIX*ABS(X)) go to 50 I = I - 1 A = A/RADIX go to 40 50 if (ABS(X) < A) go to 80 I = I + 1 A = A*RADIX go to 50 60 if (A <= ABS(X)) go to 70 I = I - 1 A = A/RADIX go to 60 70 if (ABS(X) < RADIX*A) go to 80 I = I + 1 A = A*RADIX go to 70 80 CONTINUE ! ! AT THIS POINT I IS SUCH THAT ! RADIX**(I-1) <= ABS(X) < RADIX**I IN CASE 1, ! RADIX**I <= ABS(X) < RADIX**(I+1) IN CASE 2. ITEMP = ISPACE/DLG10R A = RADIX**ITEMP B = 10.0**ISPACE 90 if (A <= B) go to 100 ITEMP = ITEMP - 1 A = A/RADIX go to 90 100 if (B < A*RADIX) go to 110 ITEMP = ITEMP + 1 A = A*RADIX go to 100 110 CONTINUE ! ! AT THIS POINT ITEMP IS SUCH THAT ! RADIX**ITEMP <= 10**ISPACE < RADIX**(ITEMP+1). if (ITEMP > 0) go to 120 ! ITEMP = 0 IF, AND ONLY IF, ISPACE = 1 AND RADIX = 16.0 X = X*RADIX**(-I) IX = IX + I call XC210(IX, Z, J,IERROR) if (IERROR /= 0) RETURN X = X*Z IX = J go to (130, 140), ICASE 120 CONTINUE I1 = I/ITEMP X = X*RADIX**(-I1*ITEMP) IX = IX + I1*ITEMP ! ! AT THIS POINT, ! RADIX**(-ITEMP) <= ABS(X) < 1.0 IN CASE 1, ! 1.0 <= ABS(X) < RADIX**ITEMP IN CASE 2. call XC210(IX, Z, J,IERROR) if (IERROR /= 0) RETURN J1 = J/ISPACE J2 = J - J1*ISPACE X = X*Z*10.0**J2 IX = J1*ISPACE ! ! AT THIS POINT, ! 10.0**(-2*ISPACE) <= ABS(X) < 1.0 IN CASE 1, ! 10.0**-1 <= ABS(X) < 10.0**(2*ISPACE-1) IN CASE 2. go to (130, 140), ICASE 130 if (B*ABS(X) >= 1.0) go to 150 X = X*B IX = IX - ISPACE go to 130 140 if (10.0*ABS(X) < B) go to 150 X = X/B IX = IX + ISPACE go to 140 150 RETURN end subroutine XERBLA (SRNAME, INFO) ! !! XERBLA is the error handler for the Level 2 and Level 3 BLAS Routines. ! !***LIBRARY SLATEC !***CATEGORY R3 !***TYPE ALL (XERBLA-A) !***KEYWORDS ERROR MESSAGE !***AUTHOR Dongarra, J. J., (ANL) !***DESCRIPTION ! ! Purpose ! ======= ! ! It is called by Level 2 and 3 BLAS routines if an input parameter ! is invalid. ! ! Parameters ! ========== ! ! SRNAME - CHARACTER*6. ! On entry, SRNAME specifies the name of the routine which ! called XERBLA. ! ! INFO - INTEGER. ! On entry, INFO specifies the position of the invalid ! parameter in the parameter-list of the calling routine. ! !***REFERENCES (NONE) !***ROUTINES CALLED XERMSG !***REVISION HISTORY (YYMMDD) ! 860720 DATE WRITTEN ! 910610 Routine rewritten to serve as an interface between the ! Level 2 and Level 3 BLAS routines and the SLATEC error ! handler XERMSG. (BKS) !***END PROLOGUE XERBLA ! ! .. Scalar Arguments .. INTEGER INFO CHARACTER*6 SRNAME CHARACTER*2 XERN1 ! !***FIRST EXECUTABLE STATEMENT XERBLA ! WRITE (XERN1, '(I2)') INFO call XERMSG ('SLATEC', SRNAME, 'On entry to '//SRNAME// & ' parameter number '//XERN1//' had an illegal value', & INFO,1) ! return ! ! End of XERBLA. ! end subroutine XERCLR ! !! XERCLR resets the XERROR current error number to zero. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XERCLR-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! This routine simply resets the current error number to zero. ! This may be necessary in order to determine that a certain ! error has occurred again since the last time NUMXER was ! referenced. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED J4SAVE !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XERCLR !***FIRST EXECUTABLE STATEMENT XERCLR JUNK = J4SAVE(1,0,.TRUE.) return end subroutine XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) ! !! XERCNT allows user control over handling of XERROR errors. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XERCNT-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! Allows user control over handling of individual errors. ! Just after each message is recorded, but before it is ! processed any further (i.e., before it is printed or ! a decision to abort is made), a call is made to XERCNT. ! If the user has provided his own version of XERCNT, he ! can then override the value of KONTROL used in processing ! this message by redefining its value. ! KONTRL may be set to any value from -2 to 2. ! The meanings for KONTRL are the same as in XSETF, except ! that the value of KONTRL changes only for this message. ! If KONTRL is set to a value outside the range from -2 to 2, ! it will be moved back into that range. ! ! Description of Parameters ! ! --Input-- ! LIBRAR - the library that the routine is in. ! SUBROU - the subroutine that XERMSG is being called from ! MESSG - the first 20 characters of the error message. ! NERR - same as in the call to XERMSG. ! LEVEL - same as in the call to XERMSG. ! KONTRL - the current value of the control flag as set ! by a call to XSETF. ! ! --Output-- ! KONTRL - the new value of KONTRL. If KONTRL is not ! defined, it will remain at its original value. ! This changed value of control affects only ! the current occurrence of the current message. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900206 Routine changed from user-callable to subsidiary. (WRB) ! 900510 Changed calling sequence to include LIBRARY and SUBROUTINE ! names, changed routine name from XERCTL to XERCNT. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XERCNT CHARACTER*(*) LIBRAR, SUBROU, MESSG !***FIRST EXECUTABLE STATEMENT XERCNT return end subroutine XERDMP ! !! XERDMP prints the XERROR error tables and then clears them. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XERDMP-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! XERDMP prints the error tables, then clears them. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED XERSVE !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Changed call of XERSAV to XERSVE. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XERDMP !***FIRST EXECUTABLE STATEMENT XERDMP call XERSVE (' ',' ',' ',0,0,0,KOUNT) return end subroutine XERHLT (MESSG) ! !! XERHLT aborts program execution after printing XERROR error message. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XERHLT-A) !***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! ***Note*** machine dependent routine ! XERHLT aborts the execution of the program. ! The error message causing the abort is given in the calling ! sequence, in case one needs it for printing on a dayfile, ! for example. ! ! Description of Parameters ! MESSG is as in XERMSG. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900206 Routine changed from user-callable to subsidiary. (WRB) ! 900510 Changed calling sequence to delete length of character ! and changed routine name from XERABT to XERHLT. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XERHLT CHARACTER*(*) MESSG !***FIRST EXECUTABLE STATEMENT XERHLT STOP end subroutine XERMAX (MAX) ! !! XERMAX sets maximum number of times any XERROR message is to be printed. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XERMAX-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! XERMAX sets the maximum number of times any message ! is to be printed. That is, non-fatal messages are ! not to be printed after they have occurred MAX times. ! Such non-fatal messages may be printed less than ! MAX times even if they occur MAX times, if error ! suppression mode (KONTRL=0) is ever in effect. ! ! Description of Parameter ! --Input-- ! MAX - the maximum number of times any one message ! is to be printed. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED J4SAVE !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XERMAX !***FIRST EXECUTABLE STATEMENT XERMAX JUNK = J4SAVE(4,MAX,.TRUE.) return end subroutine XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) !! XERMSG processes XERROR messages. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XERMSG-A) !***KEYWORDS ERROR MESSAGE, XERROR !***AUTHOR Fong, Kirby, (NMFECC at LLNL) !***DESCRIPTION ! ! XERMSG processes a diagnostic message in a manner determined by the ! value of LEVEL and the current value of the library error control ! flag, KONTRL. See subroutine XSETF for details. ! ! LIBRAR A character constant (or character variable) with the name ! of the library. This will be 'SLATEC' for the SLATEC ! Common Math Library. The error handling package is ! general enough to be used by many libraries ! simultaneously, so it is desirable for the routine that ! detects and reports an error to identify the library name ! as well as the routine name. ! ! SUBROU A character constant (or character variable) with the name ! of the routine that detected the error. Usually it is the ! name of the routine that is calling XERMSG. There are ! some instances where a user callable library routine calls ! lower level subsidiary routines where the error is ! detected. In such cases it may be more informative to ! supply the name of the routine the user called rather than ! the name of the subsidiary routine that detected the ! error. ! ! MESSG A character constant (or character variable) with the text ! of the error or warning message. In the example below, ! the message is a character constant that contains a ! generic message. ! ! call XERMSG ('SLATEC', 'MMPY', ! *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', ! *3, 1) ! ! It is possible (and is sometimes desirable) to generate a ! specific message--e.g., one that contains actual numeric ! values. Specific numeric values can be converted into ! character strings using formatted WRITE statements into ! character variables. This is called standard Fortran ! internal file I/O and is exemplified in the first three ! lines of the following example. You can also catenate ! substrings of characters to construct the error message. ! Here is an example showing the use of both writing to ! an internal file and catenating character strings. ! ! CHARACTER*5 CHARN, CHARL ! WRITE (CHARN,10) N ! WRITE (CHARL,10) LDA ! 10 FORMAT(I5) ! call XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// ! * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// ! * CHARL, 3, 1) ! ! There are two subtleties worth mentioning. One is that ! the // for character catenation is used to construct the ! error message so that no single character constant is ! continued to the next line. This avoids confusion as to ! whether there are trailing blanks at the end of the line. ! The second is that by catenating the parts of the message ! as an actual argument rather than encoding the entire ! message into one large character variable, we avoid ! having to know how long the message will be in order to ! declare an adequate length for that large character ! variable. XERMSG calls XERPRN to print the message using ! multiple lines if necessary. If the message is very long, ! XERPRN will break it into pieces of 72 characters (as ! requested by XERMSG) for printing on multiple lines. ! Also, XERMSG asks XERPRN to prefix each line with ' * ' ! so that the total line length could be 76 characters. ! Note also that XERPRN scans the error message backwards ! to ignore trailing blanks. Another feature is that ! the substring '$$' is treated as a new line sentinel ! by XERPRN. If you want to construct a multiline ! message without having to count out multiples of 72 ! characters, just use '$$' as a separator. '$$' ! obviously must occur within 72 characters of the ! start of each line to have its intended effect since ! XERPRN is asked to wrap around at 72 characters in ! addition to looking for '$$'. ! ! NERR An integer value that is chosen by the library routine's ! author. It must be in the range -99 to 999 (three ! printable digits). Each distinct error should have its ! own error number. These error numbers should be described ! in the machine readable documentation for the routine. ! The error numbers need be unique only within each routine, ! so it is reasonable for each routine to start enumerating ! errors from 1 and proceeding to the next integer. ! ! LEVEL An integer value in the range 0 to 2 that indicates the ! level (severity) of the error. Their meanings are ! ! -1 A warning message. This is used if it is not clear ! that there really is an error, but the user's attention ! may be needed. An attempt is made to only print this ! message once. ! ! 0 A warning message. This is used if it is not clear ! that there really is an error, but the user's attention ! may be needed. ! ! 1 A recoverable error. This is used even if the error is ! so serious that the routine cannot return any useful ! answer. If the user has told the error package to ! return after recoverable errors, then XERMSG will ! return to the Library routine which can then return to ! the user's routine. The user may also permit the error ! package to terminate the program upon encountering a ! recoverable error. ! ! 2 A fatal error. XERMSG will not return to its caller ! after it receives a fatal error. This level should ! hardly ever be used; it is much better to allow the ! user a chance to recover. An example of one of the few ! cases in which it is permissible to declare a level 2 ! error is a reverse communication Library routine that ! is likely to be called repeatedly until it integrates ! across some interval. If there is a serious error in ! the input such that another step cannot be taken and ! the Library routine is called again without the input ! error having been corrected by the caller, the Library ! routine will probably be called forever with improper ! input. In this case, it is reasonable to declare the ! error to be fatal. ! ! Each of the arguments to XERMSG is input; none will be modified by ! XERMSG. A routine may make multiple calls to XERMSG with warning ! level messages; however, after a call to XERMSG with a recoverable ! error, the routine should return to the user. Do not try to call ! XERMSG with a second recoverable error after the first recoverable ! error because the error package saves the error number. The user ! can retrieve this error number by calling another entry point in ! the error handling package and then clear the error number when ! recovering from the error. Calling XERMSG in succession causes the ! old error number to be overwritten by the latest error number. ! This is considered harmless for error numbers associated with ! warning messages but must not be done for error numbers of serious ! errors. After a call to XERMSG with a recoverable error, the user ! must be given a chance to call NUMXER or XERCLR to retrieve or ! clear the error number. !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE !***REVISION HISTORY (YYMMDD) ! 880101 DATE WRITTEN ! 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. ! THERE ARE TWO BASIC CHANGES. ! 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO ! PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES ! INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS ! ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE ! ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER ! ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY ! 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE ! LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. ! 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE ! FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE ! OF LOWER CASE. ! 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. ! THE PRINCIPAL CHANGES ARE ! 1. CLARIFY COMMENTS IN THE PROLOGUES ! 2. RENAME XRPRNT TO XERPRN ! 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES ! SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / ! CHARACTER FOR NEW RECORDS. ! 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO ! CLEAN UP THE CODING. ! 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN ! PREFIX. ! 891013 REVISED TO CORRECT COMMENTS. ! 891214 Prologue converted to Version 4.0 format. (WRB) ! 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but ! NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added ! LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and ! XERCTL to XERCNT. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XERMSG CHARACTER*(*) LIBRAR, SUBROU, MESSG CHARACTER*8 XLIBR, XSUBR CHARACTER*72 TEMP CHARACTER*20 LFIRST !***FIRST EXECUTABLE STATEMENT XERMSG LKNTRL = J4SAVE (2, 0, .FALSE.) MAXMES = J4SAVE (4, 0, .FALSE.) ! ! LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. ! MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE ! SHOULD BE PRINTED. ! ! WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN ! CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, ! AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. ! if (NERR < -9999999 .OR. NERR > 99999999 .OR. NERR == 0 .OR. & LEVEL < -1 .OR. LEVEL > 2) THEN call XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // & 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// & 'JOB ABORT DUE TO FATAL ERROR.', 72) call XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) call XERHLT (' ***XERMSG -- INVALID INPUT') return end if ! ! RECORD THE MESSAGE. ! I = J4SAVE (1, NERR, .TRUE.) call XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) ! ! HANDLE PRINT-ONCE WARNING MESSAGES. ! if (LEVEL == -1 .AND. KOUNT > 1) RETURN ! ! ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. ! XLIBR = LIBRAR XSUBR = SUBROU LFIRST = MESSG LERR = NERR LLEVEL = LEVEL call XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) ! LKNTRL = MAX(-2, MIN(2,LKNTRL)) MKNTRL = ABS(LKNTRL) ! ! SKIP PRINTING if THE CONTROL FLAG VALUE AS RESET IN XERCNT IS ! ZERO AND THE ERROR IS NOT FATAL. ! if (LEVEL < 2 .AND. LKNTRL == 0) go to 30 if (LEVEL == 0 .AND. KOUNT > MAXMES) go to 30 if (LEVEL == 1 .AND. KOUNT > MAXMES .AND. MKNTRL == 1) go to 30 if (LEVEL == 2 .AND. KOUNT > MAX(1,MAXMES)) go to 30 ! ! ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A ! MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) ! AND SENDING IT OUT VIA XERPRN. PRINT ONLY if CONTROL FLAG ! IS NOT ZERO. ! if (LKNTRL /= 0) THEN TEMP(1:21) = 'MESSAGE FROM ROUTINE ' I = MIN(LEN(SUBROU), 16) TEMP(22:21+I) = SUBROU(1:I) TEMP(22+I:33+I) = ' IN LIBRARY ' LTEMP = 33 + I I = MIN(LEN(LIBRAR), 16) TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) TEMP(LTEMP+I+1:LTEMP+I+1) = '.' LTEMP = LTEMP + I + 1 call XERPRN (' ***', -1, TEMP(1:LTEMP), 72) end if ! ! if LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE ! PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE ! FROM EACH OF THE FOLLOWING THREE OPTIONS. ! 1. LEVEL OF THE MESSAGE ! 'INFORMATIVE MESSAGE' ! 'POTENTIALLY RECOVERABLE ERROR' ! 'FATAL ERROR' ! 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE ! 'PROG CONTINUES' ! 'PROG ABORTED' ! 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK ! MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS ! WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) ! 'TRACEBACK REQUESTED' ! 'TRACEBACK NOT REQUESTED' ! NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT ! EXCEED 74 CHARACTERS. ! WE SKIP THE NEXT BLOCK if THE INTRODUCTORY LINE IS NOT NEEDED. ! if (LKNTRL > 0) THEN ! ! THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. ! if (LEVEL <= 0) THEN TEMP(1:20) = 'INFORMATIVE MESSAGE,' LTEMP = 20 ELSEIF (LEVEL == 1) THEN TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' LTEMP = 30 ELSE TEMP(1:12) = 'FATAL ERROR,' LTEMP = 12 ENDIF ! ! THEN WHETHER THE PROGRAM WILL CONTINUE. ! if ((MKNTRL == 2 .AND. LEVEL >= 1) .OR. & (MKNTRL == 1 .AND. LEVEL == 2)) THEN TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' LTEMP = LTEMP + 14 ELSE TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' LTEMP = LTEMP + 16 ENDIF ! ! FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. ! if (LKNTRL > 0) THEN TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' LTEMP = LTEMP + 20 ELSE TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' LTEMP = LTEMP + 24 ENDIF call XERPRN (' ***', -1, TEMP(1:LTEMP), 72) end if ! ! NOW SEND OUT THE MESSAGE. ! call XERPRN (' * ', -1, MESSG, 72) ! ! if LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A ! TRACEBACK. ! if (LKNTRL > 0) THEN WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR DO 10 I=16,22 if (TEMP(I:I) /= ' ') go to 20 10 CONTINUE ! 20 call XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) call FDUMP end if ! ! if LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. ! if (LKNTRL /= 0) THEN call XERPRN (' * ', -1, ' ', 72) call XERPRN (' ***', -1, 'END OF MESSAGE', 72) call XERPRN (' ', 0, ' ', 72) end if ! ! if THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE ! CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. ! 30 if (LEVEL <= 0 .OR. (LEVEL == 1 .AND. MKNTRL <= 1)) RETURN ! ! THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A ! FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR ! SUMMARY if THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. ! if (LKNTRL > 0 .AND. KOUNT < MAX(1,MAXMES)) THEN if (LEVEL == 1) THEN call XERPRN & (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) ELSE call XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) ENDIF call XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) call XERHLT (' ') ELSE call XERHLT (MESSG) end if return end subroutine XERPRN (PREFIX, NPREF, MESSG, NWRAP) ! !! XERPRN prints XERROR error messages processed by XERMSG. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XERPRN-A) !***KEYWORDS ERROR MESSAGES, PRINTING, XERROR !***AUTHOR Fong, Kirby, (NMFECC at LLNL) !***DESCRIPTION ! ! This routine sends one or more lines to each of the (up to five) ! logical units to which error messages are to be sent. This routine ! is called several times by XERMSG, sometimes with a single line to ! print and sometimes with a (potentially very long) message that may ! wrap around into multiple lines. ! ! PREFIX Input argument of type CHARACTER. This argument contains ! characters to be put at the beginning of each line before ! the body of the message. No more than 16 characters of ! PREFIX will be used. ! ! NPREF Input argument of type INTEGER. This argument is the number ! of characters to use from PREFIX. If it is negative, the ! intrinsic function LEN is used to determine its length. If ! it is zero, PREFIX is not used. If it exceeds 16 or if ! LEN(PREFIX) exceeds 16, only the first 16 characters will be ! used. If NPREF is positive and the length of PREFIX is less ! than NPREF, a copy of PREFIX extended with blanks to length ! NPREF will be used. ! ! MESSG Input argument of type CHARACTER. This is the text of a ! message to be printed. If it is a long message, it will be ! broken into pieces for printing on multiple lines. Each line ! will start with the appropriate prefix and be followed by a ! piece of the message. NWRAP is the number of characters per ! piece; that is, after each NWRAP characters, we break and ! start a new line. In addition the characters '$$' embedded ! in MESSG are a sentinel for a new line. The counting of ! characters up to NWRAP starts over for each new line. The ! value of NWRAP typically used by XERMSG is 72 since many ! older error messages in the SLATEC Library are laid out to ! rely on wrap-around every 72 characters. ! ! NWRAP Input argument of type INTEGER. This gives the maximum size ! piece into which to break MESSG for printing on multiple ! lines. An embedded '$$' ends a line, and the count restarts ! at the following character. If a line break does not occur ! on a blank (it would split a word) that word is moved to the ! next line. Values of NWRAP less than 16 will be treated as ! 16. Values of NWRAP greater than 132 will be treated as 132. ! The actual line length will be NPREF + NWRAP after NPREF has ! been adjusted to fall between 0 and 16 and NWRAP has been ! adjusted to fall between 16 and 132. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED I1MACH, XGETUA !***REVISION HISTORY (YYMMDD) ! 880621 DATE WRITTEN ! 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF ! JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK ! THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE ! SLASH CHARACTER IN FORMAT STATEMENTS. ! 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO ! STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK ! LINES TO BE PRINTED. ! 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF ! CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. ! 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. ! 891214 Prologue converted to Version 4.0 format. (WRB) ! 900510 Added code to break messages between words. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XERPRN CHARACTER*(*) PREFIX, MESSG INTEGER NPREF, NWRAP CHARACTER*148 CBUFF INTEGER IU(5), NUNIT CHARACTER*2 NEWLIN PARAMETER (NEWLIN = '$$') !***FIRST EXECUTABLE STATEMENT XERPRN call XGETUA(IU,NUNIT) ! ! A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD ! ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD ! ERROR MESSAGE UNIT. ! N = I1MACH(4) DO 10 I=1,NUNIT if (IU(I) == 0) IU(I) = N 10 CONTINUE ! ! LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE ! BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING ! THE REST OF THIS ROUTINE. ! if ( NPREF < 0 ) THEN LPREF = LEN(PREFIX) ELSE LPREF = NPREF end if LPREF = MIN(16, LPREF) if (LPREF /= 0) CBUFF(1:LPREF) = PREFIX ! ! LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE ! TIME FROM MESSG TO PRINT ON ONE LINE. ! LWRAP = MAX(16, MIN(132, NWRAP)) ! ! SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. ! LENMSG = LEN(MESSG) N = LENMSG DO 20 I=1,N if (MESSG(LENMSG:LENMSG) /= ' ') go to 30 LENMSG = LENMSG - 1 20 CONTINUE 30 CONTINUE ! ! if THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. ! if (LENMSG == 0) THEN CBUFF(LPREF+1:LPREF+1) = ' ' DO 40 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) 40 CONTINUE return end if ! ! SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING ! STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. ! WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. ! WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. ! ! WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE ! INDEX INTRINSIC FUNCTION RETURNS ZERO if THERE IS NO OCCURRENCE ! OR if THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH ! OF THE SECOND ARGUMENT. ! ! THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE ! FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER ! OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT ! POSITION NEXTC. ! ! LPIECE == 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE ! REMAINDER OF THE CHARACTER STRING. LPIECE ! SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, ! WHICHEVER IS LESS. ! ! LPIECE == 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: ! NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE ! PRINT NOTHING TO AVOID PRODUCING UNNECESSARY ! BLANK LINES. THIS TAKES CARE OF THE SITUATION ! WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF ! EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE ! SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC ! SHOULD BE INCREMENTED BY 2. ! ! LPIECE > LWRAP+1 REDUCE LPIECE TO LWRAP. ! ! ELSE THIS LAST CASE MEANS 2 <= LPIECE <= LWRAP+1 ! RESET LPIECE = LPIECE-1. NOTE THAT THIS ! PROPERLY HANDLES THE END CASE WHERE LPIECE == ! LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY ! AT THE END OF A LINE. ! NEXTC = 1 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) if (LPIECE == 0) THEN ! ! THERE WAS NO NEW LINE SENTINEL FOUND. ! IDELTA = 0 LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) if (LPIECE < LENMSG+1-NEXTC) THEN DO 52 I=LPIECE+1,2,-1 if (MESSG(NEXTC+I-1:NEXTC+I-1) == ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 54 ENDIF 52 CONTINUE ENDIF 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSEIF (LPIECE == 1) THEN ! ! WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). ! DON'T PRINT A BLANK LINE. ! NEXTC = NEXTC + 2 go to 50 ELSEIF (LPIECE > LWRAP+1) THEN ! ! LPIECE SHOULD BE SET DOWN TO LWRAP. ! IDELTA = 0 LPIECE = LWRAP DO 56 I=LPIECE+1,2,-1 if (MESSG(NEXTC+I-1:NEXTC+I-1) == ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 58 ENDIF 56 CONTINUE 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSE ! ! if WE ARRIVE HERE, IT MEANS 2 <= LPIECE <= LWRAP+1. ! WE SHOULD DECREMENT LPIECE BY ONE. ! LPIECE = LPIECE - 1 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + 2 end if ! ! PRINT ! DO 60 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) 60 CONTINUE ! if (NEXTC <= LENMSG) go to 50 return end subroutine XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, & ICOUNT) ! !! XERSVE records that an XERROR error has occurred. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3 !***TYPE ALL (XERSVE-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! *Usage: ! ! INTEGER KFLAG, NERR, LEVEL, ICOUNT ! CHARACTER * (len) LIBRAR, SUBROU, MESSG ! ! call XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) ! ! *Arguments: ! ! LIBRAR :IN is the library that the message is from. ! SUBROU :IN is the subroutine that the message is from. ! MESSG :IN is the message to be saved. ! KFLAG :IN indicates the action to be performed. ! when KFLAG > 0, the message in MESSG is saved. ! when KFLAG=0 the tables will be dumped and ! cleared. ! when KFLAG < 0, the tables will be dumped and ! not cleared. ! NERR :IN is the error number. ! LEVEL :IN is the error severity. ! ICOUNT :OUT the number of times this message has been seen, ! or zero if the table has overflowed and does not ! contain this message specifically. When KFLAG=0, ! ICOUNT will not be altered. ! ! *Description: ! ! Record that this error occurred and possibly dump and clear the ! tables. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED I1MACH, XGETUA !***REVISION HISTORY (YYMMDD) ! 800319 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900413 Routine modified to remove reference to KFLAG. (WRB) ! 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling ! sequence, use IF-THEN-ELSE, make number of saved entries ! easily changeable, changed routine name from XERSAV to ! XERSVE. (RWC) ! 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XERSVE PARAMETER (LENTAB=10) INTEGER LUN(5) CHARACTER*(*) LIBRAR, SUBROU, MESSG CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB CHARACTER*20 MESTAB(LENTAB), MES DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG DATA KOUNTX/0/, NMSG/0/ !***FIRST EXECUTABLE STATEMENT XERSVE ! if (KFLAG <= 0) THEN ! ! Dump the table. ! if (NMSG == 0) RETURN ! ! Print to each unit. ! call XGETUA (LUN, NUNIT) DO 20 KUNIT = 1,NUNIT IUNIT = LUN(KUNIT) if (IUNIT == 0) IUNIT = I1MACH(4) ! ! Print the table header. ! WRITE (IUNIT,9000) ! ! Print body of table. ! DO 10 I = 1,NMSG WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), & NERTAB(I),LEVTAB(I),KOUNT(I) 10 CONTINUE ! ! Print number of other errors. ! if (KOUNTX /= 0) WRITE (IUNIT,9020) KOUNTX WRITE (IUNIT,9030) 20 CONTINUE ! ! Clear the error tables. ! if (KFLAG == 0) THEN NMSG = 0 KOUNTX = 0 ENDIF ELSE ! ! PROCESS A MESSAGE... ! SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, ! OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. ! LIB = LIBRAR SUB = SUBROU MES = MESSG DO 30 I = 1,NMSG if (LIB == LIBTAB(I) .AND. SUB == SUBTAB(I) .AND. & MES == MESTAB(I) .AND. NERR == NERTAB(I) .AND. & LEVEL == LEVTAB(I)) THEN KOUNT(I) = KOUNT(I) + 1 ICOUNT = KOUNT(I) return ENDIF 30 CONTINUE ! if (NMSG < LENTAB) THEN ! ! Empty slot found for new message. ! NMSG = NMSG + 1 LIBTAB(I) = LIB SUBTAB(I) = SUB MESTAB(I) = MES NERTAB(I) = NERR LEVTAB(I) = LEVEL KOUNT (I) = 1 ICOUNT = 1 ELSE ! ! Table is full. ! KOUNTX = KOUNTX+1 ICOUNT = 0 ENDIF end if return ! ! Formats. ! 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / & ' LIBRARY SUBROUTINE MESSAGE START NERR', & ' LEVEL COUNT') 9010 FORMAT (1X,A,3X,A,3X,A,3I10) 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) 9030 FORMAT (1X) end subroutine XGETF (KONTRL) ! !! XGETF returns the current value of the XERROR error control flag. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XGETF-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! XGETF returns the current value of the error control flag ! in KONTRL. See subroutine XSETF for flag value meanings. ! (KONTRL is an output parameter only.) ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED J4SAVE !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XGETF !***FIRST EXECUTABLE STATEMENT XGETF KONTRL = J4SAVE(2,0,.FALSE.) return end subroutine XGETUA (IUNITA, N) ! !! XGETUA returns unit numbers to which XERROR messages are sent. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XGETUA-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! XGETUA may be called to determine the unit number or numbers ! to which error messages are being sent. ! These unit numbers may have been set by a call to XSETUN, ! or a call to XSETUA, or may be a default value. ! ! Description of Parameters ! --Output-- ! IUNIT - an array of one to five unit numbers, depending ! on the value of N. A value of zero refers to the ! default unit, as defined by the I1MACH machine ! constant routine. Only IUNIT(1),...,IUNIT(N) are ! defined by XGETUA. The values of IUNIT(N+1),..., ! IUNIT(5) are not defined (for N < 5) or altered ! in any way by XGETUA. ! N - the number of units to which copies of the ! error messages are being sent. N will be in the ! range from 1 to 5. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED J4SAVE !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XGETUA DIMENSION IUNITA(5) !***FIRST EXECUTABLE STATEMENT XGETUA N = J4SAVE(5,0,.FALSE.) DO 30 I=1,N INDEX = I+4 if (I == 1) INDEX = 3 IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) 30 CONTINUE return end subroutine XGETUN (IUNIT) ! !! XGETUN returns the (first) output file to which XERROR messages are sent. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XGETUN-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! XGETUN gets the (first) output file to which error messages ! are being sent. To find out if more than one file is being ! used, one must use the XGETUA routine. ! ! Description of Parameter ! --Output-- ! IUNIT - the logical unit number of the (first) unit to ! which error messages are being sent. ! A value of zero means that the default file, as ! defined by the I1MACH routine, is being used. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED J4SAVE !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XGETUN !***FIRST EXECUTABLE STATEMENT XGETUN IUNIT = J4SAVE(3,0,.FALSE.) return end subroutine XLEGF (DNU1, NUDIFF, MU1, MU2, THETA, ID, PQA, IPQA, & IERROR) ! !! XLEGF computes normalized Legendre polynomials and associated ... ! Legendre functions. ! !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE SINGLE PRECISION (XLEGF-S, DXLEGF-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! ! XLEGF: Extended-range Single-precision Legendre Functions ! ! A feature of the XLEGF subroutine for Legendre functions is ! the use of extended-range arithmetic, a software extension of ! ordinary floating-point arithmetic that greatly increases the ! exponent range of the representable numbers. This avoids the ! need for scaling the solutions to lie within the exponent range ! of the most restrictive manufacturer's hardware. The increased ! exponent range is achieved by allocating an integer storage ! location together with each floating-point storage location. ! ! The interpretation of the pair (X,I) where X is floating-point ! and I is integer is X*(IR**I) where IR is the internal radix of ! the computer arithmetic. ! ! This subroutine computes one of the following vectors: ! ! 1. Legendre function of the first kind of negative order, either ! a. P(-MU1,NU,X), P(-MU1-1,NU,X), ..., P(-MU2,NU,X) or ! b. P(-MU,NU1,X), P(-MU,NU1+1,X), ..., P(-MU,NU2,X) ! 2. Legendre function of the second kind, either ! a. Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X) or ! b. Q(MU,NU1,X), Q(MU,NU1+1,X), ..., Q(MU,NU2,X) ! 3. Legendre function of the first kind of positive order, either ! a. P(MU1,NU,X), P(MU1+1,NU,X), ..., P(MU2,NU,X) or ! b. P(MU,NU1,X), P(MU,NU1+1,X), ..., P(MU,NU2,X) ! 4. Normalized Legendre polynomials, either ! a. PN(MU1,NU,X), PN(MU1+1,NU,X), ..., PN(MU2,NU,X) or ! b. PN(MU,NU1,X), PN(MU,NU1+1,X), ..., PN(MU,NU2,X) ! ! where X = COS(THETA). ! ! The input values to XLEGF are DNU1, NUDIFF, MU1, MU2, THETA, ! and ID. These must satisfy ! ! DNU1 is REAL and greater than or equal to -0.5; ! NUDIFF is INTEGER and non-negative; ! MU1 is INTEGER and non-negative; ! MU2 is INTEGER and greater than or equal to MU1; ! THETA is REAL and in the half-open interval (0,PI/2]; ! ID is INTEGER and equal to 1, 2, 3 or 4; ! ! and additionally either NUDIFF = 0 or MU2 = MU1. ! ! If ID=1 and NUDIFF=0, a vector of type 1a above is computed ! with NU=DNU1. ! ! If ID=1 and MU1=MU2, a vector of type 1b above is computed ! with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. ! ! If ID=2 and NUDIFF=0, a vector of type 2a above is computed ! with NU=DNU1. ! ! If ID=2 and MU1=MU2, a vector of type 2b above is computed ! with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. ! ! If ID=3 and NUDIFF=0, a vector of type 3a above is computed ! with NU=DNU1. ! ! If ID=3 and MU1=MU2, a vector of type 3b above is computed ! with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. ! ! If ID=4 and NUDIFF=0, a vector of type 4a above is computed ! with NU=DNU1. ! ! If ID=4 and MU1=MU2, a vector of type 4b above is computed ! with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. ! ! In each case the vector of computed Legendre function values ! is returned in the extended-range vector (PQA(I),IPQA(I)). The ! length of this vector is either MU2-MU1+1 or NUDIFF+1. ! ! Where possible, XLEGF returns IPQA(I) as zero. In this case the ! value of the Legendre function is contained entirely in PQA(I), ! so it can be used in subsequent computations without further ! consideration of extended-range arithmetic. If IPQA(I) is nonzero, ! then the value of the Legendre function is not representable in ! floating-point because of underflow or overflow. The program that ! calls XLEGF must test IPQA(I) to ensure correct usage. ! ! IERROR is an error indicator. If no errors are detected, IERROR=0 ! when control returns to the calling routine. If an error is detected, ! IERROR is returned as nonzero. The calling routine must check the ! value of IERROR. ! ! If IERROR=110 or 111, invalid input was provided to XLEGF. ! If IERROR=101,102,103, or 104, invalid input was provided to XSET. ! If IERROR=105 or 106, an internal consistency error occurred in ! XSET (probably due to a software malfunction in the library routine ! I1MACH). ! If IERROR=107, an overflow or underflow of an extended-range number ! was detected in XADJ. ! If IERROR=108, an overflow or underflow of an extended-range number ! was detected in XC210. ! !***SEE ALSO XSET !***REFERENCES Olver and Smith, Associated Legendre Functions on the ! Cut, J Comp Phys, v 51, n 3, Sept 1983, pp 502--518. ! Smith, Olver and Lozier, Extended-Range Arithmetic and ! Normalized Legendre Polynomials, ACM Trans on Math ! Softw, v 7, n 1, March 1981, pp 93--105. !***ROUTINES CALLED XERMSG, XPMU, XPMUP, XPNRM, XPQNU, XQMU, XQNU, ! XRED, XSET !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! CALLs to XERROR changed to CALLs to XERMSG. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XLEGF REAL PQA,DNU1,DNU2,SX,THETA,X,PI2 DIMENSION PQA(*),IPQA(*) ! !***FIRST EXECUTABLE STATEMENT XLEGF IERROR=0 call XSET (0, 0, 0.0, 0,IERROR) if (IERROR /= 0) RETURN PI2=2.*ATAN(1.) ! ! ZERO OUTPUT ARRAYS ! L=(MU2-MU1)+NUDIFF+1 DO 290 I=1,L PQA(I)=0. 290 IPQA(I)=0 ! ! CHECK FOR VALID INPUT VALUES ! if ( NUDIFF < 0) go to 400 if ( DNU1 < -.5) go to 400 if ( MU2 < MU1) go to 400 if ( MU1 < 0) go to 400 if ( THETA <= 0..OR.THETA > PI2) go to 420 if ( ID < 1.OR.ID > 4) go to 400 if ( (MU1 /= MU2).AND.(NUDIFF > 0)) go to 400 ! ! if DNU1 IS NOT AN INTEGER, NORMALIZED P(MU,DNU,X) ! CANNOT BE CALCULATED. if DNU1 IS AN INTEGER AND ! MU1 > DNU2 THEN ALL VALUES OF P(+MU,DNU,X) AND ! NORMALIZED P(MU,NU,X) WILL BE ZERO. ! DNU2=DNU1+NUDIFF if ( (ID == 3).AND.(MOD(DNU1,1.) /= 0.)) go to 295 if ( (ID == 4).AND.(MOD(DNU1,1.) /= 0.)) go to 400 if ( (ID == 3.OR.ID == 4).AND.MU1 > DNU2) RETURN 295 CONTINUE ! X=COS(THETA) SX=1./SIN(THETA) if ( ID == 2) go to 300 if ( MU2-MU1 <= 0) go to 360 ! ! FIXED NU, VARIABLE MU ! call XPMU TO CALCULATE P(-MU1,NU,X),....,P(-MU2,NU,X) ! call XPMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN go to 380 ! 300 if ( MU2 == MU1) go to 320 ! ! FIXED NU, VARIABLE MU ! call XQMU TO CALCULATE Q(MU1,NU,X),....,Q(MU2,NU,X) ! call XQMU(DNU1,DNU2,MU1,MU2,THETA,X,SX,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN go to 390 ! ! FIXED MU, VARIABLE NU ! call XQNU TO CALCULATE Q(MU,DNU1,X),....,Q(MU,DNU2,X) ! 320 call XQNU(DNU1,DNU2,MU1,THETA,X,SX,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN go to 390 ! ! FIXED MU, VARIABLE NU ! call XPQNU TO CALCULATE P(-MU,DNU1,X),....,P(-MU,DNU2,X) ! 360 call XPQNU(DNU1,DNU2,MU1,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN ! ! if ID = 3, TRANSFORM P(-MU,NU,X) VECTOR INTO ! P(MU,NU,X) VECTOR. ! 380 if ( ID == 3) call XPMUP(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN ! ! if ID = 4, TRANSFORM P(-MU,NU,X) VECTOR INTO ! NORMALIZED P(MU,NU,X) VECTOR. ! if ( ID == 4) call XPNRM(DNU1,DNU2,MU1,MU2,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN ! ! PLACE RESULTS IN REDUCED FORM if POSSIBLE ! AND RETURN TO MAIN PROGRAM. ! 390 DO 395 I=1,L call XRED(PQA(I),IPQA(I),IERROR) if (IERROR /= 0) RETURN 395 CONTINUE return ! ! ***** ERROR TERMINATION ***** ! 400 call XERMSG ('SLATEC', 'XLEGF', & 'DNU1, NUDIFF, MU1, MU2, or ID not valid', 110, 1) IERROR=110 return 420 call XERMSG ('SLATEC', 'XLEGF', 'THETA out of range', 111, 1) IERROR=111 return end subroutine XNRMP (NU, MU1, MU2, SARG, MODE, SPN, IPN, ISIG, & IERROR) ! !! XNRMP computes normalized Legendre polynomials. ! !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE SINGLE PRECISION (XNRMP-S, DXNRMP-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! ! SUBROUTINE TO CALCULATE NORMALIZED LEGENDRE POLYNOMIALS ! (DXNRMP is double-precision version) ! XNRMP calculates normalized Legendre polynomials of varying ! order and fixed argument and degree. The order MU and degree ! NU are non-negative integers and the argument is real. Because ! the algorithm requires the use of numbers outside the normal ! machine range, this subroutine employs a special arithmetic ! called extended-range arithmetic. See J.M. Smith, F.W.J. Olver, ! and D.W. Lozier, Extended-Range Arithmetic and Normalized ! Legendre Polynomials, ACM Transactions on Mathematical Soft- ! ware, 93-105, March 1981, for a complete description of the ! algorithm and special arithmetic. Also see program comments ! in XSET. ! ! The normalized Legendre polynomials are multiples of the ! associated Legendre polynomials of the first kind where the ! normalizing coefficients are chosen so as to make the integral ! from -1 to 1 of the square of each function equal to 1. See ! E. Jahnke, F. Emde and F. Losch, Tables of Higher Functions, ! McGraw-Hill, New York, 1960, p. 121. ! ! The input values to XNRMP are NU, MU1, MU2, SARG, and MODE. ! These must satisfy ! 1. NU >= 0 specifies the degree of the normalized Legendre ! polynomial that is wanted. ! 2. MU1 >= 0 specifies the lowest-order normalized Legendre ! polynomial that is wanted. ! 3. MU2 >= MU1 specifies the highest-order normalized Leg- ! endre polynomial that is wanted. ! 4a. MODE = 1 and -1.0 <= SARG <= 1.0 specifies that ! Normalized Legendre(NU, MU, SARG) is wanted for MU = MU1, ! MU1 + 1, ..., MU2. ! 4b. MODE = 2 and -3.14159... < SARG < 3.14159... spec- ! ifies that Normalized Legendre(NU, MU, COS(SARG)) is want- ! ed for MU = MU1, MU1 + 1, ..., MU2. ! ! The output of XNRMP consists of the two vectors SPN and IPN ! and the error estimate ISIG. The computed values are stored as ! extended-range numbers such that ! (SPN(1),IPN(1))=NORMALIZED LEGENDRE(NU,MU1,X) ! (SPN(2),IPN(2))=NORMALIZED LEGENDRE(NU,MU1+1,X) ! . ! . ! (SPN(K),IPN(K))=NORMALIZED LEGENDRE(NU,MU2,X) ! where K = MU2 - MU1 + 1 and X = SARG or COS(SARG) according ! to whether MODE = 1 or 2. Finally, ISIG is an estimate of the ! number of decimal digits lost through rounding errors in the ! computation. For example if SARG is accurate to 12 significant ! decimals, then the computed function values are accurate to ! 12 - ISIG significant decimals (except in neighborhoods of ! zeros). ! ! The interpretation of (SPN(I),IPN(I)) is SPN(I)*(IR**IPN(I)) ! where IR is the internal radix of the computer arithmetic. When ! IPN(I) = 0 the value of the normalized Legendre polynomial is ! contained entirely in SPN(I) and subsequent single-precision ! computations can be performed without further consideration of ! extended-range arithmetic. However, if IPN(I) /= 0 the corre- ! sponding value of the normalized Legendre polynomial cannot be ! represented in single-precision because of overflow or under- ! flow. THE USER MUST TEST IPN(I) IN HIS/HER PROGRAM. In the case ! that IPN(I) is nonzero, the user should try using double pre- ! cision if it has a wider exponent range. If double precision ! fails, the user could rewrite his/her program to use extended- ! range arithmetic. ! ! The interpretation of (SPN(I),IPN(I)) can be changed to ! SPN(I)*(10**IPN(I)) by calling the extended-range subroutine ! XCON. This should be done before printing the computed values. ! As an example of usage, the Fortran coding ! J = K ! DO 20 I = 1, K ! call XCON(SPN(I), IPN(I),IERROR) ! if (IERROR /= 0) RETURN ! PRINT 10, SPN(I), IPN(I) ! 10 FORMAT(1X, E30.8 , I15) ! if ((IPN(I) == 0) .OR. (J < K)) go to 20 ! J = I - 1 ! 20 CONTINUE ! will print all computed values and determine the largest J ! such that IPN(1) = IPN(2) = ... = IPN(J) = 0. Because of the ! change of representation caused by calling XCON, (SPN(I), ! IPN(I)) for I = J+1, J+2, ... cannot be used in subsequent ! extended-range computations. ! ! IERROR is an error indicator. If no errors are detected, ! IERROR=0 when control returns to the calling routine. If ! an error is detected, IERROR is returned as nonzero. The ! calling routine must check the value of IERROR. ! ! If IERROR=112 or 113, invalid input was provided to XNRMP. ! If IERROR=101,102,103, or 104, invalid input was provided ! to XSET. ! If IERROR=105 or 106, an internal consistency error occurred ! in XSET (probably due to a software malfunction in the ! library routine I1MACH). ! If IERROR=107, an overflow or underflow of an extended-range ! number was detected in XADJ. ! If IERROR=108, an overflow or underflow of an extended-range ! number was detected in XC210. ! !***SEE ALSO XSET !***REFERENCES Smith, Olver and Lozier, Extended-Range Arithmetic and ! Normalized Legendre Polynomials, ACM Trans on Math ! Softw, v 7, n 1, March 1981, pp 93--105. !***ROUTINES CALLED XADD, XADJ, XERMSG, XRED, XSET !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! CALLs to XERROR changed to CALLs to XERMSG. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XNRMP INTEGER NU, MU1, MU2, MODE, IPN, ISIG REAL SARG, SPN DIMENSION SPN(*), IPN(*) REAL C1,C2,P,P1,P2,P3,S,SX,T,TX,X,RK ! call XSET TO INITIALIZE EXTENDED-RANGE ARITHMETIC (SEE XSET ! LISTING FOR DETAILS) !***FIRST EXECUTABLE STATEMENT XNRMP IERROR=0 call XSET (0, 0, 0.0, 0,IERROR) if (IERROR /= 0) RETURN ! ! TEST FOR PROPER INPUT VALUES. ! if (NU < 0) go to 110 if (MU1 < 0) go to 110 if (MU1 > MU2) go to 110 if (NU == 0) go to 90 if (MODE < 1 .OR. MODE > 2) go to 110 go to (10, 20), MODE 10 if (ABS(SARG) > 1.0) go to 120 if (ABS(SARG) == 1.0) go to 90 X = SARG SX = SQRT((1.0+ABS(X))*((0.5-ABS(X))+0.5)) TX = X/SX ISIG = LOG10(2.0*NU*(5.0+TX**2)) go to 30 20 if (ABS(SARG) > 4.0*ATAN(1.0)) go to 120 if (SARG == 0.0) go to 90 X = COS(SARG) SX = ABS(SIN(SARG)) TX = X/SX ISIG = LOG10(2.0*NU*(5.0+ABS(SARG*TX))) ! ! BEGIN CALCULATION ! 30 MU = MU2 I = MU2 - MU1 + 1 ! ! if MU > NU, NORMALIZED LEGENDRE(NU,MU,X)=0. ! 40 if (MU <= NU) go to 50 SPN(I) = 0.0 IPN(I) = 0 I = I - 1 MU = MU - 1 if (I > 0) go to 40 ISIG = 0 go to 160 50 MU = NU ! ! P1 = 0. = NORMALIZED LEGENDRE(NU,NU+1,X) ! P1 = 0.0 IP1 = 0 ! ! CALCULATE P2 = NORMALIZED LEGENDRE(NU,NU,X) ! P2 = 1.0 IP2 = 0 P3 = 0.5 RK = 2.0 DO 60 J=1,NU P3 = ((RK+1.0)/RK)*P3 P2 = P2*SX call XADJ(P2, IP2,IERROR) if (IERROR /= 0) RETURN RK = RK + 2.0 60 CONTINUE P2 = P2*SQRT(P3) call XADJ(P2, IP2,IERROR) if (IERROR /= 0) RETURN S = 2.0*TX T = 1.0/NU if (MU2 < NU) go to 70 SPN(I) = P2 IPN(I) = IP2 I = I - 1 if (I == 0) go to 140 ! ! RECURRENCE PROCESS ! 70 P = MU*T C1 = 1.0/SQRT((1.0-P+T)*(1.0+P)) C2 = S*P*C1*P2 C1 = -SQRT((1.0+P+T)*(1.0-P))*C1*P1 call XADD(C2, IP2, C1, IP1, P, IP,IERROR) if (IERROR /= 0) RETURN MU = MU - 1 if (MU > MU2) go to 80 ! ! STORE IN ARRAY SPN FOR RETURN TO CALLING ROUTINE. ! SPN(I) = P IPN(I) = IP I = I - 1 if (I == 0) go to 140 80 P1 = P2 IP1 = IP2 P2 = P IP2 = IP if (MU <= MU1) go to 140 go to 70 ! ! SPECIAL CASE WHEN X=-1 OR +1, OR NU=0. ! 90 K = MU2 - MU1 + 1 DO 100 I=1,K SPN(I) = 0.0 IPN(I) = 0 100 CONTINUE ISIG = 0 if (MU1 > 0) go to 160 ISIG = 1 SPN(1) = SQRT(NU+0.5) IPN(1) = 0 if (MOD(NU,2) == 0) go to 160 if (MODE == 1 .AND. SARG == 1.0) go to 160 if (MODE == 2) go to 160 SPN(1) = -SPN(1) go to 160 ! ! ERROR PRINTOUTS AND TERMINATION. ! 110 call XERMSG ('SLATEC', 'XNRMP', 'NU, MU1, MU2 or MODE not valid', & 112, 1) IERROR=112 return 120 call XERMSG ('SLATEC', 'XNRMP', 'SARG out of range', 113, 1) IERROR=113 return ! ! return TO CALLING PROGRAM ! 140 K = MU2 - MU1 + 1 DO 150 I=1,K call XRED(SPN(I),IPN(I),IERROR) if (IERROR /= 0) RETURN 150 CONTINUE 160 RETURN end subroutine XPMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA, & IERROR) ! !! XPMU computes the values of Legendre functions for XLEGF. ! ! Method: backward mu-wise recurrence for P(-MU,NU,X) for ! fixed nu to obtain P(-MU2,NU1,X), P(-(MU2-1),NU1,X), ..., ! P(-MU1,NU1,X) and store in ascending mu order. ! !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE SINGLE PRECISION (XPMU-S, DXPMU-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED XADD, XADJ, XPQNU !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XPMU REAL PQA,NU1,NU2,P0,X,SX,THETA,X1,X2 DIMENSION PQA(*),IPQA(*) ! ! call XPQNU TO OBTAIN P(-MU2,NU,X) ! !***FIRST EXECUTABLE STATEMENT XPMU IERROR=0 call XPQNU(NU1,NU2,MU2,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN P0=PQA(1) IP0=IPQA(1) MU=MU2-1 ! ! call XPQNU TO OBTAIN P(-MU2-1,NU,X) ! call XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN N=MU2-MU1+1 PQA(N)=P0 IPQA(N)=IP0 if ( N == 1) go to 300 PQA(N-1)=PQA(1) IPQA(N-1)=IPQA(1) if ( N == 2) go to 300 J=N-2 290 CONTINUE ! ! BACKWARD RECURRENCE IN MU TO OBTAIN ! P(-MU2,NU1,X),P(-(MU2-1),NU1,X),....P(-MU1,NU1,X) ! USING ! (NU-MU)*(NU+MU+1.)*P(-(MU+1),NU,X)= ! 2.*MU*X*SQRT((1./(1.-X**2))*P(-MU,NU,X)-P(-(MU-1),NU,X) ! X1=2.*MU*X*SX*PQA(J+1) X2=-(NU1-MU)*(NU1+MU+1.)*PQA(J+2) call XADD(X1,IPQA(J+1),X2,IPQA(J+2),PQA(J),IPQA(J),IERROR) if (IERROR /= 0) RETURN call XADJ(PQA(J),IPQA(J),IERROR) if (IERROR /= 0) RETURN if ( J == 1) go to 300 J=J-1 MU=MU-1 go to 290 300 RETURN end subroutine XPMUP (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR) ! !! XPMUP computes the values of Legendre functions for XLEGF. ! ! This subroutine transforms an array of Legendre functions ! of the first kind of negative order stored in array PQA ! into Legendre functions of the first kind of positive ! order stored in array PQA. The original array is destroyed. ! !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE SINGLE PRECISION (XPMUP-S, DXPMUP-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED XADJ !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XPMUP REAL DMU,NU,NU1,NU2,PQA,PROD DIMENSION PQA(*),IPQA(*) !***FIRST EXECUTABLE STATEMENT XPMUP IERROR=0 NU=NU1 MU=MU1 DMU=MU N=INT(NU2-NU1+.1)+(MU2-MU1)+1 J=1 if ( MOD(NU,1.) /= 0.) go to 210 200 if ( DMU < NU+1.) go to 210 PQA(J)=0. IPQA(J)=0 J=J+1 if ( J > N) RETURN ! INCREMENT EITHER MU OR NU AS APPROPRIATE. if ( NU2-NU1 > .5) NU=NU+1. if ( MU2 > MU1) MU=MU+1 go to 200 ! ! TRANSFORM P(-MU,NU,X) TO P(MU,NU,X) USING ! P(MU,NU,X)=(NU-MU+1)*(NU-MU+2)*...*(NU+MU)*P(-MU,NU,X)*(-1)**MU ! 210 PROD=1. IPROD=0 K=2*MU if ( K == 0) go to 222 DO 220 L=1,K PROD=PROD*(DMU-NU-L) 220 call XADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN 222 CONTINUE DO 240 I=J,N if ( MU == 0) go to 225 PQA(I)=PQA(I)*PROD*(-1)**MU IPQA(I)=IPQA(I)+IPROD call XADJ(PQA(I),IPQA(I),IERROR) if (IERROR /= 0) RETURN 225 if ( NU2-NU1 > .5) go to 230 PROD=(DMU-NU)*PROD*(-DMU-NU-1.) call XADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN MU=MU+1 DMU=DMU+1. go to 240 230 PROD=PROD*(-DMU-NU-1.)/(DMU-NU-1.) call XADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN NU=NU+1. 240 CONTINUE return end subroutine XPNRM (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR) ! !! XPNRM computes the values of Legendre functions for XLEGF. ! ! This subroutine transforms an array of Legendre functions ! of the first kind of negative order stored in array PQA ! into normalized Legendre polynomials stored in array PQA. ! The original array is destroyed. ! !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE SINGLE PRECISION (XPNRM-S, DXPNRM-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED XADJ !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XPNRM REAL C1,DMU,NU,NU1,NU2,PQA,PROD DIMENSION PQA(*),IPQA(*) !***FIRST EXECUTABLE STATEMENT XPNRM IERROR=0 L=(MU2-MU1)+(NU2-NU1+1.5) MU=MU1 DMU=MU1 NU=NU1 ! ! if MU > NU, NORM P =0. ! J=1 500 if ( DMU <= NU) go to 505 PQA(J)=0. IPQA(J)=0 J=J+1 if ( J > L) RETURN ! ! INCREMENT EITHER MU OR NU AS APPROPRIATE. ! if ( MU2 > MU1) DMU=DMU+1. if ( NU2-NU1 > .5) NU=NU+1. go to 500 ! ! TRANSFORM P(-MU,NU,X) INTO NORMALIZED P(MU,NU,X) USING ! NORM P(MU,NU,X)= ! SQRT((NU+.5)*FACTORIAL(NU+MU)/FACTORIAL(NU-MU)) ! *P(-MU,NU,X) ! 505 PROD=1. IPROD=0 K=2*MU if ( K <= 0) go to 520 DO 510 I=1,K PROD=PROD*SQRT(NU+DMU+1.-I) 510 call XADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN 520 DO 540 I=J,L C1=PROD*SQRT(NU+.5) PQA(I)=PQA(I)*C1 IPQA(I)=IPQA(I)+IPROD call XADJ(PQA(I),IPQA(I),IERROR) if (IERROR /= 0) RETURN if ( NU2-NU1 > .5) go to 530 if ( DMU >= NU) go to 525 PROD=SQRT(NU+DMU+1.)*PROD if ( NU > DMU) PROD=PROD*SQRT(NU-DMU) call XADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN MU=MU+1 DMU=DMU+1. go to 540 525 PROD=0. IPROD=0 MU=MU+1 DMU=DMU+1. go to 540 530 PROD=SQRT(NU+DMU+1.)*PROD if ( NU /= DMU-1.) PROD=PROD/SQRT(NU-DMU+1.) call XADJ(PROD,IPROD,IERROR) if (IERROR /= 0) RETURN NU=NU+1. 540 CONTINUE return end subroutine XPQNU (NU1, NU2, MU, THETA, ID, PQA, IPQA, IERROR) ! !! XPQNU computes the values of Legendre functions for XLEGF. ! ! This subroutine calculates initial values of P or Q using ! power series, then performs forward nu-wise recurrence to ! obtain P(-MU,NU,X), Q(0,NU,X), or Q(1,NU,X). The nu-wise ! recurrence is stable for P for all mu and for Q for mu=0,1. ! !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE SINGLE PRECISION (XPQNU-S, DXPQNU-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED XADD, XADJ, XPSI !***COMMON BLOCKS XBLK1 !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XPQNU REAL A,NU,NU1,NU2,PQ,PQA,XPSI,R,THETA,W,X,X1,X2,XS, & Y,Z REAL DI,DMU,PQ1,PQ2,FACTMU,FLOK DIMENSION PQA(*),IPQA(*) COMMON /XBLK1/ NBITSF SAVE /XBLK1/ ! ! J0, IPSIK, AND IPSIX ARE INITIALIZED IN THIS SUBROUTINE. ! J0 IS THE NUMBER OF TERMS USED IN SERIES EXPANSION ! IN SUBROUTINE XPQNU. ! IPSIK, IPSIX ARE VALUES OF K AND X RESPECTIVELY ! USED IN THE CALCULATION OF THE XPSI FUNCTION. ! !***FIRST EXECUTABLE STATEMENT XPQNU IERROR=0 J0=NBITSF IPSIK=1+(NBITSF/10) IPSIX=5*IPSIK IPQ=0 ! FIND NU IN INTERVAL [-.5,.5) if ID=2 ( CALCULATION OF Q ) NU=MOD(NU1,1.) if ( NU >= .5) NU=NU-1. ! FIND NU IN INTERVAL (-1.5,-.5] if ID=1,3, OR 4 ( CALC. OF P ) if ( ID /= 2.AND.NU > -.5) NU=NU-1. ! CALCULATE MU FACTORIAL K=MU DMU=MU if ( MU <= 0) go to 60 FACTMU=1. IF=0 DO 50 I=1,K FACTMU=FACTMU*I 50 call XADJ(FACTMU,IF,IERROR) if (IERROR /= 0) RETURN 60 if ( K == 0) FACTMU=1. if ( K == 0) IF=0 ! ! X=COS(THETA) ! Y=SIN(THETA/2)**2=(1-X)/2=.5-.5*X ! R=TAN(THETA/2)=SQRT((1-X)/(1+X) ! X=COS(THETA) Y=SIN(THETA/2.)**2 R=TAN(THETA/2.) ! ! USE ASCENDING SERIES TO CALCULATE TWO VALUES OF P OR Q ! FOR USE AS STARTING VALUES IN RECURRENCE RELATION. ! PQ2=0.0 DO 100 J=1,2 IPQ1=0 if ( ID == 2) go to 80 ! ! SERIES FOR P ( ID = 1, 3, OR 4 ) ! P(-MU,NU,X)=1./FACTORIAL(MU)*SQRT(((1.-X)/(1.+X))**MU) ! *SUM(FROM 0 TO J0-1)A(J)*(.5-.5*X)**J ! IPQ=0 PQ=1. A=1. IA=0 DO 65 I=2,J0 DI=I A=A*Y*(DI-2.-NU)*(DI-1.+NU)/((DI-1.+DMU)*(DI-1.)) call XADJ(A,IA,IERROR) if (IERROR /= 0) RETURN if ( A == 0.) go to 66 call XADD(PQ,IPQ,A,IA,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN 65 CONTINUE 66 CONTINUE if ( MU <= 0) go to 90 X2=R X1=PQ K=MU DO 77 I=1,K X1=X1*X2 77 call XADJ(X1,IPQ,IERROR) if (IERROR /= 0) RETURN PQ=X1/FACTMU IPQ=IPQ-IF call XADJ(PQ,IPQ,IERROR) if (IERROR /= 0) RETURN go to 90 ! ! Z=-LN(R)=.5*LN((1+X)/(1-X)) ! 80 Z=-LOG(R) W=XPSI(NU+1.,IPSIK,IPSIX) XS=1./SIN(THETA) ! ! SERIES SUMMATION FOR Q ( ID = 2 ) ! Q(0,NU,X)=SUM(FROM 0 TO J0-1)((.5*LN((1+X)/(1-X)) ! +XPSI(J+1,IPSIK,IPSIX)-XPSI(NU+1,IPSIK,IPSIX)))*A(J)*(.5-.5*X)**J ! ! Q(1,NU,X)=-SQRT(1./(1.-X**2))+SQRT((1-X)/(1+X)) ! *SUM(FROM 0 T0 J0-1)(-NU*(NU+1)/2*LN((1+X)/(1-X)) ! +(J-NU)*(J+NU+1)/(2*(J+1))+NU*(NU+1)* ! (XPSI(NU+1,IPSIK,IPSIX)-XPSI(J+1,IPSIK,IPSIX))*A(J)*(.5-.5*X)**J ! ! NOTE, IN THIS LOOP K=J+1 ! PQ=0. IPQ=0 IA=0 A=1. DO 85 K=1,J0 FLOK=K if ( K == 1) go to 81 A=A*Y*(FLOK-2.-NU)*(FLOK-1.+NU)/((FLOK-1.+DMU)*(FLOK-1.)) call XADJ(A,IA,IERROR) if (IERROR /= 0) RETURN 81 CONTINUE if ( MU >= 1) go to 83 X1=(XPSI(FLOK,IPSIK,IPSIX)-W+Z)*A IX1=IA call XADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN go to 85 83 X1=(NU*(NU+1.)*(Z-W+XPSI(FLOK,IPSIK,IPSIX))+(NU-FLOK+1.) & *(NU+FLOK)/(2.*FLOK))*A IX1=IA call XADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN 85 CONTINUE if ( MU >= 1) PQ=-R*PQ IXS=0 if ( MU >= 1) call XADD(PQ,IPQ,-XS,IXS,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN if ( J == 2) MU=-MU if ( J == 2) DMU=-DMU 90 if ( J == 1) PQ2=PQ if ( J == 1) IPQ2=IPQ NU=NU+1. 100 CONTINUE K=0 if ( NU-1.5 < NU1) go to 120 K=K+1 PQA(K)=PQ2 IPQA(K)=IPQ2 if ( NU > NU2+.5) RETURN 120 PQ1=PQ IPQ1=IPQ if ( NU < NU1+.5) go to 130 K=K+1 PQA(K)=PQ IPQA(K)=IPQ if ( NU > NU2+.5) RETURN ! ! FORWARD NU-WISE RECURRENCE FOR F(MU,NU,X) FOR FIXED MU ! USING ! (NU+MU+1)*F(MU,NU,X)=(2.*NU+1)*F(MU,NU,X)-(NU-MU)*F(MU,NU-1,X) ! WHERE F(MU,NU,X) MAY BE P(-MU,NU,X) OR if MU IS REPLACED ! BY -MU THEN F(MU,NU,X) MAY BE Q(MU,NU,X). ! NOTE, IN THIS LOOP, NU=NU+1 ! 130 X1=(2.*NU-1.)/(NU+DMU)*X*PQ1 X2=(NU-1.-DMU)/(NU+DMU)*PQ2 call XADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN call XADJ(PQ,IPQ,IERROR) if (IERROR /= 0) RETURN NU=NU+1. PQ2=PQ1 IPQ2=IPQ1 go to 120 ! end FUNCTION XPSI (A, IPSIK, IPSIX) ! !! XPSI computes values of the Psi function for XLEGF. ! !***LIBRARY SLATEC !***CATEGORY C7C !***TYPE SINGLE PRECISION (XPSI-S, DXPSI-D) !***KEYWORDS PSI FUNCTION !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XPSI REAL A,B,C,CNUM,CDENOM real XPSI DIMENSION CNUM(12),CDENOM(12) SAVE CNUM, CDENOM ! ! CNUM(I) AND CDENOM(I) ARE THE ( REDUCED ) NUMERATOR ! AND 2*I*DENOMINATOR RESPECTIVELY OF THE 2*I TH BERNOULLI ! NUMBER. ! DATA CNUM(1),CNUM(2),CNUM(3),CNUM(4),CNUM(5),CNUM(6),CNUM(7), & CNUM(8),CNUM(9),CNUM(10),CNUM(11),CNUM(12) & / 1., -1., 1., -1., 1., & -691., 1., -3617., 43867., -174611., 77683., & -236364091./ DATA CDENOM(1),CDENOM(2),CDENOM(3),CDENOM(4),CDENOM(5),CDENOM(6), & CDENOM(7),CDENOM(8),CDENOM(9),CDENOM(10),CDENOM(11),CDENOM(12) & /12.,120., 252., 240.,132., & 32760., 12., 8160., 14364., 6600., 276., 65520./ !***FIRST EXECUTABLE STATEMENT XPSI N=MAX(0,IPSIX-INT(A)) B=N+A K1=IPSIK-1 ! ! SERIES EXPANSION FOR A > IPSIX USING IPSIK-1 TERMS. ! C=0. DO 12 I=1,K1 K=IPSIK-I 12 C=(C+CNUM(K)/CDENOM(K))/B**2 XPSI=LOG(B)-(C+.5/B) if ( N == 0) go to 20 B=0. ! ! RECURRENCE FOR A <= IPSIX. ! DO 15 M=1,N 15 B=B+1./(N-M+A) XPSI=XPSI-B 20 RETURN end subroutine XQMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA, & IERROR) ! !! XQMU computes the values of Legendre functions for XLEGF. ! ! Method: forward mu-wise recurrence for Q(MU,NU,X) for fixed ! nu to obtain Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X). ! !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE SINGLE PRECISION (XQMU-S, DXQMU-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED XADD, XADJ, XPQNU !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XQMU DIMENSION PQA(*),IPQA(*) REAL DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2 REAL THETA !***FIRST EXECUTABLE STATEMENT XQMU IERROR=0 MU=0 ! ! call XPQNU TO OBTAIN Q(0.,NU1,X) ! call XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN PQ2=PQA(1) IPQ2=IPQA(1) MU=1 ! ! call XPQNU TO OBTAIN Q(1.,NU1,X) ! call XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN NU=NU1 K=0 MU=1 DMU=1. PQ1=PQA(1) IPQ1=IPQA(1) if ( MU1 > 0) go to 310 K=K+1 PQA(K)=PQ2 IPQA(K)=IPQ2 if ( MU2 < 1) go to 330 310 if ( MU1 > 1) go to 320 K=K+1 PQA(K)=PQ1 IPQA(K)=IPQ1 if ( MU2 <= 1) go to 330 320 CONTINUE ! ! FORWARD RECURRENCE IN MU TO OBTAIN ! Q(MU1,NU,X),Q(MU1+1,NU,X),....,Q(MU2,NU,X) USING ! Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X) ! -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X) ! X1=-2.*DMU*X*SX*PQ1 X2=(NU+DMU)*(NU-DMU+1.)*PQ2 call XADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN call XADJ(PQ,IPQ,IERROR) if (IERROR /= 0) RETURN PQ2=PQ1 IPQ2=IPQ1 PQ1=PQ IPQ1=IPQ MU=MU+1 DMU=DMU+1. if ( MU < MU1) go to 320 K=K+1 PQA(K)=PQ IPQA(K)=IPQ if ( MU2 > MU) go to 320 330 RETURN end subroutine XQNU (NU1, NU2, MU1, THETA, X, SX, ID, PQA, IPQA, & IERROR) ! !! XQNU computes the values of Legendre functions for XLEGF. ! ! Method: backward nu-wise recurrence for Q(MU,NU,X) for ! fixed mu to obtain Q(MU1,NU1,X), Q(MU1,NU1+1,X), ..., ! Q(MU1,NU2,X). ! !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE SINGLE PRECISION (XQNU-S, DXQNU-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR Smith, John M., (NBS and George Mason University) !***ROUTINES CALLED XADD, XADJ, XPQNU !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XQNU DIMENSION PQA(*),IPQA(*) REAL DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2 REAL THETA,PQL1,PQL2 !***FIRST EXECUTABLE STATEMENT XQNU IERROR=0 K=0 PQ2=0.0 IPQ2=0 PQL2=0.0 IPQL2=0 if ( MU1 == 1) go to 290 MU=0 ! ! call XPQNU TO OBTAIN Q(0.,NU2,X) AND Q(0.,NU2-1,X) ! call XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN if ( MU1 == 0) RETURN K=(NU2-NU1+1.5) PQ2=PQA(K) IPQ2=IPQA(K) PQL2=PQA(K-1) IPQL2=IPQA(K-1) 290 MU=1 ! ! call XPQNU TO OBTAIN Q(1.,NU2,X) AND Q(1.,NU2-1,X) ! call XPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR) if (IERROR /= 0) RETURN if ( MU1 == 1) RETURN NU=NU2 PQ1=PQA(K) IPQ1=IPQA(K) PQL1=PQA(K-1) IPQL1=IPQA(K-1) 300 MU=1 DMU=1. 320 CONTINUE ! ! FORWARD RECURRENCE IN MU TO OBTAIN Q(MU1,NU2,X) AND ! Q(MU1,NU2-1,X) USING ! Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X) ! -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X) ! ! FIRST FOR NU=NU2 ! X1=-2.*DMU*X*SX*PQ1 X2=(NU+DMU)*(NU-DMU+1.)*PQ2 call XADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN call XADJ(PQ,IPQ,IERROR) if (IERROR /= 0) RETURN PQ2=PQ1 IPQ2=IPQ1 PQ1=PQ IPQ1=IPQ MU=MU+1 DMU=DMU+1. if ( MU < MU1) go to 320 PQA(K)=PQ IPQA(K)=IPQ if ( K == 1) RETURN if ( NU < NU2) go to 340 ! ! THEN FOR NU=NU2-1 ! NU=NU-1. PQ2=PQL2 IPQ2=IPQL2 PQ1=PQL1 IPQ1=IPQL1 K=K-1 go to 300 ! ! BACKWARD RECURRENCE IN NU TO OBTAIN ! Q(MU1,NU1,X),Q(MU1,NU1+1,X),....,Q(MU1,NU2,X) ! USING ! (NU-MU+1.)*Q(MU,NU+1,X)= ! (2.*NU+1.)*X*Q(MU,NU,X)-(NU+MU)*Q(MU,NU-1,X) ! 340 PQ1=PQA(K) IPQ1=IPQA(K) PQ2=PQA(K+1) IPQ2=IPQA(K+1) 350 if ( NU <= NU1) RETURN K=K-1 X1=(2.*NU+1.)*X*PQ1/(NU+DMU) X2=-(NU-DMU+1.)*PQ2/(NU+DMU) call XADD(X1,IPQ1,X2,IPQ2,PQ,IPQ,IERROR) if (IERROR /= 0) RETURN call XADJ(PQ,IPQ,IERROR) if (IERROR /= 0) RETURN PQ2=PQ1 IPQ2=IPQ1 PQ1=PQ IPQ1=IPQ PQA(K)=PQ IPQA(K)=IPQ NU=NU-1. go to 350 end subroutine XRED (X, IX, IERROR) ! !! XRED transforms X*RADIX**IX so that IX = 0. ! !***PURPOSE To provide single-precision floating-point arithmetic ! with an extended exponent range. !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE SINGLE PRECISION (XRED-S, DXRED-D) !***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! REAL X ! INTEGER IX ! ! IF ! RADIX**(-2L) <= (ABS(X),IX) <= RADIX**(2L) ! THEN XRED TRANSFORMS (X,IX) SO THAT IX=0. ! if (X,IX) IS OUTSIDE THE ABOVE RANGE, ! THEN XRED TAKES NO ACTION. ! THIS SUBROUTINE IS USEFUL if THE ! RESULTS OF EXTENDED-RANGE CALCULATIONS ! ARE TO BE USED IN SUBSEQUENT ORDINARY ! SINGLE-PRECISION CALCULATIONS. ! !***SEE ALSO XSET !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS XBLK2 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XRED REAL X INTEGER IX REAL RADIX, RADIXL, RAD2L, DLG10R, XA INTEGER L, L2, KMAX COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX SAVE /XBLK2/ ! !***FIRST EXECUTABLE STATEMENT XRED IERROR=0 if (X == 0.0) go to 90 XA = ABS(X) if (IX == 0) go to 70 IXA = ABS(IX) IXA1 = IXA/L2 IXA2 = MOD(IXA,L2) if (IX > 0) go to 40 10 CONTINUE if (XA > 1.0) go to 20 XA = XA*RAD2L IXA1 = IXA1 + 1 go to 10 20 XA = XA/RADIX**IXA2 if (IXA1 == 0) go to 70 DO 30 I=1,IXA1 if (XA < 1.0) go to 100 XA = XA/RAD2L 30 CONTINUE go to 70 ! 40 CONTINUE if (XA < 1.0) go to 50 XA = XA/RAD2L IXA1 = IXA1 + 1 go to 40 50 XA = XA*RADIX**IXA2 if (IXA1 == 0) go to 70 DO 60 I=1,IXA1 if (XA > 1.0) go to 100 XA = XA*RAD2L 60 CONTINUE 70 if (XA > RAD2L) go to 100 if (XA > 1.0) go to 80 if (RAD2L*XA < 1.0) go to 100 80 X = SIGN(XA,X) 90 IX = 0 100 RETURN end subroutine XSET (IRAD, NRADPL, DZERO, NBITS, IERROR) ! !! XSET sets up extended exponent range arithmetic. ! !***PURPOSE To provide single-precision floating-point arithmetic ! with an extended exponent range. !***LIBRARY SLATEC !***CATEGORY A3D !***TYPE SINGLE PRECISION (XSET-S, DXSET-D) !***KEYWORDS EXTENDED-RANGE SINGLE-PRECISION ARITHMETIC !***AUTHOR Lozier, Daniel W., (National Bureau of Standards) ! Smith, John M., (NBS and George Mason University) !***DESCRIPTION ! ! SUBROUTINE XSET MUST BE CALLED PRIOR TO CALLING ANY OTHER ! EXTENDED-RANGE SUBROUTINE. IT CALCULATES AND STORES SEVERAL ! MACHINE-DEPENDENT CONSTANTS IN COMMON BLOCKS. THE USER MUST ! SUPPLY FOUR CONSTANTS THAT PERTAIN TO HIS PARTICULAR COMPUTER. ! THE CONSTANTS ARE ! ! IRAD = THE INTERNAL BASE OF SINGLE-PRECISION ! ARITHMETIC IN THE COMPUTER. ! NRADPL = THE NUMBER OF RADIX PLACES CARRIED IN ! THE SINGLE-PRECISION REPRESENTATION. ! DZERO = THE SMALLEST OF 1/DMIN, DMAX, DMAXLN WHERE ! DMIN = THE SMALLEST POSITIVE SINGLE-PRECISION ! NUMBER OR AN UPPER BOUND TO THIS NUMBER, ! DMAX = THE LARGEST SINGLE-PRECISION NUMBER ! OR A LOWER BOUND TO THIS NUMBER, ! DMAXLN = THE LARGEST SINGLE-PRECISION NUMBER ! SUCH THAT LOG10(DMAXLN) CAN BE COMPUTED BY THE ! FORTRAN SYSTEM (ON MOST SYSTEMS DMAXLN = DMAX). ! NBITS = THE NUMBER OF BITS (EXCLUSIVE OF SIGN) IN ! AN INTEGER COMPUTER WORD. ! ! ALTERNATIVELY, ANY OR ALL OF THE CONSTANTS CAN BE GIVEN ! THE VALUE 0 (0.0 FOR DZERO). if A CONSTANT IS ZERO, XSET TRIES ! TO ASSIGN AN APPROPRIATE VALUE BY CALLING I1MACH ! (SEE P.A.FOX, A.D.HALL, N.L.SCHRYER, ALGORITHM 528 FRAMEWORK ! FOR A PORTABLE LIBRARY, ACM TRANSACTIONS ON MATH SOFTWARE, ! V.4, NO.2, JUNE 1978, 177-188). ! ! THIS IS THE SETTING-UP SUBROUTINE FOR A PACKAGE OF SUBROUTINES ! THAT FACILITATE THE USE OF EXTENDED-RANGE ARITHMETIC. EXTENDED-RANGE ! ARITHMETIC ON A PARTICULAR COMPUTER IS DEFINED ON THE SET OF NUMBERS ! OF THE FORM ! ! (X,IX) = X*RADIX**IX ! ! WHERE X IS A SINGLE-PRECISION NUMBER CALLED THE PRINCIPAL PART, ! IX IS AN INTEGER CALLED THE AUXILIARY INDEX, AND RADIX IS THE ! INTERNAL BASE OF THE SINGLE-PRECISION ARITHMETIC. OBVIOUSLY, ! EACH REAL NUMBER IS REPRESENTABLE WITHOUT ERROR BY MORE THAN ONE ! EXTENDED-RANGE FORM. CONVERSIONS BETWEEN DIFFERENT FORMS ARE ! ESSENTIAL IN CARRYING OUT ARITHMETIC OPERATIONS. WITH THE CHOICE ! OF RADIX WE HAVE MADE, AND THE SUBROUTINES WE HAVE WRITTEN, THESE ! CONVERSIONS ARE PERFORMED WITHOUT ERROR (AT LEAST ON MOST COMPUTERS). ! (SEE SMITH, J.M., OLVER, F.W.J., AND LOZIER, D.W., EXTENDED-RANGE ! ARITHMETIC AND NORMALIZED LEGENDRE POLYNOMIALS, ACM TRANSACTIONS ON ! MATHEMATICAL SOFTWARE, MARCH 1981). ! ! AN EXTENDED-RANGE NUMBER (X,IX) IS SAID TO BE IN ADJUSTED FORM IF ! X AND IX ARE ZERO OR ! ! RADIX**(-L) <= ABS(X) < RADIX**L ! ! IS SATISFIED, WHERE L IS A COMPUTER-DEPENDENT INTEGER DEFINED IN THIS ! SUBROUTINE. TWO EXTENDED-RANGE NUMBERS IN ADJUSTED FORM CAN BE ADDED, ! SUBTRACTED, MULTIPLIED OR DIVIDED (IF THE DIVISOR IS NONZERO) WITHOUT ! CAUSING OVERFLOW OR UNDERFLOW IN THE PRINCIPAL PART OF THE RESULT. ! WITH PROPER USE OF THE EXTENDED-RANGE SUBROUTINES, THE ONLY OVERFLOW ! THAT CAN OCCUR IS INTEGER OVERFLOW IN THE AUXILIARY INDEX. if THIS ! IS DETECTED, THE SOFTWARE CALLS XERROR (A GENERAL ERROR-HANDLING ! FORTRAN SUBROUTINE PACKAGE). ! ! MULTIPLICATION AND DIVISION IS PERFORMED BY SETTING ! ! (X,IX)*(Y,IY) = (X*Y,IX+IY) ! OR ! (X,IX)/(Y,IY) = (X/Y,IX-IY). ! ! PRE-ADJUSTMENT OF THE OPERANDS IS ESSENTIAL TO AVOID ! OVERFLOW OR UNDERFLOW OF THE PRINCIPAL PART. SUBROUTINE ! XADJ (SEE BELOW) MAY BE CALLED TO TRANSFORM ANY EXTENDED- ! RANGE NUMBER INTO ADJUSTED FORM. ! ! ADDITION AND SUBTRACTION REQUIRE THE USE OF SUBROUTINE XADD ! (SEE BELOW). THE INPUT OPERANDS NEED NOT BE IN ADJUSTED FORM. ! HOWEVER, THE RESULT OF ADDITION OR SUBTRACTION IS RETURNED ! IN ADJUSTED FORM. THUS, FOR EXAMPLE, if (X,IX),(Y,IY), ! (U,IU), AND (V,IV) ARE IN ADJUSTED FORM, THEN ! ! (X,IX)*(Y,IY) + (U,IU)*(V,IV) ! ! CAN BE COMPUTED AND STORED IN ADJUSTED FORM WITH NO EXPLICIT ! CALLS TO XADJ. ! ! WHEN AN EXTENDED-RANGE NUMBER IS TO BE PRINTED, IT MUST BE ! CONVERTED TO AN EXTENDED-RANGE FORM WITH DECIMAL RADIX. SUBROUTINE ! XCON IS PROVIDED FOR THIS PURPOSE. ! ! THE SUBROUTINES CONTAINED IN THIS PACKAGE ARE ! ! SUBROUTINE XADD ! USAGE ! call XADD(X,IX,Y,IY,Z,IZ,IERROR) ! if (IERROR /= 0) RETURN ! DESCRIPTION ! FORMS THE EXTENDED-RANGE SUM (Z,IZ) = ! (X,IX) + (Y,IY). (Z,IZ) IS ADJUSTED ! BEFORE RETURNING. THE INPUT OPERANDS ! NEED NOT BE IN ADJUSTED FORM, BUT THEIR ! PRINCIPAL PARTS MUST SATISFY ! RADIX**(-2L) <= ABS(X) <= RADIX**(2L), ! RADIX**(-2L) <= ABS(Y) <= RADIX**(2L). ! ! SUBROUTINE XADJ ! USAGE ! call XADJ(X,IX,IERROR) ! if (IERROR /= 0) RETURN ! DESCRIPTION ! TRANSFORMS (X,IX) SO THAT ! RADIX**(-L) <= ABS(X) < RADIX**L. ! ON MOST COMPUTERS THIS TRANSFORMATION DOES ! NOT CHANGE THE MANTISSA OF X PROVIDED RADIX IS ! THE NUMBER BASE OF SINGLE-PRECISION ARITHMETIC. ! ! SUBROUTINE XC210 ! USAGE ! call XC210(K,Z,J,IERROR) ! if (IERROR /= 0) RETURN ! DESCRIPTION ! GIVEN K THIS SUBROUTINE COMPUTES J AND Z ! SUCH THAT RADIX**K = Z*10**J, WHERE Z IS IN ! THE RANGE 1/10 <= Z < 1. ! THE VALUE OF Z WILL BE ACCURATE TO FULL ! SINGLE-PRECISION PROVIDED THE NUMBER ! OF DECIMAL PLACES IN THE LARGEST ! INTEGER PLUS THE NUMBER OF DECIMAL ! PLACES CARRIED IN SINGLE-PRECISION DOES NOT ! EXCEED 60. XC210 IS CALLED BY SUBROUTINE ! XCON WHEN NECESSARY. THE USER SHOULD ! NEVER NEED TO call XC210 DIRECTLY. ! ! SUBROUTINE XCON ! USAGE ! call XCON(X,IX,IERROR) ! if (IERROR /= 0) RETURN ! DESCRIPTION ! CONVERTS (X,IX) = X*RADIX**IX ! TO DECIMAL FORM IN PREPARATION FOR ! PRINTING, SO THAT (X,IX) = X*10**IX ! WHERE 1/10 <= ABS(X) < 1 ! IS RETURNED, EXCEPT THAT IF ! (ABS(X),IX) IS BETWEEN RADIX**(-2L) ! AND RADIX**(2L) THEN THE REDUCED ! FORM WITH IX = 0 IS RETURNED. ! ! SUBROUTINE XRED ! USAGE ! call XRED(X,IX,IERROR) ! if (IERROR /= 0) RETURN ! DESCRIPTION ! IF ! RADIX**(-2L) <= (ABS(X),IX) <= RADIX**(2L) ! THEN XRED TRANSFORMS (X,IX) SO THAT IX=0. ! if (X,IX) IS OUTSIDE THE ABOVE RANGE, ! THEN XRED TAKES NO ACTION. ! THIS SUBROUTINE IS USEFUL if THE ! RESULTS OF EXTENDED-RANGE CALCULATIONS ! ARE TO BE USED IN SUBSEQUENT ORDINARY ! SINGLE-PRECISION CALCULATIONS. ! !***REFERENCES Smith, Olver and Lozier, Extended-Range Arithmetic and ! Normalized Legendre Polynomials, ACM Trans on Math ! Softw, v 7, n 1, March 1981, pp 93--105. !***ROUTINES CALLED I1MACH, XERMSG !***COMMON BLOCKS XBLK1, XBLK2, XBLK3 !***REVISION HISTORY (YYMMDD) ! 820712 DATE WRITTEN ! 881020 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! Corrected order of sections in prologue and added TYPE ! section. (WRB) ! CALLs to XERROR changed to CALLs to XERMSG. (WRB) ! 920127 Revised PURPOSE section of prologue. (DWL) !***END PROLOGUE XSET INTEGER IRAD, NRADPL, NBITS REAL DZERO, DZEROX COMMON /XBLK1/ NBITSF SAVE /XBLK1/ REAL RADIX, RADIXL, RAD2L, DLG10R INTEGER L, L2, KMAX COMMON /XBLK2/ RADIX, RADIXL, RAD2L, DLG10R, L, L2, KMAX SAVE /XBLK2/ INTEGER NLG102, MLG102, LG102 COMMON /XBLK3/ NLG102, MLG102, LG102(21) SAVE /XBLK3/ INTEGER IFLAG SAVE IFLAG ! DIMENSION LOG102(20), LGTEMP(20) SAVE LOG102 ! ! LOG102 CONTAINS THE FIRST 60 DIGITS OF LOG10(2) FOR USE IN ! CONVERSION OF EXTENDED-RANGE NUMBERS TO BASE 10 . DATA LOG102 /301,029,995,663,981,195,213,738,894,724,493,026,768, & 189,881,462,108,541,310,428/ ! ! FOLLOWING CODING PREVENTS XSET FROM BEING EXECUTED MORE THAN ONCE. ! THIS IS IMPORTANT BECAUSE SOME SUBROUTINES (SUCH AS XNRMP AND ! XLEGF) call XSET TO MAKE SURE EXTENDED-RANGE ARITHMETIC HAS ! BEEN INITIALIZED. THE USER MAY WANT TO PRE-EMPT THIS CALL, FOR ! EXAMPLE WHEN I1MACH IS NOT AVAILABLE. SEE CODING BELOW. DATA IFLAG /0/ !***FIRST EXECUTABLE STATEMENT XSET IERROR=0 if (IFLAG /= 0) RETURN IRADX = IRAD NRDPLC = NRADPL DZEROX = DZERO IMINEX = 0 IMAXEX = 0 NBITSX = NBITS ! FOLLOWING 5 STATEMENTS SHOULD BE DELETED if I1MACH IS ! NOT AVAILABLE OR NOT CONFIGURED TO RETURN THE CORRECT ! MACHINE-DEPENDENT VALUES. if (IRADX == 0) IRADX = I1MACH (10) if (NRDPLC == 0) NRDPLC = I1MACH (11) if (DZEROX == 0.0) IMINEX = I1MACH (12) if (DZEROX == 0.0) IMAXEX = I1MACH (13) if (NBITSX == 0) NBITSX = I1MACH (8) if (IRADX == 2) go to 10 if (IRADX == 4) go to 10 if (IRADX == 8) go to 10 if (IRADX == 16) go to 10 call XERMSG ('SLATEC', 'XSET', 'IMPROPER VALUE OF IRAD', 101, 1) IERROR=101 return 10 CONTINUE LOG2R=0 if (IRADX == 2) LOG2R = 1 if (IRADX == 4) LOG2R = 2 if (IRADX == 8) LOG2R = 3 if (IRADX == 16) LOG2R = 4 NBITSF=LOG2R*NRDPLC RADIX = IRADX DLG10R = LOG10(RADIX) if (DZEROX /= 0.0) go to 14 LX = MIN ((1-IMINEX)/2, (IMAXEX-1)/2) go to 16 14 LX = 0.5*LOG10(DZEROX)/DLG10R ! RADIX**(2*L) SHOULD NOT OVERFLOW, BUT REDUCE L BY 1 FOR FURTHER ! PROTECTION. LX=LX-1 16 L2 = 2*LX if (LX >= 4) go to 20 call XERMSG ('SLATEC', 'XSET', 'IMPROPER VALUE OF DZERO', 102, 1) IERROR=102 return 20 L = LX RADIXL = RADIX**L RAD2L = RADIXL**2 ! IT IS NECESSARY TO RESTRICT NBITS (OR NBITSX) TO BE LESS THAN SOME ! UPPER LIMIT BECAUSE OF BINARY-TO-DECIMAL CONVERSION. SUCH CONVERSION ! IS DONE BY XC210 AND REQUIRES A CONSTANT THAT IS STORED TO SOME FIXED ! PRECISION. THE STORED CONSTANT (LOG102 IN THIS ROUTINE) PROVIDES ! FOR CONVERSIONS ACCURATE TO THE LAST DECIMAL DIGIT WHEN THE INTEGER ! WORD LENGTH DOES NOT EXCEED 63. A LOWER LIMIT OF 15 BITS IS IMPOSED ! BECAUSE THE SOFTWARE IS DESIGNED TO RUN ON COMPUTERS WITH INTEGER WORD ! LENGTH OF AT LEAST 16 BITS. if (15 <= NBITSX .AND. NBITSX <= 63) go to 30 call XERMSG ('SLATEC', 'XSET', 'IMPROPER VALUE OF NBITS', 103, 1) IERROR=103 return 30 CONTINUE KMAX = 2**(NBITSX-1) - L2 NB = (NBITSX-1)/2 MLG102 = 2**NB if (1 <= NRDPLC*LOG2R .AND. NRDPLC*LOG2R <= 120) go to 40 call XERMSG ('SLATEC', 'XSET', 'IMPROPER VALUE OF NRADPL', 104, 1) IERROR=104 return 40 CONTINUE NLG102 = NRDPLC*LOG2R/NB + 3 NP1 = NLG102 + 1 ! ! AFTER COMPLETION OF THE FOLLOWING LOOP, IC CONTAINS ! THE INTEGER PART AND LGTEMP CONTAINS THE FRACTIONAL PART ! OF LOG10(IRADX) IN RADIX 1000. IC = 0 DO 50 II=1,20 I = 21 - II IT = LOG2R*LOG102(I) + IC IC = IT/1000 LGTEMP(I) = MOD(IT,1000) 50 CONTINUE ! ! AFTER COMPLETION OF THE FOLLOWING LOOP, LG102 CONTAINS ! LOG10(IRADX) IN RADIX MLG102. THE RADIX POINT IS ! BETWEEN LG102(1) AND LG102(2). LG102(1) = IC DO 80 I=2,NP1 LG102X = 0 DO 70 J=1,NB IC = 0 DO 60 KK=1,20 K = 21 - KK IT = 2*LGTEMP(K) + IC IC = IT/1000 LGTEMP(K) = MOD(IT,1000) 60 CONTINUE LG102X = 2*LG102X + IC 70 CONTINUE LG102(I) = LG102X 80 CONTINUE ! ! CHECK SPECIAL CONDITIONS REQUIRED BY SUBROUTINES... if (NRDPLC < L) go to 90 call XERMSG ('SLATEC', 'XSET', 'NRADPL >= L', 105, 1) IERROR=105 return 90 if (6*L <= KMAX) go to 100 call XERMSG ('SLATEC', 'XSET', '6*L > KMAX', 106, 1) IERROR=106 return 100 CONTINUE IFLAG = 1 return end subroutine XSETF (KONTRL) ! !! XSETF sets the XERROR control flag. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3A !***TYPE ALL (XSETF-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! XSETF sets the error control flag value to KONTRL. ! (KONTRL is an input parameter only.) ! The following table shows how each message is treated, ! depending on the values of KONTRL and LEVEL. (See XERMSG ! for description of LEVEL.) ! ! If KONTRL is zero or negative, no information other than the ! message itself (including numeric values, if any) will be ! printed. If KONTRL is positive, introductory messages, ! trace-backs, etc., will be printed in addition to the message. ! ! ABS(KONTRL) ! LEVEL 0 1 2 ! value ! 2 fatal fatal fatal ! ! 1 not printed printed fatal ! ! 0 not printed printed printed ! ! -1 not printed printed printed ! only only ! once once ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED J4SAVE, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890531 Changed all specific intrinsics to generic. (WRB) ! 890531 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Change call to XERRWV to XERMSG. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XSETF CHARACTER *8 XERN1 !***FIRST EXECUTABLE STATEMENT XSETF if (ABS(KONTRL) > 2) THEN WRITE (XERN1, '(I8)') KONTRL call XERMSG ('SLATEC', 'XSETF', & 'INVALID ARGUMENT = ' // XERN1, 1, 2) return end if ! JUNK = J4SAVE(2,KONTRL,.TRUE.) return end subroutine XSETUA (IUNITA, N) ! !! XSETUA sets logical unit numbers to which error messages are to be sent. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3B !***TYPE ALL (XSETUA-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! XSETUA may be called to declare a list of up to five ! logical units, each of which is to receive a copy of ! each error message processed by this package. ! The purpose of XSETUA is to allow simultaneous printing ! of each error message on, say, a main output file, ! an interactive terminal, and other files such as graphics ! communication files. ! ! Description of Parameters ! --Input-- ! IUNIT - an array of up to five unit numbers. ! Normally these numbers should all be different ! (but duplicates are not prohibited.) ! N - the number of unit numbers provided in IUNIT ! must have 1 <= N <= 5. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED J4SAVE, XERMSG !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900510 Change call to XERRWV to XERMSG. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XSETUA DIMENSION IUNITA(5) CHARACTER *8 XERN1 !***FIRST EXECUTABLE STATEMENT XSETUA ! if (N < 1 .OR. N > 5) THEN WRITE (XERN1, '(I8)') N call XERMSG ('SLATEC', 'XSETUA', & 'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2) return end if ! DO 10 I=1,N INDEX = I+4 if (I == 1) INDEX = 3 JUNK = J4SAVE(INDEX,IUNITA(I),.TRUE.) 10 CONTINUE JUNK = J4SAVE(5,N,.TRUE.) return end subroutine XSETUN (IUNIT) ! !! XSETUN sets output file to which XERROR messages are to be sent. ! !***LIBRARY SLATEC (XERROR) !***CATEGORY R3B !***TYPE ALL (XSETUN-A) !***KEYWORDS ERROR, XERROR !***AUTHOR Jones, R. E., (SNLA) !***DESCRIPTION ! ! Abstract ! XSETUN sets the output file to which error messages are to ! be sent. Only one file will be used. See XSETUA for ! how to declare more than one file. ! ! Description of Parameter ! --Input-- ! IUNIT - an input parameter giving the logical unit number ! to which error messages are to be sent. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED J4SAVE !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 861211 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XSETUN !***FIRST EXECUTABLE STATEMENT XSETUN JUNK = J4SAVE(3,IUNIT,.TRUE.) JUNK = J4SAVE(5,1,.TRUE.) return end subroutine YAIRY (X, RX, C, BI, DBI) ! !! YAIRY is subsidiary to BESJ and BESY ! !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (YAIRY-S, DYAIRY-D) !***AUTHOR Amos, D. E., (SNLA) ! Daniel, S. L., (SNLA) !***DESCRIPTION ! ! YAIRY computes the Airy function BI(X) ! and its derivative DBI(X) for ASYJY ! ! INPUT ! ! X - Argument, computed by ASYJY, X unrestricted ! RX - RX=SQRT(ABS(X)), computed by ASYJY ! C - C=2.*(ABS(X)**1.5)/3., computed by ASYJY ! ! OUTPUT ! BI - Value of function BI(X) ! DBI - Value of the derivative DBI(X) ! !***SEE ALSO BESJ, BESY !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 750101 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900328 Added TYPE section. (WRB) ! 910408 Updated the AUTHOR section. (WRB) !***END PROLOGUE YAIRY ! INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4D, N1, N1D, N2, N2D, & N3, N3D, N4D REAL AA, AX, BB, BI, BJN, BJP, BK1, BK2, BK3, BK4, C, CON1, CON2, & CON3, CV, DAA, DBB, DBI, DBJN, DBJP, DBK1, DBK2, DBK3, DBK4, D1, & D2, EX, E1, E2, FPI12, F1, F2, RTRX, RX, SPI12, S1, S2, T, TC, & TEMP1, TEMP2, TT, X DIMENSION BK1(20), BK2(20), BK3(20), BK4(14) DIMENSION BJP(19), BJN(19), AA(14), BB(14) DIMENSION DBK1(21), DBK2(20), DBK3(20), DBK4(14) DIMENSION DBJP(19), DBJN(19), DAA(14), DBB(14) SAVE N1, N2, N3, M1, M2, M3, N1D, N2D, N3D, N4D, & M1D, M2D, M3D, M4D, FPI12, SPI12, CON1, CON2, CON3, & BK1, BK2, BK3, BK4, BJP, BJN, AA, BB, DBK1, DBK2, DBK3, DBK4, & DBJP, DBJN, DAA, DBB DATA N1,N2,N3/20,19,14/ DATA M1,M2,M3/18,17,12/ DATA N1D,N2D,N3D,N4D/21,20,19,14/ DATA M1D,M2D,M3D,M4D/19,18,17,12/ DATA FPI12,SPI12,CON1,CON2,CON3/ & 1.30899693899575E+00, 1.83259571459405E+00, 6.66666666666667E-01, & 7.74148278841779E+00, 3.64766105490356E-01/ DATA BK1(1), BK1(2), BK1(3), BK1(4), BK1(5), BK1(6), & BK1(7), BK1(8), BK1(9), BK1(10), BK1(11), BK1(12), & BK1(13), BK1(14), BK1(15), BK1(16), BK1(17), BK1(18), & BK1(19), BK1(20)/ 2.43202846447449E+00, 2.57132009754685E+00, & 1.02802341258616E+00, 3.41958178205872E-01, 8.41978629889284E-02, & 1.93877282587962E-02, 3.92687837130335E-03, 6.83302689948043E-04, & 1.14611403991141E-04, 1.74195138337086E-05, 2.41223620956355E-06, & 3.24525591983273E-07, 4.03509798540183E-08, 4.70875059642296E-09, & 5.35367432585889E-10, 5.70606721846334E-11, 5.80526363709933E-12, & 5.76338988616388E-13, 5.42103834518071E-14, 4.91857330301677E-15/ DATA BK2(1), BK2(2), BK2(3), BK2(4), BK2(5), BK2(6), & BK2(7), BK2(8), BK2(9), BK2(10), BK2(11), BK2(12), & BK2(13), BK2(14), BK2(15), BK2(16), BK2(17), BK2(18), & BK2(19), BK2(20)/ 5.74830555784088E-01,-6.91648648376891E-03, & 1.97460263052093E-03,-5.24043043868823E-04, 1.22965147239661E-04, & -2.27059514462173E-05, 2.23575555008526E-06, 4.15174955023899E-07, & -2.84985752198231E-07, 8.50187174775435E-08,-1.70400826891326E-08, & 2.25479746746889E-09,-1.09524166577443E-10,-3.41063845099711E-11, & 1.11262893886662E-11,-1.75542944241734E-12, 1.36298600401767E-13, & 8.76342105755664E-15,-4.64063099157041E-15, 7.78772758732960E-16/ DATA BK3(1), BK3(2), BK3(3), BK3(4), BK3(5), BK3(6), & BK3(7), BK3(8), BK3(9), BK3(10), BK3(11), BK3(12), & BK3(13), BK3(14), BK3(15), BK3(16), BK3(17), BK3(18), & BK3(19), BK3(20)/ 5.66777053506912E-01, 2.63672828349579E-03, & 5.12303351473130E-05, 2.10229231564492E-06, 1.42217095113890E-07, & 1.28534295891264E-08, 7.28556219407507E-10,-3.45236157301011E-10, & -2.11919115912724E-10,-6.56803892922376E-11,-8.14873160315074E-12, & 3.03177845632183E-12, 1.73447220554115E-12, 1.67935548701554E-13, & -1.49622868806719E-13,-5.15470458953407E-14, 8.75741841857830E-15, & 7.96735553525720E-15,-1.29566137861742E-16,-1.11878794417520E-15/ DATA BK4(1), BK4(2), BK4(3), BK4(4), BK4(5), BK4(6), & BK4(7), BK4(8), BK4(9), BK4(10), BK4(11), BK4(12), & BK4(13), BK4(14)/ 4.85444386705114E-01,-3.08525088408463E-03, & 6.98748404837928E-05,-2.82757234179768E-06, 1.59553313064138E-07, & -1.12980692144601E-08, 9.47671515498754E-10,-9.08301736026423E-11, & 9.70776206450724E-12,-1.13687527254574E-12, 1.43982917533415E-13, & -1.95211019558815E-14, 2.81056379909357E-15,-4.26916444775176E-16/ DATA BJP(1), BJP(2), BJP(3), BJP(4), BJP(5), BJP(6), & BJP(7), BJP(8), BJP(9), BJP(10), BJP(11), BJP(12), & BJP(13), BJP(14), BJP(15), BJP(16), BJP(17), BJP(18), & BJP(19) / 1.34918611457638E-01,-3.19314588205813E-01, & 5.22061946276114E-02, 5.28869112170312E-02,-8.58100756077350E-03, & -2.99211002025555E-03, 4.21126741969759E-04, 8.73931830369273E-05, & -1.06749163477533E-05,-1.56575097259349E-06, 1.68051151983999E-07, & 1.89901103638691E-08,-1.81374004961922E-09,-1.66339134593739E-10, & 1.42956335780810E-11, 1.10179811626595E-12,-8.60187724192263E-14, & -5.71248177285064E-15, 4.08414552853803E-16/ DATA BJN(1), BJN(2), BJN(3), BJN(4), BJN(5), BJN(6), & BJN(7), BJN(8), BJN(9), BJN(10), BJN(11), BJN(12), & BJN(13), BJN(14), BJN(15), BJN(16), BJN(17), BJN(18), & BJN(19) / 6.59041673525697E-02,-4.24905910566004E-01, & 2.87209745195830E-01, 1.29787771099606E-01,-4.56354317590358E-02, & -1.02630175982540E-02, 2.50704671521101E-03, 3.78127183743483E-04, & -7.11287583284084E-05,-8.08651210688923E-06, 1.23879531273285E-06, & 1.13096815867279E-07,-1.46234283176310E-08,-1.11576315688077E-09, & 1.24846618243897E-10, 8.18334132555274E-12,-8.07174877048484E-13, & -4.63778618766425E-14, 4.09043399081631E-15/ DATA AA(1), AA(2), AA(3), AA(4), AA(5), AA(6), & AA(7), AA(8), AA(9), AA(10), AA(11), AA(12), & AA(13), AA(14) /-2.78593552803079E-01, 3.52915691882584E-03, & 2.31149677384994E-05,-4.71317842263560E-06, 1.12415907931333E-07, & 2.00100301184339E-08,-2.60948075302193E-09, 3.55098136101216E-11, & 3.50849978423875E-11,-5.83007187954202E-12, 2.04644828753326E-13, & 1.10529179476742E-13,-2.87724778038775E-14, 2.88205111009939E-15/ DATA BB(1), BB(2), BB(3), BB(4), BB(5), BB(6), & BB(7), BB(8), BB(9), BB(10), BB(11), BB(12), & BB(13), BB(14) /-4.90275424742791E-01,-1.57647277946204E-03, & 9.66195963140306E-05,-1.35916080268815E-07,-2.98157342654859E-07, & 1.86824767559979E-08, 1.03685737667141E-09,-3.28660818434328E-10, & 2.57091410632780E-11, 2.32357655300677E-12,-9.57523279048255E-13, & 1.20340828049719E-13, 2.90907716770715E-15,-4.55656454580149E-15/ DATA DBK1(1), DBK1(2), DBK1(3), DBK1(4), DBK1(5), DBK1(6), & DBK1(7), DBK1(8), DBK1(9), DBK1(10),DBK1(11),DBK1(12), & DBK1(13),DBK1(14),DBK1(15),DBK1(16),DBK1(17),DBK1(18), & DBK1(19),DBK1(20), & DBK1(21) / 2.95926143981893E+00, 3.86774568440103E+00, & 1.80441072356289E+00, 5.78070764125328E-01, 1.63011468174708E-01, & 3.92044409961855E-02, 7.90964210433812E-03, 1.50640863167338E-03, & 2.56651976920042E-04, 3.93826605867715E-05, 5.81097771463818E-06, & 7.86881233754659E-07, 9.93272957325739E-08, 1.21424205575107E-08, & 1.38528332697707E-09, 1.50190067586758E-10, 1.58271945457594E-11, & 1.57531847699042E-12, 1.50774055398181E-13, 1.40594335806564E-14, & 1.24942698777218E-15/ DATA DBK2(1), DBK2(2), DBK2(3), DBK2(4), DBK2(5), DBK2(6), & DBK2(7), DBK2(8), DBK2(9), DBK2(10),DBK2(11),DBK2(12), & DBK2(13),DBK2(14),DBK2(15),DBK2(16),DBK2(17),DBK2(18), & DBK2(19),DBK2(20)/ 5.49756809432471E-01, 9.13556983276901E-03, & -2.53635048605507E-03, 6.60423795342054E-04,-1.55217243135416E-04, & 3.00090325448633E-05,-3.76454339467348E-06,-1.33291331611616E-07, & 2.42587371049013E-07,-8.07861075240228E-08, 1.71092818861193E-08, & -2.41087357570599E-09, 1.53910848162371E-10, 2.56465373190630E-11, & -9.88581911653212E-12, 1.60877986412631E-12,-1.20952524741739E-13, & -1.06978278410820E-14, 5.02478557067561E-15,-8.68986130935886E-16/ DATA DBK3(1), DBK3(2), DBK3(3), DBK3(4), DBK3(5), DBK3(6), & DBK3(7), DBK3(8), DBK3(9), DBK3(10),DBK3(11),DBK3(12), & DBK3(13),DBK3(14),DBK3(15),DBK3(16),DBK3(17),DBK3(18), & DBK3(19),DBK3(20)/ 5.60598509354302E-01,-3.64870013248135E-03, & -5.98147152307417E-05,-2.33611595253625E-06,-1.64571516521436E-07, & -2.06333012920569E-08,-4.27745431573110E-09,-1.08494137799276E-09, & -2.37207188872763E-10,-2.22132920864966E-11, 1.07238008032138E-11, & 5.71954845245808E-12, 7.51102737777835E-13,-3.81912369483793E-13, & -1.75870057119257E-13, 6.69641694419084E-15, 2.26866724792055E-14, & 2.69898141356743E-15,-2.67133612397359E-15,-6.54121403165269E-16/ DATA DBK4(1), DBK4(2), DBK4(3), DBK4(4), DBK4(5), DBK4(6), & DBK4(7), DBK4(8), DBK4(9), DBK4(10),DBK4(11),DBK4(12), & DBK4(13),DBK4(14)/ 4.93072999188036E-01, 4.38335419803815E-03, & -8.37413882246205E-05, 3.20268810484632E-06,-1.75661979548270E-07, & 1.22269906524508E-08,-1.01381314366052E-09, 9.63639784237475E-11, & -1.02344993379648E-11, 1.19264576554355E-12,-1.50443899103287E-13, & 2.03299052379349E-14,-2.91890652008292E-15, 4.42322081975475E-16/ DATA DBJP(1), DBJP(2), DBJP(3), DBJP(4), DBJP(5), DBJP(6), & DBJP(7), DBJP(8), DBJP(9), DBJP(10),DBJP(11),DBJP(12), & DBJP(13),DBJP(14),DBJP(15),DBJP(16),DBJP(17),DBJP(18), & DBJP(19) / 1.13140872390745E-01,-2.08301511416328E-01, & 1.69396341953138E-02, 2.90895212478621E-02,-3.41467131311549E-03, & -1.46455339197417E-03, 1.63313272898517E-04, 3.91145328922162E-05, & -3.96757190808119E-06,-6.51846913772395E-07, 5.98707495269280E-08, & 7.44108654536549E-09,-6.21241056522632E-10,-6.18768017313526E-11, & 4.72323484752324E-12, 3.91652459802532E-13,-2.74985937845226E-14, & -1.95036497762750E-15, 1.26669643809444E-16/ DATA DBJN(1), DBJN(2), DBJN(3), DBJN(4), DBJN(5), DBJN(6), & DBJN(7), DBJN(8), DBJN(9), DBJN(10),DBJN(11),DBJN(12), & DBJN(13),DBJN(14),DBJN(15),DBJN(16),DBJN(17),DBJN(18), & DBJN(19) /-1.88091260068850E-02,-1.47798180826140E-01, & 5.46075900433171E-01, 1.52146932663116E-01,-9.58260412266886E-02, & -1.63102731696130E-02, 5.75364806680105E-03, 7.12145408252655E-04, & -1.75452116846724E-04,-1.71063171685128E-05, 3.24435580631680E-06, & 2.61190663932884E-07,-4.03026865912779E-08,-2.76435165853895E-09, & 3.59687929062312E-10, 2.14953308456051E-11,-2.41849311903901E-12, & -1.28068004920751E-13, 1.26939834401773E-14/ DATA DAA(1), DAA(2), DAA(3), DAA(4), DAA(5), DAA(6), & DAA(7), DAA(8), DAA(9), DAA(10), DAA(11), DAA(12), & DAA(13), DAA(14)/ 2.77571356944231E-01,-4.44212833419920E-03, & 8.42328522190089E-05, 2.58040318418710E-06,-3.42389720217621E-07, & 6.24286894709776E-09, 2.36377836844577E-09,-3.16991042656673E-10, & 4.40995691658191E-12, 5.18674221093575E-12,-9.64874015137022E-13, & 4.90190576608710E-14, 1.77253430678112E-14,-5.55950610442662E-15/ DATA DBB(1), DBB(2), DBB(3), DBB(4), DBB(5), DBB(6), & DBB(7), DBB(8), DBB(9), DBB(10), DBB(11), DBB(12), & DBB(13), DBB(14)/ 4.91627321104601E-01, 3.11164930427489E-03, & 8.23140762854081E-05,-4.61769776172142E-06,-6.13158880534626E-08, & 2.87295804656520E-08,-1.81959715372117E-09,-1.44752826642035E-10, & 4.53724043420422E-11,-3.99655065847223E-12,-3.24089119830323E-13, & 1.62098952568741E-13,-2.40765247974057E-14, 1.69384811284491E-16/ !***FIRST EXECUTABLE STATEMENT YAIRY AX = ABS(X) RX = SQRT(AX) C = CON1*AX*RX if (X < 0.0E0) go to 120 if (C > 8.0E0) go to 60 if (X > 2.5E0) go to 30 T = (X+X-2.5E0)*0.4E0 TT = T + T J = N1 F1 = BK1(J) F2 = 0.0E0 DO 10 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + BK1(J) F2 = TEMP1 10 CONTINUE BI = T*F1 - F2 + BK1(1) J = N1D F1 = DBK1(J) F2 = 0.0E0 DO 20 I=1,M1D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DBK1(J) F2 = TEMP1 20 CONTINUE DBI = T*F1 - F2 + DBK1(1) return 30 CONTINUE RTRX = SQRT(RX) T = (X+X-CON2)*CON3 TT = T + T J = N1 F1 = BK2(J) F2 = 0.0E0 DO 40 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + BK2(J) F2 = TEMP1 40 CONTINUE BI = (T*F1-F2+BK2(1))/RTRX EX = EXP(C) BI = BI*EX J = N2D F1 = DBK2(J) F2 = 0.0E0 DO 50 I=1,M2D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DBK2(J) F2 = TEMP1 50 CONTINUE DBI = (T*F1-F2+DBK2(1))*RTRX DBI = DBI*EX return ! 60 CONTINUE RTRX = SQRT(RX) T = 16.0E0/C - 1.0E0 TT = T + T J = N1 F1 = BK3(J) F2 = 0.0E0 DO 70 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + BK3(J) F2 = TEMP1 70 CONTINUE S1 = T*F1 - F2 + BK3(1) J = N2D F1 = DBK3(J) F2 = 0.0E0 DO 80 I=1,M2D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DBK3(J) F2 = TEMP1 80 CONTINUE D1 = T*F1 - F2 + DBK3(1) TC = C + C EX = EXP(C) if (TC > 35.0E0) go to 110 T = 10.0E0/C - 1.0E0 TT = T + T J = N3 F1 = BK4(J) F2 = 0.0E0 DO 90 I=1,M3 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + BK4(J) F2 = TEMP1 90 CONTINUE S2 = T*F1 - F2 + BK4(1) BI = (S1+EXP(-TC)*S2)/RTRX BI = BI*EX J = N4D F1 = DBK4(J) F2 = 0.0E0 DO 100 I=1,M4D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DBK4(J) F2 = TEMP1 100 CONTINUE D2 = T*F1 - F2 + DBK4(1) DBI = RTRX*(D1+EXP(-TC)*D2) DBI = DBI*EX return 110 BI = EX*S1/RTRX DBI = EX*RTRX*D1 return ! 120 CONTINUE if (C > 5.0E0) go to 150 T = 0.4E0*C - 1.0E0 TT = T + T J = N2 F1 = BJP(J) E1 = BJN(J) F2 = 0.0E0 E2 = 0.0E0 DO 130 I=1,M2 J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + BJP(J) E1 = TT*E1 - E2 + BJN(J) F2 = TEMP1 E2 = TEMP2 130 CONTINUE BI = (T*E1-E2+BJN(1)) - AX*(T*F1-F2+BJP(1)) J = N3D F1 = DBJP(J) E1 = DBJN(J) F2 = 0.0E0 E2 = 0.0E0 DO 140 I=1,M3D J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + DBJP(J) E1 = TT*E1 - E2 + DBJN(J) F2 = TEMP1 E2 = TEMP2 140 CONTINUE DBI = X*X*(T*F1-F2+DBJP(1)) + (T*E1-E2+DBJN(1)) return ! 150 CONTINUE RTRX = SQRT(RX) T = 10.0E0/C - 1.0E0 TT = T + T J = N3 F1 = AA(J) E1 = BB(J) F2 = 0.0E0 E2 = 0.0E0 DO 160 I=1,M3 J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + AA(J) E1 = TT*E1 - E2 + BB(J) F2 = TEMP1 E2 = TEMP2 160 CONTINUE TEMP1 = T*F1 - F2 + AA(1) TEMP2 = T*E1 - E2 + BB(1) CV = C - FPI12 BI = (TEMP1*COS(CV)+TEMP2*SIN(CV))/RTRX J = N4D F1 = DAA(J) E1 = DBB(J) F2 = 0.0E0 E2 = 0.0E0 DO 170 I=1,M4D J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + DAA(J) E1 = TT*E1 - E2 + DBB(J) F2 = TEMP1 E2 = TEMP2 170 CONTINUE TEMP1 = T*F1 - F2 + DAA(1) TEMP2 = T*E1 - E2 + DBB(1) CV = C - SPI12 DBI = (TEMP1*COS(CV)-TEMP2*SIN(CV))*RTRX return end DOUBLE PRECISION FUNCTION ZABS (ZR, ZI) ! !! ZABS is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY. ! !***LIBRARY SLATEC !***TYPE ALL (ZABS-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE ! PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) ! !***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZABS DOUBLE PRECISION ZR, ZI, U, V, Q, S !***FIRST EXECUTABLE STATEMENT ZABS U = ABS(ZR) V = ABS(ZI) S = U + V !----------------------------------------------------------------------- ! S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A ! TRUE FLOATING ZERO !----------------------------------------------------------------------- S = S*1.0D+0 if (S == 0.0D+0) go to 20 if (U > V) go to 10 Q = U/V ZABS = V*SQRT(1.D+0+Q*Q) return 10 Q = V/U ZABS = U*SQRT(1.D+0+Q*Q) return 20 ZABS = 0.0D+0 return end subroutine ZACAI (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, & ELIM, ALIM) ! !! ZACAI is subsidiary to ZAIRY ! !***LIBRARY SLATEC !***TYPE ALL (CACAI-A, ZACAI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA ! ! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) ! MP=PI*MR*CMPLX(0.0,1.0) ! ! TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT ! HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. ! ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND ! RECURRENCE REMOVED. A RECURSIVE call TO ZACON CAN RESULT if ZACON ! IS CALLED FROM ZAIRY. ! !***SEE ALSO ZAIRY !***ROUTINES CALLED D1MACH, ZABS, ZASYI, ZBKNU, ZMLRI, ZS1S2, ZSERI !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZACAI ! COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR, & CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI, & RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2) EXTERNAL ZABS DATA PI / 3.14159265358979324D0 / !***FIRST EXECUTABLE STATEMENT ZACAI NZ = 0 ZNR = -ZR ZNI = -ZI AZ = ZABS(ZR,ZI) NN = N DFNU = FNU + (N-1) if (AZ <= 2.0D0) go to 10 if (AZ*AZ*0.25D0 > DFNU+1.0D0) go to 20 10 CONTINUE !----------------------------------------------------------------------- ! POWER SERIES FOR THE I FUNCTION !----------------------------------------------------------------------- call ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM) go to 40 20 CONTINUE if (AZ < RL) go to 30 !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION !----------------------------------------------------------------------- call ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM, & ALIM) if (NW < 0) go to 80 go to 40 30 CONTINUE !----------------------------------------------------------------------- ! MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION !----------------------------------------------------------------------- call ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL) if ( NW < 0) go to 80 40 CONTINUE !----------------------------------------------------------------------- ! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION !----------------------------------------------------------------------- call ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM) if (NW /= 0) go to 80 FMR = MR SGN = -DSIGN(PI,FMR) CSGNR = 0.0D0 CSGNI = SGN if (KODE == 1) go to 50 YY = -ZNI CSGNR = -CSGNI*SIN(YY) CSGNI = CSGNI*COS(YY) 50 CONTINUE !----------------------------------------------------------------------- ! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE !----------------------------------------------------------------------- INU = FNU ARG = (FNU-INU)*SGN CSPNR = COS(ARG) CSPNI = SIN(ARG) if (MOD(INU,2) == 0) go to 60 CSPNR = -CSPNR CSPNI = -CSPNI 60 CONTINUE C1R = CYR(1) C1I = CYI(1) C2R = YR(1) C2I = YI(1) if (KODE == 1) go to 70 IUF = 0 ASCLE = 1.0D+3*D1MACH(1)/TOL call ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW 70 CONTINUE YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R return 80 CONTINUE NZ = -1 if ( NW == (-2)) NZ=-2 return end subroutine ZACON (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, & TOL, ELIM, ALIM) ! !! ZACON is subsidiary to ZBESH and ZBESK ! !***LIBRARY SLATEC !***TYPE ALL (CACON-A, ZACON-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA ! ! K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) ! MP=PI*MR*CMPLX(0.0,1.0) ! ! TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT ! HALF Z PLANE ! !***SEE ALSO ZBESH, ZBESK !***ROUTINES CALLED D1MACH, ZABS, ZBINU, ZBKNU, ZMLT, ZS1S2 !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZACON ! COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, ! *S1,S2,Y,Z,ZN DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, & CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, & CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, & FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, & SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, & YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3) EXTERNAL ZABS DATA PI / 3.14159265358979324D0 / DATA ZEROR,CONER / 0.0D0,1.0D0 / !***FIRST EXECUTABLE STATEMENT ZACON NZ = 0 ZNR = -ZR ZNI = -ZI NN = N call ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, & ELIM, ALIM) if (NW < 0) go to 90 !----------------------------------------------------------------------- ! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION !----------------------------------------------------------------------- NN = MIN(2,N) call ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) if (NW /= 0) go to 90 S1R = CYR(1) S1I = CYI(1) FMR = MR SGN = -DSIGN(PI,FMR) CSGNR = ZEROR CSGNI = SGN if (KODE == 1) go to 10 YY = -ZNI CPN = COS(YY) SPN = SIN(YY) call ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI) 10 CONTINUE !----------------------------------------------------------------------- ! CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE !----------------------------------------------------------------------- INU = FNU ARG = (FNU-INU)*SGN CPN = COS(ARG) SPN = SIN(ARG) CSPNR = CPN CSPNI = SPN if (MOD(INU,2) == 0) go to 20 CSPNR = -CSPNR CSPNI = -CSPNI 20 CONTINUE IUF = 0 C1R = S1R C1I = S1I C2R = YR(1) C2I = YI(1) ASCLE = 1.0D+3*D1MACH(1)/TOL if (KODE == 1) go to 30 call ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC1R = C1R SC1I = C1I 30 CONTINUE call ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) call ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) YR(1) = STR + PTR YI(1) = STI + PTI if (N == 1) RETURN CSPNR = -CSPNR CSPNI = -CSPNI S2R = CYR(2) S2I = CYI(2) C1R = S2R C1I = S2I C2R = YR(2) C2I = YI(2) if (KODE == 1) go to 40 call ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC2R = C1R SC2I = C1I 40 CONTINUE call ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) call ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) YR(2) = STR + PTR YI(2) = STI + PTI if (N == 2) RETURN CSPNR = -CSPNR CSPNI = -CSPNI AZN = ZABS(ZNR,ZNI) RAZN = 1.0D0/AZN STR = ZNR*RAZN STI = -ZNI*RAZN RZR = (STR+STR)*RAZN RZI = (STI+STI)*RAZN FN = FNU + 1.0D0 CKR = FN*RZR CKI = FN*RZI !----------------------------------------------------------------------- ! SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS !----------------------------------------------------------------------- CSCL = 1.0D0/TOL CSCR = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CSCR CSRR(1) = CSCR CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = ASCLE BRY(2) = 1.0D0/ASCLE BRY(3) = D1MACH(2) AS2 = ZABS(S2R,S2I) KFLAG = 2 if (AS2 > BRY(1)) go to 50 KFLAG = 1 go to 60 50 CONTINUE if (AS2 < BRY(2)) go to 60 KFLAG = 3 60 CONTINUE BSCLE = BRY(KFLAG) S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) CSR = CSRR(KFLAG) DO 80 I=3,N STR = S2R STI = S2I S2R = CKR*STR - CKI*STI + S1R S2I = CKR*STI + CKI*STR + S1I S1R = STR S1I = STI C1R = S2R*CSR C1I = S2I*CSR STR = C1R STI = C1I C2R = YR(I) C2I = YI(I) if (KODE == 1) go to 70 if (IUF < 0) go to 70 call ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) NZ = NZ + NW SC1R = SC2R SC1I = SC2I SC2R = C1R SC2I = C1I if (IUF /= 3) go to 70 IUF = -4 S1R = SC1R*CSSR(KFLAG) S1I = SC1I*CSSR(KFLAG) S2R = SC2R*CSSR(KFLAG) S2I = SC2I*CSSR(KFLAG) STR = SC2R STI = SC2I 70 CONTINUE PTR = CSPNR*C1R - CSPNI*C1I PTI = CSPNR*C1I + CSPNI*C1R YR(I) = PTR + CSGNR*C2R - CSGNI*C2I YI(I) = PTI + CSGNR*C2I + CSGNI*C2R CKR = CKR + RZR CKI = CKI + RZI CSPNR = -CSPNR CSPNI = -CSPNI if (KFLAG >= 3) go to 80 PTR = ABS(C1R) PTI = ABS(C1I) C1M = MAX(PTR,PTI) if (C1M <= BSCLE) go to 80 KFLAG = KFLAG + 1 BSCLE = BRY(KFLAG) S1R = S1R*CSR S1I = S1I*CSR S2R = STR S2I = STI S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) CSR = CSRR(KFLAG) 80 CONTINUE return 90 CONTINUE NZ = -1 if ( NW == (-2)) NZ=-2 return end subroutine ZAIRY (ZR, ZI, ID, KODE, AIR, AII, NZ, IERR) ! !! ZAIRY computes the Airy function Ai(z) or its derivative dAi/dz ... ! for complex argument z. A scaling option is available ... ! to help avoid underflow and overflow. ! !***LIBRARY SLATEC !***CATEGORY C10D !***TYPE COMPLEX (CAIRY-C, ZAIRY-C) !***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, ! BESSEL FUNCTION OF ORDER TWO THIRDS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ***A DOUBLE PRECISION ROUTINE*** ! On KODE=1, ZAIRY computes the complex Airy function Ai(z) ! or its derivative dAi/dz on ID=0 or ID=1 respectively. On ! KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz ! is provided to remove the exponential decay in -pi/31 and from power series when abs(z)<=1. ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z is large, losses ! of significance by argument reduction occur. Consequently, if ! the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), ! then losses exceeding half precision are likely and an error ! flag IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is ! double precision unit roundoff limited to 18 digits precision. ! Also, if the magnitude of ZETA is larger than U2=0.5/UR, then ! all significance is lost and IERR=4. In order to use the INT ! function, ZETA must be further restricted not to exceed ! U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA ! must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, ! and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single ! precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. ! This makes U2 limiting is single precision and U3 limiting ! in double precision. This means that the magnitude of Z ! cannot exceed approximately 3.4E+4 in single precision and ! 2.1E+6 in double precision. This also means that one can ! expect to retain, in the worst cases on 32-bit machines, ! no digits in single precision and only 6 digits in double ! precision. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 3. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 4. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACAI, ZBKNU, ZEXP, ZSQRT !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) ! 930122 Added ZEXP and ZSQRT to EXTERNAL statement. (RWC) !***END PROLOGUE ZAIRY ! COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK, & CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG, & DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR, & S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI, & ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH DIMENSION CYR(1), CYI(1) EXTERNAL ZABS, ZEXP, ZSQRT DATA TTH, C1, C2, COEF /6.66666666666666667D-01, & 3.55028053887817240D-01,2.58819403792806799D-01, & 1.83776298473930683D-01/ DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/ !***FIRST EXECUTABLE STATEMENT ZAIRY IERR = 0 NZ=0 if (ID < 0 .OR. ID > 1) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (IERR /= 0) RETURN AZ = ZABS(ZR,ZI) TOL = MAX(D1MACH(4),1.0D-18) FID = ID if (AZ > 1.0D0) go to 70 !----------------------------------------------------------------------- ! POWER SERIES FOR ABS(Z) <= 1. !----------------------------------------------------------------------- S1R = CONER S1I = CONEI S2R = CONER S2I = CONEI if (AZ < TOL) go to 170 AA = AZ*AZ if (AA < TOL/AZ) go to 40 TRM1R = CONER TRM1I = CONEI TRM2R = CONER TRM2I = CONEI ATRM = 1.0D0 STR = ZR*ZR - ZI*ZI STI = ZR*ZI + ZI*ZR Z3R = STR*ZR - STI*ZI Z3I = STR*ZI + STI*ZR AZ3 = AZ*AA AK = 2.0D0 + FID BK = 3.0D0 - FID - FID CK = 4.0D0 - FID DK = 3.0D0 + FID + FID D1 = AK*DK D2 = BK*CK AD = MIN(D1,D2) AK = 24.0D0 + 9.0D0*FID BK = 30.0D0 - 9.0D0*FID DO 30 K=1,25 STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 TRM1R = STR S1R = S1R + TRM1R S1I = S1I + TRM1I STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 TRM2R = STR S2R = S2R + TRM2R S2I = S2I + TRM2I ATRM = ATRM*AZ3/AD D1 = D1 + AK D2 = D2 + BK AD = MIN(D1,D2) if (ATRM < TOL*AD) go to 40 AK = AK + 18.0D0 BK = BK + 18.0D0 30 CONTINUE 40 CONTINUE if (ID == 1) go to 50 AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I) AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R) if (KODE == 1) RETURN call ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) call ZEXP(ZTAR, ZTAI, STR, STI) PTR = AIR*STR - AII*STI AII = AIR*STI + AII*STR AIR = PTR return 50 CONTINUE AIR = -S2R*C2 AII = -S2I*C2 if (AZ <= TOL) go to 60 STR = ZR*S1R - ZI*S1I STI = ZR*S1I + ZI*S1R CC = C1/(1.0D0+FID) AIR = AIR + CC*(STR*ZR-STI*ZI) AII = AII + CC*(STR*ZI+STI*ZR) 60 CONTINUE if (KODE == 1) RETURN call ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) call ZEXP(ZTAR, ZTAI, STR, STI) PTR = STR*AIR - STI*AII AII = STR*AII + STI*AIR AIR = PTR return !----------------------------------------------------------------------- ! CASE FOR ABS(Z) > 1.0 !----------------------------------------------------------------------- 70 CONTINUE FNU = (1.0D0+FID)/3.0D0 !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). !----------------------------------------------------------------------- K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + MAX(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 ALAZ = LOG(AZ) !----------------------------------------------------------------------- ! TEST FOR PROPER RANGE !----------------------------------------------------------------------- AA=0.5D0/TOL BB=I1MACH(9)*0.5D0 AA=MIN(AA,BB) AA=AA**TTH if (AZ > AA) go to 260 AA=SQRT(AA) if (AZ > AA) IERR=3 call ZSQRT(ZR, ZI, CSQR, CSQI) ZTAR = TTH*(ZR*CSQR-ZI*CSQI) ZTAI = TTH*(ZR*CSQI+ZI*CSQR) !----------------------------------------------------------------------- ! RE(ZTA) <= 0 WHEN RE(Z) < 0, ESPECIALLY WHEN IM(Z) IS SMALL !----------------------------------------------------------------------- IFLAG = 0 SFAC = 1.0D0 AK = ZTAI if (ZR >= 0.0D0) go to 80 BK = ZTAR CK = -ABS(BK) ZTAR = CK ZTAI = AK 80 CONTINUE if (ZI /= 0.0D0) go to 90 if (ZR > 0.0D0) go to 90 ZTAR = 0.0D0 ZTAI = AK 90 CONTINUE AA = ZTAR if (AA >= 0.0D0 .AND. ZR > 0.0D0) go to 110 if (KODE == 2) go to 100 !----------------------------------------------------------------------- ! OVERFLOW TEST !----------------------------------------------------------------------- if (AA > (-ALIM)) go to 100 AA = -AA + 0.25D0*ALAZ IFLAG = 1 SFAC = TOL if (AA > ELIM) go to 270 100 CONTINUE !----------------------------------------------------------------------- ! CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 !----------------------------------------------------------------------- MR = 1 if (ZI < 0.0D0) MR = -1 call ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL, & ELIM, ALIM) if (NN < 0) go to 280 NZ = NZ + NN go to 130 110 CONTINUE if (KODE == 2) go to 120 !----------------------------------------------------------------------- ! UNDERFLOW TEST !----------------------------------------------------------------------- if (AA < ALIM) go to 120 AA = -AA - 0.25D0*ALAZ IFLAG = 2 SFAC = 1.0D0/TOL if (AA < (-ELIM)) go to 210 120 CONTINUE call ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM, & ALIM) 130 CONTINUE S1R = CYR(1)*COEF S1I = CYI(1)*COEF if (IFLAG /= 0) go to 150 if (ID == 1) go to 140 AIR = CSQR*S1R - CSQI*S1I AII = CSQR*S1I + CSQI*S1R return 140 CONTINUE AIR = -(ZR*S1R-ZI*S1I) AII = -(ZR*S1I+ZI*S1R) return 150 CONTINUE S1R = S1R*SFAC S1I = S1I*SFAC if (ID == 1) go to 160 STR = S1R*CSQR - S1I*CSQI S1I = S1R*CSQI + S1I*CSQR S1R = STR AIR = S1R/SFAC AII = S1I/SFAC return 160 CONTINUE STR = -(S1R*ZR-S1I*ZI) S1I = -(S1R*ZI+S1I*ZR) S1R = STR AIR = S1R/SFAC AII = S1I/SFAC return 170 CONTINUE AA = 1.0D+3*D1MACH(1) S1R = ZEROR S1I = ZEROI if (ID == 1) go to 190 if (AZ <= AA) go to 180 S1R = C2*ZR S1I = C2*ZI 180 CONTINUE AIR = C1 - S1R AII = -S1I return 190 CONTINUE AIR = -C2 AII = 0.0D0 AA = SQRT(AA) if (AZ <= AA) go to 200 S1R = 0.5D0*(ZR*ZR-ZI*ZI) S1I = ZR*ZI 200 CONTINUE AIR = AIR + C1*S1R AII = AII + C1*S1I return 210 CONTINUE NZ = 1 AIR = ZEROR AII = ZEROI return 270 CONTINUE NZ = 0 IERR=2 return 280 CONTINUE if ( NN == (-1)) go to 270 NZ=0 IERR=5 return 260 CONTINUE IERR=4 NZ=0 return end subroutine ZASYI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, & ALIM) ! !! ZASYI is subsidiary to ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CASYI-A, ZASYI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z) >= 0.0 BY ! MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE ABS(Z) IN THE ! REGION ABS(Z) > MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. ! NZ < 0 INDICATES AN OVERFLOW ON KODE=1. ! !***SEE ALSO ZBESI, ZBESK !***ROUTINES CALLED D1MACH, ZABS, ZDIV, ZEXP, ZMLT, ZSQRT !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 930122 Added ZEXP and ZSQRT to EXTERNAL statement. (RWC) !***END PROLOGUE ZASYI ! COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL, & AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI, & CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I, & P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I, & S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ DIMENSION YR(N), YI(N) EXTERNAL ZABS, ZEXP, ZSQRT DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 / DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / !***FIRST EXECUTABLE STATEMENT ZASYI NZ = 0 AZ = ZABS(ZR,ZI) ARM = 1.0D+3*D1MACH(1) RTR1 = SQRT(ARM) IL = MIN(2,N) DFNU = FNU + (N-IL) !----------------------------------------------------------------------- ! OVERFLOW TEST !----------------------------------------------------------------------- RAZ = 1.0D0/AZ STR = ZR*RAZ STI = -ZI*RAZ AK1R = RTPI*STR*RAZ AK1I = RTPI*STI*RAZ call ZSQRT(AK1R, AK1I, AK1R, AK1I) CZR = ZR CZI = ZI if (KODE /= 2) go to 10 CZR = ZEROR CZI = ZI 10 CONTINUE if (ABS(CZR) > ELIM) go to 100 DNU2 = DFNU + DFNU KODED = 1 if ((ABS(CZR) > ALIM) .AND. (N > 2)) go to 20 KODED = 0 call ZEXP(CZR, CZI, STR, STI) call ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I) 20 CONTINUE FDN = 0.0D0 if (DNU2 > RTR1) FDN = DNU2*DNU2 EZR = ZR*8.0D0 EZI = ZI*8.0D0 !----------------------------------------------------------------------- ! WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE ! FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE ! EXPANSION FOR THE IMAGINARY PART. !----------------------------------------------------------------------- AEZ = 8.0D0*AZ S = TOL/AEZ JL = RL+RL + 2 P1R = ZEROR P1I = ZEROI if (ZI == 0.0D0) go to 30 !----------------------------------------------------------------------- ! CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF ! SIGNIFICANCE WHEN FNU OR N IS LARGE !----------------------------------------------------------------------- INU = FNU ARG = (FNU-INU)*PI INU = INU + N - IL AK = -SIN(ARG) BK = COS(ARG) if (ZI < 0.0D0) BK = -BK P1R = AK P1I = BK if (MOD(INU,2) == 0) go to 30 P1R = -P1R P1I = -P1I 30 CONTINUE DO 70 K=1,IL SQK = FDN - 1.0D0 ATOL = S*ABS(SQK) SGN = 1.0D0 CS1R = CONER CS1I = CONEI CS2R = CONER CS2I = CONEI CKR = CONER CKI = CONEI AK = 0.0D0 AA = 1.0D0 BB = AEZ DKR = EZR DKI = EZI DO 40 J=1,JL call ZDIV(CKR, CKI, DKR, DKI, STR, STI) CKR = STR*SQK CKI = STI*SQK CS2R = CS2R + CKR CS2I = CS2I + CKI SGN = -SGN CS1R = CS1R + CKR*SGN CS1I = CS1I + CKI*SGN DKR = DKR + EZR DKI = DKI + EZI AA = AA*ABS(SQK)/BB BB = BB + AEZ AK = AK + 8.0D0 SQK = SQK - AK if (AA <= ATOL) go to 50 40 CONTINUE go to 110 50 CONTINUE S2R = CS1R S2I = CS1I if (ZR+ZR >= ELIM) go to 60 TZR = ZR + ZR TZI = ZI + ZI call ZEXP(-TZR, -TZI, STR, STI) call ZMLT(STR, STI, P1R, P1I, STR, STI) call ZMLT(STR, STI, CS2R, CS2I, STR, STI) S2R = S2R + STR S2I = S2I + STI 60 CONTINUE FDN = FDN + 8.0D0*DFNU + 4.0D0 P1R = -P1R P1I = -P1I M = N - IL + K YR(M) = S2R*AK1R - S2I*AK1I YI(M) = S2R*AK1I + S2I*AK1R 70 CONTINUE if (N <= 2) RETURN NN = N K = NN - 2 AK = K STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ IB = 3 DO 80 I=IB,NN YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) AK = AK - 1.0D0 K = K - 1 80 CONTINUE if (KODED == 0) RETURN call ZEXP(CZR, CZI, CKR, CKI) DO 90 I=1,NN STR = YR(I)*CKR - YI(I)*CKI YI(I) = YR(I)*CKI + YI(I)*CKR YR(I) = STR 90 CONTINUE return 100 CONTINUE NZ = -1 return 110 CONTINUE NZ=-2 return end subroutine ZBESH (ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR) ! !! ZBESH computes a sequence of the Hankel functions H(m,a,z) ... ! for superscript m=1 or 2, real nonnegative orders a=b, ... ! b+1,... where b>0, and nonzero complex argument z. A ... ! scaling option is available to help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CBESH-C, ZBESH-C) !***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, ! BESSEL FUNCTIONS OF THE THIRD KIND, H BESSEL FUNCTIONS, ! HANKEL FUNCTIONS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ***A DOUBLE PRECISION ROUTINE*** ! On KODE=1, ZBESH computes an N member sequence of complex ! Hankel (Bessel) functions CY(L)=H(M,FNU+L-1,Z) for super- ! script M=1 or 2, real nonnegative orders FNU+L-1, L=1,..., ! N, and complex nonzero Z in the cut plane -pi=0 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! CY(L)=H(M,FNU+L-1,Z), L=1,...,N ! =2 returns ! CY(L)=H(M,FNU+L-1,Z)*exp(-(3-2M)*Z*i), ! L=1,...,N ! M - Superscript of Hankel function, M=1 or 2 ! N - Number of terms in the sequence, N>=1 ! ! Output ! CYR - DOUBLE PRECISION real part of result vector ! CYI - DOUBLE PRECISION imag part of result vector ! NZ - Number of underflows set to zero ! NZ=0 Normal return ! NZ>0 CY(L)=0 for NZ values of L (if M=1 and ! Im(Z)>0 or if M=2 and Im(Z)<0, then ! CY(L)=0 for L=1,...,NZ; in the com- ! plementary half planes, the underflows ! may not be in an uninterrupted sequence) ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (abs(Z) too small and/or FNU+N-1 ! too large) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has half precision or less ! because abs(Z) or FNU+N-1 is large) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision because ! abs(Z) or FNU+N-1 is too large) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! The computation is carried out by the formula ! ! H(m,a,z) = (1/t)*exp(-a*t)*K(a,z*exp(-t)) ! t = (3-2*m)*i*pi/2 ! ! where the K Bessel function is computed as described in the ! prologue to CBESK. ! ! Exponential decay of H(m,a,z) occurs in the upper half z ! plane for m=1 and the lower half z plane for m=2. Exponential ! growth occurs in the complementary half planes. Scaling ! by exp(-(3-2*m)*z*i) removes the exponential behavior in the ! whole z plane as z goes to infinity. ! ! For negative orders, the formula ! ! H(m,-a,z) = H(m,a,z)*exp((3-2*m)*a*pi*i) ! ! can be used. ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z or FNU+N-1 is ! large, losses of significance by argument reduction occur. ! Consequently, if either one exceeds U1=SQRT(0.5/UR), then ! losses exceeding half precision are likely and an error flag ! IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double ! precision unit roundoff limited to 18 digits precision. Also, ! if either is larger than U2=0.5/UR, then all significance is ! lost and IERR=4. In order to use the INT function, arguments ! must be further restricted not to exceed the largest machine ! integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 ! is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and ! U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision ! and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This ! makes U2 limiting in single precision and U3 limiting in ! double precision. This means that one can expect to retain, ! in the worst cases on IEEE machines, no digits in single pre- ! cision and only 6 digits in double precision. Similar con- ! siderations hold for other machines. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument, Report SAND83-0086, Sandia National ! Laboratories, Albuquerque, NM, May 1983. ! 3. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 4. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 5. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACON, ZBKNU, ZBUNK, ZUOIK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE ZBESH ! ! COMPLEX CY,Z,ZN,ZT,CSGN DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, & FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI, & ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI, & CSGNR, CSGNI INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, & MM, MR, N, NN, NUF, NW, NZ, I1MACH DIMENSION CYR(N), CYI(N) EXTERNAL ZABS ! DATA HPI /1.57079632679489662D0/ ! !***FIRST EXECUTABLE STATEMENT ZBESH IERR = 0 NZ=0 if (ZR == 0.0D0 .AND. ZI == 0.0D0) IERR=1 if (FNU < 0.0D0) IERR=1 if (M < 1 .OR. M > 2) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (N < 1) IERR=1 if (IERR /= 0) RETURN NN = N !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU !----------------------------------------------------------------------- TOL = MAX(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + MAX(-AA,-41.45D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 FN = FNU + (NN-1) MM = 3 - M - M FMM = MM ZNR = FMM*ZI ZNI = -FMM*ZR !----------------------------------------------------------------------- ! TEST FOR PROPER RANGE !----------------------------------------------------------------------- AZ = ZABS(ZR,ZI) AA = 0.5D0/TOL BB = I1MACH(9)*0.5D0 AA = MIN(AA,BB) if (AZ > AA) go to 260 if (FN > AA) go to 260 AA = SQRT(AA) if (AZ > AA) IERR=3 if (FN > AA) IERR=3 !----------------------------------------------------------------------- ! OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE !----------------------------------------------------------------------- UFL = D1MACH(1)*1.0D+3 if (AZ < UFL) go to 230 if (FNU > FNUL) go to 90 if (FN <= 1.0D0) go to 70 if (FN > 2.0D0) go to 60 if (AZ > TOL) go to 70 ARG = 0.5D0*AZ ALN = -FN*LOG(ARG) if (ALN > ELIM) go to 230 go to 70 60 CONTINUE call ZUOIK(ZNR, ZNI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, & ALIM) if (NUF < 0) go to 230 NZ = NZ + NUF NN = NN - NUF !----------------------------------------------------------------------- ! HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK ! if NUF=NN, THEN CY(I)=CZERO FOR ALL I !----------------------------------------------------------------------- if (NN == 0) go to 140 70 CONTINUE if ((ZNR < 0.0D0) .OR. (ZNR == 0.0D0 .AND. ZNI < 0.0D0 .AND. & M == 2)) go to 80 !----------------------------------------------------------------------- ! RIGHT HALF PLANE COMPUTATION, XN >= 0. .AND. (XN /= 0. .OR. ! YN >= 0. .OR. M=1) !----------------------------------------------------------------------- call ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM) go to 110 !----------------------------------------------------------------------- ! LEFT HALF PLANE COMPUTATION !----------------------------------------------------------------------- 80 CONTINUE MR = -MM call ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, & TOL, ELIM, ALIM) if (NW < 0) go to 240 NZ=NW go to 110 90 CONTINUE !----------------------------------------------------------------------- ! UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU > FNUL !----------------------------------------------------------------------- MR = 0 if ((ZNR >= 0.0D0) .AND. (ZNR /= 0.0D0 .OR. ZNI >= 0.0D0 .OR. & M /= 2)) go to 100 MR = -MM if (ZNR /= 0.0D0 .OR. ZNI >= 0.0D0) go to 100 ZNR = -ZNR ZNI = -ZNI 100 CONTINUE call ZBUNK(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, & ALIM) if (NW < 0) go to 240 NZ = NZ + NW 110 CONTINUE !----------------------------------------------------------------------- ! H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) ! ! ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 !----------------------------------------------------------------------- SGN = DSIGN(HPI,-FMM) !----------------------------------------------------------------------- ! CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE !----------------------------------------------------------------------- INU = FNU INUH = INU/2 IR = INU - 2*INUH ARG = (FNU-(INU-IR))*SGN RHPI = 1.0D0/SGN ! ZNI = RHPI*COS(ARG) ! ZNR = -RHPI*SIN(ARG) CSGNI = RHPI*COS(ARG) CSGNR = -RHPI*SIN(ARG) if (MOD(INUH,2) == 0) go to 120 ! ZNR = -ZNR ! ZNI = -ZNI CSGNR = -CSGNR CSGNI = -CSGNI 120 CONTINUE ZTI = -FMM RTOL = 1.0D0/TOL ASCLE = UFL*RTOL DO 130 I=1,NN ! STR = CYR(I)*ZNR - CYI(I)*ZNI ! CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR ! CYR(I) = STR ! STR = -ZNI*ZTI ! ZNI = ZNR*ZTI ! ZNR = STR AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 if (MAX(ABS(AA),ABS(BB)) > ASCLE) go to 135 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 135 CONTINUE STR = AA*CSGNR - BB*CSGNI STI = AA*CSGNI + BB*CSGNR CYR(I) = STR*ATOL CYI(I) = STI*ATOL STR = -CSGNI*ZTI CSGNI = CSGNR*ZTI CSGNR = STR 130 CONTINUE return 140 CONTINUE if (ZNR < 0.0D0) go to 230 return 230 CONTINUE NZ=0 IERR=2 return 240 CONTINUE if ( NW == (-1)) go to 230 NZ=0 IERR=5 return 260 CONTINUE NZ=0 IERR=4 return end subroutine ZBESI (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) ! !! ZBESI computes a sequence of the Bessel functions I(a,z) for ... ! complex argument z and real nonnegative orders a=b,b+1, ... ! b+2,... where b>0. A scaling option is available to ... ! help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10B4 !***TYPE COMPLEX (CBESI-C, ZBESI-C) !***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, I BESSEL FUNCTIONS, ! MODIFIED BESSEL FUNCTIONS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ***A DOUBLE PRECISION ROUTINE*** ! On KODE=1, ZBESI computes an N-member sequence of complex ! Bessel functions CY(L)=I(FNU+L-1,Z) for real nonnegative ! orders FNU+L-1, L=1,...,N and complex Z in the cut plane ! -pi=0 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! CY(L)=I(FNU+L-1,Z), L=1,...,N ! =2 returns ! CY(L)=exp(-abs(X))*I(FNU+L-1,Z), L=1,...,N ! where X=Re(Z) ! N - Number of terms in the sequence, N>=1 ! ! Output ! CYR - DOUBLE PRECISION real part of result vector ! CYI - DOUBLE PRECISION imag part of result vector ! NZ - Number of underflows set to zero ! NZ=0 Normal return ! NZ>0 CY(L)=0, L=N-NZ+1,...,N ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (Re(Z) too large on KODE=1) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has half precision or less ! because abs(Z) or FNU+N-1 is large) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision because ! abs(Z) or FNU+N-1 is too large) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! The computation of I(a,z) is carried out by the power series ! for small abs(z), the asymptotic expansion for large abs(z), ! the Miller algorithm normalized by the Wronskian and a ! Neumann series for intermediate magnitudes of z, and the ! uniform asymptotic expansions for I(a,z) and J(a,z) for ! large orders a. Backward recurrence is used to generate ! sequences or reduce orders when necessary. ! ! The calculations above are done in the right half plane and ! continued into the left half plane by the formula ! ! I(a,z*exp(t)) = exp(t*a)*I(a,z), Re(z)>0 ! t = i*pi or -i*pi ! ! For negative orders, the formula ! ! I(-a,z) = I(a,z) + (2/pi)*sin(pi*a)*K(a,z) ! ! can be used. However, for large orders close to integers the ! the function changes radically. When a is a large positive ! integer, the magnitude of I(-a,z)=I(a,z) is a large ! negative power of ten. But when a is not an integer, ! K(a,z) dominates in magnitude with a large positive power of ! ten and the most that the second term can be reduced is by ! unit roundoff from the coefficient. Thus, wide changes can ! occur within unit roundoff of a large integer for a. Here, ! large means a>abs(z). ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z or FNU+N-1 is ! large, losses of significance by argument reduction occur. ! Consequently, if either one exceeds U1=SQRT(0.5/UR), then ! losses exceeding half precision are likely and an error flag ! IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double ! precision unit roundoff limited to 18 digits precision. Also, ! if either is larger than U2=0.5/UR, then all significance is ! lost and IERR=4. In order to use the INT function, arguments ! must be further restricted not to exceed the largest machine ! integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 ! is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and ! U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision ! and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This ! makes U2 limiting in single precision and U3 limiting in ! double precision. This means that one can expect to retain, ! in the worst cases on IEEE machines, no digits in single pre- ! cision and only 6 digits in double precision. Similar con- ! siderations hold for other machines. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument, Report SAND83-0086, Sandia National ! Laboratories, Albuquerque, NM, May 1983. ! 3. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 4. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 5. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZBINU !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE ZBESI ! COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN DOUBLE PRECISION AA, ALIM, ARG, CONEI, CONER, CSGNI, CSGNR, CYI, & CYR, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, & ZR, D1MACH, AZ, BB, FN, ZABS, ASCLE, RTOL, ATOL, STI INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN, I1MACH DIMENSION CYR(N), CYI(N) EXTERNAL ZABS DATA PI /3.14159265358979324D0/ DATA CONER, CONEI /1.0D0,0.0D0/ ! !***FIRST EXECUTABLE STATEMENT ZBESI IERR = 0 NZ=0 if (FNU < 0.0D0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (N < 1) IERR=1 if (IERR /= 0) RETURN !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. !----------------------------------------------------------------------- TOL = MAX(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + MAX(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) !----------------------------------------------------------------------- ! TEST FOR PROPER RANGE !----------------------------------------------------------------------- AZ = ZABS(ZR,ZI) FN = FNU+(N-1) AA = 0.5D0/TOL BB=I1MACH(9)*0.5D0 AA = MIN(AA,BB) if (AZ > AA) go to 260 if (FN > AA) go to 260 AA = SQRT(AA) if (AZ > AA) IERR=3 if (FN > AA) IERR=3 ZNR = ZR ZNI = ZI CSGNR = CONER CSGNI = CONEI if (ZR >= 0.0D0) go to 40 ZNR = -ZR ZNI = -ZI !----------------------------------------------------------------------- ! CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE !----------------------------------------------------------------------- INU = FNU ARG = (FNU-INU)*PI if (ZI < 0.0D0) ARG = -ARG CSGNR = COS(ARG) CSGNI = SIN(ARG) if (MOD(INU,2) == 0) go to 40 CSGNR = -CSGNR CSGNI = -CSGNI 40 CONTINUE call ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, & ELIM, ALIM) if (NZ < 0) go to 120 if (ZR >= 0.0D0) RETURN !----------------------------------------------------------------------- ! ANALYTIC CONTINUATION TO THE LEFT HALF PLANE !----------------------------------------------------------------------- NN = N - NZ if (NN == 0) RETURN RTOL = 1.0D0/TOL ASCLE = D1MACH(1)*RTOL*1.0D+3 DO 50 I=1,NN ! STR = CYR(I)*CSGNR - CYI(I)*CSGNI ! CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR ! CYR(I) = STR AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 if (MAX(ABS(AA),ABS(BB)) > ASCLE) go to 55 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 55 CONTINUE STR = AA*CSGNR - BB*CSGNI STI = AA*CSGNI + BB*CSGNR CYR(I) = STR*ATOL CYI(I) = STI*ATOL CSGNR = -CSGNR CSGNI = -CSGNI 50 CONTINUE return 120 CONTINUE if ( NZ == (-2)) go to 130 NZ = 0 IERR=2 return 130 CONTINUE NZ=0 IERR=5 return 260 CONTINUE NZ=0 IERR=4 return end subroutine ZBESJ (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) ! !! ZBESJ computes a sequence of the Bessel functions J(a,z) for ... ! complex argument z and real nonnegative orders a=b,b+1, ... ! b+2,... where b>0. A scaling option is available to ... ! help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CBESJ-C, ZBESJ-C) !***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, ! BESSEL FUNCTIONS OF THE FIRST KIND, J BESSEL FUNCTIONS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ***A DOUBLE PRECISION ROUTINE*** ! On KODE=1, ZBESJ computes an N member sequence of complex ! Bessel functions CY(L)=J(FNU+L-1,Z) for real nonnegative ! orders FNU+L-1, L=1,...,N and complex Z in the cut plane ! -pi=0 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! CY(L)=J(FNU+L-1,Z), L=1,...,N ! =2 returns ! CY(L)=J(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N ! where Y=Im(Z) ! N - Number of terms in the sequence, N>=1 ! ! Output ! CYR - DOUBLE PRECISION real part of result vector ! CYI - DOUBLE PRECISION imag part of result vector ! NZ - Number of underflows set to zero ! NZ=0 Normal return ! NZ>0 CY(L)=0, L=N-NZ+1,...,N ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (Im(Z) too large on KODE=1) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has half precision or less ! because abs(Z) or FNU+N-1 is large) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision because ! abs(Z) or FNU+N-1 is too large) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! The computation is carried out by the formulae ! ! J(a,z) = exp( a*pi*i/2)*I(a,-i*z), Im(z)>=0 ! ! J(a,z) = exp(-a*pi*i/2)*I(a, i*z), Im(z)<0 ! ! where the I Bessel function is computed as described in the ! prologue to CBESI. ! ! For negative orders, the formula ! ! J(-a,z) = J(a,z)*cos(a*pi) - Y(a,z)*sin(a*pi) ! ! can be used. However, for large orders close to integers, the ! the function changes radically. When a is a large positive ! integer, the magnitude of J(-a,z)=J(a,z)*cos(a*pi) is a ! large negative power of ten. But when a is not an integer, ! Y(a,z) dominates in magnitude with a large positive power of ! ten and the most that the second term can be reduced is by ! unit roundoff from the coefficient. Thus, wide changes can ! occur within unit roundoff of a large integer for a. Here, ! large means a>abs(z). ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z or FNU+N-1 is ! large, losses of significance by argument reduction occur. ! Consequently, if either one exceeds U1=SQRT(0.5/UR), then ! losses exceeding half precision are likely and an error flag ! IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double ! precision unit roundoff limited to 18 digits precision. Also, ! if either is larger than U2=0.5/UR, then all significance is ! lost and IERR=4. In order to use the INT function, arguments ! must be further restricted not to exceed the largest machine ! integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 ! is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and ! U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision ! and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This ! makes U2 limiting in single precision and U3 limiting in ! double precision. This means that one can expect to retain, ! in the worst cases on IEEE machines, no digits in single pre- ! cision and only 6 digits in double precision. Similar con- ! siderations hold for other machines. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument, Report SAND83-0086, Sandia National ! Laboratories, Albuquerque, NM, May 1983. ! 3. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 4. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 5. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZBINU !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE ZBESJ ! ! COMPLEX CI,CSGN,CY,Z,ZN DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG, & ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR, & D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH DIMENSION CYR(N), CYI(N) EXTERNAL ZABS DATA HPI /1.57079632679489662D0/ ! !***FIRST EXECUTABLE STATEMENT ZBESJ IERR = 0 NZ=0 if (FNU < 0.0D0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (N < 1) IERR=1 if (IERR /= 0) RETURN !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. !----------------------------------------------------------------------- TOL = MAX(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + MAX(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) !----------------------------------------------------------------------- ! TEST FOR PROPER RANGE !----------------------------------------------------------------------- AZ = ZABS(ZR,ZI) FN = FNU+(N-1) AA = 0.5D0/TOL BB = I1MACH(9)*0.5D0 AA = MIN(AA,BB) if (AZ > AA) go to 260 if (FN > AA) go to 260 AA = SQRT(AA) if (AZ > AA) IERR=3 if (FN > AA) IERR=3 !----------------------------------------------------------------------- ! CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE ! WHEN FNU IS LARGE !----------------------------------------------------------------------- CII = 1.0D0 INU = FNU INUH = INU/2 IR = INU - 2*INUH ARG = (FNU-(INU-IR))*HPI CSGNR = COS(ARG) CSGNI = SIN(ARG) if (MOD(INUH,2) == 0) go to 40 CSGNR = -CSGNR CSGNI = -CSGNI 40 CONTINUE !----------------------------------------------------------------------- ! ZN IS IN THE RIGHT HALF PLANE !----------------------------------------------------------------------- ZNR = ZI ZNI = -ZR if (ZI >= 0.0D0) go to 50 ZNR = -ZNR ZNI = -ZNI CSGNI = -CSGNI CII = -CII 50 CONTINUE call ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, & ELIM, ALIM) if (NZ < 0) go to 130 NL = N - NZ if (NL == 0) RETURN RTOL = 1.0D0/TOL ASCLE = D1MACH(1)*RTOL*1.0D+3 DO 60 I=1,NL ! STR = CYR(I)*CSGNR - CYI(I)*CSGNI ! CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR ! CYR(I) = STR AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 if (MAX(ABS(AA),ABS(BB)) > ASCLE) go to 55 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 55 CONTINUE STR = AA*CSGNR - BB*CSGNI STI = AA*CSGNI + BB*CSGNR CYR(I) = STR*ATOL CYI(I) = STI*ATOL STR = -CSGNI*CII CSGNI = CSGNR*CII CSGNR = STR 60 CONTINUE return 130 CONTINUE if ( NZ == (-2)) go to 140 NZ = 0 IERR = 2 return 140 CONTINUE NZ=0 IERR=5 return 260 CONTINUE NZ=0 IERR=4 return end subroutine ZBESK (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) ! !! ZBESK computes a sequence of the Bessel functions K(a,z) for ... ! complex argument z and real nonnegative orders a=b,b+1, ... ! b+2,... where b>0. A scaling option is available to ... ! help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10B4 !***TYPE COMPLEX (CBESK-C, ZBESK-C) !***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, K BESSEL FUNCTIONS, ! MODIFIED BESSEL FUNCTIONS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ***A DOUBLE PRECISION ROUTINE*** ! On KODE=1, ZBESK computes an N member sequence of complex ! Bessel functions CY(L)=K(FNU+L-1,Z) for real nonnegative ! orders FNU+L-1, L=1,...,N and complex Z /= 0 in the cut ! plane -pi=0 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! CY(L)=K(FNU+L-1,Z), L=1,...,N ! =2 returns ! CY(L)=K(FNU+L-1,Z)*EXP(Z), L=1,...,N ! N - Number of terms in the sequence, N>=1 ! ! Output ! CYR - DOUBLE PRECISION real part of result vector ! CYI - DOUBLE PRECISION imag part of result vector ! NZ - Number of underflows set to zero ! NZ=0 Normal return ! NZ>0 CY(L)=0 for NZ values of L (if Re(Z)>0 ! then CY(L)=0 for L=1,...,NZ; in the ! complementary half plane the underflows ! may not be in an uninterrupted sequence) ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (abs(Z) too small and/or FNU+N-1 ! too large) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has half precision or less ! because abs(Z) or FNU+N-1 is large) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision because ! abs(Z) or FNU+N-1 is too large) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! Equations of the reference are implemented to compute K(a,z) ! for small orders a and a+1 in the right half plane Re(z)>=0. ! Forward recurrence generates higher orders. The formula ! ! K(a,z*exp((t)) = exp(-t)*K(a,z) - t*I(a,z), Re(z)>0 ! t = i*pi or -i*pi ! ! continues K to the left half plane. ! ! For large orders, K(a,z) is computed by means of its uniform ! asymptotic expansion. ! ! For negative orders, the formula ! ! K(-a,z) = K(a,z) ! ! can be used. ! ! CBESK assumes that a significant digit sinh function is ! available. ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z or FNU+N-1 is ! large, losses of significance by argument reduction occur. ! Consequently, if either one exceeds U1=SQRT(0.5/UR), then ! losses exceeding half precision are likely and an error flag ! IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double ! precision unit roundoff limited to 18 digits precision. Also, ! if either is larger than U2=0.5/UR, then all significance is ! lost and IERR=4. In order to use the INT function, arguments ! must be further restricted not to exceed the largest machine ! integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 ! is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and ! U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision ! and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This ! makes U2 limiting in single precision and U3 limiting in ! double precision. This means that one can expect to retain, ! in the worst cases on IEEE machines, no digits in single pre- ! cision and only 6 digits in double precision. Similar con- ! siderations hold for other machines. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument, Report SAND83-0086, Sandia National ! Laboratories, Albuquerque, NM, May 1983. ! 3. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 4. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 5. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACON, ZBKNU, ZBUNK, ZUOIK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE ZBESK ! ! COMPLEX CY,Z DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, FN, & FNU, FNUL, RL, R1M5, TOL, UFL, ZI, ZR, D1MACH, ZABS, BB INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH DIMENSION CYR(N), CYI(N) EXTERNAL ZABS !***FIRST EXECUTABLE STATEMENT ZBESK IERR = 0 NZ=0 if (ZI == 0.0E0 .AND. ZR == 0.0E0) IERR=1 if (FNU < 0.0D0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (N < 1) IERR=1 if (IERR /= 0) RETURN NN = N !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU !----------------------------------------------------------------------- TOL = MAX(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + MAX(-AA,-41.45D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 !----------------------------------------------------------------------- ! TEST FOR PROPER RANGE !----------------------------------------------------------------------- AZ = ZABS(ZR,ZI) FN = FNU + (NN-1) AA = 0.5D0/TOL BB = I1MACH(9)*0.5D0 AA = MIN(AA,BB) if (AZ > AA) go to 260 if (FN > AA) go to 260 AA = SQRT(AA) if (AZ > AA) IERR=3 if (FN > AA) IERR=3 !----------------------------------------------------------------------- ! OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE !----------------------------------------------------------------------- ! UFL = EXP(-ELIM) UFL = D1MACH(1)*1.0D+3 if (AZ < UFL) go to 180 if (FNU > FNUL) go to 80 if (FN <= 1.0D0) go to 60 if (FN > 2.0D0) go to 50 if (AZ > TOL) go to 60 ARG = 0.5D0*AZ ALN = -FN*LOG(ARG) if (ALN > ELIM) go to 180 go to 60 50 CONTINUE call ZUOIK(ZR, ZI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, & ALIM) if (NUF < 0) go to 180 NZ = NZ + NUF NN = NN - NUF !----------------------------------------------------------------------- ! HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK ! if NUF=NN, THEN CY(I)=CZERO FOR ALL I !----------------------------------------------------------------------- if (NN == 0) go to 100 60 CONTINUE if (ZR < 0.0D0) go to 70 !----------------------------------------------------------------------- ! RIGHT HALF PLANE COMPUTATION, REAL(Z) >= 0. !----------------------------------------------------------------------- call ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) if (NW < 0) go to 200 NZ=NW return !----------------------------------------------------------------------- ! LEFT HALF PLANE COMPUTATION ! PI/2 < ARG(Z) <= PI AND -PI < ARG(Z) < -PI/2. !----------------------------------------------------------------------- 70 CONTINUE if (NZ /= 0) go to 180 MR = 1 if (ZI < 0.0D0) MR = -1 call ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, & TOL, ELIM, ALIM) if (NW < 0) go to 200 NZ=NW return !----------------------------------------------------------------------- ! UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU > FNUL !----------------------------------------------------------------------- 80 CONTINUE MR = 0 if (ZR >= 0.0D0) go to 90 MR = 1 if (ZI < 0.0D0) MR = -1 90 CONTINUE call ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, & ALIM) if (NW < 0) go to 200 NZ = NZ + NW return 100 CONTINUE if (ZR < 0.0D0) go to 180 return 180 CONTINUE NZ = 0 IERR=2 return 200 CONTINUE if ( NW == (-1)) go to 180 NZ=0 IERR=5 return 260 CONTINUE NZ=0 IERR=4 return end subroutine ZBESY (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, & CWRKI, IERR) ! !! ZBESY computes a sequence of the Bessel functions Y(a,z) for ... ! complex argument z and real nonnegative orders a=b,b+1, ... ! b+2,... where b>0. A scaling option is available to ... ! help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CBESY-C, ZBESY-C) !***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, ! BESSEL FUNCTIONS OF SECOND KIND, WEBER'S FUNCTION, ! Y BESSEL FUNCTIONS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ***A DOUBLE PRECISION ROUTINE*** ! On KODE=1, ZBESY computes an N member sequence of complex ! Bessel functions CY(L)=Y(FNU+L-1,Z) for real nonnegative ! orders FNU+L-1, L=1,...,N and complex Z in the cut plane ! -pi=0 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! CY(L)=Y(FNU+L-1,Z), L=1,...,N ! =2 returns ! CY(L)=Y(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N ! where Y=Im(Z) ! N - Number of terms in the sequence, N>=1 ! CWRKR - DOUBLE PRECISION work vector of dimension N ! CWRKI - DOUBLE PRECISION work vector of dimension N ! ! Output ! CYR - DOUBLE PRECISION real part of result vector ! CYI - DOUBLE PRECISION imag part of result vector ! NZ - Number of underflows set to zero ! NZ=0 Normal return ! NZ>0 CY(L)=0 for NZ values of L, usually on ! KODE=2 (the underflows may not be in an ! uninterrupted sequence) ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (abs(Z) too small and/or FNU+N-1 ! too large) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has half precision or less ! because abs(Z) or FNU+N-1 is large) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision because ! abs(Z) or FNU+N-1 is too large) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! The computation is carried out by the formula ! ! Y(a,z) = (H(1,a,z) - H(2,a,z))/(2*i) ! ! where the Hankel functions are computed as described in CBESH. ! ! For negative orders, the formula ! ! Y(-a,z) = Y(a,z)*cos(a*pi) + J(a,z)*sin(a*pi) ! ! can be used. However, for large orders close to half odd ! integers the function changes radically. When a is a large ! positive half odd integer, the magnitude of Y(-a,z)=J(a,z)* ! sin(a*pi) is a large negative power of ten. But when a is ! not a half odd integer, Y(a,z) dominates in magnitude with a ! large positive power of ten and the most that the second term ! can be reduced is by unit roundoff from the coefficient. ! Thus, wide changes can occur within unit roundoff of a large ! half odd integer. Here, large means a>abs(z). ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z or FNU+N-1 is ! large, losses of significance by argument reduction occur. ! Consequently, if either one exceeds U1=SQRT(0.5/UR), then ! losses exceeding half precision are likely and an error flag ! IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double ! precision unit roundoff limited to 18 digits precision. Also, ! if either is larger than U2=0.5/UR, then all significance is ! lost and IERR=4. In order to use the INT function, arguments ! must be further restricted not to exceed the largest machine ! integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 ! is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and ! U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision ! and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This ! makes U2 limiting in single precision and U3 limiting in ! double precision. This means that one can expect to retain, ! in the worst cases on IEEE machines, no digits in single pre- ! cision and only 6 digits in double precision. Similar con- ! siderations hold for other machines. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument, Report SAND83-0086, Sandia National ! Laboratories, Albuquerque, NM, May 1983. ! 3. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 4. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 5. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED D1MACH, I1MACH, ZBESH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) !***END PROLOGUE ZBESY ! ! COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV DOUBLE PRECISION CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2R, & ELIM, EXI, EXR, EY, FNU, HCII, STI, STR, TAY, ZI, ZR, & D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL, R1M5 INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N) !***FIRST EXECUTABLE STATEMENT ZBESY IERR = 0 NZ=0 if (ZR == 0.0D0 .AND. ZI == 0.0D0) IERR=1 if (FNU < 0.0D0) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (N < 1) IERR=1 if (IERR /= 0) RETURN HCII = 0.5D0 call ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR) if (IERR /= 0.AND.IERR /= 3) go to 170 call ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR) if (IERR /= 0.AND.IERR /= 3) go to 170 NZ = MIN(NZ1,NZ2) if (KODE == 2) go to 60 DO 50 I=1,N STR = CWRKR(I) - CYR(I) STI = CWRKI(I) - CYI(I) CYR(I) = -STI*HCII CYI(I) = STR*HCII 50 CONTINUE return 60 CONTINUE TOL = MAX(D1MACH(4),1.0D-18) K1 = I1MACH(15) K2 = I1MACH(16) K = MIN(ABS(K1),ABS(K2)) R1M5 = D1MACH(5) !----------------------------------------------------------------------- ! ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT !----------------------------------------------------------------------- ELIM = 2.303D0*(K*R1M5-3.0D0) EXR = COS(ZR) EXI = SIN(ZR) EY = 0.0D0 TAY = ABS(ZI+ZI) if (TAY < ELIM) EY = EXP(-TAY) if (ZI < 0.0D0) go to 90 C1R = EXR*EY C1I = EXI*EY C2R = EXR C2I = -EXI 70 CONTINUE NZ = 0 RTOL = 1.0D0/TOL ASCLE = D1MACH(1)*RTOL*1.0D+3 DO 80 I=1,N ! STR = C1R*CYR(I) - C1I*CYI(I) ! STI = C1R*CYI(I) + C1I*CYR(I) ! STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I) ! STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I) ! CYR(I) = -STI*HCII ! CYI(I) = STR*HCII AA = CWRKR(I) BB = CWRKI(I) ATOL = 1.0D0 if (MAX(ABS(AA),ABS(BB)) > ASCLE) go to 75 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 75 CONTINUE STR = (AA*C2R - BB*C2I)*ATOL STI = (AA*C2I + BB*C2R)*ATOL AA = CYR(I) BB = CYI(I) ATOL = 1.0D0 if (MAX(ABS(AA),ABS(BB)) > ASCLE) go to 85 AA = AA*RTOL BB = BB*RTOL ATOL = TOL 85 CONTINUE STR = STR - (AA*C1R - BB*C1I)*ATOL STI = STI - (AA*C1I + BB*C1R)*ATOL CYR(I) = -STI*HCII CYI(I) = STR*HCII if (STR == 0.0D0 .AND. STI == 0.0D0 .AND. EY == 0.0D0) NZ = NZ & + 1 80 CONTINUE return 90 CONTINUE C1R = EXR C1I = EXI C2R = EXR*EY C2I = -EXI*EY go to 70 170 CONTINUE NZ = 0 return end subroutine ZBINU (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, & TOL, ELIM, ALIM) ! !! ZBINU is subsidiary to ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK and ZBIRY. ! !***LIBRARY SLATEC !***TYPE ALL (CBINU-A, ZBINU-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE ! !***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBIRY !***ROUTINES CALLED ZABS, ZASYI, ZBUNI, ZMLRI, ZSERI, ZUOIK, ZWRSK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZBINU DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU, & FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ DIMENSION CYR(N), CYI(N), CWR(2), CWI(2) EXTERNAL ZABS DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / !***FIRST EXECUTABLE STATEMENT ZBINU NZ = 0 AZ = ZABS(ZR,ZI) NN = N DFNU = FNU + (N-1) if (AZ <= 2.0D0) go to 10 if (AZ*AZ*0.25D0 > DFNU+1.0D0) go to 20 10 CONTINUE !----------------------------------------------------------------------- ! POWER SERIES !----------------------------------------------------------------------- call ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) INW = ABS(NW) NZ = NZ + INW NN = NN - INW if (NN == 0) RETURN if (NW >= 0) go to 120 DFNU = FNU + (NN-1) 20 CONTINUE if (AZ < RL) go to 40 if (DFNU <= 1.0D0) go to 30 if (AZ+AZ < DFNU*DFNU) go to 50 !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR LARGE Z !----------------------------------------------------------------------- 30 CONTINUE call ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM, & ALIM) if (NW < 0) go to 130 go to 120 40 CONTINUE if (DFNU <= 1.0D0) go to 70 50 CONTINUE !----------------------------------------------------------------------- ! OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM !----------------------------------------------------------------------- call ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM, & ALIM) if (NW < 0) go to 130 NZ = NZ + NW NN = NN - NW if (NN == 0) RETURN DFNU = FNU+(NN-1) if (DFNU > FNUL) go to 110 if (AZ > FNUL) go to 110 60 CONTINUE if (AZ > RL) go to 80 70 CONTINUE !----------------------------------------------------------------------- ! MILLER ALGORITHM NORMALIZED BY THE SERIES !----------------------------------------------------------------------- call ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL) if ( NW < 0) go to 130 go to 120 80 CONTINUE !----------------------------------------------------------------------- ! MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN !----------------------------------------------------------------------- !----------------------------------------------------------------------- ! OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN !----------------------------------------------------------------------- call ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM, & ALIM) if (NW >= 0) go to 100 NZ = NN DO 90 I=1,NN CYR(I) = ZEROR CYI(I) = ZEROI 90 CONTINUE return 100 CONTINUE if (NW > 0) go to 130 call ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL, & ELIM, ALIM) if (NW < 0) go to 130 go to 120 110 CONTINUE !----------------------------------------------------------------------- ! INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD !----------------------------------------------------------------------- NUI = FNUL-DFNU + 1 NUI = MAX(NUI,0) call ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL, & TOL, ELIM, ALIM) if (NW < 0) go to 130 NZ = NZ + NW if (NLAST == 0) go to 120 NN = NLAST go to 60 120 CONTINUE return 130 CONTINUE NZ = -1 if ( NW == (-2)) NZ=-2 return end subroutine ZBIRY (ZR, ZI, ID, KODE, BIR, BII, IERR) ! !! ZBIRY computes the Airy function Bi(z) or its derivative dBi/dz ... ! for complex argument z. A scaling option is available ... ! to help avoid overflow. ! !***LIBRARY SLATEC !***CATEGORY C10D !***TYPE COMPLEX (CBIRY-C, ZBIRY-C) !***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, ! BESSEL FUNCTION OF ORDER TWO THIRDS !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ***A DOUBLE PRECISION ROUTINE*** ! On KODE=1, ZBIRY computes the complex Airy function Bi(z) ! or its derivative dBi/dz on ID=0 or ID=1 respectively. ! On KODE=2, a scaling option exp(abs(Re(zeta)))*Bi(z) or ! exp(abs(Re(zeta)))*dBi/dz is provided to remove the ! exponential behavior in both the left and right half planes ! where zeta=(2/3)*z**(3/2). ! ! The Airy functions Bi(z) and dBi/dz are analytic in the ! whole z-plane, and the scaling option does not destroy this ! property. ! ! Input ! ZR - DOUBLE PRECISION real part of argument Z ! ZI - DOUBLE PRECISION imag part of argument Z ! ID - Order of derivative, ID=0 or ID=1 ! KODE - A parameter to indicate the scaling option ! KODE=1 returns ! BI=Bi(z) on ID=0 ! BI=dBi/dz on ID=1 ! at z=Z ! =2 returns ! BI=exp(abs(Re(zeta)))*Bi(z) on ID=0 ! BI=exp(abs(Re(zeta)))*dBi/dz on ID=1 ! at z=Z where zeta=(2/3)*z**(3/2) ! ! Output ! BIR - DOUBLE PRECISION real part of result ! BII - DOUBLE PRECISION imag part of result ! IERR - Error flag ! IERR=0 Normal return - COMPUTATION COMPLETED ! IERR=1 Input error - NO COMPUTATION ! IERR=2 Overflow - NO COMPUTATION ! (Re(Z) too large with KODE=1) ! IERR=3 Precision warning - COMPUTATION COMPLETED ! (Result has less than half precision) ! IERR=4 Precision error - NO COMPUTATION ! (Result has no precision) ! IERR=5 Algorithmic error - NO COMPUTATION ! (Termination condition not met) ! ! *Long Description: ! ! Bi(z) and dBi/dz are computed from I Bessel functions by ! ! Bi(z) = c*sqrt(z)*( I(-1/3,zeta) + I(1/3,zeta) ) ! dBi/dz = c* z *( I(-2/3,zeta) + I(2/3,zeta) ) ! c = 1/sqrt(3) ! zeta = (2/3)*z**(3/2) ! ! when abs(z)>1 and from power series when abs(z)<=1. ! ! In most complex variable computation, one must evaluate ele- ! mentary functions. When the magnitude of Z is large, losses ! of significance by argument reduction occur. Consequently, if ! the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), ! then losses exceeding half precision are likely and an error ! flag IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is ! double precision unit roundoff limited to 18 digits precision. ! Also, if the magnitude of ZETA is larger than U2=0.5/UR, then ! all significance is lost and IERR=4. In order to use the INT ! function, ZETA must be further restricted not to exceed ! U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA ! must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, ! and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single ! precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. ! This makes U2 limiting is single precision and U3 limiting ! in double precision. This means that the magnitude of Z ! cannot exceed approximately 3.4E+4 in single precision and ! 2.1E+6 in double precision. This also means that one can ! expect to retain, in the worst cases on 32-bit machines, ! no digits in single precision and only 6 digits in double ! precision. ! ! The approximate relative error in the magnitude of a complex ! Bessel function can be expressed as P*10**S where P=MAX(UNIT ! ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- ! sents the increase in error due to argument reduction in the ! elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), ! ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF ! ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may ! have only absolute accuracy. This is most likely to occur ! when one component (in magnitude) is larger than the other by ! several orders of magnitude. If one component is 10**K larger ! than the other, then one can expect only MAX(ABS(LOG10(P))-K, ! 0) significant digits; or, stated another way, when K exceeds ! the exponent of P, no significant digits remain in the smaller ! component. However, the phase angle retains absolute accuracy ! because, in complex arithmetic with precision P, the smaller ! component will not (as a rule) decrease below P times the ! magnitude of the larger component. In these extreme cases, ! the principal phase angle is on the order of +P, -P, PI/2-P, ! or -PI/2+P. ! !***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- ! matical Functions, National Bureau of Standards ! Applied Mathematics Series 55, U. S. Department ! of Commerce, Tenth Printing (1972) or later. ! 2. D. E. Amos, Computation of Bessel Functions of ! Complex Argument and Large Order, Report SAND83-0643, ! Sandia National Laboratories, Albuquerque, NM, May ! 1983. ! 3. D. E. Amos, A Subroutine Package for Bessel Functions ! of a Complex Argument and Nonnegative Order, Report ! SAND85-1018, Sandia National Laboratory, Albuquerque, ! NM, May 1985. ! 4. D. E. Amos, A portable package for Bessel functions ! of a complex argument and nonnegative order, ACM ! Transactions on Mathematical Software, 12 (September ! 1986), pp. 265-273. ! !***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZBINU, ZDIV, ZSQRT !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890801 REVISION DATE from Version 3.2 ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 920128 Category corrected. (WRB) ! 920811 Prologue revised. (DWL) ! 930122 Added ZSQRT to EXTERNAL statement. (RWC) !***END PROLOGUE ZBIRY ! COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR, & BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, & DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, & SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, & TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH DIMENSION CYR(2), CYI(2) EXTERNAL ZABS, ZSQRT DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01, & 6.14926627446000736D-01,4.48288357353826359D-01, & 5.77350269189625765D-01,3.14159265358979324D+00/ DATA CONER, CONEI /1.0D0,0.0D0/ !***FIRST EXECUTABLE STATEMENT ZBIRY IERR = 0 NZ=0 if (ID < 0 .OR. ID > 1) IERR=1 if (KODE < 1 .OR. KODE > 2) IERR=1 if (IERR /= 0) RETURN AZ = ZABS(ZR,ZI) TOL = MAX(D1MACH(4),1.0D-18) FID = ID if (AZ > 1.0E0) go to 70 !----------------------------------------------------------------------- ! POWER SERIES FOR ABS(Z) <= 1. !----------------------------------------------------------------------- S1R = CONER S1I = CONEI S2R = CONER S2I = CONEI if (AZ < TOL) go to 130 AA = AZ*AZ if (AA < TOL/AZ) go to 40 TRM1R = CONER TRM1I = CONEI TRM2R = CONER TRM2I = CONEI ATRM = 1.0D0 STR = ZR*ZR - ZI*ZI STI = ZR*ZI + ZI*ZR Z3R = STR*ZR - STI*ZI Z3I = STR*ZI + STI*ZR AZ3 = AZ*AA AK = 2.0D0 + FID BK = 3.0D0 - FID - FID CK = 4.0D0 - FID DK = 3.0D0 + FID + FID D1 = AK*DK D2 = BK*CK AD = MIN(D1,D2) AK = 24.0D0 + 9.0D0*FID BK = 30.0D0 - 9.0D0*FID DO 30 K=1,25 STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 TRM1R = STR S1R = S1R + TRM1R S1I = S1I + TRM1I STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 TRM2R = STR S2R = S2R + TRM2R S2I = S2I + TRM2I ATRM = ATRM*AZ3/AD D1 = D1 + AK D2 = D2 + BK AD = MIN(D1,D2) if (ATRM < TOL*AD) go to 40 AK = AK + 18.0D0 BK = BK + 18.0D0 30 CONTINUE 40 CONTINUE if (ID == 1) go to 50 BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I) BII = C1*S1I + C2*(ZR*S2I+ZI*S2R) if (KODE == 1) RETURN call ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) AA = ZTAR AA = -ABS(AA) EAA = EXP(AA) BIR = BIR*EAA BII = BII*EAA return 50 CONTINUE BIR = S2R*C2 BII = S2I*C2 if (AZ <= TOL) go to 60 CC = C1/(1.0D0+FID) STR = S1R*ZR - S1I*ZI STI = S1R*ZI + S1I*ZR BIR = BIR + CC*(STR*ZR-STI*ZI) BII = BII + CC*(STR*ZI+STI*ZR) 60 CONTINUE if (KODE == 1) RETURN call ZSQRT(ZR, ZI, STR, STI) ZTAR = TTH*(ZR*STR-ZI*STI) ZTAI = TTH*(ZR*STI+ZI*STR) AA = ZTAR AA = -ABS(AA) EAA = EXP(AA) BIR = BIR*EAA BII = BII*EAA return !----------------------------------------------------------------------- ! CASE FOR ABS(Z) > 1.0 !----------------------------------------------------------------------- 70 CONTINUE FNU = (1.0D0+FID)/3.0D0 !----------------------------------------------------------------------- ! SET PARAMETERS RELATED TO MACHINE CONSTANTS. ! TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. ! ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. ! EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL AND ! EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR ! UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. ! RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. ! DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). ! FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. !----------------------------------------------------------------------- K1 = I1MACH(15) K2 = I1MACH(16) R1M5 = D1MACH(5) K = MIN(ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) K1 = I1MACH(14) - 1 AA = R1M5*K1 DIG = MIN(AA,18.0D0) AA = AA*2.303D0 ALIM = ELIM + MAX(-AA,-41.45D0) RL = 1.2D0*DIG + 3.0D0 FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) !----------------------------------------------------------------------- ! TEST FOR RANGE !----------------------------------------------------------------------- AA=0.5D0/TOL BB=I1MACH(9)*0.5D0 AA=MIN(AA,BB) AA=AA**TTH if (AZ > AA) go to 260 AA=SQRT(AA) if (AZ > AA) IERR=3 call ZSQRT(ZR, ZI, CSQR, CSQI) ZTAR = TTH*(ZR*CSQR-ZI*CSQI) ZTAI = TTH*(ZR*CSQI+ZI*CSQR) !----------------------------------------------------------------------- ! RE(ZTA) <= 0 WHEN RE(Z) < 0, ESPECIALLY WHEN IM(Z) IS SMALL !----------------------------------------------------------------------- SFAC = 1.0D0 AK = ZTAI if (ZR >= 0.0D0) go to 80 BK = ZTAR CK = -ABS(BK) ZTAR = CK ZTAI = AK 80 CONTINUE if (ZI /= 0.0D0 .OR. ZR > 0.0D0) go to 90 ZTAR = 0.0D0 ZTAI = AK 90 CONTINUE AA = ZTAR if (KODE == 2) go to 100 !----------------------------------------------------------------------- ! OVERFLOW TEST !----------------------------------------------------------------------- BB = ABS(AA) if (BB < ALIM) go to 100 BB = BB + 0.25D0*LOG(AZ) SFAC = TOL if (BB > ELIM) go to 190 100 CONTINUE FMR = 0.0D0 if (AA >= 0.0D0 .AND. ZR > 0.0D0) go to 110 FMR = PI if (ZI < 0.0D0) FMR = -PI ZTAR = -ZTAR ZTAI = -ZTAI 110 CONTINUE !----------------------------------------------------------------------- ! AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) ! KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBESI !----------------------------------------------------------------------- call ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL, & ELIM, ALIM) if (NZ < 0) go to 200 AA = FMR*FNU Z3R = SFAC STR = COS(AA) STI = SIN(AA) S1R = (STR*CYR(1)-STI*CYI(1))*Z3R S1I = (STR*CYI(1)+STI*CYR(1))*Z3R FNU = (2.0D0-FID)/3.0D0 call ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL, & ELIM, ALIM) CYR(1) = CYR(1)*Z3R CYI(1) = CYI(1)*Z3R CYR(2) = CYR(2)*Z3R CYI(2) = CYI(2)*Z3R !----------------------------------------------------------------------- ! BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 !----------------------------------------------------------------------- call ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI) S2R = (FNU+FNU)*STR + CYR(2) S2I = (FNU+FNU)*STI + CYI(2) AA = FMR*(FNU-1.0D0) STR = COS(AA) STI = SIN(AA) S1R = COEF*(S1R+S2R*STR-S2I*STI) S1I = COEF*(S1I+S2R*STI+S2I*STR) if (ID == 1) go to 120 STR = CSQR*S1R - CSQI*S1I S1I = CSQR*S1I + CSQI*S1R S1R = STR BIR = S1R/SFAC BII = S1I/SFAC return 120 CONTINUE STR = ZR*S1R - ZI*S1I S1I = ZR*S1I + ZI*S1R S1R = STR BIR = S1R/SFAC BII = S1I/SFAC return 130 CONTINUE AA = C1*(1.0D0-FID) + FID*C2 BIR = AA BII = 0.0D0 return 190 CONTINUE IERR=2 NZ=0 return 200 CONTINUE if ( NZ == (-1)) go to 190 NZ=0 IERR=5 return 260 CONTINUE IERR=4 NZ=0 return end subroutine ZBKNU (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, ALIM) ! !! ZBKNU is subsidiary to ZAIRY, ZBESH, ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CBKNU-A, ZBKNU-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. ! !***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESK !***ROUTINES CALLED D1MACH, DGAMLN, I1MACH, ZABS, ZDIV, ZEXP, ZKSCL, ! ZLOG, ZMLT, ZSHCH, ZSQRT, ZUCHK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 930122 Added ZEXP, ZLOG and ZSQRT to EXTERNAL statement. (RWC) !***END PROLOGUE ZBKNU ! DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, & CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER, & CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR, & CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS, & FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI, & PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI, & RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM, & TOL, TTH, T1, T2, YI, YR, ZI, ZR, DGAMLN, D1MACH, ZABS, ELM, & CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ, & IDUM, I1MACH, J, IC, INUB, NW DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2), & CYI(2) EXTERNAL ZABS, ZEXP, ZLOG, ZSQRT ! COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH ! COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK ! DATA KMAX / 30 / DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/ & 0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 / DATA DPI, RTHPI, SPI ,HPI, FPI, TTH / & 3.14159265358979324D0, 1.25331413731550025D0, & 1.90985931710274403D0, 1.57079632679489662D0, & 1.89769999331517738D0, 6.66666666666666666D-01/ DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ & 5.77215664901532861D-01, -4.20026350340952355D-02, & -4.21977345555443367D-02, 7.21894324666309954D-03, & -2.15241674114950973D-04, -2.01348547807882387D-05, & 1.13302723198169588D-06, 6.11609510448141582D-09/ !***FIRST EXECUTABLE STATEMENT ZBKNU CAZ = ZABS(ZR,ZI) CSCLR = 1.0D0/TOL CRSCR = TOL CSSR(1) = CSCLR CSSR(2) = 1.0D0 CSSR(3) = CRSCR CSRR(1) = CRSCR CSRR(2) = 1.0D0 CSRR(3) = CSCLR BRY(1) = 1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) NZ = 0 IFLAG = 0 KODED = KODE RCAZ = 1.0D0/CAZ STR = ZR*RCAZ STI = -ZI*RCAZ RZR = (STR+STR)*RCAZ RZI = (STI+STI)*RCAZ INU = FNU+0.5D0 DNU = FNU - INU if (ABS(DNU) == 0.5D0) go to 110 DNU2 = 0.0D0 if (ABS(DNU) > TOL) DNU2 = DNU*DNU if (CAZ > R1) go to 110 !----------------------------------------------------------------------- ! SERIES FOR ABS(Z) <= R1 !----------------------------------------------------------------------- FC = 1.0D0 call ZLOG(RZR, RZI, SMUR, SMUI, IDUM) FMUR = SMUR*DNU FMUI = SMUI*DNU call ZSHCH(FMUR, FMUI, CSHR, CSHI, CCHR, CCHI) if (DNU == 0.0D0) go to 10 FC = DNU*DPI FC = FC/SIN(FC) SMUR = CSHR/DNU SMUI = CSHI/DNU 10 CONTINUE A2 = 1.0D0 + DNU !----------------------------------------------------------------------- ! GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) !----------------------------------------------------------------------- T2 = EXP(-DGAMLN(A2,IDUM)) T1 = 1.0D0/(T2*FC) if (ABS(DNU) > 0.1D0) go to 40 !----------------------------------------------------------------------- ! SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) !----------------------------------------------------------------------- AK = 1.0D0 S = CC(1) DO 20 K=2,8 AK = AK*DNU2 TM = CC(K)*AK S = S + TM if (ABS(TM) < TOL) go to 30 20 CONTINUE 30 G1 = -S go to 50 40 CONTINUE G1 = (T1-T2)/(DNU+DNU) 50 CONTINUE G2 = (T1+T2)*0.5D0 FR = FC*(CCHR*G1+SMUR*G2) FI = FC*(CCHI*G1+SMUI*G2) call ZEXP(FMUR, FMUI, STR, STI) PR = 0.5D0*STR/T2 PI = 0.5D0*STI/T2 call ZDIV(0.5D0, 0.0D0, STR, STI, PTR, PTI) QR = PTR/T1 QI = PTI/T1 S1R = FR S1I = FI S2R = PR S2I = PI AK = 1.0D0 A1 = 1.0D0 CKR = CONER CKI = CONEI BK = 1.0D0 - DNU2 if (INU > 0 .OR. N > 1) go to 80 !----------------------------------------------------------------------- ! GENERATE K(FNU,Z), 0.0D0 <= FNU < 0.5D0 AND N=1 !----------------------------------------------------------------------- if (CAZ < TOL) go to 70 call ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) CZR = 0.25D0*CZR CZI = 0.25D0*CZI T1 = 0.25D0*CAZ*CAZ 60 CONTINUE FR = (FR*AK+PR+QR)/BK FI = (FI*AK+PI+QI)/BK STR = 1.0D0/(AK-DNU) PR = PR*STR PI = PI*STR STR = 1.0D0/(AK+DNU) QR = QR*STR QI = QI*STR STR = CKR*CZR - CKI*CZI RAK = 1.0D0/AK CKI = (CKR*CZI+CKI*CZR)*RAK CKR = STR*RAK S1R = CKR*FR - CKI*FI + S1R S1I = CKR*FI + CKI*FR + S1I A1 = A1*T1*RAK BK = BK + AK + AK + 1.0D0 AK = AK + 1.0D0 if (A1 > TOL) go to 60 70 CONTINUE YR(1) = S1R YI(1) = S1I if (KODED == 1) RETURN call ZEXP(ZR, ZI, STR, STI) call ZMLT(S1R, S1I, STR, STI, YR(1), YI(1)) return !----------------------------------------------------------------------- ! GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE !----------------------------------------------------------------------- 80 CONTINUE if (CAZ < TOL) go to 100 call ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) CZR = 0.25D0*CZR CZI = 0.25D0*CZI T1 = 0.25D0*CAZ*CAZ 90 CONTINUE FR = (FR*AK+PR+QR)/BK FI = (FI*AK+PI+QI)/BK STR = 1.0D0/(AK-DNU) PR = PR*STR PI = PI*STR STR = 1.0D0/(AK+DNU) QR = QR*STR QI = QI*STR STR = CKR*CZR - CKI*CZI RAK = 1.0D0/AK CKI = (CKR*CZI+CKI*CZR)*RAK CKR = STR*RAK S1R = CKR*FR - CKI*FI + S1R S1I = CKR*FI + CKI*FR + S1I STR = PR - FR*AK STI = PI - FI*AK S2R = CKR*STR - CKI*STI + S2R S2I = CKR*STI + CKI*STR + S2I A1 = A1*T1*RAK BK = BK + AK + AK + 1.0D0 AK = AK + 1.0D0 if (A1 > TOL) go to 90 100 CONTINUE KFLAG = 2 A1 = FNU + 1.0D0 AK = A1*ABS(SMUR) if (AK > ALIM) KFLAG = 3 STR = CSSR(KFLAG) P2R = S2R*STR P2I = S2I*STR call ZMLT(P2R, P2I, RZR, RZI, S2R, S2I) S1R = S1R*STR S1I = S1I*STR if (KODED == 1) go to 210 call ZEXP(ZR, ZI, FR, FI) call ZMLT(S1R, S1I, FR, FI, S1R, S1I) call ZMLT(S2R, S2I, FR, FI, S2R, S2I) go to 210 !----------------------------------------------------------------------- ! IFLAG=0 MEANS NO UNDERFLOW OCCURRED ! IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH ! KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD ! RECURSION !----------------------------------------------------------------------- 110 CONTINUE call ZSQRT(ZR, ZI, STR, STI) call ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI) KFLAG = 2 if (KODED == 2) go to 120 if (ZR > ALIM) go to 290 ! BLANK LINE STR = EXP(-ZR)*CSSR(KFLAG) STI = -STR*SIN(ZI) STR = STR*COS(ZI) call ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI) 120 CONTINUE if (ABS(DNU) == 0.5D0) go to 300 !----------------------------------------------------------------------- ! MILLER ALGORITHM FOR ABS(Z) > R1 !----------------------------------------------------------------------- AK = COS(DPI*DNU) AK = ABS(AK) if (AK == CZEROR) go to 300 FHS = ABS(0.25D0-DNU2) if (FHS == CZEROR) go to 300 !----------------------------------------------------------------------- ! COMPUTE R2=F(E). if ABS(Z) >= R2, USE FORWARD RECURRENCE TO ! DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON ! 12 <= E <= 60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))= ! TOL WHERE B IS THE BASE OF THE ARITHMETIC. !----------------------------------------------------------------------- T1 = I1MACH(14)-1 T1 = T1*D1MACH(5)*3.321928094D0 T1 = MAX(T1,12.0D0) T1 = MIN(T1,60.0D0) T2 = TTH*T1 - 6.0D0 if (ZR /= 0.0D0) go to 130 T1 = HPI go to 140 130 CONTINUE T1 = DATAN(ZI/ZR) T1 = ABS(T1) 140 CONTINUE if (T2 > CAZ) go to 170 !----------------------------------------------------------------------- ! FORWARD RECURRENCE LOOP WHEN ABS(Z) >= R2 !----------------------------------------------------------------------- ETEST = AK/(DPI*CAZ*TOL) FK = CONER if (ETEST < CONER) go to 180 FKS = CTWOR CKR = CAZ + CAZ + CTWOR P1R = CZEROR P2R = CONER DO 150 I=1,KMAX AK = FHS/FKS CBR = CKR/(FK+CONER) PTR = P2R P2R = CBR*P2R - P1R*AK P1R = PTR CKR = CKR + CTWOR FKS = FKS + FK + FK + CTWOR FHS = FHS + FK + FK FK = FK + CONER STR = ABS(P2R)*FK if (ETEST < STR) go to 160 150 CONTINUE go to 310 160 CONTINUE FK = FK + SPI*T1*SQRT(T2/CAZ) FHS = ABS(0.25D0-DNU2) go to 180 170 CONTINUE !----------------------------------------------------------------------- ! COMPUTE BACKWARD INDEX K FOR ABS(Z) < R2 !----------------------------------------------------------------------- A2 = SQRT(CAZ) AK = FPI*AK/(TOL*SQRT(A2)) AA = 3.0D0*T1/(1.0D0+CAZ) BB = 14.7D0*T1/(28.0D0+CAZ) AK = (LOG(AK)+CAZ*COS(AA)/(1.0D0+0.008D0*CAZ))/COS(BB) FK = 0.12125D0*AK*AK/CAZ + 1.5D0 180 CONTINUE !----------------------------------------------------------------------- ! BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM !----------------------------------------------------------------------- K = FK FK = K FKS = FK*FK P1R = CZEROR P1I = CZEROI P2R = TOL P2I = CZEROI CSR = P2R CSI = P2I DO 190 I=1,K A1 = FKS - FK AK = (FKS+FK)/(A1+FHS) RAK = 2.0D0/(FK+CONER) CBR = (FK+ZR)*RAK CBI = ZI*RAK PTR = P2R PTI = P2I P2R = (PTR*CBR-PTI*CBI-P1R)*AK P2I = (PTI*CBR+PTR*CBI-P1I)*AK P1R = PTR P1I = PTI CSR = CSR + P2R CSI = CSI + P2I FKS = A1 - FK + CONER FK = FK - CONER 190 CONTINUE !----------------------------------------------------------------------- ! COMPUTE (P2/CS)=(P2/ABS(CS))*(CONJG(CS)/ABS(CS)) FOR BETTER ! SCALING !----------------------------------------------------------------------- TM = ZABS(CSR,CSI) PTR = 1.0D0/TM S1R = P2R*PTR S1I = P2I*PTR CSR = CSR*PTR CSI = -CSI*PTR call ZMLT(COEFR, COEFI, S1R, S1I, STR, STI) call ZMLT(STR, STI, CSR, CSI, S1R, S1I) if (INU > 0 .OR. N > 1) go to 200 ZDR = ZR ZDI = ZI if ( IFLAG == 1) go to 270 go to 240 200 CONTINUE !----------------------------------------------------------------------- ! COMPUTE P1/P2=(P1/ABS(P2)*CONJG(P2)/ABS(P2) FOR SCALING !----------------------------------------------------------------------- TM = ZABS(P2R,P2I) PTR = 1.0D0/TM P1R = P1R*PTR P1I = P1I*PTR P2R = P2R*PTR P2I = -P2I*PTR call ZMLT(P1R, P1I, P2R, P2I, PTR, PTI) STR = DNU + 0.5D0 - PTR STI = -PTI call ZDIV(STR, STI, ZR, ZI, STR, STI) STR = STR + 1.0D0 call ZMLT(STR, STI, S1R, S1I, S2R, S2I) !----------------------------------------------------------------------- ! FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH ! SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 !----------------------------------------------------------------------- 210 CONTINUE STR = DNU + 1.0D0 CKR = STR*RZR CKI = STR*RZI if (N == 1) INU = INU - 1 if (INU > 0) go to 220 if (N > 1) go to 215 S1R = S2R S1I = S2I 215 CONTINUE ZDR = ZR ZDI = ZI if ( IFLAG == 1) go to 270 go to 240 220 CONTINUE INUB = 1 if ( IFLAG == 1) go to 261 225 CONTINUE P1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 230 I=INUB,INU STR = S2R STI = S2I S2R = CKR*STR - CKI*STI + S1R S2I = CKR*STI + CKI*STR + S1I S1R = STR S1I = STI CKR = CKR + RZR CKI = CKI + RZI if (KFLAG >= 3) go to 230 P2R = S2R*P1R P2I = S2I*P1R STR = ABS(P2R) STI = ABS(P2I) P2M = MAX(STR,STI) if (P2M <= ASCLE) go to 230 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*P1R S1I = S1I*P1R S2R = P2R S2I = P2I STR = CSSR(KFLAG) S1R = S1R*STR S1I = S1I*STR S2R = S2R*STR S2I = S2I*STR P1R = CSRR(KFLAG) 230 CONTINUE if (N /= 1) go to 240 S1R = S2R S1I = S2I 240 CONTINUE STR = CSRR(KFLAG) YR(1) = S1R*STR YI(1) = S1I*STR if (N == 1) RETURN YR(2) = S2R*STR YI(2) = S2I*STR if (N == 2) RETURN KK = 2 250 CONTINUE KK = KK + 1 if (KK > N) RETURN P1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 260 I=KK,N P2R = S2R P2I = S2I S2R = CKR*P2R - CKI*P2I + S1R S2I = CKI*P2R + CKR*P2I + S1I S1R = P2R S1I = P2I CKR = CKR + RZR CKI = CKI + RZI P2R = S2R*P1R P2I = S2I*P1R YR(I) = P2R YI(I) = P2I if (KFLAG >= 3) go to 260 STR = ABS(P2R) STI = ABS(P2I) P2M = MAX(STR,STI) if (P2M <= ASCLE) go to 260 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*P1R S1I = S1I*P1R S2R = P2R S2I = P2I STR = CSSR(KFLAG) S1R = S1R*STR S1I = S1I*STR S2R = S2R*STR S2I = S2I*STR P1R = CSRR(KFLAG) 260 CONTINUE return !----------------------------------------------------------------------- ! IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW !----------------------------------------------------------------------- 261 CONTINUE HELIM = 0.5D0*ELIM ELM = EXP(-ELIM) CELMR = ELM ASCLE = BRY(1) ZDR = ZR ZDI = ZI IC = -1 J = 2 DO 262 I=1,INU STR = S2R STI = S2I S2R = STR*CKR-STI*CKI+S1R S2I = STI*CKR+STR*CKI+S1I S1R = STR S1I = STI CKR = CKR+RZR CKI = CKI+RZI AS = ZABS(S2R,S2I) ALAS = LOG(AS) P2R = -ZDR+ALAS if ( P2R < (-ELIM)) go to 263 call ZLOG(S2R,S2I,STR,STI,IDUM) P2R = -ZDR+STR P2I = -ZDI+STI P2M = EXP(P2R)/TOL P1R = P2M*COS(P2I) P1I = P2M*SIN(P2I) call ZUCHK(P1R,P1I,NW,ASCLE,TOL) if ( NW /= 0) go to 263 J = 3 - J CYR(J) = P1R CYI(J) = P1I if ( IC == (I-1)) go to 264 IC = I go to 262 263 CONTINUE if ( ALAS < HELIM) go to 262 ZDR = ZDR-ELIM S1R = S1R*CELMR S1I = S1I*CELMR S2R = S2R*CELMR S2I = S2I*CELMR 262 CONTINUE if ( N /= 1) go to 270 S1R = S2R S1I = S2I go to 270 264 CONTINUE KFLAG = 1 INUB = I+1 S2R = CYR(J) S2I = CYI(J) J = 3 - J S1R = CYR(J) S1I = CYI(J) if ( INUB <= INU) go to 225 if ( N /= 1) go to 240 S1R = S2R S1I = S2I go to 240 270 CONTINUE YR(1) = S1R YI(1) = S1I if ( N == 1) go to 280 YR(2) = S2R YI(2) = S2I 280 CONTINUE ASCLE = BRY(1) call ZKSCL(ZDR,ZDI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) INU = N - NZ if (INU <= 0) RETURN KK = NZ + 1 S1R = YR(KK) S1I = YI(KK) YR(KK) = S1R*CSRR(1) YI(KK) = S1I*CSRR(1) if (INU == 1) RETURN KK = NZ + 2 S2R = YR(KK) S2I = YI(KK) YR(KK) = S2R*CSRR(1) YI(KK) = S2I*CSRR(1) if (INU == 2) RETURN T2 = FNU + (KK-1) CKR = T2*RZR CKI = T2*RZI KFLAG = 1 go to 250 290 CONTINUE !----------------------------------------------------------------------- ! SCALE BY EXP(Z), IFLAG = 1 CASES !----------------------------------------------------------------------- KODED = 2 IFLAG = 1 KFLAG = 2 go to 120 !----------------------------------------------------------------------- ! FNU=HALF ODD INTEGER CASE, DNU=-0.5 !----------------------------------------------------------------------- 300 CONTINUE S1R = COEFR S1I = COEFI S2R = COEFR S2I = COEFI go to 210 ! ! 310 CONTINUE NZ=-2 return end subroutine ZBUNI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, & FNUL, TOL, ELIM, ALIM) ! !! ZBUNI is subsidiary to ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CBUNI-A, ZBUNI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE ABS(Z) > ! FNUL AND FNU+N-1 < FNUL. THE ORDER IS INCREASED FROM ! FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING ! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) ! ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 ! !***SEE ALSO ZBESI, ZBESK !***ROUTINES CALLED D1MACH, ZABS, ZUNI1, ZUNI2 !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZBUNI ! COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU, & ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R, & S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M, & D1MACH INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3) EXTERNAL ZABS !***FIRST EXECUTABLE STATEMENT ZBUNI NZ = 0 AX = ABS(ZR)*1.7321D0 AY = ABS(ZI) IFORM = 1 if (AY > AX) IFORM = 2 if (NUI == 0) go to 60 FNUI = NUI DFNU = FNU + (N-1) GNU = DFNU + FNUI if (IFORM == 2) go to 10 !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 !----------------------------------------------------------------------- call ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, & ELIM, ALIM) go to 20 10 CONTINUE !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 !----------------------------------------------------------------------- call ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, & ELIM, ALIM) 20 CONTINUE if (NW < 0) go to 50 if (NW /= 0) go to 90 STR = ZABS(CYR(1),CYI(1)) !---------------------------------------------------------------------- ! SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED !---------------------------------------------------------------------- BRY(1)=1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = BRY(2) IFLAG = 2 ASCLE = BRY(2) CSCLR = 1.0D0 if (STR > BRY(1)) go to 21 IFLAG = 1 ASCLE = BRY(1) CSCLR = 1.0D0/TOL go to 25 21 CONTINUE if (STR < BRY(2)) go to 25 IFLAG = 3 ASCLE=BRY(3) CSCLR = TOL 25 CONTINUE CSCRR = 1.0D0/CSCLR S1R = CYR(2)*CSCLR S1I = CYI(2)*CSCLR S2R = CYR(1)*CSCLR S2I = CYI(1)*CSCLR RAZ = 1.0D0/ZABS(ZR,ZI) STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ DO 30 I=1,NUI STR = S2R STI = S2I S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I S1R = STR S1I = STI FNUI = FNUI - 1.0D0 if (IFLAG >= 3) go to 30 STR = S2R*CSCRR STI = S2I*CSCRR C1R = ABS(STR) C1I = ABS(STI) C1M = MAX(C1R,C1I) if (C1M <= ASCLE) go to 30 IFLAG = IFLAG+1 ASCLE = BRY(IFLAG) S1R = S1R*CSCRR S1I = S1I*CSCRR S2R = STR S2I = STI CSCLR = CSCLR*TOL CSCRR = 1.0D0/CSCLR S1R = S1R*CSCLR S1I = S1I*CSCLR S2R = S2R*CSCLR S2I = S2I*CSCLR 30 CONTINUE YR(N) = S2R*CSCRR YI(N) = S2I*CSCRR if (N == 1) RETURN NL = N - 1 FNUI = NL K = NL DO 40 I=1,NL STR = S2R STI = S2I S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I S1R = STR S1I = STI STR = S2R*CSCRR STI = S2I*CSCRR YR(K) = STR YI(K) = STI FNUI = FNUI - 1.0D0 K = K - 1 if (IFLAG >= 3) go to 40 C1R = ABS(STR) C1I = ABS(STI) C1M = MAX(C1R,C1I) if (C1M <= ASCLE) go to 40 IFLAG = IFLAG+1 ASCLE = BRY(IFLAG) S1R = S1R*CSCRR S1I = S1I*CSCRR S2R = STR S2I = STI CSCLR = CSCLR*TOL CSCRR = 1.0D0/CSCLR S1R = S1R*CSCLR S1I = S1I*CSCLR S2R = S2R*CSCLR S2I = S2I*CSCLR 40 CONTINUE return 50 CONTINUE NZ = -1 if ( NW == (-2)) NZ=-2 return 60 CONTINUE if (IFORM == 2) go to 70 !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 !----------------------------------------------------------------------- call ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, & ELIM, ALIM) go to 80 70 CONTINUE !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 !----------------------------------------------------------------------- call ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, & ELIM, ALIM) 80 CONTINUE if (NW < 0) go to 50 NZ = NW return 90 CONTINUE NLAST = N return end subroutine ZBUNK (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, & ALIM) ! !! ZBUNK is subsidiary to ZBESH and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CBUNI-A, ZBUNI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU > FNUL. ! ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) ! IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 ! !***SEE ALSO ZBESH, ZBESK !***ROUTINES CALLED ZUNK1, ZUNK2 !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZBUNK ! COMPLEX Y,Z DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR INTEGER KODE, MR, N, NZ DIMENSION YR(N), YI(N) !***FIRST EXECUTABLE STATEMENT ZBUNK NZ = 0 AX = ABS(ZR)*1.7321D0 AY = ABS(ZI) if (AY > AX) go to 10 !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN ! -PI/3 <= ARG(Z) <= PI/3 !----------------------------------------------------------------------- call ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) go to 20 10 CONTINUE !----------------------------------------------------------------------- ! ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU ! APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I ! AND HPI=PI/2 !----------------------------------------------------------------------- call ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) 20 CONTINUE return end subroutine ZDIV (AR, AI, BR, BI, CR, CI) ! !! ZDIV is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY. ! !***LIBRARY SLATEC !***TYPE ALL (ZDIV-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! DOUBLE PRECISION COMPLEX DIVIDE C=A/B. ! !***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY !***ROUTINES CALLED ZABS !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZDIV DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD DOUBLE PRECISION ZABS EXTERNAL ZABS !***FIRST EXECUTABLE STATEMENT ZDIV BM = 1.0D0/ZABS(BR,BI) CC = BR*BM CD = BI*BM CA = (AR*CC+AI*CD)*BM CB = (AI*CC-AR*CD)*BM CR = CA CI = CB return end subroutine ZEXP (AR, AI, BR, BI) ! !! ZEXP is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY. ! !***LIBRARY SLATEC !***TYPE ALL (ZEXP-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) ! !***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZEXP DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB !***FIRST EXECUTABLE STATEMENT ZEXP ZM = EXP(AR) CA = ZM*COS(AI) CB = ZM*SIN(AI) BR = CA BI = CB return end subroutine ZKSCL (ZRR, ZRI, FNU, N, YR, YI, NZ, RZR, RZI, ASCLE, & TOL, ELIM) ! !! ZKSCL is subsidiary to ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CKSCL-A, ZKSCL-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE ! ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN ! return WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. ! !***SEE ALSO ZBESK !***ROUTINES CALLED ZABS, ZLOG, ZUCHK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 930122 Added ZLOG to EXTERNAL statement. (RWC) !***END PROLOGUE ZKSCL ! COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI, & CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I, & S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS, & ZDR, ZDI, CELMR, ELM, HELIM, ALAS INTEGER I, IC, IDUM, KK, N, NN, NW, NZ DIMENSION YR(N), YI(N), CYR(2), CYI(2) EXTERNAL ZABS, ZLOG DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / !***FIRST EXECUTABLE STATEMENT ZKSCL NZ = 0 IC = 0 NN = MIN(2,N) DO 10 I=1,NN S1R = YR(I) S1I = YI(I) CYR(I) = S1R CYI(I) = S1I AS = ZABS(S1R,S1I) ACS = -ZRR + LOG(AS) NZ = NZ + 1 YR(I) = ZEROR YI(I) = ZEROI if (ACS < (-ELIM)) go to 10 call ZLOG(S1R, S1I, CSR, CSI, IDUM) CSR = CSR - ZRR CSI = CSI - ZRI STR = EXP(CSR)/TOL CSR = STR*COS(CSI) CSI = STR*SIN(CSI) call ZUCHK(CSR, CSI, NW, ASCLE, TOL) if (NW /= 0) go to 10 YR(I) = CSR YI(I) = CSI IC = I NZ = NZ - 1 10 CONTINUE if (N == 1) RETURN if (IC > 1) go to 20 YR(1) = ZEROR YI(1) = ZEROI NZ = 2 20 CONTINUE if (N == 2) RETURN if (NZ == 0) RETURN FN = FNU + 1.0D0 CKR = FN*RZR CKI = FN*RZI S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) HELIM = 0.5D0*ELIM ELM = EXP(-ELIM) CELMR = ELM ZDR = ZRR ZDI = ZRI ! ! FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF ! S2 GETS LARGER THAN EXP(ELIM/2) ! DO 30 I=3,N KK = I CSR = S2R CSI = S2I S2R = CKR*CSR - CKI*CSI + S1R S2I = CKI*CSR + CKR*CSI + S1I S1R = CSR S1I = CSI CKR = CKR + RZR CKI = CKI + RZI AS = ZABS(S2R,S2I) ALAS = LOG(AS) ACS = -ZDR + ALAS NZ = NZ + 1 YR(I) = ZEROR YI(I) = ZEROI if (ACS < (-ELIM)) go to 25 call ZLOG(S2R, S2I, CSR, CSI, IDUM) CSR = CSR - ZDR CSI = CSI - ZDI STR = EXP(CSR)/TOL CSR = STR*COS(CSI) CSI = STR*SIN(CSI) call ZUCHK(CSR, CSI, NW, ASCLE, TOL) if (NW /= 0) go to 25 YR(I) = CSR YI(I) = CSI NZ = NZ - 1 if (IC == KK-1) go to 40 IC = KK go to 30 25 CONTINUE if ( ALAS < HELIM) go to 30 ZDR = ZDR - ELIM S1R = S1R*CELMR S1I = S1I*CELMR S2R = S2R*CELMR S2I = S2I*CELMR 30 CONTINUE NZ = N if ( IC == N) NZ=N-1 go to 45 40 CONTINUE NZ = KK - 2 45 CONTINUE DO 50 I=1,NZ YR(I) = ZEROR YI(I) = ZEROI 50 CONTINUE return end subroutine ZLOG (AR, AI, BR, BI, IERR) ! !! ZLOG is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY. ! !***LIBRARY SLATEC !***TYPE ALL (ZLOG-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) ! IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0) !***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY !***ROUTINES CALLED ZABS !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZLOG DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI DOUBLE PRECISION ZABS INTEGER IERR EXTERNAL ZABS DATA DPI , DHPI / 3.141592653589793238462643383D+0, & 1.570796326794896619231321696D+0/ !***FIRST EXECUTABLE STATEMENT ZLOG IERR=0 if (AR == 0.0D+0) go to 10 if (AI == 0.0D+0) go to 20 DTHETA = DATAN(AI/AR) if (DTHETA <= 0.0D+0) go to 40 if (AR < 0.0D+0) DTHETA = DTHETA - DPI go to 50 10 if (AI == 0.0D+0) go to 60 BI = DHPI BR = LOG(ABS(AI)) if (AI < 0.0D+0) BI = -BI return 20 if (AR > 0.0D+0) go to 30 BR = LOG(ABS(AR)) BI = DPI return 30 BR = LOG(AR) BI = 0.0D+0 return 40 if (AR < 0.0D+0) DTHETA = DTHETA + DPI 50 ZM = ZABS(AR,AI) BR = LOG(ZM) BI = DTHETA return 60 CONTINUE IERR=1 return end subroutine ZMLRI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL) ! !! ZMLRI is subsidiary to ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CMLRI-A, ZMLRI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z) >= 0.0 BY THE ! MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. ! !***SEE ALSO ZBESI, ZBESK !***ROUTINES CALLED D1MACH, DGAMLN, ZABS, ZEXP, ZLOG, ZMLT !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 930122 Added ZEXP and ZLOG to EXTERNAL statement. (RWC) !***END PROLOGUE ZMLRI ! COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI, & CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I, & P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI, & SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN, & D1MACH, ZABS INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ DIMENSION YR(N), YI(N) EXTERNAL ZABS, ZEXP, ZLOG DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / !***FIRST EXECUTABLE STATEMENT ZMLRI SCLE = D1MACH(1)/TOL NZ=0 AZ = ZABS(ZR,ZI) IAZ = AZ IFNU = FNU INU = IFNU + N - 1 AT = IAZ + 1.0D0 RAZ = 1.0D0/AZ STR = ZR*RAZ STI = -ZI*RAZ CKR = STR*AT*RAZ CKI = STI*AT*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ P1R = ZEROR P1I = ZEROI P2R = CONER P2I = CONEI ACK = (AT+1.0D0)*RAZ RHO = ACK + SQRT(ACK*ACK-1.0D0) RHO2 = RHO*RHO TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0)) TST = TST/TOL !----------------------------------------------------------------------- ! COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES !----------------------------------------------------------------------- AK = AT DO 10 I=1,80 PTR = P2R PTI = P2I P2R = P1R - (CKR*PTR-CKI*PTI) P2I = P1I - (CKI*PTR+CKR*PTI) P1R = PTR P1I = PTI CKR = CKR + RZR CKI = CKI + RZI AP = ZABS(P2R,P2I) if (AP > TST*AK*AK) go to 20 AK = AK + 1.0D0 10 CONTINUE go to 110 20 CONTINUE I = I + 1 K = 0 if (INU < IAZ) go to 40 !----------------------------------------------------------------------- ! COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS !----------------------------------------------------------------------- P1R = ZEROR P1I = ZEROI P2R = CONER P2I = CONEI AT = INU + 1.0D0 STR = ZR*RAZ STI = -ZI*RAZ CKR = STR*AT*RAZ CKI = STI*AT*RAZ ACK = AT*RAZ TST = SQRT(ACK/TOL) ITIME = 1 DO 30 K=1,80 PTR = P2R PTI = P2I P2R = P1R - (CKR*PTR-CKI*PTI) P2I = P1I - (CKR*PTI+CKI*PTR) P1R = PTR P1I = PTI CKR = CKR + RZR CKI = CKI + RZI AP = ZABS(P2R,P2I) if (AP < TST) go to 30 if (ITIME == 2) go to 40 ACK = ZABS(CKR,CKI) FLAM = ACK + SQRT(ACK*ACK-1.0D0) FKAP = AP/ZABS(P1R,P1I) RHO = MIN(FLAM,FKAP) TST = TST*SQRT(RHO/(RHO*RHO-1.0D0)) ITIME = 2 30 CONTINUE go to 110 40 CONTINUE !----------------------------------------------------------------------- ! BACKWARD RECURRENCE AND SUM NORMALIZING RELATION !----------------------------------------------------------------------- K = K + 1 KK = MAX(I+IAZ,K+INU) FKK = KK P1R = ZEROR P1I = ZEROI !----------------------------------------------------------------------- ! SCALE P2 AND SUM BY SCLE !----------------------------------------------------------------------- P2R = SCLE P2I = ZEROI FNF = FNU - IFNU TFNF = FNF + FNF BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) - & DGAMLN(TFNF+1.0D0,IDUM) BK = EXP(BK) SUMR = ZEROR SUMI = ZEROI KM = KK - INU DO 50 I=1,KM PTR = P2R PTI = P2I P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) P1R = PTR P1I = PTI AK = 1.0D0 - TFNF/(FKK+TFNF) ACK = BK*AK SUMR = SUMR + (ACK+BK)*P1R SUMI = SUMI + (ACK+BK)*P1I BK = ACK FKK = FKK - 1.0D0 50 CONTINUE YR(N) = P2R YI(N) = P2I if (N == 1) go to 70 DO 60 I=2,N PTR = P2R PTI = P2I P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) P1R = PTR P1I = PTI AK = 1.0D0 - TFNF/(FKK+TFNF) ACK = BK*AK SUMR = SUMR + (ACK+BK)*P1R SUMI = SUMI + (ACK+BK)*P1I BK = ACK FKK = FKK - 1.0D0 M = N - I + 1 YR(M) = P2R YI(M) = P2I 60 CONTINUE 70 CONTINUE if (IFNU <= 0) go to 90 DO 80 I=1,IFNU PTR = P2R PTI = P2I P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR) P1R = PTR P1I = PTI AK = 1.0D0 - TFNF/(FKK+TFNF) ACK = BK*AK SUMR = SUMR + (ACK+BK)*P1R SUMI = SUMI + (ACK+BK)*P1I BK = ACK FKK = FKK - 1.0D0 80 CONTINUE 90 CONTINUE PTR = ZR PTI = ZI if (KODE == 2) PTR = ZEROR call ZLOG(RZR, RZI, STR, STI, IDUM) P1R = -FNF*STR + PTR P1I = -FNF*STI + PTI AP = DGAMLN(1.0D0+FNF,IDUM) PTR = P1R - AP PTI = P1I !----------------------------------------------------------------------- ! THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW ! IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES !----------------------------------------------------------------------- P2R = P2R + SUMR P2I = P2I + SUMI AP = ZABS(P2R,P2I) P1R = 1.0D0/AP call ZEXP(PTR, PTI, STR, STI) CKR = STR*P1R CKI = STI*P1R PTR = P2R*P1R PTI = -P2I*P1R call ZMLT(CKR, CKI, PTR, PTI, CNORMR, CNORMI) DO 100 I=1,N STR = YR(I)*CNORMR - YI(I)*CNORMI YI(I) = YR(I)*CNORMI + YI(I)*CNORMR YR(I) = STR 100 CONTINUE return 110 CONTINUE NZ=-2 return end subroutine ZMLT (AR, AI, BR, BI, CR, CI) ! !! ZMLT is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY. ! !***LIBRARY SLATEC !***TYPE ALL (ZMLT-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. ! !***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZMLT DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB !***FIRST EXECUTABLE STATEMENT ZMLT CA = AR*BR - AI*BI CB = AR*BI + AI*BR CR = CA CI = CB return end subroutine ZRATI (ZR, ZI, FNU, N, CYR, CYI, TOL) ! !! ZRATI is subsidiary to ZBESH, ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CRATI-A, ZRATI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD ! RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD ! RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, ! MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, ! BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, ! BY D. J. SOOKNE. ! !***SEE ALSO ZBESH, ZBESI, ZBESK !***ROUTINES CALLED ZABS, ZDIV !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZRATI DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR, & CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU, & FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI, & RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N DIMENSION CYR(N), CYI(N) EXTERNAL ZABS DATA CZEROR,CZEROI,CONER,CONEI,RT2/ & 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 / !***FIRST EXECUTABLE STATEMENT ZRATI AZ = ZABS(ZR,ZI) INU = FNU IDNU = INU + N - 1 MAGZ = AZ AMAGZ = MAGZ+1 FDNU = IDNU FNUP = MAX(AMAGZ,FDNU) ID = IDNU - MAGZ - 1 ITIME = 1 K = 1 PTR = 1.0D0/AZ RZR = PTR*(ZR+ZR)*PTR RZI = -PTR*(ZI+ZI)*PTR T1R = RZR*FNUP T1I = RZI*FNUP P2R = -T1R P2I = -T1I P1R = CONER P1I = CONEI T1R = T1R + RZR T1I = T1I + RZI if (ID > 0) ID = 0 AP2 = ZABS(P2R,P2I) AP1 = ZABS(P1R,P1I) !----------------------------------------------------------------------- ! THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE call TO CBKNU ! GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT ! P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR ! PREMATURELY. !----------------------------------------------------------------------- ARG = (AP2+AP2)/(AP1*TOL) TEST1 = SQRT(ARG) TEST = TEST1 RAP1 = 1.0D0/AP1 P1R = P1R*RAP1 P1I = P1I*RAP1 P2R = P2R*RAP1 P2I = P2I*RAP1 AP2 = AP2*RAP1 10 CONTINUE K = K + 1 AP1 = AP2 PTR = P2R PTI = P2I P2R = P1R - (T1R*PTR-T1I*PTI) P2I = P1I - (T1R*PTI+T1I*PTR) P1R = PTR P1I = PTI T1R = T1R + RZR T1I = T1I + RZI AP2 = ZABS(P2R,P2I) if (AP1 <= TEST) go to 10 if (ITIME == 2) go to 20 AK = ZABS(T1R,T1I)*0.5D0 FLAM = AK + SQRT(AK*AK-1.0D0) RHO = MIN(AP2/AP1,FLAM) TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0D0)) ITIME = 2 go to 10 20 CONTINUE KK = K + 1 - ID AK = KK T1R = AK T1I = CZEROI DFNU = FNU + (N-1) P1R = 1.0D0/AP2 P1I = CZEROI P2R = CZEROR P2I = CZEROI DO 30 I=1,KK PTR = P1R PTI = P1I RAP1 = DFNU + T1R TTR = RZR*RAP1 TTI = RZI*RAP1 P1R = (PTR*TTR-PTI*TTI) + P2R P1I = (PTR*TTI+PTI*TTR) + P2I P2R = PTR P2I = PTI T1R = T1R - CONER 30 CONTINUE if (P1R /= CZEROR .OR. P1I /= CZEROI) go to 40 P1R = TOL P1I = TOL 40 CONTINUE call ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N)) if (N == 1) RETURN K = N - 1 AK = K T1R = AK T1I = CZEROI CDFNUR = FNU*RZR CDFNUI = FNU*RZI DO 60 I=2,N PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1) PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1) AK = ZABS(PTR,PTI) if (AK /= CZEROR) go to 50 PTR = TOL PTI = TOL AK = TOL*RT2 50 CONTINUE RAK = CONER/AK CYR(K) = RAK*PTR*RAK CYI(K) = -RAK*PTI*RAK T1R = T1R - CONER K = K - 1 60 CONTINUE return end subroutine ZS1S2 (ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, IUF) ! !! ZS1S2 is subsidiary to ZAIRY and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CS1S2-A, ZS1S2-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE ! ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- ! TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. ! ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF ! MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER ! OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE ! PRECISION ABOVE THE UNDERFLOW LIMIT. ! !***SEE ALSO ZAIRY, ZBESK !***ROUTINES CALLED ZABS, ZEXP, ZLOG !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 930122 Added ZEXP and ZLOG to EXTERNAL statement. (RWC) !***END PROLOGUE ZS1S2 ! COMPLEX CZERO,C1,S1,S1D,S2,ZR DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI, & S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS INTEGER IUF, IDUM, NZ EXTERNAL ZABS, ZEXP, ZLOG DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / !***FIRST EXECUTABLE STATEMENT ZS1S2 NZ = 0 AS1 = ZABS(S1R,S1I) AS2 = ZABS(S2R,S2I) if (S1R == 0.0D0 .AND. S1I == 0.0D0) go to 10 if (AS1 == 0.0D0) go to 10 ALN = -ZRR - ZRR + LOG(AS1) S1DR = S1R S1DI = S1I S1R = ZEROR S1I = ZEROI AS1 = ZEROR if (ALN < (-ALIM)) go to 10 call ZLOG(S1DR, S1DI, C1R, C1I, IDUM) C1R = C1R - ZRR - ZRR C1I = C1I - ZRI - ZRI call ZEXP(C1R, C1I, S1R, S1I) AS1 = ZABS(S1R,S1I) IUF = IUF + 1 10 CONTINUE AA = MAX(AS1,AS2) if (AA > ASCLE) RETURN S1R = ZEROR S1I = ZEROI S2R = ZEROR S2I = ZEROI NZ = 1 IUF = 0 return end subroutine ZSERI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, ALIM) ! !! ZSERI is subsidiary to ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CSERI-A, ZSERI-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z) >= 0.0 BY ! MEANS OF THE POWER SERIES FOR LARGE ABS(Z) IN THE ! REGION ABS(Z) <= 2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. ! NZ > 0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO ! DUE TO UNDERFLOW. NZ < 0 MEANS UNDERFLOW OCCURRED, BUT THE ! CONDITION ABS(Z) <= 2*SQRT(FNU+1) WAS VIOLATED AND THE ! COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). ! !***SEE ALSO ZBESI, ZBESK !***ROUTINES CALLED D1MACH, DGAMLN, ZABS, ZDIV, ZLOG, ZMLT, ZUCHK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 930122 Added ZLOG to EXTERNAL statement. (RWC) !***END PROLOGUE ZSERI ! COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL, & AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU, & ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI, & STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI, & ZR, DGAMLN, D1MACH, ZABS INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW DIMENSION YR(N), YI(N), WR(2), WI(2) EXTERNAL ZABS, ZLOG DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / !***FIRST EXECUTABLE STATEMENT ZSERI NZ = 0 AZ = ZABS(ZR,ZI) if (AZ == 0.0D0) go to 160 ARM = 1.0D+3*D1MACH(1) RTR1 = SQRT(ARM) CRSCR = 1.0D0 IFLAG = 0 if (AZ < ARM) go to 150 HZR = 0.5D0*ZR HZI = 0.5D0*ZI CZR = ZEROR CZI = ZEROI if (AZ <= RTR1) go to 10 call ZMLT(HZR, HZI, HZR, HZI, CZR, CZI) 10 CONTINUE ACZ = ZABS(CZR,CZI) NN = N call ZLOG(HZR, HZI, CKR, CKI, IDUM) 20 CONTINUE DFNU = FNU + (NN-1) FNUP = DFNU + 1.0D0 !----------------------------------------------------------------------- ! UNDERFLOW TEST !----------------------------------------------------------------------- AK1R = CKR*DFNU AK1I = CKI*DFNU AK = DGAMLN(FNUP,IDUM) AK1R = AK1R - AK if (KODE == 2) AK1R = AK1R - ZR if (AK1R > (-ELIM)) go to 40 30 CONTINUE NZ = NZ + 1 YR(NN) = ZEROR YI(NN) = ZEROI if (ACZ > DFNU) go to 190 NN = NN - 1 if (NN == 0) RETURN go to 20 40 CONTINUE if (AK1R > (-ALIM)) go to 50 IFLAG = 1 SS = 1.0D0/TOL CRSCR = TOL ASCLE = ARM*SS 50 CONTINUE AA = EXP(AK1R) if (IFLAG == 1) AA = AA*SS COEFR = AA*COS(AK1I) COEFI = AA*SIN(AK1I) ATOL = TOL*ACZ/FNUP IL = MIN(2,NN) DO 90 I=1,IL DFNU = FNU + (NN-I) FNUP = DFNU + 1.0D0 S1R = CONER S1I = CONEI if (ACZ < TOL*FNUP) go to 70 AK1R = CONER AK1I = CONEI AK = FNUP + 2.0D0 S = FNUP AA = 2.0D0 60 CONTINUE RS = 1.0D0/S STR = AK1R*CZR - AK1I*CZI STI = AK1R*CZI + AK1I*CZR AK1R = STR*RS AK1I = STI*RS S1R = S1R + AK1R S1I = S1I + AK1I S = S + AK AK = AK + 2.0D0 AA = AA*ACZ*RS if (AA > ATOL) go to 60 70 CONTINUE S2R = S1R*COEFR - S1I*COEFI S2I = S1R*COEFI + S1I*COEFR WR(I) = S2R WI(I) = S2I if (IFLAG == 0) go to 80 call ZUCHK(S2R, S2I, NW, ASCLE, TOL) if (NW /= 0) go to 30 80 CONTINUE M = NN - I + 1 YR(M) = S2R*CRSCR YI(M) = S2I*CRSCR if (I == IL) go to 90 call ZDIV(COEFR, COEFI, HZR, HZI, STR, STI) COEFR = STR*DFNU COEFI = STI*DFNU 90 CONTINUE if (NN <= 2) RETURN K = NN - 2 AK = K RAZ = 1.0D0/AZ STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ if (IFLAG == 1) go to 120 IB = 3 100 CONTINUE DO 110 I=IB,NN YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) AK = AK - 1.0D0 K = K - 1 110 CONTINUE return !----------------------------------------------------------------------- ! RECUR BACKWARD WITH SCALED VALUES !----------------------------------------------------------------------- 120 CONTINUE !----------------------------------------------------------------------- ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE ! UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 !----------------------------------------------------------------------- S1R = WR(1) S1I = WI(1) S2R = WR(2) S2I = WI(2) DO 130 L=3,NN CKR = S2R CKI = S2I S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI) S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR) S1R = CKR S1I = CKI CKR = S2R*CRSCR CKI = S2I*CRSCR YR(K) = CKR YI(K) = CKI AK = AK - 1.0D0 K = K - 1 if (ZABS(CKR,CKI) > ASCLE) go to 140 130 CONTINUE return 140 CONTINUE IB = L + 1 if (IB > NN) RETURN go to 100 150 CONTINUE NZ = N if (FNU == 0.0D0) NZ = NZ - 1 160 CONTINUE YR(1) = ZEROR YI(1) = ZEROI if (FNU /= 0.0D0) go to 170 YR(1) = CONER YI(1) = CONEI 170 CONTINUE if (N == 1) RETURN DO 180 I=2,N YR(I) = ZEROR YI(I) = ZEROI 180 CONTINUE return !----------------------------------------------------------------------- ! return WITH NZ < 0 if ABS(Z*Z/4) > FNU+N-NZ-1 COMPLETE ! THE CALCULATION IN CBINU WITH N=N-ABS(NZ) !----------------------------------------------------------------------- 190 CONTINUE NZ = -NZ return end subroutine ZSHCH (ZR, ZI, CSHR, CSHI, CCHR, CCHI) ! !! ZSHCH is subsidiary to ZBESH and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CSHCH-A, ZSHCH-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) ! AND CCH=COSH(X+I*Y), WHERE I**2=-1. ! !***SEE ALSO ZBESH, ZBESK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZSHCH ! DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR !***FIRST EXECUTABLE STATEMENT ZSHCH SH = SINH(ZR) CH = COSH(ZR) SN = SIN(ZI) CN = COS(ZI) CSHR = SH*CN CSHI = CH*SN CCHR = CH*CN CCHI = SH*SN return end subroutine ZSQRT (AR, AI, BR, BI) ! !! ZSQRT is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY. ! !***LIBRARY SLATEC !***TYPE ALL (ZSQRT-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) ! !***SEE ALSO ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY !***ROUTINES CALLED ZABS !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZSQRT DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT DOUBLE PRECISION ZABS EXTERNAL ZABS DATA DRT , DPI / 7.071067811865475244008443621D-1, & 3.141592653589793238462643383D+0/ !***FIRST EXECUTABLE STATEMENT ZSQRT ZM = ZABS(AR,AI) ZM = SQRT(ZM) if (AR == 0.0D+0) go to 10 if (AI == 0.0D+0) go to 20 DTHETA = DATAN(AI/AR) if (DTHETA <= 0.0D+0) go to 40 if (AR < 0.0D+0) DTHETA = DTHETA - DPI go to 50 10 if (AI > 0.0D+0) go to 60 if (AI < 0.0D+0) go to 70 BR = 0.0D+0 BI = 0.0D+0 return 20 if (AR > 0.0D+0) go to 30 BR = 0.0D+0 BI = SQRT(ABS(AR)) return 30 BR = SQRT(AR) BI = 0.0D+0 return 40 if (AR < 0.0D+0) DTHETA = DTHETA + DPI 50 DTHETA = DTHETA*0.5D+0 BR = ZM*COS(DTHETA) BI = ZM*SIN(DTHETA) return 60 BR = ZM*DRT BI = ZM*DRT return 70 BR = ZM*DRT BI = -ZM*DRT return end subroutine ZUCHK (YR, YI, NZ, ASCLE, TOL) ! !! ZUCHK is subsidiary to SERI, ZUOIK, ZUNK1, ZUNK2, ZUNI1, ZUNI2 and ZKSCL. ! !***LIBRARY SLATEC !***TYPE ALL (CUCHK-A, ZUCHK-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN ! EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE ! if THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW ! WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED ! if THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE ! OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE ! ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. ! !***SEE ALSO SERI, ZKSCL, ZUNI1, ZUNI2, ZUNK1, ZUNK2, ZUOIK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZUCHK ! ! COMPLEX Y DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI INTEGER NZ !***FIRST EXECUTABLE STATEMENT ZUCHK NZ = 0 WR = ABS(YR) WI = ABS(YI) ST = MIN(WR,WI) if (ST > ASCLE) RETURN SS = MAX(WR,WI) ST = ST/TOL if (SS < ST) NZ = 1 return end subroutine ZUNHJ (ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI, & ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) ! !! ZUNHJ is subsidiary to ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNHJ-A, ZUNHJ-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! REFERENCES ! HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. ! STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. ! ! ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC ! PRESS, N.Y., 1974, PAGE 420 ! ! ABSTRACT ! ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = ! J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU ! BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION ! ! C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) ! ! FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS ! AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. ! ! (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, ! ! ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING ! PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. ! ! MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND ! MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= ! 1 COMPUTES ALL EXCEPT ASUM AND BSUM. ! !***SEE ALSO ZBESI, ZBESK !***ROUTINES CALLED D1MACH, ZABS, ZDIV, ZLOG, ZSQRT !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 930122 Added ZLOG and ZSQRT to EXTERNAL statement. (RWC) !***END PROLOGUE ZUNHJ ! COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, ! *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, ! *ZETA2,ZTH DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR, & ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER, & CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI, & PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2, & RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR, & SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI, & TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR, & ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I, & ZETA2R, ZI, ZR, ZTHI, ZTHR, ZABS, AC, D1MACH INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, & LRP1, L1, L2, M, IDUM DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), & AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14), & DRR(14), DRI(14) EXTERNAL ZABS, ZLOG, ZSQRT DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8), & AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/ & 1.00000000000000000D+00, 1.04166666666666667D-01, & 8.35503472222222222D-02, 1.28226574556327160D-01, & 2.91849026464140464D-01, 8.81627267443757652D-01, & 3.32140828186276754D+00, 1.49957629868625547D+01, & 7.89230130115865181D+01, 4.74451538868264323D+02, & 3.20749009089066193D+03, 2.40865496408740049D+04, & 1.98923119169509794D+05, 1.79190200777534383D+06/ DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), & BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/ & 1.00000000000000000D+00, -1.45833333333333333D-01, & -9.87413194444444444D-02, -1.43312053915895062D-01, & -3.17227202678413548D-01, -9.42429147957120249D-01, & -3.51120304082635426D+00, -1.57272636203680451D+01, & -8.22814390971859444D+01, -4.92355370523670524D+02, & -3.31621856854797251D+03, -2.48276742452085896D+04, & -2.04526587315129788D+05, -1.83844491706820990D+06/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), & C(19), C(20), C(21), C(22), C(23), C(24)/ & 1.00000000000000000D+00, -2.08333333333333333D-01, & 1.25000000000000000D-01, 3.34201388888888889D-01, & -4.01041666666666667D-01, 7.03125000000000000D-02, & -1.02581259645061728D+00, 1.84646267361111111D+00, & -8.91210937500000000D-01, 7.32421875000000000D-02, & 4.66958442342624743D+00, -1.12070026162229938D+01, & 8.78912353515625000D+00, -2.36408691406250000D+00, & 1.12152099609375000D-01, -2.82120725582002449D+01, & 8.46362176746007346D+01, -9.18182415432400174D+01, & 4.25349987453884549D+01, -7.36879435947963170D+00, & 2.27108001708984375D-01, 2.12570130039217123D+02, & -7.65252468141181642D+02, 1.05999045252799988D+03/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ & -6.99579627376132541D+02, 2.18190511744211590D+02, & -2.64914304869515555D+01, 5.72501420974731445D-01, & -1.91945766231840700D+03, 8.06172218173730938D+03, & -1.35865500064341374D+04, 1.16553933368645332D+04, & -5.30564697861340311D+03, 1.20090291321635246D+03, & -1.08090919788394656D+02, 1.72772750258445740D+00, & 2.02042913309661486D+04, -9.69805983886375135D+04, & 1.92547001232531532D+05, -2.03400177280415534D+05, & 1.22200464983017460D+05, -4.11926549688975513D+04, & 7.10951430248936372D+03, -4.93915304773088012D+02, & 6.07404200127348304D+00, -2.42919187900551333D+05, & 1.31176361466297720D+06, -2.99801591853810675D+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), & C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ & 3.76327129765640400D+06, -2.81356322658653411D+06, & 1.26836527332162478D+06, -3.31645172484563578D+05, & 4.52187689813627263D+04, -2.49983048181120962D+03, & 2.43805296995560639D+01, 3.28446985307203782D+06, & -1.97068191184322269D+07, 5.09526024926646422D+07, & -7.41051482115326577D+07, 6.63445122747290267D+07, & -3.75671766607633513D+07, 1.32887671664218183D+07, & -2.78561812808645469D+06, 3.08186404612662398D+05, & -1.38860897537170405D+04, 1.10017140269246738D+02, & -4.93292536645099620D+07, 3.25573074185765749D+08, & -9.39462359681578403D+08, 1.55359689957058006D+09, & -1.62108055210833708D+09, 1.10684281682301447D+09/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), & C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), & C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ & -4.95889784275030309D+08, 1.42062907797533095D+08, & -2.44740627257387285D+07, 2.24376817792244943D+06, & -8.40054336030240853D+04, 5.51335896122020586D+02, & 8.14789096118312115D+08, -5.86648149205184723D+09, & 1.86882075092958249D+10, -3.46320433881587779D+10, & 4.12801855797539740D+10, -3.30265997498007231D+10, & 1.79542137311556001D+10, -6.56329379261928433D+09, & 1.55927986487925751D+09, -2.25105661889415278D+08, & 1.73951075539781645D+07, -5.49842327572288687D+05, & 3.03809051092238427D+03, -1.46792612476956167D+10, & 1.14498237732025810D+11, -3.99096175224466498D+11, & 8.19218669548577329D+11, -1.09837515608122331D+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), & C(105)/ & 1.00815810686538209D+12, -6.45364869245376503D+11, & 2.87900649906150589D+11, -8.78670721780232657D+10, & 1.76347306068349694D+10, -2.16716498322379509D+09, & 1.43157876718888981D+08, -3.87183344257261262D+06, & 1.82577554742931747D+04/ DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6), & ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12), & ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18), & ALFA(19), ALFA(20), ALFA(21), ALFA(22)/ & -4.44444444444444444D-03, -9.22077922077922078D-04, & -8.84892884892884893D-05, 1.65927687832449737D-04, & 2.46691372741792910D-04, 2.65995589346254780D-04, & 2.61824297061500945D-04, 2.48730437344655609D-04, & 2.32721040083232098D-04, 2.16362485712365082D-04, & 2.00738858762752355D-04, 1.86267636637545172D-04, & 1.73060775917876493D-04, 1.61091705929015752D-04, & 1.50274774160908134D-04, 1.40503497391269794D-04, & 1.31668816545922806D-04, 1.23667445598253261D-04, & 1.16405271474737902D-04, 1.09798298372713369D-04, & 1.03772410422992823D-04, 9.82626078369363448D-05/ DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28), & ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34), & ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40), & ALFA(41), ALFA(42), ALFA(43), ALFA(44)/ & 9.32120517249503256D-05, 8.85710852478711718D-05, & 8.42963105715700223D-05, 8.03497548407791151D-05, & 7.66981345359207388D-05, 7.33122157481777809D-05, & 7.01662625163141333D-05, 6.72375633790160292D-05, & 6.93735541354588974D-04, 2.32241745182921654D-04, & -1.41986273556691197D-05, -1.16444931672048640D-04, & -1.50803558053048762D-04, -1.55121924918096223D-04, & -1.46809756646465549D-04, -1.33815503867491367D-04, & -1.19744975684254051D-04, -1.06184319207974020D-04, & -9.37699549891194492D-05, -8.26923045588193274D-05, & -7.29374348155221211D-05, -6.44042357721016283D-05/ DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50), & ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56), & ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62), & ALFA(63), ALFA(64), ALFA(65), ALFA(66)/ & -5.69611566009369048D-05, -5.04731044303561628D-05, & -4.48134868008882786D-05, -3.98688727717598864D-05, & -3.55400532972042498D-05, -3.17414256609022480D-05, & -2.83996793904174811D-05, -2.54522720634870566D-05, & -2.28459297164724555D-05, -2.05352753106480604D-05, & -1.84816217627666085D-05, -1.66519330021393806D-05, & -1.50179412980119482D-05, -1.35554031379040526D-05, & -1.22434746473858131D-05, -1.10641884811308169D-05, & -3.54211971457743841D-04, -1.56161263945159416D-04, & 3.04465503594936410D-05, 1.30198655773242693D-04, & 1.67471106699712269D-04, 1.70222587683592569D-04/ DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72), & ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78), & ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84), & ALFA(85), ALFA(86), ALFA(87), ALFA(88)/ & 1.56501427608594704D-04, 1.36339170977445120D-04, & 1.14886692029825128D-04, 9.45869093034688111D-05, & 7.64498419250898258D-05, 6.07570334965197354D-05, & 4.74394299290508799D-05, 3.62757512005344297D-05, & 2.69939714979224901D-05, 1.93210938247939253D-05, & 1.30056674793963203D-05, 7.82620866744496661D-06, & 3.59257485819351583D-06, 1.44040049814251817D-07, & -2.65396769697939116D-06, -4.91346867098485910D-06, & -6.72739296091248287D-06, -8.17269379678657923D-06, & -9.31304715093561232D-06, -1.02011418798016441D-05, & -1.08805962510592880D-05, -1.13875481509603555D-05/ DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94), & ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100), & ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105), & ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/ & -1.17519675674556414D-05, -1.19987364870944141D-05, & 3.78194199201772914D-04, 2.02471952761816167D-04, & -6.37938506318862408D-05, -2.38598230603005903D-04, & -3.10916256027361568D-04, -3.13680115247576316D-04, & -2.78950273791323387D-04, -2.28564082619141374D-04, & -1.75245280340846749D-04, -1.25544063060690348D-04, & -8.22982872820208365D-05, -4.62860730588116458D-05, & -1.72334302366962267D-05, 5.60690482304602267D-06, & 2.31395443148286800D-05, 3.62642745856793957D-05, & 4.58006124490188752D-05, 5.24595294959114050D-05, & 5.68396208545815266D-05, 5.94349820393104052D-05/ DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115), & ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120), & ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125), & ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/ & 6.06478527578421742D-05, 6.08023907788436497D-05, & 6.01577894539460388D-05, 5.89199657344698500D-05, & 5.72515823777593053D-05, 5.52804375585852577D-05, & 5.31063773802880170D-05, 5.08069302012325706D-05, & 4.84418647620094842D-05, 4.60568581607475370D-05, & -6.91141397288294174D-04, -4.29976633058871912D-04, & 1.83067735980039018D-04, 6.60088147542014144D-04, & 8.75964969951185931D-04, 8.77335235958235514D-04, & 7.49369585378990637D-04, 5.63832329756980918D-04, & 3.68059319971443156D-04, 1.88464535514455599D-04/ DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135), & ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140), & ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145), & ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/ & 3.70663057664904149D-05, -8.28520220232137023D-05, & -1.72751952869172998D-04, -2.36314873605872983D-04, & -2.77966150694906658D-04, -3.02079514155456919D-04, & -3.12594712643820127D-04, -3.12872558758067163D-04, & -3.05678038466324377D-04, -2.93226470614557331D-04, & -2.77255655582934777D-04, -2.59103928467031709D-04, & -2.39784014396480342D-04, -2.20048260045422848D-04, & -2.00443911094971498D-04, -1.81358692210970687D-04, & -1.63057674478657464D-04, -1.45712672175205844D-04, & -1.29425421983924587D-04, -1.14245691942445952D-04/ DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155), & ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160), & ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165), & ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/ & 1.92821964248775885D-03, 1.35592576302022234D-03, & -7.17858090421302995D-04, -2.58084802575270346D-03, & -3.49271130826168475D-03, -3.46986299340960628D-03, & -2.82285233351310182D-03, -1.88103076404891354D-03, & -8.89531718383947600D-04, 3.87912102631035228D-06, & 7.28688540119691412D-04, 1.26566373053457758D-03, & 1.62518158372674427D-03, 1.83203153216373172D-03, & 1.91588388990527909D-03, 1.90588846755546138D-03, & 1.82798982421825727D-03, 1.70389506421121530D-03, & 1.55097127171097686D-03, 1.38261421852276159D-03/ DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175), & ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/ & 1.20881424230064774D-03, 1.03676532638344962D-03, & 8.71437918068619115D-04, 7.16080155297701002D-04, & 5.72637002558129372D-04, 4.42089819465802277D-04, & 3.24724948503090564D-04, 2.20342042730246599D-04, & 1.28412898401353882D-04, 4.82005924552095464D-05/ DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6), & BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12), & BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18), & BETA(19), BETA(20), BETA(21), BETA(22)/ & 1.79988721413553309D-02, 5.59964911064388073D-03, & 2.88501402231132779D-03, 1.80096606761053941D-03, & 1.24753110589199202D-03, 9.22878876572938311D-04, & 7.14430421727287357D-04, 5.71787281789704872D-04, & 4.69431007606481533D-04, 3.93232835462916638D-04, & 3.34818889318297664D-04, 2.88952148495751517D-04, & 2.52211615549573284D-04, 2.22280580798883327D-04, & 1.97541838033062524D-04, 1.76836855019718004D-04, & 1.59316899661821081D-04, 1.44347930197333986D-04, & 1.31448068119965379D-04, 1.20245444949302884D-04, & 1.10449144504599392D-04, 1.01828770740567258D-04/ DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28), & BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34), & BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40), & BETA(41), BETA(42), BETA(43), BETA(44)/ & 9.41998224204237509D-05, 8.74130545753834437D-05, & 8.13466262162801467D-05, 7.59002269646219339D-05, & 7.09906300634153481D-05, 6.65482874842468183D-05, & 6.25146958969275078D-05, 5.88403394426251749D-05, & -1.49282953213429172D-03, -8.78204709546389328D-04, & -5.02916549572034614D-04, -2.94822138512746025D-04, & -1.75463996970782828D-04, -1.04008550460816434D-04, & -5.96141953046457895D-05, -3.12038929076098340D-05, & -1.26089735980230047D-05, -2.42892608575730389D-07, & 8.05996165414273571D-06, 1.36507009262147391D-05, & 1.73964125472926261D-05, 1.98672978842133780D-05/ DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50), & BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56), & BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62), & BETA(63), BETA(64), BETA(65), BETA(66)/ & 2.14463263790822639D-05, 2.23954659232456514D-05, & 2.28967783814712629D-05, 2.30785389811177817D-05, & 2.30321976080909144D-05, 2.28236073720348722D-05, & 2.25005881105292418D-05, 2.20981015361991429D-05, & 2.16418427448103905D-05, 2.11507649256220843D-05, & 2.06388749782170737D-05, 2.01165241997081666D-05, & 1.95913450141179244D-05, 1.90689367910436740D-05, & 1.85533719641636667D-05, 1.80475722259674218D-05, & 5.52213076721292790D-04, 4.47932581552384646D-04, & 2.79520653992020589D-04, 1.52468156198446602D-04, & 6.93271105657043598D-05, 1.76258683069991397D-05/ DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72), & BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78), & BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84), & BETA(85), BETA(86), BETA(87), BETA(88)/ & -1.35744996343269136D-05, -3.17972413350427135D-05, & -4.18861861696693365D-05, -4.69004889379141029D-05, & -4.87665447413787352D-05, -4.87010031186735069D-05, & -4.74755620890086638D-05, -4.55813058138628452D-05, & -4.33309644511266036D-05, -4.09230193157750364D-05, & -3.84822638603221274D-05, -3.60857167535410501D-05, & -3.37793306123367417D-05, -3.15888560772109621D-05, & -2.95269561750807315D-05, -2.75978914828335759D-05, & -2.58006174666883713D-05, -2.41308356761280200D-05, & -2.25823509518346033D-05, -2.11479656768912971D-05, & -1.98200638885294927D-05, -1.85909870801065077D-05/ DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94), & BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100), & BETA(101), BETA(102), BETA(103), BETA(104), BETA(105), & BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/ & -1.74532699844210224D-05, -1.63997823854497997D-05, & -4.74617796559959808D-04, -4.77864567147321487D-04, & -3.20390228067037603D-04, -1.61105016119962282D-04, & -4.25778101285435204D-05, 3.44571294294967503D-05, & 7.97092684075674924D-05, 1.03138236708272200D-04, & 1.12466775262204158D-04, 1.13103642108481389D-04, & 1.08651634848774268D-04, 1.01437951597661973D-04, & 9.29298396593363896D-05, 8.40293133016089978D-05, & 7.52727991349134062D-05, 6.69632521975730872D-05, & 5.92564547323194704D-05, 5.22169308826975567D-05, & 4.58539485165360646D-05, 4.01445513891486808D-05/ DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115), & BETA(116), BETA(117), BETA(118), BETA(119), BETA(120), & BETA(121), BETA(122), BETA(123), BETA(124), BETA(125), & BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/ & 3.50481730031328081D-05, 3.05157995034346659D-05, & 2.64956119950516039D-05, 2.29363633690998152D-05, & 1.97893056664021636D-05, 1.70091984636412623D-05, & 1.45547428261524004D-05, 1.23886640995878413D-05, & 1.04775876076583236D-05, 8.79179954978479373D-06, & 7.36465810572578444D-04, 8.72790805146193976D-04, & 6.22614862573135066D-04, 2.85998154194304147D-04, & 3.84737672879366102D-06, -1.87906003636971558D-04, & -2.97603646594554535D-04, -3.45998126832656348D-04, & -3.53382470916037712D-04, -3.35715635775048757D-04/ DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135), & BETA(136), BETA(137), BETA(138), BETA(139), BETA(140), & BETA(141), BETA(142), BETA(143), BETA(144), BETA(145), & BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/ & -3.04321124789039809D-04, -2.66722723047612821D-04, & -2.27654214122819527D-04, -1.89922611854562356D-04, & -1.55058918599093870D-04, -1.23778240761873630D-04, & -9.62926147717644187D-05, -7.25178327714425337D-05, & -5.22070028895633801D-05, -3.50347750511900522D-05, & -2.06489761035551757D-05, -8.70106096849767054D-06, & 1.13698686675100290D-06, 9.16426474122778849D-06, & 1.56477785428872620D-05, 2.08223629482466847D-05, & 2.48923381004595156D-05, 2.80340509574146325D-05, & 3.03987774629861915D-05, 3.21156731406700616D-05/ DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155), & BETA(156), BETA(157), BETA(158), BETA(159), BETA(160), & BETA(161), BETA(162), BETA(163), BETA(164), BETA(165), & BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/ & -1.80182191963885708D-03, -2.43402962938042533D-03, & -1.83422663549856802D-03, -7.62204596354009765D-04, & 2.39079475256927218D-04, 9.49266117176881141D-04, & 1.34467449701540359D-03, 1.48457495259449178D-03, & 1.44732339830617591D-03, 1.30268261285657186D-03, & 1.10351597375642682D-03, 8.86047440419791759D-04, & 6.73073208165665473D-04, 4.77603872856582378D-04, & 3.05991926358789362D-04, 1.60315694594721630D-04, & 4.00749555270613286D-05, -5.66607461635251611D-05, & -1.32506186772982638D-04, -1.90296187989614057D-04/ DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175), & BETA(176), BETA(177), BETA(178), BETA(179), BETA(180), & BETA(181), BETA(182), BETA(183), BETA(184), BETA(185), & BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/ & -2.32811450376937408D-04, -2.62628811464668841D-04, & -2.82050469867598672D-04, -2.93081563192861167D-04, & -2.97435962176316616D-04, -2.96557334239348078D-04, & -2.91647363312090861D-04, -2.83696203837734166D-04, & -2.73512317095673346D-04, -2.61750155806768580D-04, & 6.38585891212050914D-03, 9.62374215806377941D-03, & 7.61878061207001043D-03, 2.83219055545628054D-03, & -2.09841352012720090D-03, -5.73826764216626498D-03, & -7.70804244495414620D-03, -8.21011692264844401D-03, & -7.65824520346905413D-03, -6.47209729391045177D-03/ DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195), & BETA(196), BETA(197), BETA(198), BETA(199), BETA(200), & BETA(201), BETA(202), BETA(203), BETA(204), BETA(205), & BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/ & -4.99132412004966473D-03, -3.45612289713133280D-03, & -2.01785580014170775D-03, -7.59430686781961401D-04, & 2.84173631523859138D-04, 1.10891667586337403D-03, & 1.72901493872728771D-03, 2.16812590802684701D-03, & 2.45357710494539735D-03, 2.61281821058334862D-03, & 2.67141039656276912D-03, 2.65203073395980430D-03, & 2.57411652877287315D-03, 2.45389126236094427D-03, & 2.30460058071795494D-03, 2.13684837686712662D-03, & 1.95896528478870911D-03, 1.77737008679454412D-03, & 1.59690280765839059D-03, 1.42111975664438546D-03/ DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6), & GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12), & GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18), & GAMA(19), GAMA(20), GAMA(21), GAMA(22)/ & 6.29960524947436582D-01, 2.51984209978974633D-01, & 1.54790300415655846D-01, 1.10713062416159013D-01, & 8.57309395527394825D-02, 6.97161316958684292D-02, & 5.86085671893713576D-02, 5.04698873536310685D-02, & 4.42600580689154809D-02, 3.93720661543509966D-02, & 3.54283195924455368D-02, 3.21818857502098231D-02, & 2.94646240791157679D-02, 2.71581677112934479D-02, & 2.51768272973861779D-02, 2.34570755306078891D-02, & 2.19508390134907203D-02, 2.06210828235646240D-02, & 1.94388240897880846D-02, 1.83810633800683158D-02, & 1.74293213231963172D-02, 1.65685837786612353D-02/ DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), & GAMA(29), GAMA(30)/ & 1.57865285987918445D-02, 1.50729501494095594D-02, & 1.44193250839954639D-02, 1.38184805735341786D-02, & 1.32643378994276568D-02, 1.27517121970498651D-02, & 1.22761545318762767D-02, 1.18338262398482403D-02/ DATA EX1, EX2, HPI, GPI, THPI / & 3.33333333333333333D-01, 6.66666666666666667D-01, & 1.57079632679489662D+00, 3.14159265358979324D+00, & 4.71238898038468986D+00/ DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / !***FIRST EXECUTABLE STATEMENT ZUNHJ RFNU = 1.0D0/FNU !----------------------------------------------------------------------- ! OVERFLOW TEST (Z/FNU TOO SMALL) !----------------------------------------------------------------------- TEST = D1MACH(1)*1.0D+3 AC = FNU*TEST if (ABS(ZR) > AC .OR. ABS(ZI) > AC) go to 15 ZETA1R = 2.0D0*ABS(LOG(TEST))+FNU ZETA1I = 0.0D0 ZETA2R = FNU ZETA2I = 0.0D0 PHIR = 1.0D0 PHII = 0.0D0 ARGR = 1.0D0 ARGI = 0.0D0 return 15 CONTINUE ZBR = ZR*RFNU ZBI = ZI*RFNU RFNU2 = RFNU*RFNU !----------------------------------------------------------------------- ! COMPUTE IN THE FOURTH QUADRANT !----------------------------------------------------------------------- FN13 = FNU**EX1 FN23 = FN13*FN13 RFN13 = 1.0D0/FN13 W2R = CONER - ZBR*ZBR + ZBI*ZBI W2I = CONEI - ZBR*ZBI - ZBR*ZBI AW2 = ZABS(W2R,W2I) if (AW2 > 0.25D0) go to 130 !----------------------------------------------------------------------- ! POWER SERIES FOR ABS(W2) <= 0.25D0 !----------------------------------------------------------------------- K = 1 PR(1) = CONER PI(1) = CONEI SUMAR = GAMA(1) SUMAI = ZEROI AP(1) = 1.0D0 if (AW2 < TOL) go to 20 DO 10 K=2,30 PR(K) = PR(K-1)*W2R - PI(K-1)*W2I PI(K) = PR(K-1)*W2I + PI(K-1)*W2R SUMAR = SUMAR + PR(K)*GAMA(K) SUMAI = SUMAI + PI(K)*GAMA(K) AP(K) = AP(K-1)*AW2 if (AP(K) < TOL) go to 20 10 CONTINUE K = 30 20 CONTINUE KMAX = K ZETAR = W2R*SUMAR - W2I*SUMAI ZETAI = W2R*SUMAI + W2I*SUMAR ARGR = ZETAR*FN23 ARGI = ZETAI*FN23 call ZSQRT(SUMAR, SUMAI, ZAR, ZAI) call ZSQRT(W2R, W2I, STR, STI) ZETA2R = STR*FNU ZETA2I = STI*FNU STR = CONER + EX2*(ZETAR*ZAR-ZETAI*ZAI) STI = CONEI + EX2*(ZETAR*ZAI+ZETAI*ZAR) ZETA1R = STR*ZETA2R - STI*ZETA2I ZETA1I = STR*ZETA2I + STI*ZETA2R ZAR = ZAR + ZAR ZAI = ZAI + ZAI call ZSQRT(ZAR, ZAI, STR, STI) PHIR = STR*RFN13 PHII = STI*RFN13 if (IPMTR == 1) go to 120 !----------------------------------------------------------------------- ! SUM SERIES FOR ASUM AND BSUM !----------------------------------------------------------------------- SUMBR = ZEROR SUMBI = ZEROI DO 30 K=1,KMAX SUMBR = SUMBR + PR(K)*BETA(K) SUMBI = SUMBI + PI(K)*BETA(K) 30 CONTINUE ASUMR = ZEROR ASUMI = ZEROI BSUMR = SUMBR BSUMI = SUMBI L1 = 0 L2 = 30 BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI)) ATOL = TOL PP = 1.0D0 IAS = 0 IBS = 0 if (RFNU2 < TOL) go to 110 DO 100 IS=2,7 ATOL = ATOL/RFNU2 PP = PP*RFNU2 if (IAS == 1) go to 60 SUMAR = ZEROR SUMAI = ZEROI DO 40 K=1,KMAX M = L1 + K SUMAR = SUMAR + PR(K)*ALFA(M) SUMAI = SUMAI + PI(K)*ALFA(M) if (AP(K) < ATOL) go to 50 40 CONTINUE 50 CONTINUE ASUMR = ASUMR + SUMAR*PP ASUMI = ASUMI + SUMAI*PP if (PP < TOL) IAS = 1 60 CONTINUE if (IBS == 1) go to 90 SUMBR = ZEROR SUMBI = ZEROI DO 70 K=1,KMAX M = L2 + K SUMBR = SUMBR + PR(K)*BETA(M) SUMBI = SUMBI + PI(K)*BETA(M) if (AP(K) < ATOL) go to 80 70 CONTINUE 80 CONTINUE BSUMR = BSUMR + SUMBR*PP BSUMI = BSUMI + SUMBI*PP if (PP < BTOL) IBS = 1 90 CONTINUE if (IAS == 1 .AND. IBS == 1) go to 110 L1 = L1 + 30 L2 = L2 + 30 100 CONTINUE 110 CONTINUE ASUMR = ASUMR + CONER PP = RFNU*RFN13 BSUMR = BSUMR*PP BSUMI = BSUMI*PP 120 CONTINUE return !----------------------------------------------------------------------- ! ABS(W2) > 0.25D0 !----------------------------------------------------------------------- 130 CONTINUE call ZSQRT(W2R, W2I, WR, WI) if (WR < 0.0D0) WR = 0.0D0 if (WI < 0.0D0) WI = 0.0D0 STR = CONER + WR STI = WI call ZDIV(STR, STI, ZBR, ZBI, ZAR, ZAI) call ZLOG(ZAR, ZAI, ZCR, ZCI, IDUM) if (ZCI < 0.0D0) ZCI = 0.0D0 if (ZCI > HPI) ZCI = HPI if (ZCR < 0.0D0) ZCR = 0.0D0 ZTHR = (ZCR-WR)*1.5D0 ZTHI = (ZCI-WI)*1.5D0 ZETA1R = ZCR*FNU ZETA1I = ZCI*FNU ZETA2R = WR*FNU ZETA2I = WI*FNU AZTH = ZABS(ZTHR,ZTHI) ANG = THPI if (ZTHR >= 0.0D0 .AND. ZTHI < 0.0D0) go to 140 ANG = HPI if (ZTHR == 0.0D0) go to 140 ANG = DATAN(ZTHI/ZTHR) if (ZTHR < 0.0D0) ANG = ANG + GPI 140 CONTINUE PP = AZTH**EX2 ANG = ANG*EX2 ZETAR = PP*COS(ANG) ZETAI = PP*SIN(ANG) if (ZETAI < 0.0D0) ZETAI = 0.0D0 ARGR = ZETAR*FN23 ARGI = ZETAI*FN23 call ZDIV(ZTHR, ZTHI, ZETAR, ZETAI, RTZTR, RTZTI) call ZDIV(RTZTR, RTZTI, WR, WI, ZAR, ZAI) TZAR = ZAR + ZAR TZAI = ZAI + ZAI call ZSQRT(TZAR, TZAI, STR, STI) PHIR = STR*RFN13 PHII = STI*RFN13 if (IPMTR == 1) go to 120 RAW = 1.0D0/SQRT(AW2) STR = WR*RAW STI = -WI*RAW TFNR = STR*RFNU*RAW TFNI = STI*RFNU*RAW RAZTH = 1.0D0/AZTH STR = ZTHR*RAZTH STI = -ZTHI*RAZTH RZTHR = STR*RAZTH*RFNU RZTHI = STI*RAZTH*RFNU ZCR = RZTHR*AR(2) ZCI = RZTHI*AR(2) RAW2 = 1.0D0/AW2 STR = W2R*RAW2 STI = -W2I*RAW2 T2R = STR*RAW2 T2I = STI*RAW2 STR = T2R*C(2) + C(3) STI = T2I*C(2) UPR(2) = STR*TFNR - STI*TFNI UPI(2) = STR*TFNI + STI*TFNR BSUMR = UPR(2) + ZCR BSUMI = UPI(2) + ZCI ASUMR = ZEROR ASUMI = ZEROI if (RFNU < TOL) go to 220 PRZTHR = RZTHR PRZTHI = RZTHI PTFNR = TFNR PTFNI = TFNI UPR(1) = CONER UPI(1) = CONEI PP = 1.0D0 BTOL = TOL*(ABS(BSUMR)+ABS(BSUMI)) KS = 0 KP1 = 2 L = 3 IAS = 0 IBS = 0 DO 210 LR=2,12,2 LRP1 = LR + 1 !----------------------------------------------------------------------- ! COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN ! NEXT SUMA AND SUMB !----------------------------------------------------------------------- DO 160 K=LR,LRP1 KS = KS + 1 KP1 = KP1 + 1 L = L + 1 ZAR = C(L) ZAI = ZEROI DO 150 J=2,KP1 L = L + 1 STR = ZAR*T2R - T2I*ZAI + C(L) ZAI = ZAR*T2I + ZAI*T2R ZAR = STR 150 CONTINUE STR = PTFNR*TFNR - PTFNI*TFNI PTFNI = PTFNR*TFNI + PTFNI*TFNR PTFNR = STR UPR(KP1) = PTFNR*ZAR - PTFNI*ZAI UPI(KP1) = PTFNI*ZAR + PTFNR*ZAI CRR(KS) = PRZTHR*BR(KS+1) CRI(KS) = PRZTHI*BR(KS+1) STR = PRZTHR*RZTHR - PRZTHI*RZTHI PRZTHI = PRZTHR*RZTHI + PRZTHI*RZTHR PRZTHR = STR DRR(KS) = PRZTHR*AR(KS+2) DRI(KS) = PRZTHI*AR(KS+2) 160 CONTINUE PP = PP*RFNU2 if (IAS == 1) go to 180 SUMAR = UPR(LRP1) SUMAI = UPI(LRP1) JU = LRP1 DO 170 JR=1,LR JU = JU - 1 SUMAR = SUMAR + CRR(JR)*UPR(JU) - CRI(JR)*UPI(JU) SUMAI = SUMAI + CRR(JR)*UPI(JU) + CRI(JR)*UPR(JU) 170 CONTINUE ASUMR = ASUMR + SUMAR ASUMI = ASUMI + SUMAI TEST = ABS(SUMAR) + ABS(SUMAI) if (PP < TOL .AND. TEST < TOL) IAS = 1 180 CONTINUE if (IBS == 1) go to 200 SUMBR = UPR(LR+2) + UPR(LRP1)*ZCR - UPI(LRP1)*ZCI SUMBI = UPI(LR+2) + UPR(LRP1)*ZCI + UPI(LRP1)*ZCR JU = LRP1 DO 190 JR=1,LR JU = JU - 1 SUMBR = SUMBR + DRR(JR)*UPR(JU) - DRI(JR)*UPI(JU) SUMBI = SUMBI + DRR(JR)*UPI(JU) + DRI(JR)*UPR(JU) 190 CONTINUE BSUMR = BSUMR + SUMBR BSUMI = BSUMI + SUMBI TEST = ABS(SUMBR) + ABS(SUMBI) if (PP < BTOL .AND. TEST < BTOL) IBS = 1 200 CONTINUE if (IAS == 1 .AND. IBS == 1) go to 220 210 CONTINUE 220 CONTINUE ASUMR = ASUMR + CONER STR = -BSUMR*RFN13 STI = -BSUMI*RFN13 call ZDIV(STR, STI, RTZTR, RTZTI, BSUMR, BSUMI) go to 120 end subroutine ZUNI1 (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, & TOL, ELIM, ALIM) ! !! ZUNI1 is subsidiary to ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNI1-A, ZUNI1-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC ! EXPANSION FOR I(FNU,Z) IN -PI/3 <= ARG Z <= PI/3. ! ! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC ! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. ! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER ! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL. ! Y(I)=CZERO FOR I=NLAST+1,N ! !***SEE ALSO ZBESI, ZBESK !***ROUTINES CALLED D1MACH, ZABS, ZUCHK, ZUNIK, ZUOIK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZUNI1 ! COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, ! *S2,Y,Z,ZETA1,ZETA2 DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC, & CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN, & FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI, & SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, & ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3), & CSRR(3), CYR(2), CYI(2) EXTERNAL ZABS DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / !***FIRST EXECUTABLE STATEMENT ZUNI1 NZ = 0 ND = N NLAST = 0 !----------------------------------------------------------------------- ! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- ! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, ! EXP(ALIM)=EXP(ELIM)*TOL !----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL !----------------------------------------------------------------------- ! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER !----------------------------------------------------------------------- FN = MAX(FNU,1.0D0) INIT = 0 call ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R, & ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) if (KODE == 1) go to 10 STR = ZR + ZETA2R STI = ZI + ZETA2I RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI go to 20 10 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 20 CONTINUE RS1 = S1R if (ABS(RS1) > ELIM) go to 130 30 CONTINUE NN = MIN(2,ND) DO 80 I=1,NN FN = FNU + (ND-I) INIT = 0 call ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R, & ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) if (KODE == 1) go to 40 STR = ZR + ZETA2R STI = ZI + ZETA2I RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI + ZI go to 50 40 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 50 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = S1R if (ABS(RS1) > ELIM) go to 110 if (I == 1) IFLAG = 2 if (ABS(RS1) < ALIM) go to 60 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- APHI = ZABS(PHIR,PHII) RS1 = RS1 + LOG(APHI) if (ABS(RS1) > ELIM) go to 110 if (I == 1) IFLAG = 1 if (RS1 < 0.0D0) go to 60 if (I == 1) IFLAG = 3 60 CONTINUE !----------------------------------------------------------------------- ! SCALE S1 if ABS(S1) < ASCLE !----------------------------------------------------------------------- S2R = PHIR*SUMR - PHII*SUMI S2I = PHIR*SUMI + PHII*SUMR STR = EXP(S1R)*CSSR(IFLAG) S1R = STR*COS(S1I) S1I = STR*SIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR if (IFLAG /= 1) go to 70 call ZUCHK(S2R, S2I, NW, BRY(1), TOL) if (NW /= 0) go to 110 70 CONTINUE CYR(I) = S2R CYI(I) = S2I M = ND - I + 1 YR(M) = S2R*CSRR(IFLAG) YI(M) = S2I*CSRR(IFLAG) 80 CONTINUE if (ND <= 2) go to 100 RAST = 1.0D0/ZABS(ZR,ZI) STR = ZR*RAST STI = -ZI*RAST RZR = (STR+STR)*RAST RZI = (STI+STI)*RAST BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = K DO 90 I=3,ND C2R = S2R C2I = S2I S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I C2R = S2R*C1R C2I = S2I*C1R YR(K) = C2R YI(K) = C2I K = K - 1 FN = FN - 1.0D0 if (IFLAG >= 3) go to 90 STR = ABS(C2R) STI = ABS(C2I) C2M = MAX(STR,STI) if (C2M <= ASCLE) go to 90 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) C1R = CSRR(IFLAG) 90 CONTINUE 100 CONTINUE return !----------------------------------------------------------------------- ! SET UNDERFLOW AND UPDATE PARAMETERS !----------------------------------------------------------------------- 110 CONTINUE if (RS1 > 0.0D0) go to 120 YR(ND) = ZEROR YI(ND) = ZEROI NZ = NZ + 1 ND = ND - 1 if (ND == 0) go to 100 call ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) if (NUF < 0) go to 120 ND = ND - NUF NZ = NZ + NUF if (ND == 0) go to 100 FN = FNU + (ND-1) if (FN >= FNUL) go to 30 NLAST = ND return 120 CONTINUE NZ = -1 return 130 CONTINUE if (RS1 > 0.0D0) go to 120 NZ = N DO 140 I=1,N YR(I) = ZEROR YI(I) = ZEROI 140 CONTINUE return end subroutine ZUNI2 (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, & TOL, ELIM, ALIM) ! !! ZUNI2 is subsidiary to ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNI2-A, ZUNI2-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF ! UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I ! OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. ! ! FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC ! EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. ! NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER ! FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL. ! Y(I)=CZERO FOR I=NLAST+1,N ! !***SEE ALSO ZBESI, ZBESK !***ROUTINES CALLED D1MACH, ZABS, ZAIRY, ZUCHK, ZUNHJ, ZUOIK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZUNI2 ! COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, ! *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI, & ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR, & CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII, & DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI, & RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI, & ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR, & CYI, D1MACH, ZABS, CAR, SAR INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, & NN, NUF, NW, NZ, IDUM DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3), & CSRR(3), CYR(2), CYI(2) EXTERNAL ZABS DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), & CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/ DATA HPI, AIC / & 1.57079632679489662D+00, 1.265512123484645396D+00/ !***FIRST EXECUTABLE STATEMENT ZUNI2 NZ = 0 ND = N NLAST = 0 !----------------------------------------------------------------------- ! COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- ! NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, ! EXP(ALIM)=EXP(ELIM)*TOL !----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL !----------------------------------------------------------------------- ! ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI !----------------------------------------------------------------------- ZNR = ZI ZNI = -ZR ZBR = ZR ZBI = ZI CIDI = -CONER INU = FNU ANG = HPI*(FNU-INU) C2R = COS(ANG) C2I = SIN(ANG) CAR = C2R SAR = C2I IN = INU + N - 1 IN = MOD(IN,4) + 1 STR = C2R*CIPR(IN) - C2I*CIPI(IN) C2I = C2R*CIPI(IN) + C2I*CIPR(IN) C2R = STR if (ZI > 0.0D0) go to 10 ZNR = -ZNR ZBI = -ZBI CIDI = -CIDI C2I = -C2I 10 CONTINUE !----------------------------------------------------------------------- ! CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER !----------------------------------------------------------------------- FN = MAX(FNU,1.0D0) call ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, & ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) if (KODE == 1) go to 20 STR = ZBR + ZETA2R STI = ZBI + ZETA2I RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI go to 30 20 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 30 CONTINUE RS1 = S1R if (ABS(RS1) > ELIM) go to 150 40 CONTINUE NN = MIN(2,ND) DO 90 I=1,NN FN = FNU + (ND-I) call ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI, & ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) if (KODE == 1) go to 50 STR = ZBR + ZETA2R STI = ZBI + ZETA2I RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZETA1R + STR S1I = -ZETA1I + STI + ABS(ZI) go to 60 50 CONTINUE S1R = -ZETA1R + ZETA2R S1I = -ZETA1I + ZETA2I 60 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = S1R if (ABS(RS1) > ELIM) go to 120 if (I == 1) IFLAG = 2 if (ABS(RS1) < ALIM) go to 70 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- !----------------------------------------------------------------------- APHI = ZABS(PHIR,PHII) AARG = ZABS(ARGR,ARGI) RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC if (ABS(RS1) > ELIM) go to 120 if (I == 1) IFLAG = 1 if (RS1 < 0.0D0) go to 70 if (I == 1) IFLAG = 3 70 CONTINUE !----------------------------------------------------------------------- ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES !----------------------------------------------------------------------- call ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM) call ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM) STR = DAIR*BSUMR - DAII*BSUMI STI = DAIR*BSUMI + DAII*BSUMR STR = STR + (AIR*ASUMR-AII*ASUMI) STI = STI + (AIR*ASUMI+AII*ASUMR) S2R = PHIR*STR - PHII*STI S2I = PHIR*STI + PHII*STR STR = EXP(S1R)*CSSR(IFLAG) S1R = STR*COS(S1I) S1I = STR*SIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR if (IFLAG /= 1) go to 80 call ZUCHK(S2R, S2I, NW, BRY(1), TOL) if (NW /= 0) go to 120 80 CONTINUE if (ZI <= 0.0D0) S2I = -S2I STR = S2R*C2R - S2I*C2I S2I = S2R*C2I + S2I*C2R S2R = STR CYR(I) = S2R CYI(I) = S2I J = ND - I + 1 YR(J) = S2R*CSRR(IFLAG) YI(J) = S2I*CSRR(IFLAG) STR = -C2I*CIDI C2I = C2R*CIDI C2R = STR 90 CONTINUE if (ND <= 2) go to 110 RAZ = 1.0D0/ZABS(ZR,ZI) STR = ZR*RAZ STI = -ZI*RAZ RZR = (STR+STR)*RAZ RZI = (STI+STI)*RAZ BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(IFLAG) ASCLE = BRY(IFLAG) K = ND - 2 FN = K DO 100 I=3,ND C2R = S2R C2I = S2I S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I C2R = S2R*C1R C2I = S2I*C1R YR(K) = C2R YI(K) = C2I K = K - 1 FN = FN - 1.0D0 if (IFLAG >= 3) go to 100 STR = ABS(C2R) STI = ABS(C2I) C2M = MAX(STR,STI) if (C2M <= ASCLE) go to 100 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) C1R = CSRR(IFLAG) 100 CONTINUE 110 CONTINUE return 120 CONTINUE if (RS1 > 0.0D0) go to 140 !----------------------------------------------------------------------- ! SET UNDERFLOW AND UPDATE PARAMETERS !----------------------------------------------------------------------- YR(ND) = ZEROR YI(ND) = ZEROI NZ = NZ + 1 ND = ND - 1 if (ND == 0) go to 110 call ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) if (NUF < 0) go to 140 ND = ND - NUF NZ = NZ + NUF if (ND == 0) go to 110 FN = FNU + (ND-1) if (FN < FNUL) go to 130 ! FN = CIDI ! J = NUF + 1 ! K = MOD(J,4) + 1 ! S1R = CIPR(K) ! S1I = CIPI(K) ! if (FN < 0.0D0) S1I = -S1I ! STR = C2R*S1R - C2I*S1I ! C2I = C2R*S1I + C2I*S1R ! C2R = STR IN = INU + ND - 1 IN = MOD(IN,4) + 1 C2R = CAR*CIPR(IN) - SAR*CIPI(IN) C2I = CAR*CIPI(IN) + SAR*CIPR(IN) if (ZI <= 0.0D0) C2I = -C2I go to 40 130 CONTINUE NLAST = ND return 140 CONTINUE NZ = -1 return 150 CONTINUE if (RS1 > 0.0D0) go to 140 NZ = N DO 160 I=1,N YR(I) = ZEROR YI(I) = ZEROI 160 CONTINUE return end subroutine ZUNIK (ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, & PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) ! !! ZUNIK is subsidiary to ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNIK-A, ZUNIK-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC ! EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 ! RESPECTIVELY BY ! ! W(FNU,ZR) = PHI*EXP(ZETA)*SUM ! ! WHERE ZETA=-ZETA1 + ZETA2 OR ! ZETA1 - ZETA2 ! ! THE FIRST call MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE ! SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= ! 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK ! ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, ! ZETA1,ZETA2. ! !***SEE ALSO ZBESI, ZBESK !***ROUTINES CALLED D1MACH, ZDIV, ZLOG, ZSQRT !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 930122 Added EXTERNAL statement with ZLOG and ZSQRT. (RWC) !***END PROLOGUE ZUNIK ! COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, ! *ZETA2,ZN,ZR DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI, & CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI, & SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R, & ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2) EXTERNAL ZLOG, ZSQRT DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / DATA CON(1), CON(2) / & 3.98942280401432678D-01, 1.25331413731550025D+00 / DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), & C(19), C(20), C(21), C(22), C(23), C(24)/ & 1.00000000000000000D+00, -2.08333333333333333D-01, & 1.25000000000000000D-01, 3.34201388888888889D-01, & -4.01041666666666667D-01, 7.03125000000000000D-02, & -1.02581259645061728D+00, 1.84646267361111111D+00, & -8.91210937500000000D-01, 7.32421875000000000D-02, & 4.66958442342624743D+00, -1.12070026162229938D+01, & 8.78912353515625000D+00, -2.36408691406250000D+00, & 1.12152099609375000D-01, -2.82120725582002449D+01, & 8.46362176746007346D+01, -9.18182415432400174D+01, & 4.25349987453884549D+01, -7.36879435947963170D+00, & 2.27108001708984375D-01, 2.12570130039217123D+02, & -7.65252468141181642D+02, 1.05999045252799988D+03/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ & -6.99579627376132541D+02, 2.18190511744211590D+02, & -2.64914304869515555D+01, 5.72501420974731445D-01, & -1.91945766231840700D+03, 8.06172218173730938D+03, & -1.35865500064341374D+04, 1.16553933368645332D+04, & -5.30564697861340311D+03, 1.20090291321635246D+03, & -1.08090919788394656D+02, 1.72772750258445740D+00, & 2.02042913309661486D+04, -9.69805983886375135D+04, & 1.92547001232531532D+05, -2.03400177280415534D+05, & 1.22200464983017460D+05, -4.11926549688975513D+04, & 7.10951430248936372D+03, -4.93915304773088012D+02, & 6.07404200127348304D+00, -2.42919187900551333D+05, & 1.31176361466297720D+06, -2.99801591853810675D+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), & C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ & 3.76327129765640400D+06, -2.81356322658653411D+06, & 1.26836527332162478D+06, -3.31645172484563578D+05, & 4.52187689813627263D+04, -2.49983048181120962D+03, & 2.43805296995560639D+01, 3.28446985307203782D+06, & -1.97068191184322269D+07, 5.09526024926646422D+07, & -7.41051482115326577D+07, 6.63445122747290267D+07, & -3.75671766607633513D+07, 1.32887671664218183D+07, & -2.78561812808645469D+06, 3.08186404612662398D+05, & -1.38860897537170405D+04, 1.10017140269246738D+02, & -4.93292536645099620D+07, 3.25573074185765749D+08, & -9.39462359681578403D+08, 1.55359689957058006D+09, & -1.62108055210833708D+09, 1.10684281682301447D+09/ DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), & C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), & C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ & -4.95889784275030309D+08, 1.42062907797533095D+08, & -2.44740627257387285D+07, 2.24376817792244943D+06, & -8.40054336030240853D+04, 5.51335896122020586D+02, & 8.14789096118312115D+08, -5.86648149205184723D+09, & 1.86882075092958249D+10, -3.46320433881587779D+10, & 4.12801855797539740D+10, -3.30265997498007231D+10, & 1.79542137311556001D+10, -6.56329379261928433D+09, & 1.55927986487925751D+09, -2.25105661889415278D+08, & 1.73951075539781645D+07, -5.49842327572288687D+05, & 3.03809051092238427D+03, -1.46792612476956167D+10, & 1.14498237732025810D+11, -3.99096175224466498D+11, & 8.19218669548577329D+11, -1.09837515608122331D+12/ DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), & C(105), C(106), C(107), C(108), C(109), C(110), C(111), & C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ & 1.00815810686538209D+12, -6.45364869245376503D+11, & 2.87900649906150589D+11, -8.78670721780232657D+10, & 1.76347306068349694D+10, -2.16716498322379509D+09, & 1.43157876718888981D+08, -3.87183344257261262D+06, & 1.82577554742931747D+04, 2.86464035717679043D+11, & -2.40629790002850396D+12, 9.10934118523989896D+12, & -2.05168994109344374D+13, 3.05651255199353206D+13, & -3.16670885847851584D+13, 2.33483640445818409D+13, & -1.23204913055982872D+13, 4.61272578084913197D+12, & -1.19655288019618160D+12, 2.05914503232410016D+11, & -2.18229277575292237D+10, 1.24700929351271032D+09/ DATA C(119), C(120)/ & -2.91883881222208134D+07, 1.18838426256783253D+05/ !***FIRST EXECUTABLE STATEMENT ZUNIK if (INIT /= 0) go to 40 !----------------------------------------------------------------------- ! INITIALIZE ALL VARIABLES !----------------------------------------------------------------------- RFN = 1.0D0/FNU !----------------------------------------------------------------------- ! OVERFLOW TEST (ZR/FNU TOO SMALL) !----------------------------------------------------------------------- TEST = D1MACH(1)*1.0D+3 AC = FNU*TEST if (ABS(ZRR) > AC .OR. ABS(ZRI) > AC) go to 15 ZETA1R = 2.0D0*ABS(LOG(TEST))+FNU ZETA1I = 0.0D0 ZETA2R = FNU ZETA2I = 0.0D0 PHIR = 1.0D0 PHII = 0.0D0 return 15 CONTINUE TR = ZRR*RFN TI = ZRI*RFN SR = CONER + (TR*TR-TI*TI) SI = CONEI + (TR*TI+TI*TR) call ZSQRT(SR, SI, SRR, SRI) STR = CONER + SRR STI = CONEI + SRI call ZDIV(STR, STI, TR, TI, ZNR, ZNI) call ZLOG(ZNR, ZNI, STR, STI, IDUM) ZETA1R = FNU*STR ZETA1I = FNU*STI ZETA2R = FNU*SRR ZETA2I = FNU*SRI call ZDIV(CONER, CONEI, SRR, SRI, TR, TI) SRR = TR*RFN SRI = TI*RFN call ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16)) PHIR = CWRKR(16)*CON(IKFLG) PHII = CWRKI(16)*CON(IKFLG) if (IPMTR /= 0) RETURN call ZDIV(CONER, CONEI, SR, SI, T2R, T2I) CWRKR(1) = CONER CWRKI(1) = CONEI CRFNR = CONER CRFNI = CONEI AC = 1.0D0 L = 1 DO 20 K=2,15 SR = ZEROR SI = ZEROI DO 10 J=1,K L = L + 1 STR = SR*T2R - SI*T2I + C(L) SI = SR*T2I + SI*T2R SR = STR 10 CONTINUE STR = CRFNR*SRR - CRFNI*SRI CRFNI = CRFNR*SRI + CRFNI*SRR CRFNR = STR CWRKR(K) = CRFNR*SR - CRFNI*SI CWRKI(K) = CRFNR*SI + CRFNI*SR AC = AC*RFN TEST = ABS(CWRKR(K)) + ABS(CWRKI(K)) if (AC < TOL .AND. TEST < TOL) go to 30 20 CONTINUE K = 15 30 CONTINUE INIT = K 40 CONTINUE if (IKFLG == 2) go to 60 !----------------------------------------------------------------------- ! COMPUTE SUM FOR THE I FUNCTION !----------------------------------------------------------------------- SR = ZEROR SI = ZEROI DO 50 I=1,INIT SR = SR + CWRKR(I) SI = SI + CWRKI(I) 50 CONTINUE SUMR = SR SUMI = SI PHIR = CWRKR(16)*CON(1) PHII = CWRKI(16)*CON(1) return 60 CONTINUE !----------------------------------------------------------------------- ! COMPUTE SUM FOR THE K FUNCTION !----------------------------------------------------------------------- SR = ZEROR SI = ZEROI TR = CONER DO 70 I=1,INIT SR = SR + TR*CWRKR(I) SI = SI + TR*CWRKI(I) TR = -TR 70 CONTINUE SUMR = SR SUMI = SI PHIR = CWRKR(16)*CON(2) PHII = CWRKI(16)*CON(2) return end subroutine ZUNK1 (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, & ALIM) ! !! ZUNK1 is subsidiary to ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNK1-A, ZUNK1-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE ! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE ! UNIFORM ASYMPTOTIC EXPANSION. ! MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. ! NZ=-1 MEANS AN OVERFLOW WILL OCCUR ! !***SEE ALSO ZBESK !***ROUTINES CALLED D1MACH, ZABS, ZS1S2, ZUCHK, ZUNIK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZUNK1 ! COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, ! *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR, & CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR, & CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN, & FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI, & RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I, & S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, & ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR, D1MACH, ZABS INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, & KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J, M DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2), & ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), & CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2) EXTERNAL ZABS DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / DATA PI / 3.14159265358979324D0 / !***FIRST EXECUTABLE STATEMENT ZUNK1 KDFLG = 1 NZ = 0 !----------------------------------------------------------------------- ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN ! THE UNDERFLOW LIMIT !----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) ZRR = ZR ZRI = ZI if (ZR >= 0.0D0) go to 10 ZRR = -ZR ZRI = -ZI 10 CONTINUE J = 2 DO 70 I=1,N !----------------------------------------------------------------------- ! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J !----------------------------------------------------------------------- J = 3 - J FN = FNU + (I-1) INIT(J) = 0 call ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J), & ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J), & CWRKR(1,J), CWRKI(1,J)) if (KODE == 1) go to 20 STR = ZRR + ZETA2R(J) STI = ZRI + ZETA2I(J) RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZETA1R(J) - STR S1I = ZETA1I(J) - STI go to 30 20 CONTINUE S1R = ZETA1R(J) - ZETA2R(J) S1I = ZETA1I(J) - ZETA2I(J) 30 CONTINUE RS1 = S1R !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- if (ABS(RS1) > ELIM) go to 60 if (KDFLG == 1) KFLAG = 2 if (ABS(RS1) < ALIM) go to 40 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- APHI = ZABS(PHIR(J),PHII(J)) RS1 = RS1 + LOG(APHI) if (ABS(RS1) > ELIM) go to 60 if (KDFLG == 1) KFLAG = 1 if (RS1 < 0.0D0) go to 40 if (KDFLG == 1) KFLAG = 3 40 CONTINUE !----------------------------------------------------------------------- ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES !----------------------------------------------------------------------- S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J) S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J) STR = EXP(S1R)*CSSR(KFLAG) S1R = STR*COS(S1I) S1I = STR*SIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S1R*S2I + S2R*S1I S2R = STR if (KFLAG /= 1) go to 50 call ZUCHK(S2R, S2I, NW, BRY(1), TOL) if (NW /= 0) go to 60 50 CONTINUE CYR(KDFLG) = S2R CYI(KDFLG) = S2I YR(I) = S2R*CSRR(KFLAG) YI(I) = S2I*CSRR(KFLAG) if (KDFLG == 2) go to 75 KDFLG = 2 go to 70 60 CONTINUE if (RS1 > 0.0D0) go to 300 !----------------------------------------------------------------------- ! FOR ZR < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW !----------------------------------------------------------------------- if (ZR < 0.0D0) go to 300 KDFLG = 1 YR(I)=ZEROR YI(I)=ZEROI NZ=NZ+1 if (I == 1) go to 70 if ((YR(I-1) == ZEROR).AND.(YI(I-1) == ZEROI)) go to 70 YR(I-1)=ZEROR YI(I-1)=ZEROI NZ=NZ+1 70 CONTINUE I = N 75 CONTINUE RAZR = 1.0D0/ZABS(ZRR,ZRI) STR = ZRR*RAZR STI = -ZRI*RAZR RZR = (STR+STR)*RAZR RZI = (STI+STI)*RAZR CKR = FN*RZR CKI = FN*RZI IB = I + 1 if (N < IB) go to 160 !----------------------------------------------------------------------- ! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO ! ON UNDERFLOW. !----------------------------------------------------------------------- FN = FNU + (N-1) IPARD = 1 if (MR /= 0) IPARD = 0 INITD = 0 call ZUNIK(ZRR, ZRI, FN, 2, IPARD, TOL, INITD, PHIDR, PHIDI, & ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, CWRKR(1,3), & CWRKI(1,3)) if (KODE == 1) go to 80 STR = ZRR + ZET2DR STI = ZRI + ZET2DI RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZET1DR - STR S1I = ZET1DI - STI go to 90 80 CONTINUE S1R = ZET1DR - ZET2DR S1I = ZET1DI - ZET2DI 90 CONTINUE RS1 = S1R if (ABS(RS1) > ELIM) go to 95 if (ABS(RS1) < ALIM) go to 100 !----------------------------------------------------------------------- ! REFINE ESTIMATE AND TEST !----------------------------------------------------------------------- APHI = ZABS(PHIDR,PHIDI) RS1 = RS1+LOG(APHI) if (ABS(RS1) < ELIM) go to 100 95 CONTINUE if (ABS(RS1) > 0.0D0) go to 300 !----------------------------------------------------------------------- ! FOR ZR < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW !----------------------------------------------------------------------- if (ZR < 0.0D0) go to 300 NZ = N DO 96 I=1,N YR(I) = ZEROR YI(I) = ZEROI 96 CONTINUE return !----------------------------------------------------------------------- ! FORWARD RECUR FOR REMAINDER OF THE SEQUENCE !----------------------------------------------------------------------- 100 CONTINUE S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 120 I=IB,N C2R = S2R C2I = S2I S2R = CKR*C2R - CKI*C2I + S1R S2I = CKR*C2I + CKI*C2R + S1I S1R = C2R S1I = C2I CKR = CKR + RZR CKI = CKI + RZI C2R = S2R*C1R C2I = S2I*C1R YR(I) = C2R YI(I) = C2I if (KFLAG >= 3) go to 120 STR = ABS(C2R) STI = ABS(C2I) C2M = MAX(STR,STI) if (C2M <= ASCLE) go to 120 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) C1R = CSRR(KFLAG) 120 CONTINUE 160 CONTINUE if (MR == 0) RETURN !----------------------------------------------------------------------- ! ANALYTIC CONTINUATION FOR RE(Z) < 0.0D0 !----------------------------------------------------------------------- NZ = 0 FMR = MR SGN = -DSIGN(PI,FMR) !----------------------------------------------------------------------- ! CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. !----------------------------------------------------------------------- CSGNI = SGN INU = FNU FNF = FNU - INU IFN = INU + N - 1 ANG = FNF*SGN CSPNR = COS(ANG) CSPNI = SIN(ANG) if (MOD(IFN,2) == 0) go to 170 CSPNR = -CSPNR CSPNI = -CSPNI 170 CONTINUE ASC = BRY(1) IUF = 0 KK = N KDFLG = 1 IB = IB - 1 IC = IB - 1 DO 270 K=1,N FN = FNU + (KK-1) !----------------------------------------------------------------------- ! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K ! FUNCTION ABOVE !----------------------------------------------------------------------- M=3 if (N > 2) go to 175 172 CONTINUE INITD = INIT(J) PHIDR = PHIR(J) PHIDI = PHII(J) ZET1DR = ZETA1R(J) ZET1DI = ZETA1I(J) ZET2DR = ZETA2R(J) ZET2DI = ZETA2I(J) SUMDR = SUMR(J) SUMDI = SUMI(J) M = J J = 3 - J go to 180 175 CONTINUE if ((KK == N).AND.(IB < N)) go to 180 if ((KK == IB).OR.(KK == IC)) go to 172 INITD = 0 180 CONTINUE call ZUNIK(ZRR, ZRI, FN, 1, 0, TOL, INITD, PHIDR, PHIDI, & ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, & CWRKR(1,M), CWRKI(1,M)) if (KODE == 1) go to 200 STR = ZRR + ZET2DR STI = ZRI + ZET2DI RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZET1DR + STR S1I = -ZET1DI + STI go to 210 200 CONTINUE S1R = -ZET1DR + ZET2DR S1I = -ZET1DI + ZET2DI 210 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = S1R if (ABS(RS1) > ELIM) go to 260 if (KDFLG == 1) IFLAG = 2 if (ABS(RS1) < ALIM) go to 220 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- APHI = ZABS(PHIDR,PHIDI) RS1 = RS1 + LOG(APHI) if (ABS(RS1) > ELIM) go to 260 if (KDFLG == 1) IFLAG = 1 if (RS1 < 0.0D0) go to 220 if (KDFLG == 1) IFLAG = 3 220 CONTINUE STR = PHIDR*SUMDR - PHIDI*SUMDI STI = PHIDR*SUMDI + PHIDI*SUMDR S2R = -CSGNI*STI S2I = CSGNI*STR STR = EXP(S1R)*CSSR(IFLAG) S1R = STR*COS(S1I) S1I = STR*SIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR if (IFLAG /= 1) go to 230 call ZUCHK(S2R, S2I, NW, BRY(1), TOL) if (NW == 0) go to 230 S2R = ZEROR S2I = ZEROI 230 CONTINUE CYR(KDFLG) = S2R CYI(KDFLG) = S2I C2R = S2R C2I = S2I S2R = S2R*CSRR(IFLAG) S2I = S2I*CSRR(IFLAG) !----------------------------------------------------------------------- ! ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N !----------------------------------------------------------------------- S1R = YR(KK) S1I = YI(KK) if (KODE == 1) go to 250 call ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 250 CONTINUE YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R YI(KK) = CSPNR*S1I + CSPNI*S1R + S2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI if (C2R /= 0.0D0 .OR. C2I /= 0.0D0) go to 255 KDFLG = 1 go to 270 255 CONTINUE if (KDFLG == 2) go to 275 KDFLG = 2 go to 270 260 CONTINUE if (RS1 > 0.0D0) go to 300 S2R = ZEROR S2I = ZEROI go to 230 270 CONTINUE K = N 275 CONTINUE IL = N - K if (IL == 0) RETURN !----------------------------------------------------------------------- ! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE ! K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP ! INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. !----------------------------------------------------------------------- S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) CSR = CSRR(IFLAG) ASCLE = BRY(IFLAG) FN = INU+IL DO 290 I=1,IL C2R = S2R C2I = S2I S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I FN = FN - 1.0D0 C2R = S2R*CSR C2I = S2I*CSR CKR = C2R CKI = C2I C1R = YR(KK) C1I = YI(KK) if (KODE == 1) go to 280 call ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 280 CONTINUE YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI if (IFLAG >= 3) go to 290 C2R = ABS(CKR) C2I = ABS(CKI) C2M = MAX(C2R,C2I) if (C2M <= ASCLE) go to 290 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*CSR S1I = S1I*CSR S2R = CKR S2I = CKI S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) CSR = CSRR(IFLAG) 290 CONTINUE return 300 CONTINUE NZ = -1 return end subroutine ZUNK2 (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, & ALIM) ! !! ZUNK2 is subsidiary to ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUNK2-A, ZUNK2-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE ! RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE ! UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) ! WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR ! -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z if Z IS IN THE RIGHT ! HALF PLANE OR ZR=-Z if Z IS IN THE LEFT HALF PLANE. MR INDIC- ! ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. ! NZ=-1 MEANS AN OVERFLOW WILL OCCUR ! !***SEE ALSO ZBESK !***ROUTINES CALLED D1MACH, ZABS, ZAIRY, ZS1S2, ZUCHK, ZUNHJ !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZUNK2 ! COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, ! *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, ! *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI, & ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR, & BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR, & CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI, & CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M, & C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR, & PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN, & STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI, & ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI, & ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK, & KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC DIMENSION BRY(3), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2), & BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2), & ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4), & CIPI(4), CSSR(3), CSRR(3) EXTERNAL ZABS DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I / & 0.0D0, 0.0D0, 1.0D0, & 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 / DATA HPI, PI, AIC / & 1.57079632679489662D+00, 3.14159265358979324D+00, & 1.26551212348464539D+00/ DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), & CIPI(4) / & 1.0D0,0.0D0 , 0.0D0,-1.0D0 , -1.0D0,0.0D0 , 0.0D0,1.0D0 / !***FIRST EXECUTABLE STATEMENT ZUNK2 KDFLG = 1 NZ = 0 !----------------------------------------------------------------------- ! EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN ! THE UNDERFLOW LIMIT !----------------------------------------------------------------------- CSCL = 1.0D0/TOL CRSC = TOL CSSR(1) = CSCL CSSR(2) = CONER CSSR(3) = CRSC CSRR(1) = CRSC CSRR(2) = CONER CSRR(3) = CSCL BRY(1) = 1.0D+3*D1MACH(1)/TOL BRY(2) = 1.0D0/BRY(1) BRY(3) = D1MACH(2) ZRR = ZR ZRI = ZI if (ZR >= 0.0D0) go to 10 ZRR = -ZR ZRI = -ZI 10 CONTINUE YY = ZRI ZNR = ZRI ZNI = -ZRR ZBR = ZRR ZBI = ZRI INU = FNU FNF = FNU - INU ANG = -HPI*FNF CAR = COS(ANG) SAR = SIN(ANG) C2R = HPI*SAR C2I = -HPI*CAR KK = MOD(INU,4) + 1 STR = C2R*CIPR(KK) - C2I*CIPI(KK) STI = C2R*CIPI(KK) + C2I*CIPR(KK) CSR = CR1R*STR - CR1I*STI CSI = CR1R*STI + CR1I*STR if (YY > 0.0D0) go to 20 ZNR = -ZNR ZBI = -ZBI 20 CONTINUE !----------------------------------------------------------------------- ! K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST ! QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE COMPUTED BY ! CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS !----------------------------------------------------------------------- J = 2 DO 80 I=1,N !----------------------------------------------------------------------- ! J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J !----------------------------------------------------------------------- J = 3 - J FN = FNU + (I-1) call ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J), & ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J), & ASUMI(J), BSUMR(J), BSUMI(J)) if (KODE == 1) go to 30 STR = ZBR + ZETA2R(J) STI = ZBI + ZETA2I(J) RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZETA1R(J) - STR S1I = ZETA1I(J) - STI go to 40 30 CONTINUE S1R = ZETA1R(J) - ZETA2R(J) S1I = ZETA1I(J) - ZETA2I(J) 40 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = S1R if (ABS(RS1) > ELIM) go to 70 if (KDFLG == 1) KFLAG = 2 if (ABS(RS1) < ALIM) go to 50 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- APHI = ZABS(PHIR(J),PHII(J)) AARG = ZABS(ARGR(J),ARGI(J)) RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC if (ABS(RS1) > ELIM) go to 70 if (KDFLG == 1) KFLAG = 1 if (RS1 < 0.0D0) go to 50 if (KDFLG == 1) KFLAG = 3 50 CONTINUE !----------------------------------------------------------------------- ! SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR ! EXPONENT EXTREMES !----------------------------------------------------------------------- C2R = ARGR(J)*CR2R - ARGI(J)*CR2I C2I = ARGR(J)*CR2I + ARGI(J)*CR2R call ZAIRY(C2R, C2I, 0, 2, AIR, AII, NAI, IDUM) call ZAIRY(C2R, C2I, 1, 2, DAIR, DAII, NDAI, IDUM) STR = DAIR*BSUMR(J) - DAII*BSUMI(J) STI = DAIR*BSUMI(J) + DAII*BSUMR(J) PTR = STR*CR2R - STI*CR2I PTI = STR*CR2I + STI*CR2R STR = PTR + (AIR*ASUMR(J)-AII*ASUMI(J)) STI = PTI + (AIR*ASUMI(J)+AII*ASUMR(J)) PTR = STR*PHIR(J) - STI*PHII(J) PTI = STR*PHII(J) + STI*PHIR(J) S2R = PTR*CSR - PTI*CSI S2I = PTR*CSI + PTI*CSR STR = EXP(S1R)*CSSR(KFLAG) S1R = STR*COS(S1I) S1I = STR*SIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S1R*S2I + S2R*S1I S2R = STR if (KFLAG /= 1) go to 60 call ZUCHK(S2R, S2I, NW, BRY(1), TOL) if (NW /= 0) go to 70 60 CONTINUE if (YY <= 0.0D0) S2I = -S2I CYR(KDFLG) = S2R CYI(KDFLG) = S2I YR(I) = S2R*CSRR(KFLAG) YI(I) = S2I*CSRR(KFLAG) STR = CSI CSI = -CSR CSR = STR if (KDFLG == 2) go to 85 KDFLG = 2 go to 80 70 CONTINUE if (RS1 > 0.0D0) go to 320 !----------------------------------------------------------------------- ! FOR ZR < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW !----------------------------------------------------------------------- if (ZR < 0.0D0) go to 320 KDFLG = 1 YR(I)=ZEROR YI(I)=ZEROI NZ=NZ+1 STR = CSI CSI =-CSR CSR = STR if (I == 1) go to 80 if ((YR(I-1) == ZEROR).AND.(YI(I-1) == ZEROI)) go to 80 YR(I-1)=ZEROR YI(I-1)=ZEROI NZ=NZ+1 80 CONTINUE I = N 85 CONTINUE RAZR = 1.0D0/ZABS(ZRR,ZRI) STR = ZRR*RAZR STI = -ZRI*RAZR RZR = (STR+STR)*RAZR RZI = (STI+STI)*RAZR CKR = FN*RZR CKI = FN*RZI IB = I + 1 if (N < IB) go to 180 !----------------------------------------------------------------------- ! TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO ! ON UNDERFLOW. !----------------------------------------------------------------------- FN = FNU + (N-1) IPARD = 1 if (MR /= 0) IPARD = 0 call ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI, & ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI) if (KODE == 1) go to 90 STR = ZBR + ZET2DR STI = ZBI + ZET2DI RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = ZET1DR - STR S1I = ZET1DI - STI go to 100 90 CONTINUE S1R = ZET1DR - ZET2DR S1I = ZET1DI - ZET2DI 100 CONTINUE RS1 = S1R if (ABS(RS1) > ELIM) go to 105 if (ABS(RS1) < ALIM) go to 120 !----------------------------------------------------------------------- ! REFINE ESTIMATE AND TEST !----------------------------------------------------------------------- APHI = ZABS(PHIDR,PHIDI) RS1 = RS1+LOG(APHI) if (ABS(RS1) < ELIM) go to 120 105 CONTINUE if (RS1 > 0.0D0) go to 320 !----------------------------------------------------------------------- ! FOR ZR < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW !----------------------------------------------------------------------- if (ZR < 0.0D0) go to 320 NZ = N DO 106 I=1,N YR(I) = ZEROR YI(I) = ZEROI 106 CONTINUE return 120 CONTINUE S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) C1R = CSRR(KFLAG) ASCLE = BRY(KFLAG) DO 130 I=IB,N C2R = S2R C2I = S2I S2R = CKR*C2R - CKI*C2I + S1R S2I = CKR*C2I + CKI*C2R + S1I S1R = C2R S1I = C2I CKR = CKR + RZR CKI = CKI + RZI C2R = S2R*C1R C2I = S2I*C1R YR(I) = C2R YI(I) = C2I if (KFLAG >= 3) go to 130 STR = ABS(C2R) STI = ABS(C2I) C2M = MAX(STR,STI) if (C2M <= ASCLE) go to 130 KFLAG = KFLAG + 1 ASCLE = BRY(KFLAG) S1R = S1R*C1R S1I = S1I*C1R S2R = C2R S2I = C2I S1R = S1R*CSSR(KFLAG) S1I = S1I*CSSR(KFLAG) S2R = S2R*CSSR(KFLAG) S2I = S2I*CSSR(KFLAG) C1R = CSRR(KFLAG) 130 CONTINUE 180 CONTINUE if (MR == 0) RETURN !----------------------------------------------------------------------- ! ANALYTIC CONTINUATION FOR RE(Z) < 0.0D0 !----------------------------------------------------------------------- NZ = 0 FMR = MR SGN = -DSIGN(PI,FMR) !----------------------------------------------------------------------- ! CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. !----------------------------------------------------------------------- CSGNI = SGN if (YY <= 0.0D0) CSGNI = -CSGNI IFN = INU + N - 1 ANG = FNF*SGN CSPNR = COS(ANG) CSPNI = SIN(ANG) if (MOD(IFN,2) == 0) go to 190 CSPNR = -CSPNR CSPNI = -CSPNI 190 CONTINUE !----------------------------------------------------------------------- ! CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS ! COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST ! QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE COMPUTED BY ! CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS !----------------------------------------------------------------------- CSR = SAR*CSGNI CSI = CAR*CSGNI IN = MOD(IFN,4) + 1 C2R = CIPR(IN) C2I = CIPI(IN) STR = CSR*C2R + CSI*C2I CSI = -CSR*C2I + CSI*C2R CSR = STR ASC = BRY(1) IUF = 0 KK = N KDFLG = 1 IB = IB - 1 IC = IB - 1 DO 290 K=1,N FN = FNU + (KK-1) !----------------------------------------------------------------------- ! LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K ! FUNCTION ABOVE !----------------------------------------------------------------------- if (N > 2) go to 175 172 CONTINUE PHIDR = PHIR(J) PHIDI = PHII(J) ARGDR = ARGR(J) ARGDI = ARGI(J) ZET1DR = ZETA1R(J) ZET1DI = ZETA1I(J) ZET2DR = ZETA2R(J) ZET2DI = ZETA2I(J) ASUMDR = ASUMR(J) ASUMDI = ASUMI(J) BSUMDR = BSUMR(J) BSUMDI = BSUMI(J) J = 3 - J go to 210 175 CONTINUE if ((KK == N).AND.(IB < N)) go to 210 if ((KK == IB).OR.(KK == IC)) go to 172 call ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIDR, PHIDI, ARGDR, & ARGDI, ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, & ASUMDI, BSUMDR, BSUMDI) 210 CONTINUE if (KODE == 1) go to 220 STR = ZBR + ZET2DR STI = ZBI + ZET2DI RAST = FN/ZABS(STR,STI) STR = STR*RAST*RAST STI = -STI*RAST*RAST S1R = -ZET1DR + STR S1I = -ZET1DI + STI go to 230 220 CONTINUE S1R = -ZET1DR + ZET2DR S1I = -ZET1DI + ZET2DI 230 CONTINUE !----------------------------------------------------------------------- ! TEST FOR UNDERFLOW AND OVERFLOW !----------------------------------------------------------------------- RS1 = S1R if (ABS(RS1) > ELIM) go to 280 if (KDFLG == 1) IFLAG = 2 if (ABS(RS1) < ALIM) go to 240 !----------------------------------------------------------------------- ! REFINE TEST AND SCALE !----------------------------------------------------------------------- APHI = ZABS(PHIDR,PHIDI) AARG = ZABS(ARGDR,ARGDI) RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC if (ABS(RS1) > ELIM) go to 280 if (KDFLG == 1) IFLAG = 1 if (RS1 < 0.0D0) go to 240 if (KDFLG == 1) IFLAG = 3 240 CONTINUE call ZAIRY(ARGDR, ARGDI, 0, 2, AIR, AII, NAI, IDUM) call ZAIRY(ARGDR, ARGDI, 1, 2, DAIR, DAII, NDAI, IDUM) STR = DAIR*BSUMDR - DAII*BSUMDI STI = DAIR*BSUMDI + DAII*BSUMDR STR = STR + (AIR*ASUMDR-AII*ASUMDI) STI = STI + (AIR*ASUMDI+AII*ASUMDR) PTR = STR*PHIDR - STI*PHIDI PTI = STR*PHIDI + STI*PHIDR S2R = PTR*CSR - PTI*CSI S2I = PTR*CSI + PTI*CSR STR = EXP(S1R)*CSSR(IFLAG) S1R = STR*COS(S1I) S1I = STR*SIN(S1I) STR = S2R*S1R - S2I*S1I S2I = S2R*S1I + S2I*S1R S2R = STR if (IFLAG /= 1) go to 250 call ZUCHK(S2R, S2I, NW, BRY(1), TOL) if (NW == 0) go to 250 S2R = ZEROR S2I = ZEROI 250 CONTINUE if (YY <= 0.0D0) S2I = -S2I CYR(KDFLG) = S2R CYI(KDFLG) = S2I C2R = S2R C2I = S2I S2R = S2R*CSRR(IFLAG) S2I = S2I*CSRR(IFLAG) !----------------------------------------------------------------------- ! ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N !----------------------------------------------------------------------- S1R = YR(KK) S1I = YI(KK) if (KODE == 1) go to 270 call ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 270 CONTINUE YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R YI(KK) = S1R*CSPNI + S1I*CSPNR + S2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI STR = CSI CSI = -CSR CSR = STR if (C2R /= 0.0D0 .OR. C2I /= 0.0D0) go to 255 KDFLG = 1 go to 290 255 CONTINUE if (KDFLG == 2) go to 295 KDFLG = 2 go to 290 280 CONTINUE if (RS1 > 0.0D0) go to 320 S2R = ZEROR S2I = ZEROI go to 250 290 CONTINUE K = N 295 CONTINUE IL = N - K if (IL == 0) RETURN !----------------------------------------------------------------------- ! RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE ! K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP ! INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. !----------------------------------------------------------------------- S1R = CYR(1) S1I = CYI(1) S2R = CYR(2) S2I = CYI(2) CSR = CSRR(IFLAG) ASCLE = BRY(IFLAG) FN = INU+IL DO 310 I=1,IL C2R = S2R C2I = S2I S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) S1R = C2R S1I = C2I FN = FN - 1.0D0 C2R = S2R*CSR C2I = S2I*CSR CKR = C2R CKI = C2I C1R = YR(KK) C1I = YI(KK) if (KODE == 1) go to 300 call ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) NZ = NZ + NW 300 CONTINUE YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I KK = KK - 1 CSPNR = -CSPNR CSPNI = -CSPNI if (IFLAG >= 3) go to 310 C2R = ABS(CKR) C2I = ABS(CKI) C2M = MAX(C2R,C2I) if (C2M <= ASCLE) go to 310 IFLAG = IFLAG + 1 ASCLE = BRY(IFLAG) S1R = S1R*CSR S1I = S1I*CSR S2R = CKR S2I = CKI S1R = S1R*CSSR(IFLAG) S1I = S1I*CSSR(IFLAG) S2R = S2R*CSSR(IFLAG) S2I = S2I*CSSR(IFLAG) CSR = CSRR(IFLAG) 310 CONTINUE return 320 CONTINUE NZ = -1 return end subroutine ZUOIK (ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, & ELIM, ALIM) ! !! ZUOIK is subsidiary to ZBESH, ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CUOIK-A, ZUOIK-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC ! EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM ! (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW ! WHERE ALIM < ELIM. if THE MAGNITUDE, BASED ON THE LEADING ! EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN ! THE RESULT IS ON SCALE. if NOT, THEN A REFINED TEST USING OTHER ! MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE ! EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= ! EXP(-ELIM)/TOL ! ! IKFLG=1 MEANS THE I SEQUENCE IS TESTED ! =2 MEANS THE K SEQUENCE IS TESTED ! NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE ! =-1 MEANS AN OVERFLOW WOULD OCCUR ! IKFLG=1 AND NUF > 0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO ! THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE ! IKFLG=2 AND NUF == N MEANS ALL Y VALUES WERE SET TO ZERO ! IKFLG=2 AND 0 < NUF < N NOT CONSIDERED. Y MUST BE SET BY ! ANOTHER ROUTINE ! !***SEE ALSO ZBESH, ZBESI, ZBESK !***ROUTINES CALLED D1MACH, ZABS, ZLOG, ZUCHK, ZUNHJ, ZUNIK !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) ! 930122 Added ZLOG to EXTERNAL statement. (RWC) !***END PROLOGUE ZUOIK ! COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, ! *ZR DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR, & ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN, & FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI, & YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, & ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16) EXTERNAL ZABS, ZLOG DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / DATA AIC / 1.265512123484645396D+00 / !***FIRST EXECUTABLE STATEMENT ZUOIK NUF = 0 NN = N ZRR = ZR ZRI = ZI if (ZR >= 0.0D0) go to 10 ZRR = -ZR ZRI = -ZI 10 CONTINUE ZBR = ZRR ZBI = ZRI AX = ABS(ZR)*1.7321D0 AY = ABS(ZI) IFORM = 1 if (AY > AX) IFORM = 2 GNU = MAX(FNU,1.0D0) if (IKFLG == 1) go to 20 FNN = NN GNN = FNU + FNN - 1.0D0 GNU = MAX(GNN,FNN) 20 CONTINUE !----------------------------------------------------------------------- ! ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE ! REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET ! THE SIGN OF THE IMAGINARY PART CORRECT. !----------------------------------------------------------------------- if (IFORM == 2) go to 30 INIT = 0 call ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, & ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I go to 50 30 CONTINUE ZNR = ZRI ZNI = -ZRR if (ZI > 0.0D0) go to 40 ZNR = -ZNR 40 CONTINUE call ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, & ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I AARG = ZABS(ARGR,ARGI) 50 CONTINUE if (KODE == 1) go to 60 CZR = CZR - ZBR CZI = CZI - ZBI 60 CONTINUE if (IKFLG == 1) go to 70 CZR = -CZR CZI = -CZI 70 CONTINUE APHI = ZABS(PHIR,PHII) RCZ = CZR !----------------------------------------------------------------------- ! OVERFLOW TEST !----------------------------------------------------------------------- if (RCZ > ELIM) go to 210 if (RCZ < ALIM) go to 80 RCZ = RCZ + LOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC if (RCZ > ELIM) go to 210 go to 130 80 CONTINUE !----------------------------------------------------------------------- ! UNDERFLOW TEST !----------------------------------------------------------------------- if (RCZ < (-ELIM)) go to 90 if (RCZ > (-ALIM)) go to 130 RCZ = RCZ + LOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC if (RCZ > (-ELIM)) go to 110 90 CONTINUE DO 100 I=1,NN YR(I) = ZEROR YI(I) = ZEROI 100 CONTINUE NUF = NN return 110 CONTINUE ASCLE = 1.0D+3*D1MACH(1)/TOL call ZLOG(PHIR, PHII, STR, STI, IDUM) CZR = CZR + STR CZI = CZI + STI if (IFORM == 1) go to 120 call ZLOG(ARGR, ARGI, STR, STI, IDUM) CZR = CZR - 0.25D0*STR - AIC CZI = CZI - 0.25D0*STI 120 CONTINUE AX = EXP(RCZ)/TOL AY = CZI CZR = AX*COS(AY) CZI = AX*SIN(AY) call ZUCHK(CZR, CZI, NW, ASCLE, TOL) if (NW /= 0) go to 90 130 CONTINUE if (IKFLG == 2) RETURN if (N == 1) RETURN !----------------------------------------------------------------------- ! SET UNDERFLOWS ON I SEQUENCE !----------------------------------------------------------------------- 140 CONTINUE GNU = FNU + (NN-1) if (IFORM == 2) go to 150 INIT = 0 call ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, & ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I go to 160 150 CONTINUE call ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, & ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) CZR = -ZETA1R + ZETA2R CZI = -ZETA1I + ZETA2I AARG = ZABS(ARGR,ARGI) 160 CONTINUE if (KODE == 1) go to 170 CZR = CZR - ZBR CZI = CZI - ZBI 170 CONTINUE APHI = ZABS(PHIR,PHII) RCZ = CZR if (RCZ < (-ELIM)) go to 180 if (RCZ > (-ALIM)) RETURN RCZ = RCZ + LOG(APHI) if (IFORM == 2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC if (RCZ > (-ELIM)) go to 190 180 CONTINUE YR(NN) = ZEROR YI(NN) = ZEROI NN = NN - 1 NUF = NUF + 1 if (NN == 0) RETURN go to 140 190 CONTINUE ASCLE = 1.0D+3*D1MACH(1)/TOL call ZLOG(PHIR, PHII, STR, STI, IDUM) CZR = CZR + STR CZI = CZI + STI if (IFORM == 1) go to 200 call ZLOG(ARGR, ARGI, STR, STI, IDUM) CZR = CZR - 0.25D0*STR - AIC CZI = CZI - 0.25D0*STI 200 CONTINUE AX = EXP(RCZ)/TOL AY = CZI CZR = AX*COS(AY) CZI = AX*SIN(AY) call ZUCHK(CZR, CZI, NW, ASCLE, TOL) if (NW /= 0) go to 180 return 210 CONTINUE NUF = -1 return end subroutine ZWRSK (ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, & TOL, ELIM, ALIM) ! !! ZWRSK is subsidiary to ZBESI and ZBESK. ! !***LIBRARY SLATEC !***TYPE ALL (CWRSK-A, ZWRSK-A) !***AUTHOR Amos, D. E., (SNL) !***DESCRIPTION ! ! ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z) >= 0.0 BY ! NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN ! !***SEE ALSO ZBESI, ZBESK !***ROUTINES CALLED D1MACH, ZABS, ZBKNU, ZRATI !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 910415 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE ZWRSK ! COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI, & CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT, & STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH INTEGER I, KODE, N, NW, NZ DIMENSION YR(N), YI(N), CWR(2), CWI(2) EXTERNAL ZABS !***FIRST EXECUTABLE STATEMENT ZWRSK !----------------------------------------------------------------------- ! I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS ! Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE ! WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. !----------------------------------------------------------------------- ! NZ = 0 call ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM) if (NW /= 0) go to 50 call ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL) !----------------------------------------------------------------------- ! RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), ! R(FNU+J-1,Z)=Y(J), J=1,...,N !----------------------------------------------------------------------- CINUR = 1.0D0 CINUI = 0.0D0 if (KODE == 1) go to 10 CINUR = COS(ZRI) CINUI = SIN(ZRI) 10 CONTINUE !----------------------------------------------------------------------- ! ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH ! THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE ! SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT ! THE RESULT IS ON SCALE. !----------------------------------------------------------------------- ACW = ZABS(CWR(2),CWI(2)) ASCLE = 1.0D+3*D1MACH(1)/TOL CSCLR = 1.0D0 if (ACW > ASCLE) go to 20 CSCLR = 1.0D0/TOL go to 30 20 CONTINUE ASCLE = 1.0D0/ASCLE if (ACW < ASCLE) go to 30 CSCLR = TOL 30 CONTINUE C1R = CWR(1)*CSCLR C1I = CWI(1)*CSCLR C2R = CWR(2)*CSCLR C2I = CWI(2)*CSCLR STR = YR(1) STI = YI(1) !----------------------------------------------------------------------- ! CINU=CINU*(CONJG(CT)/ABS(CT))*(1.0D0/ABS(CT) PREVENTS ! UNDER- OR OVERFLOW PREMATURELY BY SQUARING ABS(CT) !----------------------------------------------------------------------- PTR = STR*C1R - STI*C1I PTI = STR*C1I + STI*C1R PTR = PTR + C2R PTI = PTI + C2I CTR = ZRR*PTR - ZRI*PTI CTI = ZRR*PTI + ZRI*PTR ACT = ZABS(CTR,CTI) RACT = 1.0D0/ACT CTR = CTR*RACT CTI = -CTI*RACT PTR = CINUR*RACT PTI = CINUI*RACT CINUR = PTR*CTR - PTI*CTI CINUI = PTR*CTI + PTI*CTR YR(1) = CINUR*CSCLR YI(1) = CINUI*CSCLR if (N == 1) RETURN DO 40 I=2,N PTR = STR*CINUR - STI*CINUI CINUI = STR*CINUI + STI*CINUR CINUR = PTR STR = YR(I) STI = YI(I) YR(I) = CINUR*CSCLR YI(I) = CINUI*CSCLR 40 CONTINUE return 50 CONTINUE NZ = -1 if ( NW == (-2)) NZ=-2 return end